000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IPOPN220.                                         00020000
000300**============================================================**  00030000
000400 DATE-COMPILED.                                                   00040000
000500 ENVIRONMENT DIVISION.                                            00050000
000600 CONFIGURATION SECTION.                                           00060000
000700 SOURCE-COMPUTER.            IBM-370.                             00070000
000800 OBJECT-COMPUTER.            IBM-370.                             00080000
000900 INPUT-OUTPUT  SECTION.                                           00090000
001000 FILE-CONTROL.                                                    00100000
001100                                                                  00110000
001200     SELECT PROV-FILE ASSIGN      TO  UT-S-PPSPROV                00120000
001300            FILE STATUS IS PROV-STAT.                             00130000
001400     SELECT MSAX-FILE ASSIGN      TO  UT-S-PPSMSAX                00140000
001500            FILE STATUS IS MSAX-STAT.                             00150000
001600     SELECT CBSA-FILE ASSIGN      TO  UT-S-IPFCBSA                00160000
001700            FILE STATUS IS CBSA-STAT.                             00170000
001800                                                                  00180000
001900 DATA DIVISION.                                                   00190000
002000 FILE SECTION.                                                    00200000
002100                                                                  00210000
002200 FD  PROV-FILE                                                    00220000
002300     RECORDING MODE IS F                                          00230000
002400     LABEL RECORDS ARE STANDARD                                   00240000
002500     BLOCK CONTAINS 0 RECORDS.                                    00250000
002600 01  PROV-REC.                                                    00260000
002700     05  PROV-PART1                 PIC X(80).                    00270000
002800     05  PROV-PART2                 PIC X(80).                    00280000
002900     05  PROV-PART3                 PIC X(80).                    00290000
003000                                                                  00300000
003100 FD  MSAX-FILE                                                    00310000
003200     RECORDING MODE IS F                                          00320000
003300     LABEL RECORDS ARE STANDARD                                   00330000
003400     BLOCK CONTAINS 0 RECORDS.                                    00340000
003500**============================================================*   00350000
003600*    THIS RECORD IS SUPPLIED BY CMS  AND CONTAINS             *   00360000
003700*    THE WAGE INDEX FOR THE STATES (RURAL) AND MSA'S (URBAN). *   00370000
003800**============================================================*   00380000
003900 01  MSAX-REC.                                                    00390000
004000     05  X-MSA-X.                                                 00400000
004100         10  M-BLANK                PIC X(02).                    00410000
004200         10  M-STATE                PIC 9(02).                    00420000
004300     05  X-MSA REDEFINES X-MSA-X    PIC 9(04).                    00430000
004400     05  X-SIZE                     PIC X(01).                    00440000
004500     05  XE-DATE.                                                 00450000
004600         10  XE-CC                  PIC 9(02).                    00460000
004700         10  XE-YY                  PIC 9(02).                    00470000
004800         10  XE-MM                  PIC 9(02).                    00480000
004900         10  XE-DD                  PIC 9(02).                    00490000
005000     05  FILLER                     PIC X(01).                    00500000
005100     05  X-WAGE-INDX1               PIC S9(02)V9(04).             00510000
005200     05  FILLER                     PIC X(01).                    00520000
005300     05  X-WAGE-INDX2               PIC S9(02)V9(04).             00530000
005400     05  FILLER                     PIC X(01).                    00540000
005500     05  X-STATE-MSA-NAME           PIC X(51).                    00550000
005600     05  FILLER                     PIC X(01).                    00560000
005700                                                                  00570000
005800 FD  CBSA-FILE                                                    00580000
005900     RECORDING MODE IS F                                          00590000
006000     LABEL RECORDS ARE STANDARD                                   00600000
006100     BLOCK CONTAINS 0 RECORDS.                                    00610000
006200**============================================================*   00620000
006300*    THIS RECORD IS SUPPLIED BY CMS  AND CONTAINS             *   00630000
006400*    THE WAGE INDEX FOR THE STATES (RURAL) AND CBSA  (URBAN). *   00640000
006500**============================================================*   00650000
006600 01  F-CBSA-REC.                                                  00660000
006700     05  F-CBSA.                                                  00670000
006800         10  F-CBSA-BLANK             PIC X(03).                  00680000
006900         10  F-CBSA-STATE             PIC 9(02).                  00690000
007000     05  F-CBSA9 REDEFINES F-CBSA     PIC 9(05).                  00700000
007100     05  F-CBSA-SIZE                  PIC X(01).                  00710000
007200     05  F-CBSA-EFF-DATE.                                         00720000
007300         10  F-CBSA-CC                PIC 9(02).                  00730000
007400         10  F-CBSA-YY                PIC 9(02).                  00740000
007500         10  F-CBSA-MM                PIC 9(02).                  00750000
007600         10  F-CBSA-DD                PIC 9(02).                  00760000
007700     05  FILLER                       PIC X(01).                  00770000
007800     05  F-CBSA-INDX1                 PIC S9(02)V9(04).           00780000
007900     05  FILLER                       PIC X(01).                  00790000
008000     05  F-CBSA-INDX2                 PIC S9(02)V9(04).           00800000
008100     05  FILLER                       PIC X(52).                  00810000
008200                                                                  00820000
008300 WORKING-STORAGE SECTION.                                         00830000
008400 77  W-STORAGE-REF         PIC X(40)  VALUE                       00840000
008500     'IPOPN220 - W O R K I N G   S T O R A G E'.                  00850000
008600 01  OPN-VERSION           PIC X(05) VALUE 'O22.0'.               00860000
008700 01  IPDRV220              PIC X(08) VALUE 'IPDRV220'.            00870000
008800 01  TABLES-LOADED-SW      PIC 9(01)  VALUE 0.                    00880000
008900 01  EOF-SW                PIC 9(01)  VALUE 0.                    00890000
009000                                                                  00900000
009100**============================================================*   00910000
009200 01  W-PROV-NEW-HOLD.                                             00920000
009300     02  W-PROV-NEWREC-HOLD1.                                     00930000
009400         05  W-P-NEW-NPI10.                                       00940000
009500             10  W-P-NEW-NPI8           PIC X(08).                00950000
009600             10  W-P-NEW-NPI-FILLER     PIC X(02).                00960000
009700         05  W-P-NEW-PROVIDER-OSCAR-NO.                           00970000
009800             10  W-P-NEW-STATE            PIC X(02).              00980000
009900             10  FILLER                 PIC X(04).                00990000
009910         05  W-P-NEW-DATE-DATA.                                   00991000
009920             10  W-P-NEW-EFF-DATE.                                00992000
009930                 15  W-P-NEW-EFF-DT-CC    PIC 9(02).              00993000
009940                 15  W-P-NEW-EFF-DT-YY    PIC 9(02).              00994000
009950                 15  W-P-NEW-EFF-DT-MM    PIC 9(02).              00995000
009960                 15  W-P-NEW-EFF-DT-DD    PIC 9(02).              00996000
009970             10  W-P-NEW-FY-BEGIN-DATE.                           00997000
009980                 15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).              00998000
009990                 15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).              00999000
010000                 15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).              01000000
010100                 15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).              01010000
010200             10  W-P-NEW-REPORT-DATE.                             01020000
010300                 15  W-P-NEW-REPORT-DT-CC PIC 9(02).              01030000
010400                 15  W-P-NEW-REPORT-DT-YY PIC 9(02).              01040000
010500                 15  W-P-NEW-REPORT-DT-MM PIC 9(02).              01050000
010600                 15  W-P-NEW-REPORT-DT-DD PIC 9(02).              01060000
010700             10  W-P-NEW-TERMINATION-DATE.                        01070000
010800                 15  W-P-NEW-TERM-DT-CC   PIC 9(02).              01080000
010900                 15  W-P-NEW-TERM-DT-YY   PIC 9(02).              01090000
011000                 15  W-P-NEW-TERM-DT-MM   PIC 9(02).              01100000
011100                 15  W-P-NEW-TERM-DT-DD   PIC 9(02).              01110000
011200         05  W-P-NEW-WAIVER-CODE          PIC X(01).              01120000
011300             88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.            01130000
011400         05  W-P-NEW-INTER-NO             PIC X(05).              01140000
011500         05  W-P-NEW-PROVIDER-TYPE        PIC X(02).              01150000
011600         05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).              01160000
011700         05  W-P-NEW-MSA-DATA.                                    01170000
011800             10  W-P-NEW-CHG-CODE-INDEX    PIC X.                 01180000
011900             10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT. 01190000
012000             10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT. 01200000
012100             10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT. 01210000
012200             10  W-P-NEW-STAND-AMT-LOC-MSA9                       01220000
012300       REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.                       01230000
012400                 15  W-P-NEW-RURAL-1ST.                           01240000
012500                     20  W-P-NEW-STAND-RURAL  PIC XX.             01250000
012600                 15  W-P-NEW-RURAL-2ND        PIC XX.             01260000
012700         05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                  01270000
012800         05  W-P-NEW-LUGAR               PIC X.                   01280000
012900         05  W-P-NEW-TEMP-RELIEF-IND     PIC X.                   01290000
013000         05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.                   01300000
013100         05  FILLER                      PIC X(05).               01310000
013200     02  W-PROV-NEWREC-HOLD2.                                     01320000
013300         05  W-P-NEW-VARIABLES.                                   01330000
013400             10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).            01340000
013500             10  W-P-NEW-COLA              PIC  X(04).            01350000
013600             10  W-P-NEW-INTERN-RATIO      PIC  X(05).            01360000
013700             10  W-P-NEW-BED-SIZE          PIC  X(05).            01370000
013800             10  W-P-NEW-CCR               PIC  X(04).            01380000
013900             10  W-P-NEW-CMI               PIC  X(05).            01390000
014000             10  W-P-NEW-SSI-RATIO         PIC  X(04).            01400000
014100             10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).            01410000
014200             10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).            01420000
014300             10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).      01430000
014400             10  W-P-NEW-DSH-PERCENT       PIC  V9(04).           01440000
014500             10  W-P-NEW-FYE-DATE.                                01450000
014600                 15  W-P-NEW-FYE-CC        PIC 99.                01460000
014700                 15  W-P-NEW-FYE-YY        PIC 99.                01470000
014800                 15  W-P-NEW-FYE-MM        PIC 99.                01480000
014900                 15  W-P-NEW-FYE-DD        PIC 99.                01490000
015000         05  W-P-NEW-CBSA-DATA.                                   01500000
015100             10  W-P-NEW-CBSA-SPEC-PAY-IND   PIC X.               01510000
015200             10  W-P-NEW-CBSA-HOSP-QUAL-IND  PIC X.               01520000
015300             10  W-P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.01530000
015400             10  W-P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.01540000
015500             10  W-P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.01550000
015600             10  W-P-NEW-CBSA-STAND-AMT-LOC9                      01560000
015700       REDEFINES W-P-NEW-CBSA-STAND-AMT-LOC.                      01570000
015800                 15  W-P-NEW-CBSA-RURAL-1ST.                      01580000
015900                     20  W-P-NEW-CBSA-STAND-RURAL PIC 999.        01590000
016000                 15  W-P-NEW-CBSA-RURAL-2ND       PIC 99.         01600000
016100             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).01610000
016200     02  W-PROV-NEWREC-HOLD3.                                     01620000
016300         05  W-P-NEW-PASS-AMT-DATA.                               01630000
016400             10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).           01640000
016500             10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).           01650000
016600             10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).           01660000
016700             10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).           01670000
016800         05  W-P-NEW-CAPI-DATA.                                   01680000
016900             15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.               01690000
017000             15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).            01700000
017100             15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).            01710000
017200             15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).            01720000
017300             15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).           01730000
017400             15  W-P-NEW-CAPI-NEW-HOSP       PIC X.               01740000
017500             15  W-P-NEW-CAPI-IME            PIC X(05).           01750000
017600             15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).            01760000
017700             15  W-P-VAL-BASED-PURCH-SCORE   PIC 9V999.           01770000
017800*-----------------------------------------------------------------01780000
017900*                SUPPLEMENTAL WAGE INDEX                          01790000
018000*    1=PRIOR YEAR WAGE INDEX                                      01800000
018100*    2=CURRENT YEAR IPPS-COMPARABLE WAGE INDEX (LTCHS ONLY)       01810000
018200*    3=FUTURE USE                                                 01820000
018300*    4=FUTURE USE                                                 01830000
018400         05  W-P-NEW-SUPPLEMENTAL-WI.                             01840000
018500             10  W-P-NEW-SUPP-WI-IND         PIC X.               01850000
018600                 88 W-P-SUPP-WI-PRIOR-YEAR     VALUE '1'.         01860000
018610             10  W-P-NEW-SUPP-WI             PIC 9(2)V9(04).      01861000
018620         05  FILLER                        PIC X(11).             01862000
018630                                                                  01863000
018640 01  PROV-STAT.                                                   01864000
018650     02  PROV-STAT1     PIC X.                                    01865000
018660     02  PROV-STAT2     PIC X.                                    01866000
018670                                                                  01867000
018680 01  MSAX-STAT.                                                   01868000
018690     02  MSAX-STAT1     PIC X.                                    01869000
018700     02  MSAX-STAT2     PIC X.                                    01870000
018800                                                                  01880000
018900 01  CBSA-STAT.                                                   01890000
019000     02  CBSA-STAT1     PIC X.                                    01900000
019100     02  CBSA-STAT2     PIC X.                                    01910000
019200                                                                  01920000
019300 01  HOLD-PROV-MSAX.                                              01930000
019400         10  H-MSAX-PROV-BLANK   PIC X(2).                        01940000
019500         10  H-MSAX-PROV-STATE.                                   01950000
019600             15  FILLER          PIC X.                           01960000
019700             15  H-MSAX-LAST-POS PIC X.                           01970000
019800                                                                  01980000
019900 01  HOLD-PROV-CBSA.                                              01990000
020000         10  H-CBSA-PROV-BLANK   PIC X(3).                        02000000
020100         10  H-CBSA-PROV-STATE.                                   02010000
020200             15  FILLER          PIC X.                           02020000
020300             15  H-CBSA-LAST-POS PIC X.                           02030000
020400                                                                  02040000
020500 01  MSAX-WI-TABLE.                                               02050000
020600     05  M-MSAX-DATA                OCCURS 4000                   02060000
020700                                    INDEXED BY MU1 MU2 MU3.       02070000
020800         10  M-MSAX-MSA             PIC X(4).                     02080000
020900         10  M-MSAX-SIZE            PIC X(01).                    02090000
021000         10  M-MSAX-EFF-DATE        PIC X(08).                    02100000
021100         10  M-MSAX-WAGE-INDX1      PIC S9(02)V9(04).             02110000
021200         10  M-MSAX-WAGE-INDX2      PIC S9(02)V9(04).             02120000
021300                                                                  02130000
021400 01  CBSA-WI-TABLE.                                               02140000
021500     05  TB-CBSA-DATA                OCCURS 7000                  02150000
021600                                    INDEXED BY MA1 MA2 MA3.       02160000
021700         10  TB-CBSA                PIC X(5).                     02170000
021800         10  TB-CBSA-SIZE           PIC X(01).                    02180000
021900         10  TB-CBSA-EFF-DATE       PIC X(08).                    02190000
022000         10  TB-CBSA-WAGE-INDX1     PIC S9(02)V9(04).             02200000
022100         10  TB-CBSA-WAGE-INDX2     PIC S9(02)V9(04).             02210000
022200                                                                  02220000
022300**============================================================*   02230000
022400*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   02240000
022500*      THE IPCAL056 PROGRAM FOR PROCESSING                        02250000
022600**============================================================*   02260000
022700 01  WAGE-NEW-INDEX-RECORD.                                       02270000
022800     05  W-NEW-MSA               PIC 9(4).                        02280000
022900     05  W-NEW-SIZE              PIC X(01).                       02290000
023000         88  NEW-LARGE-URBAN       VALUE 'L'.                     02300000
023100         88  NEW-OTHER-URBAN       VALUE 'O'.                     02310000
023200         88  NEW-ALL-RURAL         VALUE 'R'.                     02320000
023300     05  W-NEW-EFF-DATE.                                          02330000
023400          10  W-NEW-EFF-DATE-CC   PIC 9(2).                       02340000
023500          10  W-NEW-EFF-DATE-YMD.                                 02350000
023600              15  W-NEW-EFF-DATE-YY   PIC 9(2).                   02360000
023700              15  W-NEW-EFF-DATE-MM   PIC 9(2).                   02370000
023800              15  W-NEW-EFF-DATE-DD   PIC 9(2).                   02380000
023900     05  FILLER              PIC X.                               02390000
024000     05  W-NEW-INDEX-RECORD      PIC S9(02)V9(04).                02400000
024100     05  FILLER                  PIC S9(02)V9(04).                02410000
024200                                                                  02420000
024300**============================================================*   02430000
024400*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   02440000
024500*      THE IPCAL08X PROGRAM FOR PROCESSING                        02450000
024600**============================================================*   02460000
024700 01  CBSA-WAGE-INDEX-RECORD.                                      02470000
024800     05  W-CBSA               PIC 9(5).                           02480000
024900     05  W-CBSA-X  REDEFINES W-CBSA PIC X(05).                    02490000
025000     05  W-CBSA-SIZE             PIC X(01).                       02500000
025100         88  W-CBSA-LARGE-URBAN       VALUE 'L'.                  02510000
025200         88  W-CBSA-OTHER-URBAN       VALUE 'O'.                  02520000
025300         88  W-CBSA-ALL-RURAL         VALUE 'R'.                  02530000
025400     05  W-CBSA-EFF-DATE.                                         02540000
025500          10  W-CBSA-EFF-DATE-CC       PIC 9(2).                  02550000
025600          10  W-CBSA-EFF-DATE-YMD.                                02560000
025700              15  W-CBSA-EFF-DATE-YY   PIC 9(2).                  02570000
025800              15  W-CBSA-EFF-DATE-MM   PIC 9(2).                  02580000
025900              15  W-CBSA-EFF-DATE-DD   PIC 9(2).                  02590000
026000     05  FILLER             PIC X.                                02600000
026100     05  W-CBSA-INDEX       PIC S9(02)V9(04).                     02610000
026200     05  FILLER             PIC S9(02)V9(04).                     02620000
026300                                                                  02630000
026400**============================================================    02640000
026500*   PROV RECORD PASSED OPTION P                                   02650000
026600**============================================================    02660000
026700 01  PROV-RECORD-FROM-USER.                                       02670000
026800     05  PROV-REC1                  PIC X(80).                    02680000
026900     05  PROV-REC2                  PIC X(80).                    02690000
027000     05  PROV-REC3                  PIC X(80).                    02700000
027100                                                                  02710000
027200**============================================================    02720000
027300*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *    02730000
027400*      ALL IPCAL PROGRAMS                                    *    02740000
027500**============================================================    02750000
027600 01  PROV-NEW-HOLD.                                               02760000
027700     02  PROV-NEWREC-HOLD1.                                       02770000
027800         05  P-NEW-NPI10.                                         02780000
027900             10  P-NEW-NPI8             PIC X(08).                02790000
028000             10  P-NEW-NPI-FILLER       PIC X(02).                02800000
028100         05  P-NEW-PROVIDER-NO.                                   02810000
028200             10  P-NEW-STATE            PIC 9(02).                02820000
028300             10  FILLER                 PIC X(04).                02830000
028400         05  P-NEW-DATE-DATA.                                     02840000
028500             10  P-NEW-EFF-DATE.                                  02850000
028600                 15  P-NEW-EFF-DT-CC    PIC 9(02).                02860000
028700                 15  P-NEW-EFF-DT-YY    PIC 9(02).                02870000
028800                 15  P-NEW-EFF-DT-MM    PIC 9(02).                02880000
028900                 15  P-NEW-EFF-DT-DD    PIC 9(02).                02890000
029000             10  P-NEW-FY-BEGIN-DATE.                             02900000
029100                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                02910000
029200                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                02920000
029300                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                02930000
029400                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                02940000
029500             10  P-NEW-REPORT-DATE.                               02950000
029600                 15  P-NEW-REPORT-DT-CC PIC 9(02).                02960000
029700                 15  P-NEW-REPORT-DT-YY PIC 9(02).                02970000
029800                 15  P-NEW-REPORT-DT-MM PIC 9(02).                02980000
029900                 15  P-NEW-REPORT-DT-DD PIC 9(02).                02990000
030000             10  P-NEW-TERMINATION-DATE.                          03000000
030100                 15  P-NEW-TERM-DT-CC   PIC 9(02).                03010000
030200                 15  P-NEW-TERM-DT-YY   PIC 9(02).                03020000
030300                 15  P-NEW-TERM-DT-MM   PIC 9(02).                03030000
030400                 15  P-NEW-TERM-DT-DD   PIC 9(02).                03040000
030500         05  P-NEW-WAIVER-CODE          PIC X(01).                03050000
030600             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              03060000
030700         05  P-NEW-INTER-NO             PIC 9(05).                03070000
030800         05  P-NEW-PROVIDER-TYPE        PIC X(02).                03080000
030900             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      03090000
031000             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       03100000
031100                                                  '15' '17'       03110000
031200                                                  '22'.           03120000
031300             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           03130000
031400             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           03140000
031500             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           03150000
031600             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           03160000
031700             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      03170000
031800             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           03180000
031900             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      03190000
032000             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           03200000
032100             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           03210000
032200             88  P-N-EACH                   VALUE '21' '22'.      03220000
032300             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           03230000
032400             88  P-N-NHCMQ-II-SNF           VALUE '32'.           03240000
032500             88  P-N-NHCMQ-III-SNF          VALUE '33'.           03250000
032600         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                03260000
032700             88  P-N-NEW-ENGLAND            VALUE  1.             03270000
032800             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             03280000
032900             88  P-N-SOUTH-ATLANTIC         VALUE  3.             03290000
033000             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             03300000
033100             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             03310000
033200             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             03320000
033300             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             03330000
033400             88  P-N-MOUNTAIN               VALUE  8.             03340000
033500             88  P-N-PACIFIC                VALUE  9.             03350000
033600         05  P-NEW-CURRENT-DIV   REDEFINES                        03360000
033700                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         03370000
033800             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          03380000
033900         05  P-NEW-MSA-DATA.                                      03390000
034000             10  P-NEW-CHG-CODE-INDEX       PIC X.                03400000
034100             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 03410000
034200             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   03420000
034300                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       03430000
034400             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  03440000
034500                             P-NEW-GEO-LOC-MSA9.                  03450000
034600                 15  P-NEW-GEO-MSA-1ST    PIC X.                  03460000
034700                 15  P-NEW-GEO-MSA-2ND    PIC X.                  03470000
034800                 15  P-NEW-GEO-MSA-3RD    PIC X.                  03480000
034900                 15  P-NEW-GEO-MSA-4TH    PIC X.                  03490000
035000             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 03500000
035100             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 03510000
035200             10  P-NEW-STAND-AMT-LOC-MSA9                         03520000
035300       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         03530000
035400                 15  P-NEW-RURAL-1ST.                             03540000
035500                     20  P-NEW-STAND-RURAL  PIC XX.               03550000
035600                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    03560000
035700                 15  P-NEW-RURAL-2ND        PIC XX.               03570000
035800         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    03580000
035900                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           03590000
036000                 88  P-NEW-SCH-YR82       VALUE   '82'.           03600000
036100                 88  P-NEW-SCH-YR87       VALUE   '87'.           03610000
036200         05  P-NEW-LUGAR                    PIC X.                03620000
036300         05  P-NEW-TEMP-RELIEF-IND          PIC X.                03630000
036400             88  P-NEW-LOW-VOL25PCT     VALUE 'Y'.                03640000
036500***          Y = LOW VOLUME PERCENTAGE  25 % ADD ON               03650000
036600         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                03660000
036700         05  FILLER                         PIC X(05).            03670000
036800     02  PROV-NEWREC-HOLD2.                                       03680000
036900         05  P-NEW-VARIABLES.                                     03690000
037000             10  P-NEW-CMI-ADJ-CPD       PIC  9(05)V9(02).        03700000
037100             10  P-NEW-COLA              PIC  9(01)V9(03).        03710000
037200             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        03720000
037300             10  P-NEW-BED-SIZE          PIC  9(05).              03730000
037400             10  P-NEW-CCR               PIC  9(01)V9(03).        03740000
037500             10  P-NEW-CMI               PIC  9(01)V9(04).        03750000
037600             10  P-NEW-SSI-RATIO         PIC  V9(04).             03760000
037700             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             03770000
037800             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).              03780000
037900             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).        03790000
038000             10  P-NEW-DSH-PERCENT       PIC  V9(04).             03800000
038100             10  P-NEW-FYE-DATE.                                  03810000
038200                 15  P-NEW-FYE-CC        PIC 99.                  03820000
038300                 15  P-NEW-FYE-YY        PIC 99.                  03830000
038400                 15  P-NEW-FYE-MM        PIC 99.                  03840000
038500                 15  P-NEW-FYE-DD        PIC 99.                  03850000
038600         05  P-NEW-CBSA-DATA.                                     03860000
038700             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                03870000
038800                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.          03880000
038900                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.          03890000
039000                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.      03900000
039100***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI   03910000
039200***                  2 = RECLASS WITH SPEC WI                     03920000
039300             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 03930000
039400                 88  P-NEW-CBSA-HOSP-QUAL-MET   VALUE '1'.        03940000
039500                 88  P-NEW-CBSA-HOSP-QUAL-25PER VALUE '2'.        03950000
039600                 88  P-NEW-CBSA-HOSP-QUAL-BOTH  VALUE '3'.        03960000
039700             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  03970000
039800             10  P-NEW-CBSA-GEO-LOC9  REDEFINES                   03980000
039900                             P-NEW-CBSA-GEO-LOC  PIC 9(05).       03990000
040000             10  P-NEW-CBSA-GEO-LOC-AST REDEFINES                 04000000
040100                             P-NEW-CBSA-GEO-LOC9.                 04010000
040200                 15  P-NEW-CBSA-GEO-1ST    PIC X.                 04020000
040300                 15  P-NEW-CBSA-GEO-2ND    PIC X.                 04030000
040400                 15  P-NEW-CBSA-GEO-3RD    PIC X.                 04040000
040500                 15  P-NEW-CBSA-GEO-4TH    PIC X.                 04050000
040600                 15  P-NEW-CBSA-GEO-5TH    PIC X.                 04060000
040700             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04070000
040800             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04080000
040900             10  P-NEW-CBSA-STAND-AMT-LOC-MSA9                    04090000
041000       REDEFINES P-NEW-CBSA-STAND-AMT-LOC.                        04100000
041100               15  P-NEW-CBSA-RURAL-1ST.                          04110000
041200                   20  P-NEW-CBSA-STAND-RURAL  PIC XXX.           04120000
041300                      88  P-NEW-CBSA-STD-RURAL-CHECK VALUE '   '. 04130000
041400               15  P-NEW-CBSA-RURAL-2ND    PIC XX.                04140000
041500             10  P-NEW-CBSA-SPEC-WI          PIC 9(02)V9(04).     04150000
041600             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  04160000
041700                 P-NEW-CBSA-SPEC-WI          PIC 9(06).           04170000
041800     02  PROV-NEWREC-HOLD3.                                       04180000
041900         05  P-NEW-PASS-AMT-DATA.                                 04190000
042000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04200000
042100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04210000
042200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04220000
042300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04230000
042400         05  P-NEW-CAPI-DATA.                                     04240000
042500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04250000
042600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04260000
042700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04270000
042800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04280000
042900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04290000
043000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04300000
043100             15  P-NEW-CAPI-IME            PIC 9V9999.            04310000
043200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04320000
043300             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            04330000
043400*-----------------------------------------------------------------04340000
043500*                SUPPLEMENTAL WAGE INDEX                          04350000
043600*    1=PRIOR YEAR WAGE INDEX                                      04360000
043700*    2=CURRENT YEAR IPPS-COMPARABLE WAGE INDEX (LTCHS ONLY)       04370000
043800*    3=FUTURE USE                                                 04380000
043900*    4=FUTURE USE                                                 04390000
044000         05  P-NEW-SUPPLEMENTAL-WI.                               04400000
044100             10  P-NEW-SUPP-WI-IND         PIC X.                 04410000
044110                 88 SUPP-WI-PRIOR-YEAR     VALUE '1'.             04411000
044120             10  P-NEW-SUPP-WI             PIC 9(2)V9(04).        04412000
044130         05  FILLER                        PIC X(11).             04413000
044140                                                                  04414000
044150**============================================================*   04415000
044160*    THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY     *   04416000
044170*    SET TO OCCUR 2400 TIMES. THIS NUMBER SHOULD BY ADJUSTED  *   04417000
044180*    BY THE USER TO REFLECT THE NUMBER OF PROVIDER RECORDS    *   04418000
044190*    PLUS EXPANSION. EACH ENTRY COSTS 240 BYTES OF MEMORY.    *   04419000
044200*    THIS FILE MUST BE IN PROVIDER NUMBER, EFFECTIVE-DATE     *   04420000
044300*    SEQUENCE.                                                *   04430000
044400**============================================================*   04440000
044500 01  PROV-TABLE.                                                  04450000
044600     05  PROV-ENTRIES               OCCURS 7000                   04460006
044700                                    ASCENDING KEY IS PROV-NO      04470000
044800                                    INDEXED BY PX1 PX2 PX3.       04480000
044900         10  PROV-DATA1.                                          04490000
045000             15  PROV-NPI10.                                      04500000
045100                 20  PROV-NPI8       PIC X(08).                   04510000
045200                 20  PROV-NPI-FILLER PIC X(02).                   04520000
045300             15  PROV-NO             PIC X(06).                   04530000
045400             15  PROV-EFF-DATE       PIC X(08).                   04540000
045500             15  FILLER              PIC X(56).                   04550000
045600 01  PROV-DATA-2.                                                 04560000
045700     05  PROV-ENTRIES2               OCCURS 7000                  04570000
045800                                     INDEXED BY PD2.              04580000
045900         10  PROV-DATA2              PIC X(80).                   04590000
046000 01  PROV-DATA-3.                                                 04600000
046100     05  PROV-ENTRIES3               OCCURS 7000                  04610000
046200                                     INDEXED BY PD3.              04620000
046300         10  PROV-DATA3              PIC X(80).                   04630000
046400                                                                  04640000
046500**============================================================    04650000
046600*   MSAX RECORD PASSED OPTION B                                   04660000
046700**============================================================    04670000
046800 01  MSAX-TABLE-FROM-USER.                                        04680000
046900     05  FILLER                     PIC X(32000).                 04690000
047000     05  FILLER                     PIC X(30000).                 04700000
047100     05  FILLER                     PIC X(30000).                 04710000
047200                                                                  04720000
047300**============================================================    04730000
047400*  OM-USERA RECORD PASSED OPTION B                                04740000
047500**============================================================    04750000
047600 01  CBSA-TABLE-FROM-USER.                                        04760000
047700     05  FILLER                     PIC X(32000).                 04770000
047800     05  FILLER                     PIC X(30000).                 04780000
047900     05  FILLER                     PIC X(30000).                 04790000
048000                                                                  04800000
048100**============================================================*   04810000
048200 LINKAGE SECTION.                                                 04820000
048300                                                                  04830000
048400**==================================================***           04840000
048500*    PASSED AND RETURNED BY IPCAL                     *           04850000
048600**==================================================***           04860000
048700 01  BILL-INPUT-DATA.                                             04870000
048800     05  BILL-IN-DATA.                                            04880000
048900         10  BILL-NPI-NUMBER.                                     04890000
049000             15  BILL-NPI            PIC X(08).                   04900000
049100             15  BILL-NPI-FILLER     PIC X(02).                   04910000
049200         10  BILL-PROVIDER-NO        PIC X(06).                   04920000
049300         10  BILL-HIC-NO             PIC X(12).                   04930000
049400         10  BILL-DISCHARGE-DATE.                                 04940000
049500             15  BILL-D-CC           PIC 9(02).                   04950000
049600             15  BILL-D-YY           PIC 9(02).                   04960000
049700             15  BILL-D-MM           PIC 9(02).                   04970000
049800             15  BILL-D-DD           PIC 9(02).                   04980000
049900         10  BILL-PATIENT-STATUS     PIC X(02).                   04990000
050000         10  BILL-AGE                PIC 9(03).                   05000000
050100         10  BILL-DRG                PIC 9(03).                   05010000
050200         10  BILL-LOS                PIC 9(05).                   05020000
050300         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   05030000
050400         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   05040000
050500         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   05050000
050600         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             05060000
050700         10  BILL-OTHER-DIAG-DATA    PIC X(175).                  05070000
050800         10  BILL-OTHER-PROC-DATA    PIC X(175).                  05080000
050900         10  BILL-PRIOR-DAYS         PIC 9(03).                   05090000
051000**==================================================***           05100000
051100*    PASSED AND RETURNED BY IPCAL                     *           05110000
051200**==================================================***           05120000
051300 01  IPF-DATA-VARIABLES.                                          05130000
051400         10  IPF-RTC                 PIC 9(02).                   05140000
051500         10  IPF-MSA-CBSA            PIC X(05).                   05150000
051600         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 05160000
051700             15  IPF-MSA             PIC X(04).                   05170000
051800             15  FILLER              PIC X.                       05180000
051900         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                05190000
052000             15  IPF-CBSA            PIC X(05).                   05200000
052100         10  IPF-WAGE-INDX           PIC 9(02)V9(04).             05210000
052200         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             05220000
052300         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             05230000
052400         10  IPF-COLA                PIC 9(01)V9(03).             05240000
052500         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             05250000
052600         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             05260000
052700         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             05270000
052800         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             05280000
052900         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             05290000
053000         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             05300000
053100         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             05310000
053200         10  IPF-FED-PPS-BLEND-IND   PIC X.                       05320000
053300         10  IPF-CAL-VERSION         PIC X(05).                   05330000
053400         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             05340000
053500         10  FILLER                  PIC X(08).                   05350000
053600                                                                  05360000
053700**==================================================***           05370000
053800*    PASSED AND RETURNED BY IPCAL                     *           05380000
053900**==================================================***           05390000
054000 01  IPF-ADDITIONAL-VARIABLES.                                    05400000
054100     02  IPF-MF-VARIABLES.                                        05410000
054200         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).          05420000
054300         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).          05430000
054400         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).          05440000
054500         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).          05450000
054600         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).          05460000
054700         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).          05470000
054800         10  IPF-OUTL-COST              PIC 9(07)V9(02).          05480000
054900         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).          05490000
055000         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).          05500000
055100         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).          05510000
055200         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).          05520000
055300         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).          05530000
055400         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).          05540000
055500         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).          05550000
055600         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).          05560000
055700         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).          05570000
055800         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).          05580000
055900         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).          05590000
056000         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).          05600000
056100         10  IPF-TEACH-PAYMENT          PIC 9(07)V9(02).          05610000
056200         10  FILLER                     PIC X(01).                05620000
056300      02 IPF-PC-VARIABLES.                                        05630000
056400         10  IPF-PC-DATA                PIC X(44).                05640000
056500                                                                  05650000
056600 01  PRICER-OPT-VERS-SW.                                          05660000
056700     02  PRICER-OPTION-SW               PIC X(01).                05670000
056800         88  VARIABLES                  VALUE 'S'.                05680000
056900         88  PROV-RECORD-PASSED         VALUE 'P'.                05690000
057000         88  ALL-TABLES-PASSED          VALUE 'B'.                05700000
057100     02  IPF-VERSIONS.                                            05710000
057200         10  IPOPN-VERSION              PIC X(05).                05720000
057300                                                                  05730000
057400**===========================================================     05740000
057500 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        05750000
057600                           IPF-DATA-VARIABLES                     05760000
057700                           IPF-ADDITIONAL-VARIABLES               05770000
057800                           PRICER-OPT-VERS-SW.                    05780000
057900                                                                  05790000
058000**============================================================****05800000
058100*    PROCESSING:                                                  05810000
058200*        A. THIS MODULE WILL CALL THE IPCAL MODULES.              05820000
058300*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  05830000
058400*           SUBROUTINE IS CALLED.                                 05840000
058500*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH*05850000
058600*           EACH BILL WILL BE PASSED TO THE IPCAL PROGRAMS.       05860000
058700*        D. CALL COMORBIDITY GROUPER AND RETURN A                 05870000
058800*           APPLIED COMORBIDITY ADJUSTER                          05880000
058900**============================================================****05890000
059000                                                                  05900000
059100     MOVE OPN-VERSION TO IPOPN-VERSION.                           05910000
059200                                                                  05920000
059300     MOVE ALL '0' TO IPF-ADDITIONAL-VARIABLES                     05930000
059400                     IPF-DATA-VARIABLES.                          05940000
059500**============================================================****05950000
059600***     RTC = 98 >> A BILL LESS  THEN 20050101                    05960000
059700***                                                               05970000
059800                                                                  05980000
059900     IF BILL-DISCHARGE-DATE < 20050101                            05990000
060000             MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES            06000000
060100                              IPF-DATA-VARIABLES                  06010000
060200             MOVE 98 TO IPF-RTC                                   06020000
060300             GOBACK.                                              06030000
060400                                                                  06040000
060500**============================================================****06050000
060600                                                                  06060000
060700 0010-LOAD-TABLES.                                                06070000
060860                                                                  06086002
060900     IF  PRICER-OPTION-SW  = 'B'                                  06090000
061000         PERFORM 1900-OPTION-SW-B THRU 1900-EXIT                  06100000
061100     ELSE                                                         06110000
061200     IF  PRICER-OPTION-SW  = 'P'                                  06120000
061300         PERFORM 2000-OPTION-SW-P THRU 2000-EXIT                  06130000
061400     ELSE                                                         06140000
061500         PERFORM 2100-OPTION-SW THRU 2100-EXIT.                   06150000
061600                                                                  06160000
061700***************************************************************** 06170000
061800***  GET THE PROVIDER RECORD                                      06180000
061900                                                                  06190000
062000     IF PROV-RECORD-PASSED OR ALL-TABLES-PASSED                   06200000
062100        MOVE 00 TO IPF-RTC                                        06210000
062200     ELSE                                                         06220000
062300        PERFORM 1200-GET-THIS-PROVIDER THRU 1200-EXIT.            06230000
062400                                                                  06240000
062500***     RTC = 51  --  PROVIDER NOT FOUND                          06250000
062600     IF IPF-RTC = 51                                              06260000
062610        GOBACK.                                                   06261000
062620                                                                  06262000
062630***************************************************************** 06263000
062640***  IF BILL-DISCHARGE-DATE < P-NEW-EFF-DATE                      06264000
062650***     MOVE 55 TO IPF-RTC                                        06265000
062660***     GOBACK.                                                   06266000
062670                                                                  06267000
062680***  IF BILL-DISCHARGE-DATE > 20060630 AND                        06268000
062690***     P-NEW-EFF-DATE < 20060701                                 06269000
062700***     MOVE 55 TO IPF-RTC                                        06270000
062800***     DISPLAY 'BILL-DISCHARGE-DATE: ' BILL-DISCHARGE-DATE       06280000
062900***     DISPLAY 'P-NEW-EFF-DATE     : ' P-NEW-EFF-DATE            06290000
063000***     GOBACK.                                                   06300000
063100                                                                  06310000
063200***     RTC = 52  --  WAGE-INDEX NOT FOUND                        06320000
063300                                                                  06330000
063400     IF IPF-RTC = 52                                              06340000
063500          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               06350000
063600          GOBACK.                                                 06360000
063700                                                                  06370000
063800         CALL  IPDRV220 USING BILL-INPUT-DATA                     06380000
063900                              IPF-DATA-VARIABLES                  06390000
064000                              IPF-ADDITIONAL-VARIABLES            06400000
064100                              PRICER-OPT-VERS-SW                  06410000
064200                              PROV-NEW-HOLD                       06420000
064300                              MSAX-WI-TABLE                       06430000
064400                              CBSA-WI-TABLE.                      06440000
064500         GOBACK.                                                  06450000
064600**============================================================****06460000
064700                                                                  06470000
064800 1200-GET-THIS-PROVIDER.                                          06480000
064900***************************************************************   06490000
065000*    ON A PROVIDER BREAK:                                     *   06500000
065100*        FIND THE NEW PROVIDER SPECIFIC DATA ELEMENTS         *   06510000
065200*    NOTE: IF BILLS ARE SORTED/BATCHED BY PROVIDER, FEWER     *   06520000
065300*             TABLE SEARCHES WILL BE NECESSARY.               *   06530000
065400***************************************************************   06540000
065500     SET PX1 TO 1.                                                06550004
065600*    IF BILL-PROVIDER-NO NOT = P-NEW-PROVIDER-NO                  06560002
065610                                                                  06561007
065700        SEARCH ALL PROV-ENTRIES                                   06570000
065800            AT END                                                06580000
065900               MOVE 51 TO IPF-RTC                                 06590000
066000               GO TO 1200-EXIT                                    06600000
066100        WHEN PROV-NO (PX1) = BILL-PROVIDER-NO                     06610000
066110            MOVE 00 TO IPF-RTC.                                   06611000
066120       SET PD3 TO PX1.                                            06612000
066130       MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2.                06613000
066140       MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.                06614000
066150                                                                  06615000
066160       PERFORM 1300-GET-CURR-PROV THRU 1300-EXIT                  06616000
066170         VARYING PX1 FROM PX1 BY 1                                06617000
066180           UNTIL PROV-NO (PX1) NOT = BILL-PROVIDER-NO             06618000
066190             OR PROV-NO (PX1) = '999999'.                         06619000
066200                                                                  06620000
066201 1200-EXIT.                                                       06620100
066202     EXIT.                                                        06620200
066203                                                                  06620300
066204 1300-GET-CURR-PROV.                                              06620400
066205                                                                  06620500
066206     IF BILL-DISCHARGE-DATE NOT < PROV-EFF-DATE (PX1)             06620600
066207         MOVE PROV-DATA1 (PX1) TO PROV-NEWREC-HOLD1               06620700
066208         SET PD2 TO PX1                                           06620800
066209         SET PD3 TO PX1                                           06620900
066210         MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2               06621000
066211         MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.              06621100
066212                                                                  06621200
066213 1300-EXIT.                                                       06621300
066214     EXIT.                                                        06621400
066215                                                                  06621500
066216**============================================================****06621600
066217 1500-LOAD-ALL-TABLES.                                            06621700
066218**============================================================*   06621800
066219*    THE FIRST TIME CALLED:                                   *   06621900
066220*        LOAD ALL TABLES SUPPLIED BY CMS                      *   06622000
066230*        LOAD THE PROVIDER SPECIFIC TABLE SUPPLIED BY         *   06623000
066240*             THE INTERMEDIARY.                               *   06624000
066250**============================================================*   06625000
066260     MOVE HIGH-VALUES TO MSAX-WI-TABLE.                           06626000
066270     MOVE HIGH-VALUES TO CBSA-WI-TABLE.                           06627000
066280     MOVE ALL '9' TO PROV-NEW-HOLD.                               06628000
066290     MOVE ALL '9' TO PROV-TABLE.                                  06629000
066300     MOVE ALL '9' TO PROV-DATA-2.                                 06630000
066400     MOVE ALL '9' TO PROV-DATA-3.                                 06640000
066500     OPEN  INPUT  PROV-FILE.                                      06650000
066600     MOVE 0 TO EOF-SW.                                            06660000
066700     SET PX1 TO EOF-SW.                                           06670000
066800                                                                  06680000
066900     PERFORM 1600-READ-PROV-FILE THRU 1600-EXIT                   06690000
067000                           UNTIL EOF-SW = 1.                      06700000
067100                                                                  06710000
067200     CLOSE        PROV-FILE.                                      06720000
067300                                                                  06730000
067400     PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT.                  06740000
067500     PERFORM 1750-LOAD-CBSA-FILE THRU 1750-EXIT.                  06750000
067600                                                                  06760000
067700 1500-EXIT.  EXIT.                                                06770000
067800                                                                  06780000
067900 1600-READ-PROV-FILE.                                             06790000
068000     READ PROV-FILE                                               06800000
068100         AT END                                                   06810000
068200             SET PX1 UP BY 1                                      06820000
068300             MOVE ALL '9' TO PROV-DATA1 (PX1)                     06830000
068400             SET PD2 TO PX1                                       06840000
068500             SET PD3 TO PX1                                       06850000
068600             MOVE ALL '9' TO PROV-DATA2 (PD2)                     06860000
068700             MOVE ALL '9' TO PROV-DATA3 (PD3)                     06870000
068800             MOVE '999999' TO P-NEW-PROVIDER-NO                   06880000
068900             MOVE 1 TO EOF-SW.                                    06890000
069000                                                                  06900000
069100     IF  EOF-SW = 0                                               06910000
069200         SET PX1 UP BY 1                                          06920000
069300         MOVE PROV-PART1 TO PROV-DATA1 (PX1)                      06930000
069400         SET PD2 TO PX1                                           06940000
069500         SET PD3 TO PX1                                           06950000
069600         MOVE PROV-PART2 TO PROV-DATA2 (PD2)                      06960000
069700         MOVE PROV-PART3 TO PROV-DATA3 (PD3).                     06970000
069800                                                                  06980000
069900 1600-EXIT.  EXIT.                                                06990000
070000                                                                  07000000
070100 1700-LOAD-MSAX-FILE.                                             07010000
070200     OPEN  INPUT  MSAX-FILE.                                      07020000
070300     MOVE 0 TO EOF-SW.                                            07030000
070400     SET MU3 TO EOF-SW.                                           07040000
070500                                                                  07050000
070600     PERFORM 1800-READ-MSAX-FILE THRU 1800-EXIT                   07060000
070700                      UNTIL EOF-SW = 1.                           07070000
070800     CLOSE        MSAX-FILE.                                      07080000
070900                                                                  07090000
071000 1700-EXIT.  EXIT.                                                07100000
071100                                                                  07110000
071200 1750-LOAD-CBSA-FILE.                                             07120000
071300     OPEN  INPUT  CBSA-FILE.                                      07130000
071400     MOVE 0 TO EOF-SW.                                            07140000
071500     SET MA3 TO EOF-SW.                                           07150000
071600                                                                  07160000
071700     PERFORM 1850-READ-CBSA-FILE THRU 1850-EXIT                   07170000
071800                      UNTIL EOF-SW = 1.                           07180000
071900     CLOSE        CBSA-FILE.                                      07190000
072000                                                                  07200000
072100 1750-EXIT.  EXIT.                                                07210000
072200                                                                  07220000
072300                                                                  07230000
072400 1800-READ-MSAX-FILE.                                             07240000
072500     READ MSAX-FILE                                               07250000
072600         AT END                                                   07260000
072700             MOVE 1 TO EOF-SW.                                    07270000
072800                                                                  07280000
072900     IF  EOF-SW = 0                                               07290000
073000             IF  XE-DATE > '20040930'                             07300000
073100                SET MU3 UP BY 1                                   07310000
073200                MOVE X-MSA-X      TO M-MSAX-MSA        (MU3)      07320000
073300                MOVE X-SIZE       TO M-MSAX-SIZE       (MU3)      07330000
073400                MOVE XE-DATE      TO M-MSAX-EFF-DATE   (MU3)      07340000
073500                MOVE X-WAGE-INDX1 TO M-MSAX-WAGE-INDX1 (MU3)      07350000
073600                MOVE X-WAGE-INDX2 TO M-MSAX-WAGE-INDX2 (MU3).     07360000
073700                                                                  07370000
073800 1800-EXIT.  EXIT.                                                07380000
073900                                                                  07390000
074000 1850-READ-CBSA-FILE.                                             07400000
074100     READ CBSA-FILE                                               07410000
074200         AT END                                                   07420000
074300             MOVE 1 TO EOF-SW.                                    07430000
074400                                                                  07440000
074500     IF  EOF-SW = 0                                               07450000
074600         IF  F-CBSA-EFF-DATE > '20040930'                         07460000
074700             SET MA3 UP BY 1                                      07470000
074800             MOVE F-CBSA          TO TB-CBSA            (MA3)     07480000
074900             MOVE F-CBSA-SIZE     TO TB-CBSA-SIZE       (MA3)     07490000
075000             MOVE F-CBSA-EFF-DATE TO TB-CBSA-EFF-DATE   (MA3)     07500000
075100             MOVE F-CBSA-INDX1    TO TB-CBSA-WAGE-INDX1 (MA3)     07510000
075200             MOVE F-CBSA-INDX2    TO TB-CBSA-WAGE-INDX2 (MA3).    07520000
075300                                                                  07530000
075400 1850-EXIT.  EXIT.                                                07540000
075500                                                                  07550000
075600                                                                  07560000
075700 1900-OPTION-SW-B.                                                07570000
075800     MOVE ALL '9'               TO PROV-NEW-HOLD.                 07580000
075900     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 07590000
076000     IF  TABLES-LOADED-SW = 0                                     07600000
076100         MOVE HIGH-VALUES           TO MSAX-WI-TABLE              07610000
076200         MOVE MSAX-TABLE-FROM-USER  TO MSAX-WI-TABLE              07620000
076300         MOVE 1 TO TABLES-LOADED-SW.                              07630000
076400                                                                  07640000
076500 1900-EXIT.  EXIT.                                                07650000
076600                                                                  07660000
076700 2000-OPTION-SW-P.                                                07670000
076800     MOVE ALL '9'               TO PROV-NEW-HOLD.                 07680000
076900     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 07690000
077000     IF  TABLES-LOADED-SW = 0                                     07700000
077100         MOVE HIGH-VALUES       TO MSAX-WI-TABLE                  07710000
077200         PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT               07720000
077300         MOVE 1 TO TABLES-LOADED-SW.                              07730000
077400                                                                  07740000
077500 2000-EXIT.  EXIT.                                                07750000
077600                                                                  07760000
077700 2100-OPTION-SW.                                                  07770000
077800                                                                  07780000
077900     IF  TABLES-LOADED-SW = 0                                     07790000
078000         PERFORM 1500-LOAD-ALL-TABLES THRU 1500-EXIT              07800000
078100         MOVE 1 TO TABLES-LOADED-SW.                              07810000
078200                                                                  07820000
078300 2100-EXIT.  EXIT.                                                07830000
078400                                                                  07840000
078500**===========================================================**   07850000
078600**           L A S T   S O U R C E   S T A T E M E N T       **   07860000
078700**===========================================================**   07870000
