000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IPMGR190.                                         00020008
000300*AUTHOR.   CMS.                                                   00030000
000400*          CENTERS FOR MEDICARE AND MEDICAID SERVICES             00040000
000500*          INPATIENT PSYCHIATRIC FACILITY PPS PRICER              00050000
000600 DATE-COMPILED.                                                   00060000
000700 ENVIRONMENT                     DIVISION.                        00070000
000800 CONFIGURATION                   SECTION.                         00080000
000900 SOURCE-COMPUTER.                IBM-370.                         00090000
001000 OBJECT-COMPUTER.                IBM-370.                         00100000
001100 INPUT-OUTPUT SECTION.                                            00110000
001200 FILE-CONTROL.                                                    00120000
001300                                                                  00130000
001400     SELECT IPFBILL    ASSIGN TO UT-S-IPFBILL                     00140000
001500         FILE STATUS IS UT1-STAT.                                 00150000
001600     SELECT IPFOUT     ASSIGN TO UT-S-IPFOUT                      00160000
001700         FILE STATUS IS UT2-STAT.                                 00170000
001800     SELECT IPFPRT     ASSIGN TO UT-S-IPFPRT                      00180000
001900         FILE STATUS IS OPR-STAT.                                 00190000
002000                                                                  00200000
002100 DATA DIVISION.                                                   00210000
002110 FILE SECTION.                                                    00211000
002120 FD  IPFBILL                                                      00212000
002130     LABEL RECORDS ARE STANDARD                                   00213000
002140     RECORDING MODE IS F                                          00214000
002150     BLOCK CONTAINS 0 RECORDS.                                    00215000
002160 01  IPF-REC                     PIC X(416).                      00216000
002170                                                                  00217000
002180 FD  IPFOUT                                                       00218000
002190     LABEL RECORDS ARE STANDARD                                   00219000
002200     RECORDING MODE IS F                                          00220000
002300     BLOCK CONTAINS 0 RECORDS.                                    00230000
002400 01  OUT-REC                     PIC X(752).                      00240000
002500                                                                  00250000
002600 FD  IPFPRT                                                       00260000
002700     RECORDING MODE IS F                                          00270000
002800     BLOCK CONTAINS 133 RECORDS                                   00280000
002900     LABEL RECORDS ARE STANDARD.                                  00290000
003000 01  IPFPRT-LINE                 PIC X(133).                      00300000
003100                                                                  00310000
003200                                                                  00320000
003300 WORKING-STORAGE SECTION.                                         00330000
003400 77  W-STORAGE-REF               PIC X(49)  VALUE                 00340000
003500     'P P M A N A G E R - W O R K I N G   S T O R A G E'.         00350000
003600 01  IPMGR-VERSION               PIC X(05)  VALUE 'M19.0'.        00360008
003700 01  IPOPN-VERSION               PIC X(05)  VALUE 'O19.0'.        00370008
003800 01  IPOPN190                    PIC X(08)  VALUE 'IPOPN190'.     00380008
003900 01  EOF-SW                      PIC 9(01)  VALUE 0.              00390000
004000 01  TBL-EOF-SW                  PIC 9(01)  VALUE 0.              00400000
004100 01  X1                          PIC 9(05)  COMP SYNC VALUE 0.    00410000
004200 01  X2                          PIC 9(05)  COMP SYNC VALUE 0.    00420000
004300 01  X3                          PIC 9(05)  COMP SYNC VALUE 0.    00430000
004400 01  X4                          PIC 9(05)  COMP SYNC VALUE 0.    00440000
004500 01  OPERLINE-CTR                PIC 9(02)  VALUE 65.             00450000
004600 01  IPFBILL-CTR                 PIC 9(09)  VALUE 0.              00460000
004700 01  IPFOUT-CTR                  PIC 9(09)  VALUE 0.              00470000
004800 01  UT1-STAT.                                                    00480000
004900     05  UT1-STAT1               PIC X.                           00490000
005000     05  UT1-STAT2               PIC X.                           00500000
005100 01  UT2-STAT.                                                    00510000
005200     05  UT2-STAT1               PIC X.                           00520000
005300     05  UT2-STAT2               PIC X.                           00530000
005400 01  OPR-STAT.                                                    00540000
005500     05  OPR-STAT1               PIC X.                           00550000
005600     05  OPR-STAT2               PIC X.                           00560000
005700*******************************************************           00570000
005800*******************************************************           00580000
005900*               BILL RECORD FORMAT                    *           00590000
006000*******************************************************           00600000
006100 01  BILL-WORK.                                                   00610000
006200     05  BILL-IN-DATA.                                            00620000
006300         10  BILL-NPI-NUMBER.                                     00630000
006400             15  BILL-NPI            PIC X(08).                   00640000
006500             15  BILL-NPI-FILLER     PIC X(02).                   00650000
006600         10  BILL-PROVIDER-NO        PIC X(06).                   00660000
006700         10  BILL-HIC-NO             PIC X(12).                   00670000
006800         10  BILL-DISCHARGE-DATE.                                 00680000
006900             15  D-CC                PIC 9(02).                   00690000
007000             15  D-YY                PIC 9(02).                   00700000
007100             15  D-MM                PIC 9(02).                   00710000
007200             15  D-DD                PIC 9(02).                   00720000
007300         10  BILL-PATIENT-STATUS     PIC X(02).                   00730000
007400         10  BILL-AGE                PIC 9(03).                   00740000
007500         10  BILL-DRG                PIC 9(03).                   00750000
007600         10  BILL-LOS                PIC 9(05).                   00760000
007700         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   00770000
007800         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   00780000
007900         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   00790000
008000         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             00800000
008100         10  BILL-OTHER-DIAG-DATA    PIC X(175).                  00810000
008200         10  BILL-OTHER-PROC-DATA    PIC X(175).                  00820000
008300         10  BILL-PRIOR-DAYS         PIC 9(03).                   00830000
008400         10  FILLER                  PIC X(11).                   00840000
008500*******************************************************           00850000
008600*    PASSED AND RETURNED BY IPDRV                     *           00860000
008700*******************************************************           00870000
008800     05  IPF-DATA-VARIABLES.                                      00880000
008900         10  IPF-RTC                 PIC 9(02).                   00890000
009000         10  IPF-MSA-CBSA            PIC X(05).                   00900000
009100         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 00910000
009200             15  IPF-MSA             PIC X(04).                   00920000
009300             15  FILLER              PIC X.                       00930000
009400         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                00940000
009500             15  IPF-CBSA            PIC X(05).                   00950000
009600         10  IPF-WAGE-INDEX          PIC 9(02)V9(04).             00960000
009700         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             00970000
009800         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             00980000
009900         10  IPF-COLA                PIC 9(01)V9(03).             00990000
010000         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             01000000
010100         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             01010000
010200         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             01020000
010300         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             01030000
010400         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             01040000
010500         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             01050000
010600         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             01060000
010700         10  IPF-FED-PPS-BLEND-IND   PIC X.                       01070000
010800         10  IPF-CAL-VERSION         PIC X(05).                   01080000
010900         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             01090000
011000         10  FILLER                  PIC X(08).                   01100000
011100                                                                  01110000
011200*******************************************************           01120000
011300*    PASSED AND RETURNED BY IPDRV                     *           01130000
011400*******************************************************           01140000
011500     05  IPF-ADDITIONAL-VARIABLES.                                01150000
011600       07  IPF-MF-VARIABLES.                                      01160000
011700         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).          01170000
011800         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).          01180000
011900         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).          01190000
012000         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).          01200000
012100         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).          01210000
012200         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).          01220000
012300         10  IPF-OUTL-COST              PIC 9(07)V9(02).          01230000
012400         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).          01240000
012500         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).          01250000
012600         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).          01260000
012700         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).          01270000
012800         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).          01280000
012900         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).          01290000
013000         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).          01300000
013100         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).          01310000
013200         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).          01320000
013300         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).          01330000
013400         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).          01340000
013500         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).          01350000
013600         10  FILLER                     PIC X(10).                01360000
013700       07  IPF-PC-VARIABLES.                                      01370000
013800           10  IPF-PC-DATA            PIC X(44).                  01380000
013900     05  FILLER                         PIC X(18).                01390000
014000                                                                  01400000
014100                                                                  01410000
014200*******************************************************           01420000
014300*    PASSED TO IPDRV___                               *           01430000
014400*******************************************************           01440000
014500 01  BILL-INPUT-DATA.                                             01450000
014600     05  B-INPUT-DATA.                                            01460000
014700         10  B-NPI-NUMBER.                                        01470000
014800             15  B-NPI            PIC X(08).                      01480000
014900             15  B-NPI-FILLER     PIC X(02).                      01490000
015000         10  B-PROVIDER-NO        PIC X(06).                      01500000
015100         10  B-HIC-NO             PIC X(12).                      01510000
015200         10  B-DISCHARGE-DATE.                                    01520000
015300             15  B-D-CC           PIC 9(02).                      01530000
015400             15  B-D-YY           PIC 9(02).                      01540000
015500             15  B-D-MM           PIC 9(02).                      01550000
015600             15  B-D-DD           PIC 9(02).                      01560000
015700         10  B-PATIENT-STATUS     PIC X(02).                      01570000
015800         10  B-AGE                PIC 9(03).                      01580000
015900         10  B-DRG                PIC 9(03).                      01590000
016000         10  B-LOS                PIC 9(05).                      01600000
016100         10  B-OUTL-OCCUR-IND     PIC X(01).                      01610000
016200         10  B-SRC-OF-ADMISSION   PIC X(01).                      01620000
016300         10  B-ECT-NO-OF-UNITS    PIC X(03).                      01630000
016400         10  B-CHARGES-CLAIMED    PIC 9(07)V9(02).                01640000
016500         10  B-OTHER-DIAG-DATA    PIC X(175).                     01650000
016600         10  B-OTHER-PROC-DATA    PIC X(175).                     01660000
016700         10  B-PRIOR-DAYS         PIC X(03).                      01670000
016800                                                                  01680000
016900*******************************************************           01690000
017000*    PASSED AND RETURNED BY IPDRV                     *           01700000
017100*******************************************************           01710000
017200 01  PRICER-OPT-VERS-SW.                                          01720000
017300     02  PRICER-OPTION-SW        PIC X.                           01730000
017400     02  IPF-VERSIONS.                                            01740000
017500         10  IPDRV-VERSION       PIC X(05).                       01750000
017600                                                                  01760000
017700*******************************************************           01770000
017800*    CAN BE PASSED TO IPDRV___  OPTION P OR B         *           01780000
017900*******************************************************           01790000
018000 01  PROV-RECORD-FROM-USER       PIC X(240).                      01800000
018100                                                                  01810000
018200*******************************************************           01820000
018300*    CAN BE PASSED TO IPDRV___  OPTION B              *           01830000
018400*******************************************************           01840000
018500 01  MSAX-TABLE-FROM-USER.                                        01850000
018600     05  FILLER                  PIC X(32000).                    01860000
018700     05  FILLER                  PIC X(30000).                    01870000
018800     05  FILLER                  PIC X(30000).                    01880000
018900                                                                  01890000
019000*******************************************************           01900000
019100*    CAN BE PASSED TO IPDRV___  OPTION B              *           01910000
019200*******************************************************           01920000
019300 01  CBSA-TABLE-FROM-USER.                                        01930000
019400     05  FILLER                  PIC X(32000).                    01940000
019500     05  FILLER                  PIC X(30000).                    01950000
019600     05  FILLER                  PIC X(30000).                    01960000
019700                                                                  01970000
019800*******************************************************           01980000
019900*    PASSED TO COMORBIDITY GROUPER AND RETURNED       *           01990000
020000*******************************************************           02000000
020100                                                                  02010000
020200*******************************************************           02020000
020300*    PROSPECTIVE PAYMENT REPORT COMPONENTS            *           02030000
020400*******************************************************           02040000
020500 01  IPF-DETAIL-LINE.                                             02050000
020600     05  FILLER                  PIC X(01)  VALUE SPACES.         02060000
020700     05  PRT-HIC                 PIC X(12).                       02070000
020800     05  FILLER                  PIC X(01)  VALUE SPACES.         02080000
020900     05  PRT-PROV                PIC X(06).                       02090000
021000     05  FILLER                  PIC X(01)  VALUE SPACES.         02100000
021100     05  PRT-WAGE-INDEX          PIC 9.9999.                      02110000
021200     05  FILLER                  PIC X(01)  VALUE SPACES.         02120000
021300     05  PRT-GRP-DRG             PIC 9(03).                       02130000
021400     05  FILLER                  PIC X(01)  VALUE SPACES.         02140000
021500     05  PRT-DRG-FACTOR          PIC 9.99.                        02150000
021600     05  FILLER                  PIC X(01)  VALUE SPACES.         02160000
021700     05  PRT-AGE                 PIC ZZ9.                         02170000
021800     05  FILLER                  PIC X(01)  VALUE SPACES.         02180000
021900     05  PRT-DISCHG-DATE         PIC 9(08).                       02190000
022000     05  FILLER                  PIC X(01)  VALUE SPACES.         02200000
022100     05  PRT-TOT-PAY             PIC Z,ZZZ,ZZZ.99.                02210000
022200     05  FILLER                  PIC X(01)  VALUE SPACES.         02220000
022300     05  PRT-ECT-PAY             PIC ZZZ,ZZZ.99.                  02230000
022400     05  FILLER                  PIC X(02)  VALUE SPACES.         02240000
022500     05  PRT-ECT-UNITS           PIC ZZ9.                         02250000
022600     05  FILLER                  PIC X      VALUE SPACES.         02260000
022700     05  PRT-OUTLIER-PAY         PIC ZZZ,ZZZ.99.                  02270000
022800     05  FILLER                  PIC X(03)  VALUE SPACES.         02280000
022900     05  PRT-OUTL-OCCUR-IND      PIC X(01)  VALUE SPACES.         02290000
023000     05  FILLER                  PIC X(01)  VALUE SPACES.         02300000
023100     05  PRT-MSA-CBSA            PIC X(05).                       02310000
023200     05  FILLER                  PIC X(01)  VALUE SPACES.         02320000
023300     05  PRT-STOPLOSS-AMT        PIC ZZZ,ZZZ.99.                  02330000
023400     05  FILLER                  PIC X(01)  VALUE SPACES.         02340000
023500     05  PRT-FAC-PAY             PIC ZZZ,ZZZ.99.                  02350000
023600     05  FILLER                  PIC X(01)  VALUE SPACES.         02360000
023700     05  PRT-LOS                 PIC ZZ9.                         02370000
023800     05  FILLER                  PIC X(02)  VALUE SPACES.         02380000
023900     05  PRT-PATIENT-STATUS      PIC 99.                          02390000
024000     05  FILLER                  PIC X(01)  VALUE SPACES.         02400000
024100     05  PRT-PPS-RTC             PIC 99.                          02410000
024200     05  FILLER                  PIC X(01)  VALUE SPACES.         02420000
024300                                                                  02430000
024400 01  PPS-HEAD1.                                                   02440000
024500     05  FILLER                  PIC X(01)  VALUE SPACES.         02450000
024600     05  FILLER                  PIC X(44)  VALUE                 02460000
024700        '  C M S ,                                   '.           02470000
024800     05  FILLER                  PIC X(44)  VALUE                 02480000
024900        '                                            '.           02490000
025000     05  FILLER                  PIC X(44)  VALUE                 02500000
025100        '                                            '.           02510000
025200                                                                  02520000
025300 01  PPS-HEAD2-OPER.                                              02530000
025400     05  FILLER                  PIC X(01)  VALUE SPACES.         02540000
025500     05  FILLER                  PIC X(44)  VALUE                 02550000
025600        '  C M S     IPF PRICER        P R O S P E C '.           02560000
025700     05  FILLER                  PIC X(44)  VALUE                 02570000
025800        'T I V E   P A Y M E N T   T E S T   D A T A '.           02580000
025900     05  FILLER                  PIC X(44)  VALUE                 02590000
026000        '  R E P O R T                               '.           02600000
026100                                                                  02610000
026200 01  PPS-HEAD3-OPER.                                              02620000
026300     05  FILLER                  PIC X(01)  VALUE SPACES.         02630000
026400     05  FILLER                  PIC X(44)  VALUE                 02640000
026500        ' HI CLAIM   PROVIDER WAGE  DRG DRG AGE DIS-D'.           02650000
026600     05  FILLER                  PIC X(44)  VALUE                 02660000
026700        'ATE      TOT BLEND     ECT     ECT   OUTLIER'.           02670000
026800     05  FILLER                  PIC X(44)  VALUE                 02680000
026900        ' OUTL MSA/CBSA STOPLOSS   FAC      STAT IPF '.           02690000
027000                                                                  02700000
027100 01  PPS-HEAD4-OPER.                                              02710000
027200     05  FILLER                  PIC X(01)  VALUE SPACES.         02720000
027300     05  FILLER                  PIC X(44)  VALUE                 02730000
027400        '    NO         NO    INDEX  NO FAC     CCYYM'.           02740000
027500     05  FILLER                  PIC X(44)  VALUE                 02750000
027600        'MDD      PAYMENT     PAYMENT  UNITS  PAYMENT'.           02760000
027700     05  FILLER                  PIC X(44)  VALUE                 02770000
027800        '  IND   NO.     AMOUNT  PAYMENT LOS CD  RTC '.           02780000
027900                                                                  02790000
028000                                                                  02800000
028010*----------------------------------------------------------------*02801004
028020*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*02802004
028030*----------------------------------------------------------------*02803004
028100 01  TOTAL-COUNTERS.                                              02810000
028200     03  FILLER                  OCCURS 22.                       02820009
028300         05  COUNT-TOTAL             PIC 9(09) COMP.              02830000
028400                                                                  02840000
028500 01  PRT-LINE.                                                    02850000
028600     05  FILLER                  PIC X(01)  VALUE SPACES.         02860000
028700     05  PRT-LNE                 OCCURS 8.                        02870000
028800         10  PRT-XXX             PIC X(02).                       02880000
028900         10  PRT-DRG             PIC 9(03).                       02890000
029000         10  PRT-CNT             PIC Z(08)9B.                     02900000
029100         10  PRT-COL             PIC X(01).                       02910000
029200                                                                  02920000
029300 01  PRT-HDG-OLD.                                                 02930000
029400     05  FILLER                  PIC X(01)  VALUE SPACES.         02940000
029500     05  FILLER                  PIC X(44)  VALUE                 02950000
029600         '   ****** A L L   R E C O R D S ******      '.          02960000
029700     05  FILLER                  PIC X(44)  VALUE                 02970000
029800         '    DISCHARGES OLDER THEN 5 YEARS           '.          02980000
029900     05  FILLER                  PIC X(35)  VALUE                 02990000
030000        '                C M S ,            '.                    03000000
030100                                                                  03010000
030200                                                                  03020000
030300 01  PRT-HDG-V220.                                                03030000
030400     05  FILLER                  PIC X(01)  VALUE SPACES.         03040000
030500     05  FILLER                  PIC X(44)  VALUE                 03050000
030600         'G R O U P E R  V22/23 COUNTS BY   D R G     '.          03060000
030700     05  FILLER                  PIC X(44)  VALUE                 03070000
030800         'FOR DISCHARGES ON OR AFTER 01/01/2005       '.          03080000
030900     05  FILLER                  PIC X(35)  VALUE                 03090000
031000        '                C M S ,            '.                    03100000
031100                                                                  03110000
031200 01  PRT-HDG-V230.                                                03120000
031300     05  FILLER                  PIC X(01)  VALUE SPACES.         03130000
031400     05  FILLER                  PIC X(44)  VALUE                 03140000
031500         'G R O U P E R  V23.0  COUNTS BY   D R G     '.          03150000
031600     05  FILLER                  PIC X(44)  VALUE                 03160000
031700         'FOR DISCHARGES ON OR AFTER 07/01/2006       '.          03170000
031800     05  FILLER                  PIC X(35)  VALUE                 03180000
031900        '                C M S ,            '.                    03190000
032000                                                                  03200000
032100 01  PRT-HDG-V240.                                                03210000
032200     05  FILLER                  PIC X(01)  VALUE SPACES.         03220000
032300     05  FILLER                  PIC X(44)  VALUE                 03230000
032400         'G R O U P E R  V23.0  COUNTS BY   D R G     '.          03240000
032500     05  FILLER                  PIC X(44)  VALUE                 03250000
032600         'FOR DISCHARGES ON OR AFTER 07/01/2007       '.          03260000
032700     05  FILLER                  PIC X(35)  VALUE                 03270000
032800        '                C M S ,            '.                    03280000
032900                                                                  03290000
033000                                                                  03300000
033100 01  PRT-HDG                     PIC X(132).                      03310000
033200                                                                  03320000
033300**=============================================================   03330000
033400 PROCEDURE  DIVISION.                                             03340000
033500                                                                  03350000
033600 0000-MAINLINE  SECTION.                                          03360000
033700     OPEN INPUT  IPFBILL.                                         03370000
033800                                                                  03380000
033900     OPEN OUTPUT IPFOUT.                                          03390000
034000     OPEN OUTPUT IPFPRT.                                          03400000
034100                                                                  03410000
034200     MOVE LOW-VALUES   TO TOTAL-COUNTERS.                         03420000
034300     MOVE ALL '0'      TO BILL-INPUT-DATA                         03430000
034400                          IPF-DATA-VARIABLES                      03440000
034500                          IPF-ADDITIONAL-VARIABLES                03450000
034600                          IPF-VERSIONS.                           03460000
034700                                                                  03470000
034800     PERFORM 0100-PROCESS-RECORDS THRU 0100-EXIT UNTIL EOF-SW = 1.03480000
034900                                                                  03490000
035000     DISPLAY '-- PROGRAM IPMGR___  VERSION ==> ' IPMGR-VERSION.   03500000
035100     DISPLAY '-- PROGRAM IPOPN___  VERSION ==> ' IPOPN-VERSION.   03510000
035200     DISPLAY '-- PROGRAM IPDRV___  VERSION ==> ' IPDRV-VERSION.   03520000
035300                                                                  03530000
035410*----------------------------------------------------------------*03541004
035420*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*03542004
035430*----------------------------------------------------------------*03543004
035440     DISPLAY ' '.                                                 03544004
035500     IF COUNT-TOTAL (2) > 0                                       03550000
035600       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C05.7 '.         03560000
035700     IF COUNT-TOTAL (3) > 0                                       03570000
035800       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C07.6 '.         03580000
035900     IF COUNT-TOTAL (4) > 0                                       03590000
036000       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C08.A '.         03600000
036100     IF COUNT-TOTAL (5) > 0                                       03610000
036200       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C08.6 '.         03620000
036300     IF COUNT-TOTAL (6) > 0                                       03630000
036400       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C09.A '.         03640000
036500     IF COUNT-TOTAL (7) > 0                                       03650000
036600       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C09.4 '.         03660000
036700     IF COUNT-TOTAL (8) > 0                                       03670000
036800       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C10.0 '.         03680000
036900     IF COUNT-TOTAL (9) > 0                                       03690000
037000       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C10.2 '.         03700000
037100     IF COUNT-TOTAL (10) > 0                                      03710000
037200       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C11.0 '.         03720000
037300     IF COUNT-TOTAL (11) > 0                                      03730000
037400       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C11.1 '.         03740000
037500     IF COUNT-TOTAL (12) > 0                                      03750000
037600       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C11.2 '.         03760000
037700     IF COUNT-TOTAL (13) > 0                                      03770000
037800       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C12.0 '.         03780000
037900     IF COUNT-TOTAL (14) > 0                                      03790000
038000       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C12.1 '.         03800000
038100     IF COUNT-TOTAL (15) > 0                                      03810000
038200       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C13.0 '.         03820000
038300     IF COUNT-TOTAL (16) > 0                                      03830000
038310       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C14.0 '.         03831000
038320     IF COUNT-TOTAL (17) > 0                                      03832000
038330       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C15.0 '.         03833000
038331     IF COUNT-TOTAL (18) > 0                                      03833100
038332       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C16.0 '.         03833200
038333     IF COUNT-TOTAL (19) > 0                                      03833304
038334       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C17.0 '.         03833404
038335     IF COUNT-TOTAL (20) > 0                                      03833508
038336       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C18.0 '.         03833608
038337     IF COUNT-TOTAL (21) > 0                                      03833708
038338       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C19.0 '.         03833808
038339                                                                  03833908
038340*----------------------------------------------------------------*03834008
038341*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*03834108
038342*----------------------------------------------------------------*03834208
038343     DISPLAY ' '.                                                 03834308
038344     IF COUNT-TOTAL (1) > 0                                       03834408
038345      DISPLAY '--   TOTAL OLD RECORDS   ======> ' COUNT-TOTAL (1).03834508
038346     IF COUNT-TOTAL (2) > 0                                       03834608
038347      DISPLAY '-- FY 2005 RECORD COUNTS ======> ' COUNT-TOTAL (2).03834708
038348     IF COUNT-TOTAL (3) > 0                                       03834808
038349      DISPLAY '-- FY 2007 RECORD COUNTS ======> ' COUNT-TOTAL (3).03834908
038350     IF COUNT-TOTAL (4) > 0                                       03835008
038351      DISPLAY '-- FY 2008-A REC  COUNTS ======> ' COUNT-TOTAL (4).03835108
038352     IF COUNT-TOTAL (5) > 0                                       03835208
038360      DISPLAY '-- FY 2008-6 REC  COUNTS ======> ' COUNT-TOTAL (5).03836000
038370     IF COUNT-TOTAL (6) > 0                                       03837000
038380      DISPLAY '-- FY 2009-A REC  COUNTS ======> ' COUNT-TOTAL (6).03838000
038390     IF COUNT-TOTAL (7) > 0                                       03839000
038400      DISPLAY '-- FY 2009-4 REC  COUNTS ======> ' COUNT-TOTAL (7).03840000
038500     IF COUNT-TOTAL (8) > 0                                       03850000
038600      DISPLAY '-- FY 2010 RECORD COUNTS ======> ' COUNT-TOTAL (8).03860000
038700     IF COUNT-TOTAL (9) > 0                                       03870000
038800      DISPLAY '-- FY 2010-2 REC  COUNTS ======> ' COUNT-TOTAL (9).03880000
038900     IF COUNT-TOTAL (10) > 0                                      03890000
038910      DISPLAY '-- FY 2011 REC  COUNTS ======> ' COUNT-TOTAL (10). 03891000
038920     IF COUNT-TOTAL (11) > 0                                      03892000
038930      DISPLAY '-- FY 2011-2 REC  COUNTS =====> ' COUNT-TOTAL (11).03893000
038940     IF COUNT-TOTAL (12) > 0                                      03894000
038950      DISPLAY '-- FY 2011-3 REC  COUNTS =====> ' COUNT-TOTAL (12).03895000
038960     IF COUNT-TOTAL (13) > 0                                      03896000
038970      DISPLAY '-- FY 2012-0 REC  COUNTS =====> ' COUNT-TOTAL (13).03897000
038980     IF COUNT-TOTAL (14) > 0                                      03898000
038990      DISPLAY '-- FY 2012-1 REC  COUNTS =====> ' COUNT-TOTAL (14).03899000
038991     IF COUNT-TOTAL (15) > 0                                      03899100
038992      DISPLAY '-- FY 2013-0 REC  COUNTS =====> ' COUNT-TOTAL (15).03899200
038993     IF COUNT-TOTAL (16) > 0                                      03899300
038994      DISPLAY '-- FY 2014-0 REC  COUNTS =====> ' COUNT-TOTAL (16).03899400
038995     IF COUNT-TOTAL (17) > 0                                      03899500
038996      DISPLAY '-- FY 2015-0 REC  COUNTS =====> ' COUNT-TOTAL (17).03899600
038997     IF COUNT-TOTAL (18) > 0                                      03899700
038998      DISPLAY '-- FY 2016-0 REC  COUNTS =====> ' COUNT-TOTAL (18).03899800
038999     IF COUNT-TOTAL (19) > 0                                      03899904
039000      DISPLAY '-- FY 2017-0 REC  COUNTS =====> ' COUNT-TOTAL (19).03900006
039001     IF COUNT-TOTAL (21) > 0                                      03900108
039002      DISPLAY '-- FY 2018-0 REC  COUNTS =====> ' COUNT-TOTAL (20).03900208
039003     IF COUNT-TOTAL (22) > 0                                      03900308
039004      DISPLAY '-- FY 2019-0 REC  COUNTS =====> ' COUNT-TOTAL (21).03900408
039005                                                                  03900508
039006     DISPLAY '                                -----------'.       03900608
039007                                                                  03900708
039010     DISPLAY '-- INPUT  COUNTS FOR IPFBILL ===> ' IPFBILL-CTR.    03901000
039100     DISPLAY '-- OUTPUT COUNTS FOR IPFOUT  ===> ' IPFOUT-CTR.     03910000
039200                                                                  03920000
039300     CLOSE IPFBILL.                                               03930000
039400     CLOSE IPFOUT.                                                03940000
039500                                                                  03950000
039600*    MOVE 1 TO X4.                                                03960001
039700*    MOVE PRT-HDG-OLD  TO PRT-HDG.                                03970001
039800*    WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING PAGE.         03980001
039900*    IF OPR-STAT1 > 0 DISPLAY ' BAD1 WRITE ON IPFPRT FILE'.       03990001
040000                                                                  04000000
040100     MOVE SPACES TO PRT-LINE.                                     04010000
040200     MOVE '  TOTAL RECORDS PROCESSED' TO PRT-HDG.                 04020000
040300     WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING 3.            04030000
040400     IF OPR-STAT1 > 0 DISPLAY ' BAD2 WRITE ON IPFPRT FILE'.       04040000
040500                                                                  04050000
040600     MOVE COUNT-TOTAL (X4) TO PRT-CNT (1).                        04060000
040700     WRITE IPFPRT-LINE FROM PRT-LINE AFTER ADVANCING 1.           04070000
040800     IF OPR-STAT1 > 0 DISPLAY ' BAD3 WRITE ON IPFPRT FILE'.       04080000
040900                                                                  04090000
041000*    MOVE 2 TO X4.                                                04100001
041100*    MOVE PRT-HDG-V220 TO PRT-HDG.                                04110001
041200*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04120001
041300                                                                  04130000
041400*    MOVE 3 TO X4.                                                04140001
041500*    MOVE PRT-HDG-V230 TO PRT-HDG.                                04150001
041600*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04160001
041700                                                                  04170000
041800*    MOVE 4 TO X4.                                                04180001
041900*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04190001
042000*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04200001
042100                                                                  04210000
042200*    MOVE 5 TO X4.                                                04220001
042300*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04230001
042400*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04240001
042500                                                                  04250001
042600*    MOVE 6 TO X4.                                                04260001
042700*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04270001
042800*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04280001
042900                                                                  04290000
043000*    MOVE 7 TO X4.                                                04300001
043100*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04310001
043200*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04320001
043300                                                                  04330000
043400     CLOSE IPFPRT.                                                04340000
043500     STOP RUN.                                                    04350000
043600                                                                  04360000
043700 0100-PROCESS-RECORDS.                                            04370000
043800     READ IPFBILL INTO BILL-WORK                                  04380000
043900         AT END                                                   04390000
044000             MOVE 1 TO EOF-SW.                                    04400000
044010     MOVE BILL-NPI-NUMBER       TO B-NPI-NUMBER.                  04401005
044100     MOVE BILL-PROVIDER-NO      TO B-PROVIDER-NO.                 04410000
044200     MOVE BILL-HIC-NO           TO B-HIC-NO.                      04420000
044300     MOVE BILL-PATIENT-STATUS   TO B-PATIENT-STATUS.              04430000
044400     MOVE BILL-AGE              TO B-AGE.                         04440000
044500     MOVE BILL-DRG              TO B-DRG.                         04450000
044600     MOVE BILL-LOS              TO B-LOS.                         04460000
044700     MOVE BILL-DISCHARGE-DATE   TO B-DISCHARGE-DATE.              04470000
044800     MOVE BILL-CHARGES-CLAIMED  TO B-CHARGES-CLAIMED.             04480000
044900     MOVE BILL-OUTL-OCCUR-IND   TO B-OUTL-OCCUR-IND.              04490000
045000     MOVE BILL-SRC-OF-ADMISSION TO B-SRC-OF-ADMISSION.            04500000
045100     MOVE BILL-ECT-NO-OF-UNITS  TO B-ECT-NO-OF-UNITS.             04510000
045200     MOVE BILL-OTHER-DIAG-DATA  TO B-OTHER-DIAG-DATA.             04520000
045300     MOVE BILL-OTHER-PROC-DATA  TO B-OTHER-PROC-DATA.             04530000
045400     MOVE BILL-PRIOR-DAYS       TO B-PRIOR-DAYS.                  04540000
045500                                                                  04550000
045600     IF  EOF-SW = 0                                               04560000
045700         ADD 1 TO IPFBILL-CTR                                     04570000
045800         PERFORM 0200-APPLY-YR  THRU 0200-EXIT                    04580000
045900         PERFORM 1000-CALC-PAYMENT THRU 1000-EXIT                 04590000
046000         PERFORM 1100-WRITE-IPFOUT THRU 1100-EXIT.                04600000
046100                                                                  04610000
046200 0100-EXIT.  EXIT.                                                04620000
046300                                                                  04630000
046310*----------------------------------------------------------------*04631004
046320*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*04632004
046330*----------------------------------------------------------------*04633004
046400 0200-APPLY-YR.                                                   04640000
046500*******************************************************           04650000
046600****  OLD RECORDS BEFORE IPF STARTED                              04660000
046700*******************************************************           04670000
046800     IF BILL-DISCHARGE-DATE < 20050101                            04680000
046900        MOVE 1 TO X4                                              04690000
047000        ADD 1             TO COUNT-TOTAL (X4)                     04700000
047100     ELSE                                                         04710000
047200                                                                  04720000
047300*******************************************************           04730000
047400****  BETWEEN 01/01/2005 AND 07/01/2006    FOR 2005               04740000
047500****       18 MONTHS                                              04750000
047600*******************************************************           04760000
047700     IF BILL-DISCHARGE-DATE < 20060701                            04770000
047800        MOVE 2 TO X4                                              04780000
047900        ADD 1             TO COUNT-TOTAL (X4)                     04790000
048000     ELSE                                                         04800000
048100                                                                  04810000
048200*******************************************************           04820000
048300****  BETWEEN 07/01/2006 AND 07/01/2007    FOR 2006               04830000
048400****       12 MONTHS                                              04840000
048500*******************************************************           04850000
048600     IF BILL-DISCHARGE-DATE < 20070701                            04860000
048700        MOVE 3 TO X4                                              04870000
048800        ADD 1             TO COUNT-TOTAL (X4)                     04880000
048900     ELSE                                                         04890000
049000                                                                  04900000
049100*******************************************************           04910000
049200****  BETWEEN 07/01/2007 AND 10/01/2007    FOR 2007               04920000
049300****        3 MONTHS                                              04930000
049400*******************************************************           04940000
049500     IF BILL-DISCHARGE-DATE < 20071001                            04950000
049600        MOVE 4 TO X4                                              04960000
049700        ADD 1             TO COUNT-TOTAL (X4)                     04970000
049800     ELSE                                                         04980000
049900                                                                  04990000
050000*******************************************************           05000000
050100****  BETWEEN 07/01/2007 AND 06/30/2008    FOR 2008               05010000
050200****        3 MONTHS                                              05020000
050300*******************************************************           05030000
050400     IF BILL-DISCHARGE-DATE < 20080701                            05040000
050500        MOVE 5 TO X4                                              05050000
050600        ADD 1             TO COUNT-TOTAL (X4)                     05060000
050700     ELSE                                                         05070000
050800                                                                  05080000
050900*******************************************************           05090000
051000****  AFTER 06/30/08 - RATE   YEAR 2009 JUL - SEPT                05100000
051100*******************************************************           05110000
051200     IF BILL-DISCHARGE-DATE < 20081001                            05120000
051300        MOVE 6 TO X4                                              05130000
051400        ADD 1             TO COUNT-TOTAL (X4)                     05140000
051500     ELSE                                                         05150000
051600*******************************************************           05160000
051700****  AFTER 09/30/08 - RATE   YEAR 2009-2 OCT08 - JUL09           05170000
051800*******************************************************           05180000
051900     IF BILL-DISCHARGE-DATE < 20090701                            05190000
052000        MOVE 7 TO X4                                              05200000
052100        ADD 1             TO COUNT-TOTAL (X4)                     05210000
052200     ELSE                                                         05220000
052300*******************************************************           05230000
052400****  AFTER 06/30/09 - RATE   YEAR 2010   JUL - SEPT              05240000
052500*******************************************************           05250000
052600     IF BILL-DISCHARGE-DATE < 20091001                            05260000
052700        MOVE 8 TO X4                                              05270000
052800        ADD 1             TO COUNT-TOTAL (X4)                     05280000
052900     ELSE                                                         05290000
053000*******************************************************           05300000
053100****  AFTER 09/30/09 - RATE   YEAR 2010-2 OCT09 - JUL10           05310000
053200*******************************************************           05320000
053300     IF BILL-DISCHARGE-DATE < 20100701                            05330000
053400        MOVE 9 TO X4                                              05340000
053500        ADD 1             TO COUNT-TOTAL (X4)                     05350000
053600     ELSE                                                         05360000
053700*******************************************************           05370000
053800****  AFTER 06/30/10 - RATE   YEAR 2011 JUL10 - SEP11             05380000
053900*******************************************************           05390000
054000     IF BILL-DISCHARGE-DATE < 20101001                            05400000
054010        MOVE 10 TO X4                                             05401000
054020        ADD 1             TO COUNT-TOTAL (X4)                     05402000
054030     ELSE                                                         05403000
054040     IF BILL-DISCHARGE-DATE < 20110101                            05404000
054050        MOVE 11 TO X4                                             05405000
054060        ADD 1             TO COUNT-TOTAL (X4)                     05406000
054070     ELSE                                                         05407000
054080     IF BILL-DISCHARGE-DATE < 20110701                            05408000
054090        MOVE 12 TO X4                                             05409000
054091        ADD 1             TO COUNT-TOTAL (X4)                     05409100
054092     ELSE                                                         05409200
054093     IF BILL-DISCHARGE-DATE < 20111001                            05409300
054094        MOVE 13 TO X4                                             05409400
054095        ADD 1             TO COUNT-TOTAL (X4)                     05409500
054096     ELSE                                                         05409600
054097     IF BILL-DISCHARGE-DATE < 20121001                            05409700
054098        MOVE 14 TO X4                                             05409800
054099        ADD 1             TO COUNT-TOTAL (X4)                     05409900
054100     ELSE                                                         05410000
054110     IF BILL-DISCHARGE-DATE < 20131001                            05411000
054111        MOVE 15 TO X4                                             05411100
054112        ADD 1             TO COUNT-TOTAL (X4)                     05411200
054113     ELSE                                                         05411300
054114     IF BILL-DISCHARGE-DATE < 20141001                            05411400
054115        MOVE 16 TO X4                                             05411500
054116        ADD 1             TO COUNT-TOTAL (X4)                     05411600
054117     ELSE                                                         05411700
054118     IF BILL-DISCHARGE-DATE < 20151001                            05411800
054119        MOVE 17 TO X4                                             05411900
054120        ADD 1             TO COUNT-TOTAL (X4)                     05412000
054121     ELSE                                                         05412104
054124     IF BILL-DISCHARGE-DATE < 20161001                            05412404
054125        MOVE 18 TO X4                                             05412504
054126        ADD 1             TO COUNT-TOTAL (X4)                     05412604
054127     ELSE                                                         05412704
054128     IF BILL-DISCHARGE-DATE < 20171001                            05412807
054129        MOVE 19 TO X4                                             05412907
054130        ADD 1             TO COUNT-TOTAL (X4)                     05413007
054131     ELSE                                                         05413107
054132     IF BILL-DISCHARGE-DATE < 20181001                            05413208
054133        MOVE 20 TO X4                                             05413308
054134        ADD 1             TO COUNT-TOTAL (X4)                     05413408
054135     ELSE                                                         05413508
054136        MOVE 21 TO X4                                             05413608
054137        ADD 1             TO COUNT-TOTAL (X4).                    05413708
054138 0200-EXIT.  EXIT.                                                05413808
054139                                                                  05413908
054140                                                                  05414000
054150 1000-CALC-PAYMENT.                                               05415000
054160*******************************************************           05416000
054170*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE      *           05417000
054180*    PAYMENT                                          *           05418000
054190*******************************************************           05419000
054200***************************************************************   05420000
054300* OPTION (1)                                                  *   05430000
054400*       (1)  MOVE 'S' TO PRICER-OPTION-SW.                    *   05440000
054500*            CALL 'IPDRV___' USING BILL-INPUT-DATA            *   05450000
054600*                                  IPF-DATA-VARIABLES         *   05460000
054700*                                  IPF-ADDITIONAL-VARIABLES   *   05470000
054710*                                  PRICER-OPT-VERS-SW.        *   05471000
054720*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING. *   05472000
054730*                        *  *  *  *                           *   05473000
054740*                        *  *  *  *                           *   05474000
054750* OPTION (2)                                                  *   05475000
054760*       (2)  MOVE 'P' TO PRICER-OPTION-SW.                    *   05476000
054770*            CALL 'IPDRV___' USING BILL-INPUT-DATA            *   05477000
054780*                                  IPF-DATA-VARIABLES         *   05478000
054790*                                  IPF-ADDITIONAL-VARIABLES   *   05479000
054800*                                  PRICER-OPT-VERS-SW         *   05480000
054900*                                  PROV-RECORD-FROM-USER.     *   05490000
055000*        THIS PASSES THE STANDARD VARIABLES                   *   05500000
055100*       AND ADDITIONAL VARIABLES USED FOR PRICING.            *   05510000
055200*        THE PROVIDER RECORD FROM THE USER                    *   05520000
055300*       USED FOR THIS BILL ONLY IS ALSO PASSED.               *   05530000
055400*                        *  *  *  *                           *   05540000
055500* OPTION (3)                                                  *   05550000
055600*       (3)  MOVE 'B' TO PRICER-OPTION-SW.                    *   05560000
055700*            CALL 'IPDRV___' USING BILL-INPUT-DATA            *   05570000
055800*                                  IPF-DATA-VARIABLES         *   05580000
055900*                                  IPF-ADDITIONAL-VARIABLES   *   05590000
056000*                                  PRICER-OPT-VERS-SW         *   05600000
056100*                                  PROV-RECORD-FROM-USER      *   05610000
056200*                                  MSAX-TABLE-FROM-USER.      *   05620000
056300*        THIS IS THE ONLINE COMPATIBLE INTERFACE.             *   05630000
056400*        THIS PASSES THE STANDARD VARIIABLES AND THE          *   05640000
056500*      ADDITIONAL VARIABLES USED FOR PRICING.                 *   05650000
056600*        THE PROVIDER RECORD AND THE WAGE INDEX TABLE FROM    *   05660000
056700*      THE USERS ARE PASSED.                                  *   05670000
056800***************************************************************   05680000
056900                                                                  05690000
057000*** OPTION (1)                                                    05700000
057100     MOVE 'S' TO PRICER-OPTION-SW.                                05710000
057200     CALL  IPOPN190   USING BILL-INPUT-DATA                       05720008
057300                            IPF-DATA-VARIABLES                    05730000
057400                            IPF-ADDITIONAL-VARIABLES              05740000
057500                            PRICER-OPT-VERS-SW.                   05750000
057600*** OPTION (2)                                                    05760000
057700*    MOVE 'P' TO PRICER-OPTION-SW.                                05770000
057800*    CALL  IPDRV072   USING BILL-INPUT-DATA                       05780000
057900*                           IPF-DATA-VARIABLES                    05790000
058000*                           IPF-ADDITIONAL-VARIABLES              05800000
058100*                           PRICER-OPT-VERS-SW                    05810000
058200*                           PROV-RECORD-FROM-USER.                05820000
058300*** OPTION (3)                                                    05830000
058400*    MOVE 'B' TO PRICER-OPTION-SW.                                05840000
058500*    CALL  IPDRV072   USING BILL-INPUT-DATA                       05850000
058600*                           IPF-DATA-VARIABLES                    05860000
058700*                           IPF-ADDITIONAL-VARIABLES              05870000
058800*                           PRICER-OPT-VERS-SW                    05880000
058900*                           PROV-RECORD-FROM-USER                 05890000
059000*                           MSAX-TABLE-FROM-USER                  05900000
059100*                           CBSA-TABLE-FROM-USER.                 05910000
059200                                                                  05920000
059300 1000-EXIT.  EXIT.                                                05930000
059400                                                                  05940000
059500 1100-WRITE-IPFOUT.                                               05950000
059600******************************************************************05960000
059700*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL         05970000
059800*    REPORT AND WRITE TEST PAYMENT RECORD ROUTINE                 05980000
059900******************************************************************05990000
060000     IF  OPERLINE-CTR > 54                                        06000000
060100         PERFORM 1200-PPS-HEADINGS THRU 1200-EXIT.                06010000
060200     MOVE SPACES               TO  IPF-DETAIL-LINE.               06020000
060300     MOVE B-PROVIDER-NO        TO  PRT-PROV.                      06030000
060400     MOVE B-HIC-NO             TO  PRT-HIC.                       06040000
060500     MOVE B-DISCHARGE-DATE     TO  PRT-DISCHG-DATE.               06050000
060600     MOVE B-DRG                TO  PRT-GRP-DRG.                   06060000
060700     MOVE B-AGE                TO  PRT-AGE.                       06070000
060800     MOVE B-LOS                TO  PRT-LOS.                       06080000
060900     MOVE B-ECT-NO-OF-UNITS    TO  PRT-ECT-UNITS.                 06090000
061000     MOVE B-PATIENT-STATUS     TO  PRT-PATIENT-STATUS.            06100000
061100     MOVE B-OUTL-OCCUR-IND     TO  PRT-OUTL-OCCUR-IND.            06110000
061200     MOVE IPF-DRG-FACTOR       TO  PRT-DRG-FACTOR.                06120000
061300     MOVE IPF-RTC              TO  PRT-PPS-RTC.                   06130000
061400     MOVE IPF-WAGE-INDEX       TO PRT-WAGE-INDEX.                 06140000
061500     MOVE IPF-TOT-PAYMENT      TO  PRT-TOT-PAY.                   06150000
061600     MOVE IPF-FAC-PAYMENT      TO  PRT-FAC-PAY.                   06160000
061700     MOVE IPF-OUTLIER-PAYMENT  TO  PRT-OUTLIER-PAY.               06170000
061800     MOVE IPF-ECT-PAYMENT      TO  PRT-ECT-PAY.                   06180000
061900     IF BILL-DISCHARGE-DATE > 20060630                            06190000
062000        MOVE IPF-CBSA TO PRT-MSA-CBSA                             06200000
062100     ELSE                                                         06210000
062200        MOVE IPF-MSA  TO  PRT-MSA-CBSA.                           06220000
062300     MOVE IPF-100PCT-STOPLOS-AMT TO PRT-STOPLOSS-AMT.             06230000
062400                                                                  06240000
062500     WRITE IPFPRT-LINE FROM IPF-DETAIL-LINE                       06250000
062600                             AFTER ADVANCING 1.                   06260000
062700     IF OPR-STAT1 > 0 DISPLAY ' BAD4 WRITE ON IPFPRT FILE'.       06270000
062800     ADD 1 TO OPERLINE-CTR.                                       06280000
062900                                                                  06290000
063000        WRITE OUT-REC FROM BILL-WORK.                             06300000
063100                                                                  06310000
063200     IF UT2-STAT1 > 0 DISPLAY ' BAD1 WRITE ON IPFOUT  FILE'.      06320000
063300     ADD 1 TO IPFOUT-CTR.                                         06330000
063400                                                                  06340000
063500**************************************************************    06350000
063600 1100-EXIT.  EXIT.                                                06360000
063700                                                                  06370000
063800 1200-PPS-HEADINGS.                                               06380000
063900*    WRITE IPFPRT-LINE FROM PPS-HEAD1                             06390001
064000*                            AFTER ADVANCING PAGE.                06400001
064100*    IF OPR-STAT1 > 0 DISPLAY ' BAD5 WRITE ON IPFPRT FILE'.       06410001
064200*    WRITE IPFPRT-LINE FROM PPS-HEAD2-OPER                        06420001
064300*                            AFTER ADVANCING 1.                   06430001
064310     WRITE IPFPRT-LINE FROM PPS-HEAD2-OPER                        06431001
064320                             AFTER ADVANCING PAGE.                06432001
064400     IF OPR-STAT1 > 0 DISPLAY ' BAD6 WRITE ON IPFPRT FILE'.       06440000
064500     WRITE IPFPRT-LINE FROM PPS-HEAD3-OPER                        06450000
064600                             AFTER ADVANCING 2.                   06460000
064700     IF OPR-STAT1 > 0 DISPLAY ' BAD7 WRITE ON IPFPRT FILE'.       06470000
064800     WRITE IPFPRT-LINE FROM PPS-HEAD4-OPER                        06480000
064900                             AFTER ADVANCING 1.                   06490000
065000     IF OPR-STAT1 > 0 DISPLAY ' BAD8 WRITE ON IPFPRT FILE'.       06500000
065100     MOVE ALL '  -' TO IPFPRT-LINE.                               06510000
065200     WRITE IPFPRT-LINE AFTER ADVANCING 1.                         06520000
065300     IF OPR-STAT1 > 0 DISPLAY ' BAD9 WRITE ON IPFPRT FILE'.       06530000
065400     MOVE 5 TO OPERLINE-CTR.                                      06540000
065500                                                                  06550000
065600 1200-EXIT.  EXIT.                                                06560000
065700                                                                  06570000
065800                                                                  06580000
065900*1300-PRINT-COUNTERS.                                             06590002
066000*******************************************************           06600000
066100*    PRINT COUNTERS TABLE ROUTINES AT EOJ             *           06610000
066200*******************************************************           06620000
066300*    WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING PAGE.         06630002
066400*    IF OPR-STAT1 > 0 DISPLAY ' BAD10 WRITE ON IPFPRT FILE'.      06640002
066500                                                                  06650000
066600*    MOVE '  TOTAL RECORDS PROCESSED' TO PRT-HDG.                 06660002
066700*    WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING 3.            06670002
066800*    IF OPR-STAT1 > 0 DISPLAY ' BAD13 WRITE ON IPFPRT FILE'.      06680002
066900                                                                  06690000
067000*    MOVE SPACES TO PRT-LINE.                                     06700002
067100*    MOVE COUNT-TOTAL (X4) TO PRT-CNT (1).                        06710002
067200*    WRITE IPFPRT-LINE FROM PRT-LINE AFTER ADVANCING 1.           06720002
067300*    IF OPR-STAT1 > 0 DISPLAY ' BAD14 WRITE ON IPFPRT FILE'.      06730002
067400                                                                  06740000
067500*1300-EXIT.  EXIT.                                                06750002
067600                                                                  06760000
067700**===================================================**           06770000
067800**           LAST STATEMENT                          **           06780000
067900**===================================================**           06790000
