000100 IDENTIFICATION DIVISION.                                         00010006
000200 PROGRAM-ID.    IPMGR210.                                         00020006
000300*AUTHOR.   CMS.                                                   00030006
000400*          CENTERS FOR MEDICARE AND MEDICAID SERVICES             00040006
000500*          INPATIENT PSYCHIATRIC FACILITY PPS PRICER              00050006
000600 DATE-COMPILED.                                                   00060006
000700 ENVIRONMENT                     DIVISION.                        00070006
000800 CONFIGURATION                   SECTION.                         00080006
000900 SOURCE-COMPUTER.                IBM-370.                         00090006
001000 OBJECT-COMPUTER.                IBM-370.                         00100006
001100 INPUT-OUTPUT SECTION.                                            00110006
001200 FILE-CONTROL.                                                    00120006
001300                                                                  00130006
001400     SELECT IPFBILL    ASSIGN TO UT-S-IPFBILL                     00140006
001500         FILE STATUS IS UT1-STAT.                                 00150006
001600     SELECT IPFOUT     ASSIGN TO UT-S-IPFOUT                      00160006
001700         FILE STATUS IS UT2-STAT.                                 00170006
001800     SELECT IPFPRT     ASSIGN TO UT-S-IPFPRT                      00180006
001900         FILE STATUS IS OPR-STAT.                                 00190006
002000                                                                  00200006
002100 DATA DIVISION.                                                   00210006
002110 FILE SECTION.                                                    00211006
002120 FD  IPFBILL                                                      00212006
002130     LABEL RECORDS ARE STANDARD                                   00213006
002140     RECORDING MODE IS F                                          00214006
002150     BLOCK CONTAINS 0 RECORDS.                                    00215006
002160 01  IPF-REC                     PIC X(416).                      00216006
002170                                                                  00217006
002180 FD  IPFOUT                                                       00218006
002190     LABEL RECORDS ARE STANDARD                                   00219006
002200     RECORDING MODE IS F                                          00220006
002300     BLOCK CONTAINS 0 RECORDS.                                    00230006
002400 01  OUT-REC                     PIC X(752).                      00240006
002500                                                                  00250006
002600 FD  IPFPRT                                                       00260006
002700     RECORDING MODE IS F                                          00270006
002800     BLOCK CONTAINS 133 RECORDS                                   00280006
002900     LABEL RECORDS ARE STANDARD.                                  00290006
003000 01  IPFPRT-LINE                 PIC X(133).                      00300006
003100                                                                  00310006
003200                                                                  00320006
003300 WORKING-STORAGE SECTION.                                         00330006
003400 77  W-STORAGE-REF               PIC X(40)  VALUE                 00340006
003500     'IPMGR210 - W O R K I N G   S T O R A G E'.                  00350006
003600 01  IPMGR-VERSION               PIC X(05)  VALUE 'M21.0'.        00360006
003700 01  IPOPN-VERSION               PIC X(05)  VALUE 'O21.0'.        00370006
003800 01  IPOPN21B                    PIC X(08)  VALUE 'IPOPN210'.     00380006
003900 01  EOF-SW                      PIC 9(01)  VALUE 0.              00390006
004000 01  TBL-EOF-SW                  PIC 9(01)  VALUE 0.              00400006
004100 01  X1                          PIC 9(05)  COMP SYNC VALUE 0.    00410006
004200 01  X2                          PIC 9(05)  COMP SYNC VALUE 0.    00420006
004300 01  X3                          PIC 9(05)  COMP SYNC VALUE 0.    00430006
004400 01  X4                          PIC 9(05)  COMP SYNC VALUE 0.    00440006
004500 01  OPERLINE-CTR                PIC 9(02)  VALUE 65.             00450006
004600 01  IPFBILL-CTR                 PIC 9(09)  VALUE 0.              00460006
004700 01  IPFOUT-CTR                  PIC 9(09)  VALUE 0.              00470006
004800 01  UT1-STAT.                                                    00480006
004900     05  UT1-STAT1               PIC X.                           00490006
005000     05  UT1-STAT2               PIC X.                           00500006
005100 01  UT2-STAT.                                                    00510006
005200     05  UT2-STAT1               PIC X.                           00520006
005300     05  UT2-STAT2               PIC X.                           00530006
005400 01  OPR-STAT.                                                    00540006
005500     05  OPR-STAT1               PIC X.                           00550006
005600     05  OPR-STAT2               PIC X.                           00560006
005700*******************************************************           00570006
005800*******************************************************           00580006
005900*               BILL RECORD FORMAT                    *           00590006
006000*******************************************************           00600006
006100 01  BILL-WORK.                                                   00610006
006200     05  BILL-IN-DATA.                                            00620006
006300         10  BILL-NPI-NUMBER.                                     00630006
006400             15  BILL-NPI            PIC X(08).                   00640006
006500             15  BILL-NPI-FILLER     PIC X(02).                   00650006
006600         10  BILL-PROVIDER-NO        PIC X(06).                   00660006
006700         10  BILL-HIC-NO             PIC X(12).                   00670006
006800         10  BILL-DISCHARGE-DATE.                                 00680006
006900             15  D-CC                PIC 9(02).                   00690006
007000             15  D-YY                PIC 9(02).                   00700006
007100             15  D-MM                PIC 9(02).                   00710006
007200             15  D-DD                PIC 9(02).                   00720006
007300         10  BILL-PATIENT-STATUS     PIC X(02).                   00730006
007400         10  BILL-AGE                PIC 9(03).                   00740006
007500         10  BILL-DRG                PIC 9(03).                   00750006
007600         10  BILL-LOS                PIC 9(05).                   00760006
007700         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   00770006
007800         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   00780006
007900         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   00790006
008000         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             00800006
008100         10  BILL-OTHER-DIAG-DATA    PIC X(175).                  00810006
008200         10  BILL-OTHER-PROC-DATA    PIC X(175).                  00820006
008300         10  BILL-PRIOR-DAYS         PIC 9(03).                   00830006
008400         10  FILLER                  PIC X(11).                   00840006
008500*******************************************************           00850006
008600*    PASSED AND RETURNED BY IPDRV                     *           00860006
008700*******************************************************           00870006
008800     05  IPF-DATA-VARIABLES.                                      00880006
008900         10  IPF-RTC                 PIC 9(02).                   00890006
009000         10  IPF-MSA-CBSA            PIC X(05).                   00900006
009100         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 00910006
009200             15  IPF-MSA             PIC X(04).                   00920006
009300             15  FILLER              PIC X.                       00930006
009400         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                00940006
009500             15  IPF-CBSA            PIC X(05).                   00950006
009600         10  IPF-WAGE-INDEX          PIC 9(02)V9(04).             00960006
009700         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             00970006
009800         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             00980006
009900         10  IPF-COLA                PIC 9(01)V9(03).             00990006
010000         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             01000006
010100         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             01010006
010200         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             01020006
010300         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             01030006
010400         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             01040006
010500         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             01050006
010600         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             01060006
010700         10  IPF-FED-PPS-BLEND-IND   PIC X.                       01070006
010800         10  IPF-CAL-VERSION         PIC X(05).                   01080006
010900         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             01090006
011000         10  FILLER                  PIC X(08).                   01100006
011100                                                                  01110006
011200*******************************************************           01120006
011300*    PASSED AND RETURNED BY IPDRV                     *           01130006
011400*******************************************************           01140006
011500     05  IPF-ADDITIONAL-VARIABLES.                                01150006
011600       07  IPF-MF-VARIABLES.                                      01160006
011700         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).          01170006
011800         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).          01180006
011900         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).          01190006
012000         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).          01200006
012100         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).          01210006
012200         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).          01220006
012300         10  IPF-OUTL-COST              PIC 9(07)V9(02).          01230006
012400         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).          01240006
012500         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).          01250006
012600         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).          01260006
012700         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).          01270006
012800         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).          01280006
012900         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).          01290006
013000         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).          01300006
013100         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).          01310006
013200         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).          01320006
013300         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).          01330006
013400         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).          01340006
013500         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).          01350006
013600         10  FILLER                     PIC X(10).                01360006
013700       07  IPF-PC-VARIABLES.                                      01370006
013800           10  IPF-PC-DATA            PIC X(44).                  01380006
013900     05  FILLER                         PIC X(18).                01390006
014000                                                                  01400006
014100                                                                  01410006
014200*******************************************************           01420006
014300*    PASSED TO IPDRV___                               *           01430006
014400*******************************************************           01440006
014500 01  BILL-INPUT-DATA.                                             01450006
014600     05  B-INPUT-DATA.                                            01460006
014700         10  B-NPI-NUMBER.                                        01470006
014800             15  B-NPI            PIC X(08).                      01480006
014900             15  B-NPI-FILLER     PIC X(02).                      01490006
015000         10  B-PROVIDER-NO        PIC X(06).                      01500006
015100         10  B-HIC-NO             PIC X(12).                      01510006
015200         10  B-DISCHARGE-DATE.                                    01520006
015300             15  B-D-CC           PIC 9(02).                      01530006
015400             15  B-D-YY           PIC 9(02).                      01540006
015500             15  B-D-MM           PIC 9(02).                      01550006
015600             15  B-D-DD           PIC 9(02).                      01560006
015700         10  B-PATIENT-STATUS     PIC X(02).                      01570006
015800         10  B-AGE                PIC 9(03).                      01580006
015900         10  B-DRG                PIC 9(03).                      01590006
016000         10  B-LOS                PIC 9(05).                      01600006
016100         10  B-OUTL-OCCUR-IND     PIC X(01).                      01610006
016200         10  B-SRC-OF-ADMISSION   PIC X(01).                      01620006
016300         10  B-ECT-NO-OF-UNITS    PIC X(03).                      01630006
016400         10  B-CHARGES-CLAIMED    PIC 9(07)V9(02).                01640006
016500         10  B-OTHER-DIAG-DATA    PIC X(175).                     01650006
016600         10  B-OTHER-PROC-DATA    PIC X(175).                     01660006
016700         10  B-PRIOR-DAYS         PIC X(03).                      01670006
016800                                                                  01680006
016900*******************************************************           01690006
017000*    PASSED AND RETURNED BY IPDRV                     *           01700006
017100*******************************************************           01710006
017200 01  PRICER-OPT-VERS-SW.                                          01720006
017300     02  PRICER-OPTION-SW        PIC X.                           01730006
017400     02  IPF-VERSIONS.                                            01740006
017500         10  IPDRV-VERSION       PIC X(05).                       01750006
017600                                                                  01760006
017700*******************************************************           01770006
017800*    CAN BE PASSED TO IPDRV___  OPTION P OR B         *           01780006
017900*******************************************************           01790006
018000 01  PROV-RECORD-FROM-USER       PIC X(240).                      01800006
018100                                                                  01810006
018200*******************************************************           01820006
018300*    CAN BE PASSED TO IPDRV___  OPTION B              *           01830006
018400*******************************************************           01840006
018500 01  MSAX-TABLE-FROM-USER.                                        01850006
018600     05  FILLER                  PIC X(32000).                    01860006
018700     05  FILLER                  PIC X(30000).                    01870006
018800     05  FILLER                  PIC X(30000).                    01880006
018900                                                                  01890006
019000*******************************************************           01900006
019100*    CAN BE PASSED TO IPDRV___  OPTION B              *           01910006
019200*******************************************************           01920006
019300 01  CBSA-TABLE-FROM-USER.                                        01930006
019400     05  FILLER                  PIC X(32000).                    01940006
019500     05  FILLER                  PIC X(30000).                    01950006
019600     05  FILLER                  PIC X(30000).                    01960006
019700                                                                  01970006
019800*******************************************************           01980006
019900*    PASSED TO COMORBIDITY GROUPER AND RETURNED       *           01990006
020000*******************************************************           02000006
020100                                                                  02010006
020200*******************************************************           02020006
020300*    PROSPECTIVE PAYMENT REPORT COMPONENTS            *           02030006
020400*******************************************************           02040006
020500 01  IPF-DETAIL-LINE.                                             02050006
020600     05  FILLER                  PIC X(01)  VALUE SPACES.         02060006
020700     05  PRT-HIC                 PIC X(12).                       02070006
020800     05  FILLER                  PIC X(01)  VALUE SPACES.         02080006
020900     05  PRT-PROV                PIC X(06).                       02090006
021000     05  FILLER                  PIC X(01)  VALUE SPACES.         02100006
021100     05  PRT-WAGE-INDEX          PIC 9.9999.                      02110006
021200     05  FILLER                  PIC X(01)  VALUE SPACES.         02120006
021300     05  PRT-GRP-DRG             PIC 9(03).                       02130006
021400     05  FILLER                  PIC X(01)  VALUE SPACES.         02140006
021500     05  PRT-DRG-FACTOR          PIC 9.99.                        02150006
021600     05  FILLER                  PIC X(01)  VALUE SPACES.         02160006
021700     05  PRT-AGE                 PIC ZZ9.                         02170006
021800     05  FILLER                  PIC X(01)  VALUE SPACES.         02180006
021900     05  PRT-DISCHG-DATE         PIC 9(08).                       02190006
022000     05  FILLER                  PIC X(01)  VALUE SPACES.         02200006
022100     05  PRT-TOT-PAY             PIC Z,ZZZ,ZZZ.99.                02210006
022200     05  FILLER                  PIC X(01)  VALUE SPACES.         02220006
022300     05  PRT-ECT-PAY             PIC ZZZ,ZZZ.99.                  02230006
022400     05  FILLER                  PIC X(02)  VALUE SPACES.         02240006
022500     05  PRT-ECT-UNITS           PIC ZZ9.                         02250006
022600     05  FILLER                  PIC X      VALUE SPACES.         02260006
022700     05  PRT-OUTLIER-PAY         PIC ZZZ,ZZZ.99.                  02270006
022800     05  FILLER                  PIC X(03)  VALUE SPACES.         02280006
022900     05  PRT-OUTL-OCCUR-IND      PIC X(01)  VALUE SPACES.         02290006
023000     05  FILLER                  PIC X(01)  VALUE SPACES.         02300006
023100     05  PRT-MSA-CBSA            PIC X(05).                       02310006
023200     05  FILLER                  PIC X(01)  VALUE SPACES.         02320006
023300     05  PRT-STOPLOSS-AMT        PIC ZZZ,ZZZ.99.                  02330006
023400     05  FILLER                  PIC X(01)  VALUE SPACES.         02340006
023500     05  PRT-FAC-PAY             PIC ZZZ,ZZZ.99.                  02350006
023600     05  FILLER                  PIC X(01)  VALUE SPACES.         02360006
023700     05  PRT-LOS                 PIC ZZ9.                         02370006
023800     05  FILLER                  PIC X(02)  VALUE SPACES.         02380006
023900     05  PRT-PATIENT-STATUS      PIC 99.                          02390006
024000     05  FILLER                  PIC X(01)  VALUE SPACES.         02400006
024100     05  PRT-PPS-RTC             PIC 99.                          02410006
024200     05  FILLER                  PIC X(01)  VALUE SPACES.         02420006
024300                                                                  02430006
024400 01  PPS-HEAD1.                                                   02440006
024500     05  FILLER                  PIC X(01)  VALUE SPACES.         02450006
024600     05  FILLER                  PIC X(44)  VALUE                 02460006
024700        '  C M S ,                                   '.           02470006
024800     05  FILLER                  PIC X(44)  VALUE                 02480006
024900        '                                            '.           02490006
025000     05  FILLER                  PIC X(44)  VALUE                 02500006
025100        '                                            '.           02510006
025200                                                                  02520006
025300 01  PPS-HEAD2-OPER.                                              02530006
025400     05  FILLER                  PIC X(01)  VALUE SPACES.         02540006
025500     05  FILLER                  PIC X(44)  VALUE                 02550006
025600        '  C M S     IPF PRICER        P R O S P E C '.           02560006
025700     05  FILLER                  PIC X(44)  VALUE                 02570006
025800        'T I V E   P A Y M E N T   T E S T   D A T A '.           02580006
025900     05  FILLER                  PIC X(44)  VALUE                 02590006
026000        '  R E P O R T                               '.           02600006
026100                                                                  02610006
026200 01  PPS-HEAD3-OPER.                                              02620006
026300     05  FILLER                  PIC X(01)  VALUE SPACES.         02630006
026400     05  FILLER                  PIC X(44)  VALUE                 02640006
026500        ' HI CLAIM   PROVIDER WAGE  DRG DRG AGE DIS-D'.           02650006
026600     05  FILLER                  PIC X(44)  VALUE                 02660006
026700        'ATE      TOT BLEND     ECT     ECT   OUTLIER'.           02670006
026800     05  FILLER                  PIC X(44)  VALUE                 02680006
026900        ' OUTL MSA/CBSA STOPLOSS   FAC      STAT IPF '.           02690006
027000                                                                  02700006
027100 01  PPS-HEAD4-OPER.                                              02710006
027200     05  FILLER                  PIC X(01)  VALUE SPACES.         02720006
027300     05  FILLER                  PIC X(44)  VALUE                 02730006
027400        '    NO         NO    INDEX  NO FAC     CCYYM'.           02740006
027500     05  FILLER                  PIC X(44)  VALUE                 02750006
027600        'MDD      PAYMENT     PAYMENT  UNITS  PAYMENT'.           02760006
027700     05  FILLER                  PIC X(44)  VALUE                 02770006
027800        '  IND   NO.     AMOUNT  PAYMENT LOS CD  RTC '.           02780006
027900                                                                  02790006
028000                                                                  02800006
028010*----------------------------------------------------------------*02801006
028020*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*02802006
028030*----------------------------------------------------------------*02803006
028040 01  TOTAL-COUNTERS.                                              02804006
028050     03  FILLER                  OCCURS 24.                       02805006
028060         05  COUNT-TOTAL             PIC 9(09) COMP.              02806006
028070                                                                  02807006
028080 01  PRT-LINE.                                                    02808006
028090     05  FILLER                  PIC X(01)  VALUE SPACES.         02809006
028100     05  PRT-LNE                 OCCURS 8.                        02810006
028200         10  PRT-XXX             PIC X(02).                       02820006
028300         10  PRT-DRG             PIC 9(03).                       02830006
028400         10  PRT-CNT             PIC Z(08)9B.                     02840006
028500         10  PRT-COL             PIC X(01).                       02850006
028600                                                                  02860006
028700 01  PRT-HDG-OLD.                                                 02870006
028800     05  FILLER                  PIC X(01)  VALUE SPACES.         02880006
028900     05  FILLER                  PIC X(44)  VALUE                 02890006
029000         '   ****** A L L   R E C O R D S ******      '.          02900006
029100     05  FILLER                  PIC X(44)  VALUE                 02910006
029200         '    DISCHARGES OLDER THEN 5 YEARS           '.          02920006
029300     05  FILLER                  PIC X(35)  VALUE                 02930006
029400        '                C M S ,            '.                    02940006
029500                                                                  02950006
029600                                                                  02960006
029700 01  PRT-HDG-V220.                                                02970006
029800     05  FILLER                  PIC X(01)  VALUE SPACES.         02980006
029900     05  FILLER                  PIC X(44)  VALUE                 02990006
030000         'G R O U P E R  V22/23 COUNTS BY   D R G     '.          03000006
030100     05  FILLER                  PIC X(44)  VALUE                 03010006
030200         'FOR DISCHARGES ON OR AFTER 01/01/2005       '.          03020006
030300     05  FILLER                  PIC X(35)  VALUE                 03030006
030400        '                C M S ,            '.                    03040006
030500                                                                  03050006
030600 01  PRT-HDG-V230.                                                03060006
030700     05  FILLER                  PIC X(01)  VALUE SPACES.         03070006
030800     05  FILLER                  PIC X(44)  VALUE                 03080006
030900         'G R O U P E R  V23.0  COUNTS BY   D R G     '.          03090006
031000     05  FILLER                  PIC X(44)  VALUE                 03100006
031100         'FOR DISCHARGES ON OR AFTER 07/01/2006       '.          03110006
031200     05  FILLER                  PIC X(35)  VALUE                 03120006
031300        '                C M S ,            '.                    03130006
031400                                                                  03140006
031500 01  PRT-HDG-V240.                                                03150006
031600     05  FILLER                  PIC X(01)  VALUE SPACES.         03160006
031700     05  FILLER                  PIC X(44)  VALUE                 03170006
031800         'G R O U P E R  V23.0  COUNTS BY   D R G     '.          03180006
031900     05  FILLER                  PIC X(44)  VALUE                 03190006
032000         'FOR DISCHARGES ON OR AFTER 07/01/2007       '.          03200006
032100     05  FILLER                  PIC X(35)  VALUE                 03210006
032200        '                C M S ,            '.                    03220006
032300                                                                  03230006
032400                                                                  03240006
032500 01  PRT-HDG                     PIC X(132).                      03250006
032600                                                                  03260006
032700**=============================================================   03270006
032800 PROCEDURE  DIVISION.                                             03280006
032900                                                                  03290006
033000 0000-MAINLINE  SECTION.                                          03300006
033100     OPEN INPUT  IPFBILL.                                         03310006
033200                                                                  03320006
033300     OPEN OUTPUT IPFOUT.                                          03330006
033400     OPEN OUTPUT IPFPRT.                                          03340006
033500                                                                  03350006
033600     MOVE LOW-VALUES   TO TOTAL-COUNTERS.                         03360006
033700     MOVE ALL '0'      TO BILL-INPUT-DATA                         03370006
033800                          IPF-DATA-VARIABLES                      03380006
033900                          IPF-ADDITIONAL-VARIABLES                03390006
034000                          IPF-VERSIONS.                           03400006
034100                                                                  03410006
034200     PERFORM 0100-PROCESS-RECORDS THRU 0100-EXIT UNTIL EOF-SW = 1.03420006
034300                                                                  03430006
034400     DISPLAY '-- PROGRAM IPMGR___  VERSION ==> ' IPMGR-VERSION.   03440006
034500     DISPLAY '-- PROGRAM IPOPN___  VERSION ==> ' IPOPN-VERSION.   03450006
034600     DISPLAY '-- PROGRAM IPDRV___  VERSION ==> ' IPDRV-VERSION.   03460006
034700                                                                  03470006
034800*----------------------------------------------------------------*03480006
034900*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*03490006
035000*----------------------------------------------------------------*03500006
035100     DISPLAY ' '.                                                 03510006
035200     IF COUNT-TOTAL (2) > 0                                       03520006
035300       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C05.7 '.         03530006
035400     IF COUNT-TOTAL (3) > 0                                       03540006
035500       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C07.6 '.         03550006
035600     IF COUNT-TOTAL (4) > 0                                       03560006
035700       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C08.A '.         03570006
035800     IF COUNT-TOTAL (5) > 0                                       03580006
035900       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C08.6 '.         03590006
036000     IF COUNT-TOTAL (6) > 0                                       03600006
036100       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C09.A '.         03610006
036200     IF COUNT-TOTAL (7) > 0                                       03620006
036300       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C09.4 '.         03630006
036400     IF COUNT-TOTAL (8) > 0                                       03640006
036500       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C10.0 '.         03650006
036600     IF COUNT-TOTAL (9) > 0                                       03660006
036700       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C10.2 '.         03670006
036800     IF COUNT-TOTAL (10) > 0                                      03680006
036900       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C11.0 '.         03690006
037000     IF COUNT-TOTAL (11) > 0                                      03700006
037100       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C11.1 '.         03710006
037200     IF COUNT-TOTAL (12) > 0                                      03720006
037300       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C11.2 '.         03730006
037400     IF COUNT-TOTAL (13) > 0                                      03740006
037500       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C12.0 '.         03750006
037600     IF COUNT-TOTAL (14) > 0                                      03760006
037700       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C12.1 '.         03770006
037800     IF COUNT-TOTAL (15) > 0                                      03780006
037900       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C13.0 '.         03790006
038000     IF COUNT-TOTAL (16) > 0                                      03800006
038100       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C14.0 '.         03810006
038200     IF COUNT-TOTAL (17) > 0                                      03820006
038300       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C15.0 '.         03830006
038310     IF COUNT-TOTAL (18) > 0                                      03831006
038320       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C16.0 '.         03832006
038330     IF COUNT-TOTAL (19) > 0                                      03833006
038331       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C17.0 '.         03833106
038332     IF COUNT-TOTAL (20) > 0                                      03833206
038333       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C18.0 '.         03833306
038334     IF COUNT-TOTAL (21) > 0                                      03833406
038335       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C19.0 '.         03833506
038336     IF COUNT-TOTAL (22) > 0                                      03833606
038337       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C20.1 '.         03833706
038338     IF COUNT-TOTAL (23) > 0                                      03833806
038339       DISPLAY '-- PROGRAM IPCAL___  VERSION ==> C21.0 '.         03833906
038340                                                                  03834006
038341*----------------------------------------------------------------*03834106
038342*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*03834206
038343*----------------------------------------------------------------*03834306
038344     DISPLAY ' '.                                                 03834406
038345     IF COUNT-TOTAL (1) > 0                                       03834506
038346      DISPLAY '--   TOTAL OLD RECORDS   ======> ' COUNT-TOTAL (1).03834606
038347     IF COUNT-TOTAL (2) > 0                                       03834706
038348      DISPLAY '-- FY 2005 RECORD COUNTS ======> ' COUNT-TOTAL (2).03834806
038349     IF COUNT-TOTAL (3) > 0                                       03834906
038350      DISPLAY '-- FY 2007 RECORD COUNTS ======> ' COUNT-TOTAL (3).03835006
038351     IF COUNT-TOTAL (4) > 0                                       03835106
038352      DISPLAY '-- FY 2008-A REC  COUNTS ======> ' COUNT-TOTAL (4).03835206
038353     IF COUNT-TOTAL (5) > 0                                       03835306
038354      DISPLAY '-- FY 2008-6 REC  COUNTS ======> ' COUNT-TOTAL (5).03835406
038355     IF COUNT-TOTAL (6) > 0                                       03835506
038356      DISPLAY '-- FY 2009-A REC  COUNTS ======> ' COUNT-TOTAL (6).03835606
038357     IF COUNT-TOTAL (7) > 0                                       03835706
038358      DISPLAY '-- FY 2009-4 REC  COUNTS ======> ' COUNT-TOTAL (7).03835806
038359     IF COUNT-TOTAL (8) > 0                                       03835906
038360      DISPLAY '-- FY 2010 RECORD COUNTS ======> ' COUNT-TOTAL (8).03836006
038370     IF COUNT-TOTAL (9) > 0                                       03837006
038380      DISPLAY '-- FY 2010-2 REC  COUNTS ======> ' COUNT-TOTAL (9).03838006
038390     IF COUNT-TOTAL (10) > 0                                      03839006
038400      DISPLAY '-- FY 2011 REC  COUNTS ======> ' COUNT-TOTAL (10). 03840006
038500     IF COUNT-TOTAL (11) > 0                                      03850006
038600      DISPLAY '-- FY 2011-2 REC  COUNTS =====> ' COUNT-TOTAL (11).03860006
038700     IF COUNT-TOTAL (12) > 0                                      03870006
038800      DISPLAY '-- FY 2011-3 REC  COUNTS =====> ' COUNT-TOTAL (12).03880006
038900     IF COUNT-TOTAL (13) > 0                                      03890006
038910      DISPLAY '-- FY 2012-0 REC  COUNTS =====> ' COUNT-TOTAL (13).03891006
038920     IF COUNT-TOTAL (14) > 0                                      03892006
038930      DISPLAY '-- FY 2012-1 REC  COUNTS =====> ' COUNT-TOTAL (14).03893006
038940     IF COUNT-TOTAL (15) > 0                                      03894006
038950      DISPLAY '-- FY 2013-0 REC  COUNTS =====> ' COUNT-TOTAL (15).03895006
038960     IF COUNT-TOTAL (16) > 0                                      03896006
038970      DISPLAY '-- FY 2014-0 REC  COUNTS =====> ' COUNT-TOTAL (16).03897006
038980     IF COUNT-TOTAL (17) > 0                                      03898006
038990      DISPLAY '-- FY 2015-0 REC  COUNTS =====> ' COUNT-TOTAL (17).03899006
038991     IF COUNT-TOTAL (18) > 0                                      03899106
038992      DISPLAY '-- FY 2016-0 REC  COUNTS =====> ' COUNT-TOTAL (18).03899206
038993     IF COUNT-TOTAL (19) > 0                                      03899306
038994      DISPLAY '-- FY 2017-0 REC  COUNTS =====> ' COUNT-TOTAL (19).03899406
038995     IF COUNT-TOTAL (21) > 0                                      03899506
038996      DISPLAY '-- FY 2018-0 REC  COUNTS =====> ' COUNT-TOTAL (21).03899606
038997     IF COUNT-TOTAL (22) > 0                                      03899706
038998      DISPLAY '-- FY 2019-0 REC  COUNTS =====> ' COUNT-TOTAL (22).03899806
038999     IF COUNT-TOTAL (23) > 0                                      03899906
039000      DISPLAY '-- FY 2021-0 REC  COUNTS =====> ' COUNT-TOTAL (23).03900006
039001*    IF COUNT-TOTAL (24) > 0                                      03900106
039002*     DISPLAY '-- FY 2021-0 REC  COUNTS =====> ' COUNT-TOTAL (24).03900206
039003                                                                  03900306
039004     DISPLAY '                                -----------'.       03900406
039005                                                                  03900506
039006     DISPLAY '-- INPUT  COUNTS FOR IPFBILL ===> ' IPFBILL-CTR.    03900606
039007     DISPLAY '-- OUTPUT COUNTS FOR IPFOUT  ===> ' IPFOUT-CTR.     03900706
039008                                                                  03900806
039009     CLOSE IPFBILL.                                               03900906
039010     CLOSE IPFOUT.                                                03901006
039020                                                                  03902006
039030*    MOVE 1 TO X4.                                                03903006
039040*    MOVE PRT-HDG-OLD  TO PRT-HDG.                                03904006
039050*    WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING PAGE.         03905006
039060*    IF OPR-STAT1 > 0 DISPLAY ' BAD1 WRITE ON IPFPRT FILE'.       03906006
039070                                                                  03907006
039080     MOVE SPACES TO PRT-LINE.                                     03908006
039090     MOVE '  TOTAL RECORDS PROCESSED' TO PRT-HDG.                 03909006
039100     WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING 3.            03910006
039200     IF OPR-STAT1 > 0 DISPLAY ' BAD2 WRITE ON IPFPRT FILE'.       03920006
039300                                                                  03930006
039400     MOVE COUNT-TOTAL (X4) TO PRT-CNT (1).                        03940006
039500     WRITE IPFPRT-LINE FROM PRT-LINE AFTER ADVANCING 1.           03950006
039600     IF OPR-STAT1 > 0 DISPLAY ' BAD3 WRITE ON IPFPRT FILE'.       03960006
039700                                                                  03970006
039800*    MOVE 2 TO X4.                                                03980006
039900*    MOVE PRT-HDG-V220 TO PRT-HDG.                                03990006
040000*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04000006
040100                                                                  04010006
040200*    MOVE 3 TO X4.                                                04020006
040300*    MOVE PRT-HDG-V230 TO PRT-HDG.                                04030006
040400*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04040006
040500                                                                  04050006
040600*    MOVE 4 TO X4.                                                04060006
040700*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04070006
040800*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04080006
040900                                                                  04090006
041000*    MOVE 5 TO X4.                                                04100006
041100*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04110006
041200*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04120006
041300                                                                  04130006
041400*    MOVE 6 TO X4.                                                04140006
041500*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04150006
041600*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04160006
041700                                                                  04170006
041800*    MOVE 7 TO X4.                                                04180006
041900*    MOVE PRT-HDG-V240 TO PRT-HDG.                                04190006
042000*    PERFORM 1300-PRINT-COUNTERS THRU 1300-EXIT.                  04200006
042100                                                                  04210006
042200     CLOSE IPFPRT.                                                04220006
042300     STOP RUN.                                                    04230006
042400                                                                  04240006
042500 0100-PROCESS-RECORDS.                                            04250006
042600     READ IPFBILL INTO BILL-WORK                                  04260006
042700         AT END                                                   04270006
042800             MOVE 1 TO EOF-SW.                                    04280006
042900     MOVE BILL-NPI-NUMBER       TO B-NPI-NUMBER.                  04290006
043000     MOVE BILL-PROVIDER-NO      TO B-PROVIDER-NO.                 04300006
043100     MOVE BILL-HIC-NO           TO B-HIC-NO.                      04310006
043200     MOVE BILL-PATIENT-STATUS   TO B-PATIENT-STATUS.              04320006
043300     MOVE BILL-AGE              TO B-AGE.                         04330006
043400     MOVE BILL-DRG              TO B-DRG.                         04340006
043500     MOVE BILL-LOS              TO B-LOS.                         04350006
043600     MOVE BILL-DISCHARGE-DATE   TO B-DISCHARGE-DATE.              04360006
043700     MOVE BILL-CHARGES-CLAIMED  TO B-CHARGES-CLAIMED.             04370006
043800     MOVE BILL-OUTL-OCCUR-IND   TO B-OUTL-OCCUR-IND.              04380006
043900     MOVE BILL-SRC-OF-ADMISSION TO B-SRC-OF-ADMISSION.            04390006
044000     MOVE BILL-ECT-NO-OF-UNITS  TO B-ECT-NO-OF-UNITS.             04400006
044100     MOVE BILL-OTHER-DIAG-DATA  TO B-OTHER-DIAG-DATA.             04410006
044200     MOVE BILL-OTHER-PROC-DATA  TO B-OTHER-PROC-DATA.             04420006
044300     MOVE BILL-PRIOR-DAYS       TO B-PRIOR-DAYS.                  04430006
044400                                                                  04440006
044500     IF  EOF-SW = 0                                               04450006
044600         ADD 1 TO IPFBILL-CTR                                     04460006
044700         PERFORM 0200-APPLY-YR  THRU 0200-EXIT                    04470006
044800         PERFORM 1000-CALC-PAYMENT THRU 1000-EXIT                 04480006
044900         PERFORM 1100-WRITE-IPFOUT THRU 1100-EXIT.                04490006
045000                                                                  04500006
045100 0100-EXIT.  EXIT.                                                04510006
045200                                                                  04520006
045300*----------------------------------------------------------------*04530006
045400*- UPDATE THIS COUNTER WITH EVERY RELEASE                       -*04540006
045500*----------------------------------------------------------------*04550006
045600 0200-APPLY-YR.                                                   04560006
045700*******************************************************           04570006
045800****  OLD RECORDS BEFORE IPF STARTED                              04580006
045900*******************************************************           04590006
046000     IF BILL-DISCHARGE-DATE < 20050101                            04600006
046100        MOVE 1 TO X4                                              04610006
046200        ADD 1             TO COUNT-TOTAL (X4)                     04620006
046300     ELSE                                                         04630006
046400                                                                  04640006
046500*******************************************************           04650006
046600****  BETWEEN 01/01/2005 AND 07/01/2006    FOR 2005               04660006
046700****       18 MONTHS                                              04670006
046800*******************************************************           04680006
046900     IF BILL-DISCHARGE-DATE < 20060701                            04690006
047000        MOVE 2 TO X4                                              04700006
047100        ADD 1             TO COUNT-TOTAL (X4)                     04710006
047200     ELSE                                                         04720006
047300                                                                  04730006
047400*******************************************************           04740006
047500****  BETWEEN 07/01/2006 AND 07/01/2007    FOR 2006               04750006
047600****       12 MONTHS                                              04760006
047700*******************************************************           04770006
047800     IF BILL-DISCHARGE-DATE < 20070701                            04780006
047900        MOVE 3 TO X4                                              04790006
048000        ADD 1             TO COUNT-TOTAL (X4)                     04800006
048100     ELSE                                                         04810006
048200                                                                  04820006
048300*******************************************************           04830006
048400****  BETWEEN 07/01/2007 AND 10/01/2007    FOR 2007               04840006
048500****        3 MONTHS                                              04850006
048600*******************************************************           04860006
048700     IF BILL-DISCHARGE-DATE < 20071001                            04870006
048800        MOVE 4 TO X4                                              04880006
048900        ADD 1             TO COUNT-TOTAL (X4)                     04890006
049000     ELSE                                                         04900006
049100                                                                  04910006
049200*******************************************************           04920006
049300****  BETWEEN 07/01/2007 AND 06/30/2008    FOR 2008               04930006
049400****        3 MONTHS                                              04940006
049500*******************************************************           04950006
049600     IF BILL-DISCHARGE-DATE < 20080701                            04960006
049700        MOVE 5 TO X4                                              04970006
049800        ADD 1             TO COUNT-TOTAL (X4)                     04980006
049900     ELSE                                                         04990006
050000                                                                  05000006
050100*******************************************************           05010006
050200****  AFTER 06/30/08 - RATE   YEAR 2009 JUL - SEPT                05020006
050300*******************************************************           05030006
050400     IF BILL-DISCHARGE-DATE < 20081001                            05040006
050500        MOVE 6 TO X4                                              05050006
050600        ADD 1             TO COUNT-TOTAL (X4)                     05060006
050700     ELSE                                                         05070006
050800*******************************************************           05080006
050900****  AFTER 09/30/08 - RATE   YEAR 2009-2 OCT08 - JUL09           05090006
051000*******************************************************           05100006
051100     IF BILL-DISCHARGE-DATE < 20090701                            05110006
051200        MOVE 7 TO X4                                              05120006
051300        ADD 1             TO COUNT-TOTAL (X4)                     05130006
051400     ELSE                                                         05140006
051500*******************************************************           05150006
051600****  AFTER 06/30/09 - RATE   YEAR 2010   JUL - SEPT              05160006
051700*******************************************************           05170006
051800     IF BILL-DISCHARGE-DATE < 20091001                            05180006
051900        MOVE 8 TO X4                                              05190006
052000        ADD 1             TO COUNT-TOTAL (X4)                     05200006
052100     ELSE                                                         05210006
052200*******************************************************           05220006
052300****  AFTER 09/30/09 - RATE   YEAR 2010-2 OCT09 - JUL10           05230006
052400*******************************************************           05240006
052500     IF BILL-DISCHARGE-DATE < 20100701                            05250006
052600        MOVE 9 TO X4                                              05260006
052700        ADD 1             TO COUNT-TOTAL (X4)                     05270006
052800     ELSE                                                         05280006
052900*******************************************************           05290006
053000****  AFTER 06/30/10 - RATE   YEAR 2011 JUL10 - SEP11             05300006
053100*******************************************************           05310006
053200     IF BILL-DISCHARGE-DATE < 20101001                            05320006
053300        MOVE 10 TO X4                                             05330006
053400        ADD 1             TO COUNT-TOTAL (X4)                     05340006
053500     ELSE                                                         05350006
053600     IF BILL-DISCHARGE-DATE < 20110101                            05360006
053700        MOVE 11 TO X4                                             05370006
053800        ADD 1             TO COUNT-TOTAL (X4)                     05380006
053900     ELSE                                                         05390006
054000     IF BILL-DISCHARGE-DATE < 20110701                            05400006
054010        MOVE 12 TO X4                                             05401006
054020        ADD 1             TO COUNT-TOTAL (X4)                     05402006
054030     ELSE                                                         05403006
054040     IF BILL-DISCHARGE-DATE < 20111001                            05404006
054050        MOVE 13 TO X4                                             05405006
054060        ADD 1             TO COUNT-TOTAL (X4)                     05406006
054070     ELSE                                                         05407006
054080     IF BILL-DISCHARGE-DATE < 20121001                            05408006
054090        MOVE 14 TO X4                                             05409006
054091        ADD 1             TO COUNT-TOTAL (X4)                     05409106
054092     ELSE                                                         05409206
054093     IF BILL-DISCHARGE-DATE < 20131001                            05409306
054094        MOVE 15 TO X4                                             05409406
054095        ADD 1             TO COUNT-TOTAL (X4)                     05409506
054096     ELSE                                                         05409606
054097     IF BILL-DISCHARGE-DATE < 20141001                            05409706
054098        MOVE 16 TO X4                                             05409806
054099        ADD 1             TO COUNT-TOTAL (X4)                     05409906
054100     ELSE                                                         05410006
054110     IF BILL-DISCHARGE-DATE < 20151001                            05411006
054111        MOVE 17 TO X4                                             05411106
054112        ADD 1             TO COUNT-TOTAL (X4)                     05411206
054113     ELSE                                                         05411306
054114     IF BILL-DISCHARGE-DATE < 20161001                            05411406
054115        MOVE 18 TO X4                                             05411506
054116        ADD 1             TO COUNT-TOTAL (X4)                     05411606
054117     ELSE                                                         05411706
054118     IF BILL-DISCHARGE-DATE < 20171001                            05411806
054119        MOVE 19 TO X4                                             05411906
054120        ADD 1             TO COUNT-TOTAL (X4)                     05412006
054130     ELSE                                                         05413006
054131     IF BILL-DISCHARGE-DATE < 20181001                            05413106
054132        MOVE 20 TO X4                                             05413206
054133        ADD 1             TO COUNT-TOTAL (X4)                     05413306
054134     ELSE                                                         05413406
054135     IF BILL-DISCHARGE-DATE < 20191001                            05413506
054136        MOVE 21 TO X4                                             05413606
054137        ADD 1             TO COUNT-TOTAL (X4)                     05413706
054138     ELSE                                                         05413806
054139     IF BILL-DISCHARGE-DATE < 20201001                            05413906
054140        MOVE 22 TO X4                                             05414006
054141        ADD 1             TO COUNT-TOTAL (X4)                     05414106
054142     ELSE                                                         05414206
054143     IF BILL-DISCHARGE-DATE < 20211001                            05414306
054144        MOVE 23 TO X4                                             05414406
054145        ADD 1             TO COUNT-TOTAL (X4)                     05414506
054146     ELSE                                                         05414606
054147        MOVE 24 TO X4                                             05414706
054148        ADD 1             TO COUNT-TOTAL (X4).                    05414806
054149 0200-EXIT.  EXIT.                                                05414906
054150                                                                  05415006
054151                                                                  05415106
054152 1000-CALC-PAYMENT.                                               05415206
054153*******************************************************           05415306
054154*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE      *           05415406
054155*    PAYMENT                                          *           05415506
054156*******************************************************           05415606
054157***************************************************************   05415706
054158* OPTION (1)                                                  *   05415806
054159*       (1)  MOVE 'S' TO PRICER-OPTION-SW.                    *   05415906
054160*            CALL 'IPDRV___' USING BILL-INPUT-DATA            *   05416006
054170*                                  IPF-DATA-VARIABLES         *   05417006
054180*                                  IPF-ADDITIONAL-VARIABLES   *   05418006
054190*                                  PRICER-OPT-VERS-SW.        *   05419006
054200*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING. *   05420006
054300*                        *  *  *  *                           *   05430006
054400*                        *  *  *  *                           *   05440006
054500* OPTION (2)                                                  *   05450006
054600*       (2)  MOVE 'P' TO PRICER-OPTION-SW.                    *   05460006
054700*            CALL 'IPDRV___' USING BILL-INPUT-DATA            *   05470006
054710*                                  IPF-DATA-VARIABLES         *   05471006
054720*                                  IPF-ADDITIONAL-VARIABLES   *   05472006
054730*                                  PRICER-OPT-VERS-SW         *   05473006
054740*                                  PROV-RECORD-FROM-USER.     *   05474006
054750*        THIS PASSES THE STANDARD VARIABLES                   *   05475006
054760*       AND ADDITIONAL VARIABLES USED FOR PRICING.            *   05476006
054770*        THE PROVIDER RECORD FROM THE USER                    *   05477006
054780*       USED FOR THIS BILL ONLY IS ALSO PASSED.               *   05478006
054790*                        *  *  *  *                           *   05479006
054800* OPTION (3)                                                  *   05480006
054900*       (3)  MOVE 'B' TO PRICER-OPTION-SW.                    *   05490006
055000*            CALL 'IPDRV___' USING BILL-INPUT-DATA            *   05500006
055100*                                  IPF-DATA-VARIABLES         *   05510006
055200*                                  IPF-ADDITIONAL-VARIABLES   *   05520006
055300*                                  PRICER-OPT-VERS-SW         *   05530006
055400*                                  PROV-RECORD-FROM-USER      *   05540006
055500*                                  MSAX-TABLE-FROM-USER.      *   05550006
055600*        THIS IS THE ONLINE COMPATIBLE INTERFACE.             *   05560006
055700*        THIS PASSES THE STANDARD VARIIABLES AND THE          *   05570006
055800*      ADDITIONAL VARIABLES USED FOR PRICING.                 *   05580006
055900*        THE PROVIDER RECORD AND THE WAGE INDEX TABLE FROM    *   05590006
056000*      THE USERS ARE PASSED.                                  *   05600006
056100***************************************************************   05610006
056200                                                                  05620006
056300*** OPTION (1)                                                    05630006
056400     MOVE 'S' TO PRICER-OPTION-SW.                                05640006
056500     CALL  IPOPN21B   USING BILL-INPUT-DATA                       05650006
056600                            IPF-DATA-VARIABLES                    05660006
056700                            IPF-ADDITIONAL-VARIABLES              05670006
056800                            PRICER-OPT-VERS-SW.                   05680006
056900*** OPTION (2)                                                    05690006
057000*    MOVE 'P' TO PRICER-OPTION-SW.                                05700006
057100*    CALL  IPDRV072   USING BILL-INPUT-DATA                       05710006
057200*                           IPF-DATA-VARIABLES                    05720006
057300*                           IPF-ADDITIONAL-VARIABLES              05730006
057400*                           PRICER-OPT-VERS-SW                    05740006
057500*                           PROV-RECORD-FROM-USER.                05750006
057600*** OPTION (3)                                                    05760006
057700*    MOVE 'B' TO PRICER-OPTION-SW.                                05770006
057800*    CALL  IPDRV072   USING BILL-INPUT-DATA                       05780006
057900*                           IPF-DATA-VARIABLES                    05790006
058000*                           IPF-ADDITIONAL-VARIABLES              05800006
058100*                           PRICER-OPT-VERS-SW                    05810006
058200*                           PROV-RECORD-FROM-USER                 05820006
058300*                           MSAX-TABLE-FROM-USER                  05830006
058400*                           CBSA-TABLE-FROM-USER.                 05840006
058500                                                                  05850006
058600 1000-EXIT.  EXIT.                                                05860006
058700                                                                  05870006
058800 1100-WRITE-IPFOUT.                                               05880006
058900******************************************************************05890006
059000*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL         05900006
059100*    REPORT AND WRITE TEST PAYMENT RECORD ROUTINE                 05910006
059200******************************************************************05920006
059300     IF  OPERLINE-CTR > 54                                        05930006
059400         PERFORM 1200-PPS-HEADINGS THRU 1200-EXIT.                05940006
059500     MOVE SPACES               TO  IPF-DETAIL-LINE.               05950006
059600     MOVE B-PROVIDER-NO        TO  PRT-PROV.                      05960006
059700     MOVE B-HIC-NO             TO  PRT-HIC.                       05970006
059800     MOVE B-DISCHARGE-DATE     TO  PRT-DISCHG-DATE.               05980006
059900     MOVE B-DRG                TO  PRT-GRP-DRG.                   05990006
060000     MOVE B-AGE                TO  PRT-AGE.                       06000006
060100     MOVE B-LOS                TO  PRT-LOS.                       06010006
060200     MOVE B-ECT-NO-OF-UNITS    TO  PRT-ECT-UNITS.                 06020006
060300     MOVE B-PATIENT-STATUS     TO  PRT-PATIENT-STATUS.            06030006
060400     MOVE B-OUTL-OCCUR-IND     TO  PRT-OUTL-OCCUR-IND.            06040006
060500     MOVE IPF-DRG-FACTOR       TO  PRT-DRG-FACTOR.                06050006
060600     MOVE IPF-RTC              TO  PRT-PPS-RTC.                   06060006
060700     MOVE IPF-WAGE-INDEX       TO PRT-WAGE-INDEX.                 06070006
060800     MOVE IPF-TOT-PAYMENT      TO  PRT-TOT-PAY.                   06080006
060900     MOVE IPF-FAC-PAYMENT      TO  PRT-FAC-PAY.                   06090006
061000     MOVE IPF-OUTLIER-PAYMENT  TO  PRT-OUTLIER-PAY.               06100006
061100     MOVE IPF-ECT-PAYMENT      TO  PRT-ECT-PAY.                   06110006
061200     IF BILL-DISCHARGE-DATE > 20060630                            06120006
061300        MOVE IPF-CBSA TO PRT-MSA-CBSA                             06130006
061400     ELSE                                                         06140006
061500        MOVE IPF-MSA  TO  PRT-MSA-CBSA.                           06150006
061600     MOVE IPF-100PCT-STOPLOS-AMT TO PRT-STOPLOSS-AMT.             06160006
061700                                                                  06170006
061800     WRITE IPFPRT-LINE FROM IPF-DETAIL-LINE                       06180006
061900                             AFTER ADVANCING 1.                   06190006
062000     IF OPR-STAT1 > 0 DISPLAY ' BAD4 WRITE ON IPFPRT FILE'.       06200006
062100     ADD 1 TO OPERLINE-CTR.                                       06210006
062200                                                                  06220006
062300        WRITE OUT-REC FROM BILL-WORK.                             06230006
062400                                                                  06240006
062500     IF UT2-STAT1 > 0 DISPLAY ' BAD1 WRITE ON IPFOUT  FILE'.      06250006
062600     ADD 1 TO IPFOUT-CTR.                                         06260006
062700                                                                  06270006
062800**************************************************************    06280006
062900 1100-EXIT.  EXIT.                                                06290006
063000                                                                  06300006
063100 1200-PPS-HEADINGS.                                               06310006
063200*    WRITE IPFPRT-LINE FROM PPS-HEAD1                             06320006
063300*                            AFTER ADVANCING PAGE.                06330006
063400*    IF OPR-STAT1 > 0 DISPLAY ' BAD5 WRITE ON IPFPRT FILE'.       06340006
063500*    WRITE IPFPRT-LINE FROM PPS-HEAD2-OPER                        06350006
063600*                            AFTER ADVANCING 1.                   06360006
063700     WRITE IPFPRT-LINE FROM PPS-HEAD2-OPER                        06370006
063800                             AFTER ADVANCING PAGE.                06380006
063900     IF OPR-STAT1 > 0 DISPLAY ' BAD6 WRITE ON IPFPRT FILE'.       06390006
064000     WRITE IPFPRT-LINE FROM PPS-HEAD3-OPER                        06400006
064100                             AFTER ADVANCING 2.                   06410006
064200     IF OPR-STAT1 > 0 DISPLAY ' BAD7 WRITE ON IPFPRT FILE'.       06420006
064300     WRITE IPFPRT-LINE FROM PPS-HEAD4-OPER                        06430006
064400                             AFTER ADVANCING 1.                   06440006
064500     IF OPR-STAT1 > 0 DISPLAY ' BAD8 WRITE ON IPFPRT FILE'.       06450006
064600     MOVE ALL '  -' TO IPFPRT-LINE.                               06460006
064700     WRITE IPFPRT-LINE AFTER ADVANCING 1.                         06470006
064800     IF OPR-STAT1 > 0 DISPLAY ' BAD9 WRITE ON IPFPRT FILE'.       06480006
064900     MOVE 5 TO OPERLINE-CTR.                                      06490006
065000                                                                  06500006
065100 1200-EXIT.  EXIT.                                                06510006
065200                                                                  06520006
065300                                                                  06530006
065400*1300-PRINT-COUNTERS.                                             06540006
065500*******************************************************           06550006
065600*    PRINT COUNTERS TABLE ROUTINES AT EOJ             *           06560006
065700*******************************************************           06570006
065800*    WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING PAGE.         06580006
065900*    IF OPR-STAT1 > 0 DISPLAY ' BAD10 WRITE ON IPFPRT FILE'.      06590006
066000                                                                  06600006
066100*    MOVE '  TOTAL RECORDS PROCESSED' TO PRT-HDG.                 06610006
066200*    WRITE IPFPRT-LINE FROM PRT-HDG AFTER ADVANCING 3.            06620006
066300*    IF OPR-STAT1 > 0 DISPLAY ' BAD13 WRITE ON IPFPRT FILE'.      06630006
066400                                                                  06640006
066500*    MOVE SPACES TO PRT-LINE.                                     06650006
066600*    MOVE COUNT-TOTAL (X4) TO PRT-CNT (1).                        06660006
066700*    WRITE IPFPRT-LINE FROM PRT-LINE AFTER ADVANCING 1.           06670006
066800*    IF OPR-STAT1 > 0 DISPLAY ' BAD14 WRITE ON IPFPRT FILE'.      06680006
066900                                                                  06690006
067000*1300-EXIT.  EXIT.                                                06700006
067100                                                                  06710006
067200**===================================================**           06720006
067300**           LAST STATEMENT                          **           06730006
067400**===================================================**           06740006
