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