000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IPDRV170.                                         00020000
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
001010*=================================================================00101000
001020*  THIS MODULE UPDATED IN ACCORDANCE WITH CR 9143                *00102000
001030*=================================================================00103000
001040 DATE-COMPILED.                                                   00104000
001050 ENVIRONMENT DIVISION.                                            00105000
001060 CONFIGURATION SECTION.                                           00106000
001070 SOURCE-COMPUTER.            IBM-370.                             00107000
001080 OBJECT-COMPUTER.            IBM-370.                             00108000
001090 INPUT-OUTPUT  SECTION.                                           00109000
001100 FILE-CONTROL.                                                    00110000
001200 DATA DIVISION.                                                   00120000
001300 FILE SECTION.                                                    00130000
001400                                                                  00140000
001500 WORKING-STORAGE SECTION.                                         00150000
001600 77  W-STORAGE-REF         PIC X(48)  VALUE                       00160000
001700     'IPF D R I V E R - W O R K I N G   S T O R A G E'.           00170000
001800 01  DRV-VERSION           PIC X(05) VALUE 'D17.0'.               00180000
001900 01  IPCAL170              PIC X(08) VALUE 'IPCAL170'.            00190000
002000 01  IPCAL161              PIC X(08) VALUE 'IPCAL161'.            00200000
002100 01  IPCAL150              PIC X(08) VALUE 'IPCAL150'.            00210000
002200 01  IPCAL140              PIC X(08) VALUE 'IPCAL140'.            00220000
002300 01  IPCAL130              PIC X(08) VALUE 'IPCAL130'.            00230000
002400 01  IPCAL121              PIC X(08) VALUE 'IPCAL121'.            00240000
002500 01  IPCAL120              PIC X(08) VALUE 'IPCAL120'.            00250000
002600 01  IPCAL112              PIC X(08) VALUE 'IPCAL112'.            00260000
002700 01  IPCAL111              PIC X(08) VALUE 'IPCAL111'.            00270000
002800 01  IPCAL110              PIC X(08) VALUE 'IPCAL110'.            00280000
002900 01  IPCAL102              PIC X(08) VALUE 'IPCAL102'.            00290000
002901 01  IPCAL100              PIC X(08) VALUE 'IPCAL100'.            00290100
002902 01  IPCAL094              PIC X(08) VALUE 'IPCAL094'.            00290200
002903 01  IPCAL09A              PIC X(08) VALUE 'IPCAL09A'.            00290300
002904 01  IPCAL08A              PIC X(08) VALUE 'IPCAL08A'.            00290400
002905 01  IPCAL086              PIC X(08) VALUE 'IPCAL086'.            00290500
002906 01  IPCAL076              PIC X(08) VALUE 'IPCAL076'.            00290600
002907 01  IPCAL057              PIC X(08) VALUE 'IPCAL057'.            00290700
002908 01  TABLES-LOADED-SW      PIC 9(01)  VALUE 0.                    00290800
002909 01  EOF-SW                PIC 9(01)  VALUE 0.                    00290900
002910 01  PROV-STAT.                                                   00291000
002911     02  PROV-STAT1     PIC X.                                    00291100
002912     02  PROV-STAT2     PIC X.                                    00291200
002913                                                                  00291300
002914 01  MSAX-STAT.                                                   00291400
002915     02  MSAX-STAT1     PIC X.                                    00291500
002916     02  MSAX-STAT2     PIC X.                                    00291600
002917                                                                  00291700
002918 01  CBSA-STAT.                                                   00291800
002919     02  CBSA-STAT1     PIC X.                                    00291900
002920     02  CBSA-STAT2     PIC X.                                    00292000
002930                                                                  00293000
002940 01  HOLD-PROV-MSAX.                                              00294000
002950         10  H-MSAX-PROV-BLANK   PIC X(2).                        00295000
002960         10  H-MSAX-PROV-STATE.                                   00296000
002970             15  FILLER          PIC X.                           00297000
002980             15  H-MSAX-LAST-POS PIC X.                           00298000
002990                                                                  00299000
003000 01  HOLD-PROV-CBSA.                                              00300000
003100         10  H-CBSA-PROV-BLANK   PIC X(3).                        00310000
003200         10  H-CBSA-PROV-STATE.                                   00320000
003300             15  FILLER          PIC X.                           00330000
003400             15  H-CBSA-LAST-POS PIC X.                           00340000
003500                                                                  00350000
003600**================================================================00360000
003700*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   00370000
003800*      THE IPCAL056 PROGRAM FOR PROCESSING                        00380000
003900**================================================================00390000
004000 01  WAGE-NEW-INDEX-RECORD.                                       00400000
004100     05  W-NEW-MSA               PIC 9(4).                        00410000
004200     05  W-NEW-SIZE              PIC X(01).                       00420000
004300         88  NEW-LARGE-URBAN       VALUE 'L'.                     00430000
004400         88  NEW-OTHER-URBAN       VALUE 'O'.                     00440000
004500         88  NEW-ALL-RURAL         VALUE 'R'.                     00450000
004600     05  W-NEW-EFF-DATE.                                          00460000
004700          10  W-NEW-EFF-DATE-CC   PIC 9(2).                       00470000
004800          10  W-NEW-EFF-DATE-YMD.                                 00480000
004900              15  W-NEW-EFF-DATE-YY   PIC 9(2).                   00490000
005000              15  W-NEW-EFF-DATE-MM   PIC 9(2).                   00500000
005100              15  W-NEW-EFF-DATE-DD   PIC 9(2).                   00510000
005200     05  FILLER              PIC X.                               00520000
005300     05  W-NEW-INDEX-RECORD      PIC S9(02)V9(04).                00530000
005400     05  FILLER                  PIC S9(02)V9(04).                00540000
005500                                                                  00550000
005600**================================================================00560000
005700*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   00570000
005800*      THE IPCAL    PROGRAM FOR PROCESSING                        00580000
005900**================================================================00590000
006000 01  CBSA-WAGE-INDEX-RECORD.                                      00600000
006100     05  W-CBSA               PIC 9(5).                           00610000
006200     05  W-CBSA-X  REDEFINES W-CBSA PIC X(05).                    00620000
006300     05  W-CBSA-SIZE             PIC X(01).                       00630000
006400         88  W-CBSA-LARGE-URBAN       VALUE 'L'.                  00640000
006500         88  W-CBSA-OTHER-URBAN       VALUE 'O'.                  00650000
006600         88  W-CBSA-ALL-RURAL         VALUE 'R'.                  00660000
006700     05  W-CBSA-EFF-DATE.                                         00670000
006800          10  W-CBSA-EFF-DATE-CC       PIC 9(2).                  00680000
006900          10  W-CBSA-EFF-DATE-YMD.                                00690000
007000              15  W-CBSA-EFF-DATE-YY   PIC 9(2).                  00700000
007100              15  W-CBSA-EFF-DATE-MM   PIC 9(2).                  00710000
007200              15  W-CBSA-EFF-DATE-DD   PIC 9(2).                  00720000
007300     05  FILLER             PIC X.                                00730000
007400     05  W-CBSA-INDEX       PIC S9(02)V9(04).                     00740000
007500     05  FILLER             PIC S9(02)V9(04).                     00750000
007600                                                                  00760000
007700                                                                  00770000
007800**==============================================================**00780000
007900*   MSAX RECORD PASSED OPTION B                                   00790000
008000**==============================================================**00800000
008100 01  MSAX-TABLE-FROM-USER.                                        00810000
008200     05  FILLER                     PIC X(32000).                 00820000
008300     05  FILLER                     PIC X(30000).                 00830000
008400     05  FILLER                     PIC X(30000).                 00840000
008500                                                                  00850000
008600**==============================================================**00860000
008700*   CBSA RECORD PASSED OPTION B                                   00870000
008800**==============================================================**00880000
008900 01  CBSA-TABLE-FROM-USER.                                        00890000
009000     05  FILLER                     PIC X(32000).                 00900000
009100     05  FILLER                     PIC X(30000).                 00910000
009200     05  FILLER                     PIC X(30000).                 00920000
009300                                                                  00930000
009400**==============================================================**00940000
009500*   PROV RECORD PASSED OPTION P                                   00950000
009600**==============================================================**00960000
009700 01  PROV-NEW-HOLD.                                               00970000
009800     02  PROV-NEWREC-HOLD1.                                       00980000
009900         05  P-NEW-NPI10.                                         00990000
010000             10  P-NEW-NPI8             PIC X(08).                01000000
010100             10  P-NEW-NPI-FILLER       PIC X(02).                01010000
010200         05  P-NEW-PROVIDER-NO.                                   01020000
010300             10  P-NEW-STATE            PIC 9(02).                01030000
010400             10  FILLER                 PIC X(04).                01040000
010500         05  P-NEW-DATE-DATA.                                     01050000
010600             10  P-NEW-EFF-DATE.                                  01060000
010700                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01070000
010800                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01080000
010900                 15  P-NEW-EFF-DT-MM    PIC 9(02).                01090000
011000                 15  P-NEW-EFF-DT-DD    PIC 9(02).                01100000
011100             10  P-NEW-FY-BEGIN-DATE.                             01110000
011200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                01120000
011300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                01130000
011400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                01140000
011500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                01150000
011600             10  P-NEW-REPORT-DATE.                               01160000
011700                 15  P-NEW-REPORT-DT-CC PIC 9(02).                01170000
011800                 15  P-NEW-REPORT-DT-YY PIC 9(02).                01180000
011900                 15  P-NEW-REPORT-DT-MM PIC 9(02).                01190000
012000                 15  P-NEW-REPORT-DT-DD PIC 9(02).                01200000
012100             10  P-NEW-TERMINATION-DATE.                          01210000
012200                 15  P-NEW-TERM-DT-CC   PIC 9(02).                01220000
012300                 15  P-NEW-TERM-DT-YY   PIC 9(02).                01230000
012400                 15  P-NEW-TERM-DT-MM   PIC 9(02).                01240000
012500                 15  P-NEW-TERM-DT-DD   PIC 9(02).                01250000
012600         05  P-NEW-WAIVER-CODE          PIC X(01).                01260000
012700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              01270000
012800         05  P-NEW-INTER-NO             PIC 9(05).                01280000
012900         05  P-NEW-PROVIDER-TYPE        PIC X(02).                01290000
013000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      01300000
013100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       01310000
013200                                                  '15' '17'       01320000
013300                                                  '22'.           01330000
013400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           01340000
013500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           01350000
013600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           01360000
013700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           01370000
013800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      01380000
013900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           01390000
014000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      01400000
014100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           01410000
014200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           01420000
014300             88  P-N-EACH                   VALUE '21' '22'.      01430000
014400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           01440000
014500             88  P-N-NHCMQ-II-SNF           VALUE '32'.           01450000
014600             88  P-N-NHCMQ-III-SNF          VALUE '33'.           01460000
014700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                01470000
014800             88  P-N-NEW-ENGLAND            VALUE  1.             01480000
014900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             01490000
015000             88  P-N-SOUTH-ATLANTIC         VALUE  3.             01500000
015100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             01510000
015200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             01520000
015300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             01530000
015400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             01540000
015500             88  P-N-MOUNTAIN               VALUE  8.             01550000
015600             88  P-N-PACIFIC                VALUE  9.             01560000
015700         05  P-NEW-CURRENT-DIV   REDEFINES                        01570000
015800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         01580000
015900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          01590000
016000         05  P-NEW-MSA-DATA.                                      01600000
016100             10  P-NEW-CHG-CODE-INDEX       PIC X.                01610000
016200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 01620000
016300             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   01630000
016400                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       01640000
016500             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  01650000
016600                             P-NEW-GEO-LOC-MSA9.                  01660000
016700                 15  P-NEW-GEO-MSA-1ST    PIC X.                  01670000
016800                 15  P-NEW-GEO-MSA-2ND    PIC X.                  01680000
016900                 15  P-NEW-GEO-MSA-3RD    PIC X.                  01690000
017000                 15  P-NEW-GEO-MSA-4TH    PIC X.                  01700000
017100             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 01710000
017200             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 01720000
017300             10  P-NEW-STAND-AMT-LOC-MSA9                         01730000
017400       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         01740000
017500                 15  P-NEW-RURAL-1ST.                             01750000
017600                     20  P-NEW-STAND-RURAL  PIC XX.               01760000
017700                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    01770000
017800                 15  P-NEW-RURAL-2ND        PIC XX.               01780000
017900         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    01790000
018000                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           01800000
018100                 88  P-NEW-SCH-YR82       VALUE   '82'.           01810000
018200                 88  P-NEW-SCH-YR87       VALUE   '87'.           01820000
018300         05  P-NEW-LUGAR                    PIC X.                01830000
018400         05  P-NEW-TEMP-RELIEF-IND          PIC X.                01840000
018500             88  P-NEW-LOW-VOL25PCT     VALUE 'Y'.                01850000
018600***          Y = LOW VOLUME PERCENTAGE  25 % ADD ON               01860000
018700         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                01870000
018800         05  FILLER                         PIC X(05).            01880000
018900     02  PROV-NEWREC-HOLD2.                                       01890000
019000         05  P-NEW-VARIABLES.                                     01900000
019100             10  P-NEW-CMI-ADJ-CPD       PIC  9(05)V9(02).        01910000
019200             10  P-NEW-COLA              PIC  9(01)V9(03).        01920000
019300             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        01930000
019400             10  P-NEW-BED-SIZE          PIC  9(05).              01940000
019500             10  P-NEW-CCR               PIC  9(01)V9(03).        01950000
019600             10  P-NEW-CMI               PIC  9(01)V9(04).        01960000
019700             10  P-NEW-SSI-RATIO         PIC  V9(04).             01970000
019800             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             01980000
019900             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).              01990000
020000             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).        02000000
020100             10  P-NEW-DSH-PERCENT       PIC  V9(04).             02010000
020200             10  P-NEW-FYE-DATE.                                  02020000
020300                 15  P-NEW-FYE-CC        PIC 99.                  02030000
020400                 15  P-NEW-FYE-YY        PIC 99.                  02040000
020500                 15  P-NEW-FYE-MM        PIC 99.                  02050000
020600                 15  P-NEW-FYE-DD        PIC 99.                  02060000
020700         05  P-NEW-CBSA-DATA.                                     02070000
020800             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                02080000
020900                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.          02090000
021000                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.          02100000
021100                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.      02110000
021200***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI   02120000
021300***                  2 = RECLASS WITH SPEC WI                     02130000
021400             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 02140000
021500                 88  P-NEW-CBSA-HOSP-QUAL-MET   VALUE '1'.        02150000
021600                 88  P-NEW-CBSA-HOSP-QUAL-25PER VALUE '2'.        02160000
021700                 88  P-NEW-CBSA-HOSP-QUAL-BOTH  VALUE '3'.        02170000
021800             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  02180000
021900             10  P-NEW-CBSA-GEO-LOC9  REDEFINES                   02190000
022000                             P-NEW-CBSA-GEO-LOC  PIC 9(05).       02200000
022100             10  P-NEW-CBSA-GEO-LOC-AST REDEFINES                 02210000
022200                             P-NEW-CBSA-GEO-LOC9.                 02220000
022300                 15  P-NEW-CBSA-GEO-1ST    PIC X.                 02230000
022400                 15  P-NEW-CBSA-GEO-2ND    PIC X.                 02240000
022500                 15  P-NEW-CBSA-GEO-3RD    PIC X.                 02250000
022600                 15  P-NEW-CBSA-GEO-4TH    PIC X.                 02260000
022700                 15  P-NEW-CBSA-GEO-5TH    PIC X.                 02270000
022800             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  02280000
022900             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  02290000
023000             10  P-NEW-CBSA-STAND-AMT-LOC-MSA9                    02300000
023100       REDEFINES P-NEW-CBSA-STAND-AMT-LOC.                        02310000
023200               15  P-NEW-CBSA-RURAL-1ST.                          02320000
023300                   20  P-NEW-CBSA-STAND-RURAL  PIC XXX.           02330000
023400                      88  P-NEW-CBSA-STD-RURAL-CHECK VALUE '   '. 02340000
023500               15  P-NEW-CBSA-RURAL-2ND    PIC XX.                02350000
023600             10  P-NEW-CBSA-SPEC-WI          PIC 9(02)V9(04).     02360000
023700             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  02370000
023800                 P-NEW-CBSA-SPEC-WI          PIC 9(06).           02380000
023900     02  PROV-NEWREC-HOLD3.                                       02390000
024000         05  P-NEW-PASS-AMT-DATA.                                 02400000
024100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02410000
024200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02420000
024300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02430000
024400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02440000
024500         05  P-NEW-CAPI-DATA.                                     02450000
024600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02460000
024700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02470000
024800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02480000
024900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02490000
025000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02500000
025100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02510000
025200             15  P-NEW-CAPI-IME            PIC 9V9999.            02520000
025300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02530000
025400             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            02540000
025500         05  FILLER                         PIC X(18).            02550000
025600                                                                  02560000
025700**================================================================02570000
025800 LINKAGE SECTION.                                                 02580000
025900                                                                  02590000
026000**========================================================        02600000
026100*    PASSED AND RETURNED BY IPCAL                     *           02610000
026200**==============================*========================*        02620000
026300 01  BILL-INPUT-DATA.                                             02630000
026400     05  BILL-IN-DATA.                                            02640000
026500         10  BILL-NPI-NUMBER.                                     02650000
026600             15  BILL-NPI            PIC X(08).                   02660000
026700             15  BILL-NPI-FILLER     PIC X(02).                   02670000
026800         10  BILL-PROVIDER-NO        PIC X(06).                   02680000
026900         10  BILL-HIC-NO             PIC X(12).                   02690000
027000         10  BILL-DISCHARGE-DATE.                                 02700000
027100             15  BILL-D-CC           PIC 9(02).                   02710000
027200             15  BILL-D-YY           PIC 9(02).                   02720000
027300             15  BILL-D-MM           PIC 9(02).                   02730000
027400             15  BILL-D-DD           PIC 9(02).                   02740000
027500         10  BILL-PATIENT-STATUS     PIC X(02).                   02750000
027600         10  BILL-AGE                PIC 9(03).                   02760000
027700         10  BILL-DRG                PIC 9(03).                   02770000
027800         10  BILL-LOS                PIC 9(05).                   02780000
027900         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   02790000
028000         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   02800000
028100         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   02810000
028200         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             02820000
028300         10  BILL-OTHER-DIAG-DATA    PIC X(175).                  02830000
028400         10  BILL-OTHER-PROC-DATA    PIC X(175).                  02840000
028500         10  BILL-PRIOR-DAYS         PIC 9(03).                   02850000
028600**========================================================        02860000
028700*    PASSED AND RETURNED BY IPCAL                     *           02870000
028800**======================================================**        02880000
028900 01  IPF-DATA-VARIABLES.                                          02890000
029000         10  IPF-RTC                 PIC 9(02).                   02900000
029100         10  IPF-MSA-CBSA            PIC X(05).                   02910000
029200         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 02920000
029300             15  IPF-MSA             PIC X(04).                   02930000
029400             15  FILLER              PIC X.                       02940000
029500         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                02950000
029600             15  IPF-CBSA            PIC X(05).                   02960000
029700         10  IPF-WAGE-INDX           PIC 9(02)V9(04).             02970000
029800         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             02980000
029900         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             02990000
030000         10  IPF-COLA                PIC 9(01)V9(03).             03000000
030100         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             03010000
030200         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             03020000
030300         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             03030000
030400         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             03040000
030500         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             03050000
030600         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             03060000
030700         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             03070000
030800         10  IPF-FED-PPS-BLEND-IND   PIC X.                       03080000
030900         10  IPF-CAL-VERSION         PIC X(05).                   03090000
031000         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             03100000
031100         10  FILLER                  PIC X(08).                   03110000
031200                                                                  03120000
031300**======================================================**        03130000
031400*    PASSED AND RETURNED BY IPCAL                     *           03140000
031500**======================================================**        03150000
031600 01  IPF-ADDITIONAL-VARIABLES.                                    03160000
031700     02  IPF-MF-VARIABLES.                                        03170000
031800         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).          03180000
031900         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).          03190000
032000         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).          03200000
032100         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).          03210000
032200         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).          03220000
032300         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).          03230000
032400         10  IPF-OUTL-COST              PIC 9(07)V9(02).          03240000
032500         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).          03250000
032600         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).          03260000
032700         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).          03270000
032800         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).          03280000
032900         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).          03290000
033000         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).          03300000
033100         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).          03310000
033200         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).          03320000
033300         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).          03330000
033400         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).          03340000
033500         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).          03350000
033600         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).          03360000
033700         10  IPF-TEACH-PAYMENT          PIC 9(07)V9(02).          03370000
033800         10  FILLER                     PIC X(01).                03380000
033900      02 IPF-PC-VARIABLES.                                        03390000
034000         10  IPF-PC-DATA                PIC X(44).                03400000
034100                                                                  03410000
034200 01  PRICER-OPT-VERS-SW.                                          03420000
034300     02  PRICER-OPTION-SW               PIC X(01).                03430000
034400         88  VARIABLES                  VALUE 'S'.                03440000
034500         88  PROV-RECORD-PASSED         VALUE 'P'.                03450000
034600         88  ALL-TABLES-PASSED          VALUE 'B'.                03460000
034700     02  IPF-VERSIONS.                                            03470000
034800         10  IPDRV-VERSION              PIC X(05).                03480000
034900                                                                  03490000
035000**===============================================================*03500000
035100* THE PROVIDER SPECIFIC PASSED FROM CALLING PROGRAM              *03510000
035200**===============================================================*03520000
035300 01  PROV-RECORD-FROM-USER.                                       03530000
035400     02  PROV-FROM-USER-HOLD1           PIC X(80).                03540000
035500     02  PROV-FROM-USER-HOLD2           PIC X(80).                03550000
035600     02  PROV-FROM-USER-HOLD3           PIC X(80).                03560000
035700                                                                  03570000
035800 01  MSAX-WI-TABLE.                                               03580000
035900     05  M-MSAX-DATA                OCCURS 4000                   03590000
036000                                    INDEXED BY MU1 MU2 MU3.       03600000
036100         10  M-MSAX-MSA             PIC X(4).                     03610000
036200         10  M-MSAX-SIZE            PIC X(01).                    03620000
036300         10  M-MSAX-EFF-DATE        PIC X(08).                    03630000
036400         10  M-MSAX-WAGE-INDX1      PIC S9(02)V9(04).             03640000
036500         10  M-MSAX-WAGE-INDX2      PIC S9(02)V9(04).             03650000
036600                                                                  03660000
036700 01  CBSA-WI-TABLE.                                               03670000
036800     05  TB-CBSA-DATA                OCCURS 6000                  03680000
036900                                    INDEXED BY MA1 MA2 MA3.       03690000
037000         10  TB-CBSA                PIC X(5).                     03700000
037100         10  TB-CBSA-SIZE           PIC X(01).                    03710000
037200         10  TB-CBSA-EFF-DATE       PIC X(08).                    03720000
037300         10  TB-CBSA-WAGE-INDX1     PIC S9(02)V9(04).             03730000
037400         10  TB-CBSA-WAGE-INDX2     PIC S9(02)V9(04).             03740000
037500                                                                  03750000
037600**============================================================    03760000
037700 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        03770000
037800                           IPF-DATA-VARIABLES                     03780000
037900                           IPF-ADDITIONAL-VARIABLES               03790000
038000                           PRICER-OPT-VERS-SW                     03800000
038100                           PROV-RECORD-FROM-USER                  03810000
038200                           MSAX-WI-TABLE                          03820000
038300                           CBSA-WI-TABLE.                         03830000
038400                                                                  03840000
038500**==============================================================**03850000
038600*    PROCESSING:                                                  03860000
038700*        A. THIS MODULE WILL CALL THE IPCAL MODULES.              03870000
038800*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  03880000
038900*           SUBROUTINE IS CALLED.                                 03890000
039000*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH*03900000
039100*           EACH BILL WILL BE PASSED TO THE IPCAL PROGRAMS.       03910000
039200*        D. CALL COMORBIDITY GROUPER AND RETURN A                 03920000
039300*           APPLIED COMORBIDITY ADJUSTER                          03930000
039400**==============================================================**03940000
039500                                                                  03950000
039600     MOVE DRV-VERSION TO IPDRV-VERSION.                           03960000
039700                                                                  03970000
039800     MOVE ALL '0' TO IPF-ADDITIONAL-VARIABLES                     03980000
039900                     IPF-DATA-VARIABLES.                          03990000
040000                                                                  04000000
040100**==============================================================**04010000
040200***     RTC = 98 >> A BILL LESS THEN 20050101                     04020000
040300                                                                  04030000
040400     IF BILL-DISCHARGE-DATE < 20050101                            04040000
040500             MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES            04050000
040600                              IPF-DATA-VARIABLES                  04060000
040700             MOVE 98 TO IPF-RTC                                   04070000
040800             GOBACK.                                              04080000
040900**==============================================================**04090000
041000                                                                  04100000
041100 0010-PROCESS-RECORDS.                                            04110000
041200**==============================================================**04120000
041300***  GET THE PROVIDER RECORD                                      04130000
041400                                                                  04140000
041500     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 04150000
041600     IF PROV-RECORD-FROM-USER <= SPACES                           04160000
041700        MOVE 51 TO IPF-RTC                                        04170000
041800        MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES                 04180000
041900        GOBACK                                                    04190000
042000     END-IF.                                                      04200000
042100                                                                  04210000
042200     PERFORM 1350-N-CHECK-MSA THRU 1350-N-EXIT.                   04220000
042300                                                                  04230000
042400     IF BILL-DISCHARGE-DATE < P-NEW-EFF-DATE                      04240000
042500        MOVE 55 TO IPF-RTC                                        04250000
042600        GOBACK.                                                   04260000
042700                                                                  04270000
042800     IF BILL-DISCHARGE-DATE > 20060630 AND                        04280000
042900        P-NEW-EFF-DATE < 20060701                                 04290000
043000        MOVE 55 TO IPF-RTC                                        04300000
043100        GOBACK.                                                   04310000
043200                                                                  04320000
043300     IF P-NEW-EFF-DATE < 20060701                                 04330000
043400        PERFORM 0500-GET-MSA THRU 0500-EXIT                       04340000
043500     ELSE                                                         04350000
043600        PERFORM 0550-GET-CBSA THRU 0550-EXIT.                     04360000
043700                                                                  04370000
043800***     RTC = 52  --  WAGE-INDEX NOT FOUND                        04380000
043900                                                                  04390000
044000     IF IPF-RTC = 52                                              04400000
044100          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               04410000
044200          GOBACK.                                                 04420000
044300                                                                  04430000
044400**==============================================================**04440000
044500** MAKE SURE DATE IS CODED THE DAY BEFORE THE EFFECTIVE DATE    **04450000
044600**==============================================================**04460000
044700**          THIS NEXT CALL WILL PROCESS 2017 BILLS WITH           04470000
044800**              A DISCHARGE DATE ON OR AFTER 20161001             04480000
044900**==============================================================**04490000
045000     IF BILL-DISCHARGE-DATE                                       04500000
045100              > 20160930                                          04510000
045200         CALL  IPCAL170 USING BILL-INPUT-DATA                     04520000
045300                              IPF-DATA-VARIABLES                  04530000
045400                              IPF-ADDITIONAL-VARIABLES            04540000
045500                              PRICER-OPT-VERS-SW                  04550000
045600                              PROV-NEW-HOLD                       04560000
045700                              CBSA-WAGE-INDEX-RECORD              04570000
045800         GOBACK.                                                  04580000
045900**==============================================================**04590000
046000**          THIS NEXT CALL WILL PROCESS 2016 BILLS WITH           04600000
046100**              A DISCHARGE DATE ON OR AFTER 20151001             04610000
046200**==============================================================**04620000
046300     IF BILL-DISCHARGE-DATE                                       04630000
046301              > 20150930                                          04630100
046302         CALL  IPCAL161 USING BILL-INPUT-DATA                     04630200
046303                              IPF-DATA-VARIABLES                  04630300
046304                              IPF-ADDITIONAL-VARIABLES            04630400
046305                              PRICER-OPT-VERS-SW                  04630500
046306                              PROV-NEW-HOLD                       04630600
046307                              CBSA-WAGE-INDEX-RECORD              04630700
046308         GOBACK.                                                  04630800
046309**==============================================================**04630900
046310**          THIS NEXT CALL WILL PROCESS 2015 BILLS WITH           04631000
046320**              A DISCHARGE DATE ON OR AFTER 20141001             04632000
046330**==============================================================**04633000
046340     IF BILL-DISCHARGE-DATE                                       04634000
046350              > 20140930                                          04635000
046360         CALL  IPCAL150 USING BILL-INPUT-DATA                     04636000
046370                              IPF-DATA-VARIABLES                  04637000
046380                              IPF-ADDITIONAL-VARIABLES            04638000
046390                              PRICER-OPT-VERS-SW                  04639000
046391                              PROV-NEW-HOLD                       04639100
046392                              CBSA-WAGE-INDEX-RECORD              04639200
046393         GOBACK.                                                  04639300
046394**==============================================================**04639400
046395**          THIS NEXT CALL WILL PROCESS 2014 BILLS WITH           04639500
046396**              A DISCHARGE DATE ON OR AFTER 20131001             04639600
046397**==============================================================**04639700
046398     IF BILL-DISCHARGE-DATE                                       04639800
046399              > 20130930                                          04639900
046400         CALL  IPCAL140 USING BILL-INPUT-DATA                     04640000
046500                              IPF-DATA-VARIABLES                  04650000
046600                              IPF-ADDITIONAL-VARIABLES            04660000
046700                              PRICER-OPT-VERS-SW                  04670000
046800                              PROV-NEW-HOLD                       04680000
046900                              CBSA-WAGE-INDEX-RECORD              04690000
047000         GOBACK.                                                  04700000
047100**==============================================================**04710000
047200**          THIS NEXT CALL WILL PROCESS 2013 BILLS WITH           04720000
047300**              A DISCHARGE DATE ON OR AFTER 20121001             04730000
047400**==============================================================**04740000
047500     IF BILL-DISCHARGE-DATE                                       04750000
047600              > 20120930                                          04760000
047700         CALL  IPCAL130 USING BILL-INPUT-DATA                     04770000
047800                              IPF-DATA-VARIABLES                  04780000
047900                              IPF-ADDITIONAL-VARIABLES            04790000
048000                              PRICER-OPT-VERS-SW                  04800000
048100                              PROV-NEW-HOLD                       04810000
048200                              CBSA-WAGE-INDEX-RECORD              04820000
048300         GOBACK.                                                  04830000
048400**==============================================================**04840000
048500**          THIS NEXT CALL WILL PROCESS 2012 BILLS WITH           04850000
048600**              A DISCHARGE DATE ON OR AFTER 20111001             04860000
048700**==============================================================**04870000
048800     IF BILL-DISCHARGE-DATE                                       04880000
048900              > 20110930                                          04890000
049000         CALL  IPCAL121 USING BILL-INPUT-DATA                     04900000
049100                              IPF-DATA-VARIABLES                  04910000
049200                              IPF-ADDITIONAL-VARIABLES            04920000
049300                              PRICER-OPT-VERS-SW                  04930000
049400                              PROV-NEW-HOLD                       04940000
049500                              CBSA-WAGE-INDEX-RECORD              04950000
049600         GOBACK.                                                  04960000
049700**==============================================================**04970000
049800**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH           04980000
049900**              A DISCHARGE DATE ON OR AFTER 20110701             04990000
050000**==============================================================**05000000
050100     IF BILL-DISCHARGE-DATE                                       05010000
050200              > 20110630                                          05020000
050300         CALL  IPCAL120 USING BILL-INPUT-DATA                     05030000
050400                              IPF-DATA-VARIABLES                  05040000
050500                              IPF-ADDITIONAL-VARIABLES            05050000
050600                              PRICER-OPT-VERS-SW                  05060000
050700                              PROV-NEW-HOLD                       05070000
050800                              CBSA-WAGE-INDEX-RECORD              05080000
050900         GOBACK.                                                  05090000
051000**==============================================================**05100000
051100**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH           05110000
051200**              A DISCHARGE DATE ON OR AFTER 20110101             05120000
051300**==============================================================**05130000
051400     IF BILL-DISCHARGE-DATE                                       05140000
051500              > 20101231                                          05150000
051600         CALL  IPCAL112 USING BILL-INPUT-DATA                     05160000
051700                              IPF-DATA-VARIABLES                  05170000
051800                              IPF-ADDITIONAL-VARIABLES            05180000
051900                              PRICER-OPT-VERS-SW                  05190000
052000                              PROV-NEW-HOLD                       05200000
052100                              CBSA-WAGE-INDEX-RECORD              05210000
052200         GOBACK.                                                  05220000
052300**==============================================================**05230000
052400**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH          05240000
052500**              A DISCHARGE DATE ON OR AFTER 20101001             05250000
052600**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05260000
052700**              USES THE CBSA FOR WAGE INDEXES                    05270000
052800**      FOR RY 2011 10/01/2010 TO 06/30/2011                      05280000
052900**==============================================================**05290000
053000     IF BILL-DISCHARGE-DATE                                       05300000
053100              > 20100930                                          05310000
053200         CALL  IPCAL111 USING BILL-INPUT-DATA                     05320000
053300                              IPF-DATA-VARIABLES                  05330000
053400                              IPF-ADDITIONAL-VARIABLES            05340000
053500                              PRICER-OPT-VERS-SW                  05350000
053600                              PROV-NEW-HOLD                       05360000
053700                              CBSA-WAGE-INDEX-RECORD              05370000
053800         GOBACK.                                                  05380000
053900                                                                  05390000
054000**==============================================================**05400000
054100**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH          05410000
054200**              A DISCHARGE DATE ON OR AFTER 20101001             05420000
054300**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05430000
054400**              USES THE CBSA FOR WAGE INDEXES                    05440000
054500**      FOR RY 2011 07/01/2010 TO 06/30/2011                      05450000
054600**==============================================================**05460000
054700     IF BILL-DISCHARGE-DATE                                       05470000
054800              > 20100630                                          05480000
054900         CALL  IPCAL110 USING BILL-INPUT-DATA                     05490000
055000                              IPF-DATA-VARIABLES                  05500000
055100                              IPF-ADDITIONAL-VARIABLES            05510000
055200                              PRICER-OPT-VERS-SW                  05520000
055300                              PROV-NEW-HOLD                       05530000
055400                              CBSA-WAGE-INDEX-RECORD              05540000
055500         GOBACK.                                                  05550000
055600**==============================================================**05560000
055700**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          05570000
055800**              A DISCHARGE DATE ON OR AFTER 20091001             05580000
055900**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05590000
056000**              USES THE CBSA FOR WAGE INDEXES                    05600000
056100**      FOR RY 2010 10/01/2010 TO 06/30/2010                      05610000
056200**==============================================================**05620000
056300     IF BILL-DISCHARGE-DATE                                       05630000
056400              > 20090930                                          05640000
056500         CALL  IPCAL102 USING BILL-INPUT-DATA                     05650000
056600                              IPF-DATA-VARIABLES                  05660000
056700                              IPF-ADDITIONAL-VARIABLES            05670000
056800                              PRICER-OPT-VERS-SW                  05680000
056900                              PROV-NEW-HOLD                       05690000
057000                              CBSA-WAGE-INDEX-RECORD              05700000
057100         GOBACK.                                                  05710000
057200**==============================================================**05720000
057300**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          05730000
057400**              A DISCHARGE DATE ON OR AFTER 20090701             05740000
057500**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05750000
057600**              USES THE CBSA FOR WAGE INDEXES                    05760000
057700**      FOR RY 2010 07/01/2009 TO 06/30/2010                      05770000
057800**==============================================================**05780000
057900     IF BILL-DISCHARGE-DATE                                       05790000
058000              > 20090630                                          05800000
058100         CALL  IPCAL100 USING BILL-INPUT-DATA                     05810000
058200                              IPF-DATA-VARIABLES                  05820000
058300                              IPF-ADDITIONAL-VARIABLES            05830000
058400                              PRICER-OPT-VERS-SW                  05840000
058500                              PROV-NEW-HOLD                       05850000
058600                              CBSA-WAGE-INDEX-RECORD              05860000
058700         GOBACK.                                                  05870000
058800**==============================================================**05880000
058900**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          05890000
059000**              A DISCHARGE DATE ON OR AFTER 20080930             05900000
059100**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05910000
059200**              USES THE CBSA FOR WAGE INDEXES                    05920000
059300**      FOR RY 2009 10/01/2008 TO 06/30/2009                      05930000
059400**==============================================================**05940000
059500     IF BILL-DISCHARGE-DATE                                       05950000
059600              > 20080930                                          05960000
059700         CALL  IPCAL094 USING BILL-INPUT-DATA                     05970000
059800                              IPF-DATA-VARIABLES                  05980000
059900                              IPF-ADDITIONAL-VARIABLES            05990000
060000                              PRICER-OPT-VERS-SW                  06000000
060100                              PROV-NEW-HOLD                       06010000
060200                              CBSA-WAGE-INDEX-RECORD              06020000
060300         GOBACK.                                                  06030000
060400**==============================================================**06040000
060500**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          06050000
060600**              A DISCHARGE DATE ON OR AFTER 20080630             06060000
060700**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06070000
060800**              USES THE CBSA FOR WAGE INDEXES                    06080000
060900**      FOR RY 2009 07/01/2008 TO 09/30/2009                      06090000
061000**==============================================================**06100000
061100     IF BILL-DISCHARGE-DATE                                       06110000
061200              > 20080630                                          06120000
061300         CALL  IPCAL09A USING BILL-INPUT-DATA                     06130000
061400                              IPF-DATA-VARIABLES                  06140000
061500                              IPF-ADDITIONAL-VARIABLES            06150000
061600                              PRICER-OPT-VERS-SW                  06160000
061700                              PROV-NEW-HOLD                       06170000
061800                              CBSA-WAGE-INDEX-RECORD              06180000
061900         GOBACK.                                                  06190000
062000**==============================================================**06200000
062100**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH          06210000
062200**              A DISCHARGE DATE ON OR AFTER 20070630             06220000
062300**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06230000
062400**              USES THE CBSA FOR WAGE INDEXES                    06240000
062500**      FOR RY 2008 10/01/2007 TO 07/01/2008                      06250000
062600**==============================================================**06260000
062700     IF BILL-DISCHARGE-DATE                                       06270000
062800              > 20070930                                          06280000
062900         CALL  IPCAL086 USING BILL-INPUT-DATA                     06290000
063000                              IPF-DATA-VARIABLES                  06300000
063100                              IPF-ADDITIONAL-VARIABLES            06310000
063200                              PRICER-OPT-VERS-SW                  06320000
063300                              PROV-NEW-HOLD                       06330000
063400                              CBSA-WAGE-INDEX-RECORD              06340000
063500         GOBACK.                                                  06350000
063600**==============================================================**06360000
063700**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH          06370000
063800**              A DISCHARGE DATE ON OR AFTER 20070630             06380000
063900**              BUT BEFORE 20071001 WHEN DRG'S ARE REVISED        06390000
064000**              USES THE CBSA FOR WAGE INDEXES                    06400000
064100**      FOR RY 2008 07/01/2007 TO 10/01/2007                      06410000
064200**==============================================================**06420000
064300     IF BILL-DISCHARGE-DATE                                       06430000
064400              > 20070630                                          06440000
064500         CALL  IPCAL08A USING BILL-INPUT-DATA                     06450000
064600                              IPF-DATA-VARIABLES                  06460000
064700                              IPF-ADDITIONAL-VARIABLES            06470000
064800                              PRICER-OPT-VERS-SW                  06480000
064900                              PROV-NEW-HOLD                       06490000
065000                              CBSA-WAGE-INDEX-RECORD              06500000
065100         GOBACK.                                                  06510000
065200**==============================================================**06520000
065300**          THIS NEXT CALL WILL PROCESS 2007 BILLS  WITH          06530000
065400**              A DISCHARGE DATE ON OR AFTER 20060630             06540000
065500**              USES THE CBSA FOR WAGE INDEXES                    06550000
065600**      FOR RY 2007                                               06560000
065700**==============================================================**06570000
065800     IF BILL-DISCHARGE-DATE                                       06580000
065900              > 20060630                                          06590000
066000         CALL  IPCAL076 USING BILL-INPUT-DATA                     06600000
066100                              IPF-DATA-VARIABLES                  06610000
066200                              IPF-ADDITIONAL-VARIABLES            06620000
066300                              PRICER-OPT-VERS-SW                  06630000
066400                              PROV-NEW-HOLD                       06640000
066500                              CBSA-WAGE-INDEX-RECORD              06650000
066600         GOBACK.                                                  06660000
066700**==============================================================**06670000
066800**          THIS NEXT CALL WILL PROCESS 2005 BILLS  WITH          06680000
066900**              A DISCHARGE DATE ON OR AFTER 20050101             06690000
067000**              USES MSA FILE FOR WAGE INDEX                      06700000
067100**==============================================================**06710000
067200     IF BILL-DISCHARGE-DATE                                       06720000
067300              > 20041231                                          06730000
067400         CALL  IPCAL057 USING BILL-INPUT-DATA                     06740000
067500                              IPF-DATA-VARIABLES                  06750000
067600                              IPF-ADDITIONAL-VARIABLES            06760000
067700                              PRICER-OPT-VERS-SW                  06770000
067800                              PROV-NEW-HOLD                       06780000
067900                              WAGE-NEW-INDEX-RECORD               06790000
068000         GOBACK.                                                  06800000
068100**==============================================================**06810000
068200     MOVE 98 TO IPF-RTC.                                          06820000
068300     GOBACK.                                                      06830000
068400                                                                  06840000
068500 0100-GET-MSA.                                                    06850000
068600     SET MU1 TO 1.                                                06860000
068700                                                                  06870000
068800     SEARCH M-MSAX-DATA VARYING MU1                               06880000
068900     AT END                                                       06890000
069000          MOVE 999999 TO P-NEW-PROVIDER-NO                        06900000
069100          MOVE 52     TO IPF-RTC                                  06910000
069200          GO TO 0100-EXIT                                         06920000
069300     WHEN M-MSAX-MSA (MU1) = HOLD-PROV-MSAX                       06930000
069400          SET MU2 TO MU1.                                         06940000
069500                                                                  06950000
069600 0100-EXIT.  EXIT.                                                06960000
069700                                                                  06970000
069800 0150-GET-CBSA.                                                   06980000
069900     SET MA1 TO 1.                                                06990000
070000                                                                  07000000
070100     SEARCH TB-CBSA-DATA VARYING MA1                              07010000
070200     AT END                                                       07020000
070300          MOVE 999999 TO P-NEW-PROVIDER-NO                        07030000
070400          MOVE 52     TO IPF-RTC                                  07040000
070500          GO TO 0150-EXIT                                         07050000
070600     WHEN TB-CBSA (MA1) = HOLD-PROV-CBSA                          07060000
070700          SET MA2 TO MA1.                                         07070000
070800                                                                  07080000
070900 0150-EXIT.  EXIT.                                                07090000
071000                                                                  07100000
071100 0500-GET-MSA.                                                    07110000
071200     IF P-NEW-CHG-CODE-INDEX = 'Y'                                07120000
071300        MOVE P-NEW-WAGE-INDEX-LOC-MSA TO HOLD-PROV-MSAX           07130000
071400                                         IPF-MSA                  07140000
071500     ELSE                                                         07150000
071600        MOVE P-NEW-GEO-LOC-MSA9 TO HOLD-PROV-MSAX                 07160000
071700                                   IPF-MSA.                       07170000
071800                                                                  07180000
071900     PERFORM 0100-GET-MSA THRU 0100-EXIT.                         07190000
072000                                                                  07200000
072100***     RTC = 52  --  MSA NOT FOUND                               07210000
072200     IF IPF-RTC = 52    GOBACK.                                   07220000
072300                                                                  07230000
072400     IF IPF-RTC = 00                                              07240000
072500        PERFORM 0600-N-GET-WAGE-INDX                              07250000
072600           THRU 0600-N-EXIT VARYING MU2                           07260000
072700           FROM MU1 BY 1 UNTIL                                    07270000
072800           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.                 07280000
072900                                                                  07290000
073000***     RTC = 52  --  WAGE-INDEX NOT FOUND                        07300000
073100     IF IPF-RTC = 52    GOBACK.                                   07310000
073200                                                                  07320000
073300     IF W-NEW-INDEX-RECORD = 00.0000                              07330000
073400        MOVE 52 TO IPF-RTC.                                       07340000
073500                                                                  07350000
073600***  GET THE WAGE-SIZE                                            07360000
073700                                                                  07370000
073800     MOVE P-NEW-STAND-AMT-LOC-MSA TO HOLD-PROV-MSAX.              07380000
073900                                                                  07390000
074000     PERFORM 0100-GET-MSA THRU 0100-EXIT.                         07400000
074100                                                                  07410000
074200     IF IPF-RTC = 00                                              07420000
074300         PERFORM 0700-N-GET-WAGE-SIZE                             07430000
074400           THRU 0700-N-EXIT VARYING MU2                           07440000
074500           FROM MU1 BY 1 UNTIL                                    07450000
074600           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.                 07460000
074700                                                                  07470000
074800***     RTC = 52  --  PR-WAGE-INDEX NOT FOUND                     07480000
074900     IF IPF-RTC = 52                                              07490000
075000          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               07500000
075100          GOBACK.                                                 07510000
075200                                                                  07520000
075300 0500-EXIT.  EXIT.                                                07530000
075400                                                                  07540000
075500 0550-GET-CBSA.                                                   07550000
075600                                                                  07560000
075700     MOVE P-NEW-CBSA-GEO-LOC TO HOLD-PROV-CBSA                    07570000
075800                                IPF-CBSA.                         07580000
075900                                                                  07590000
076000     IF (P-NEW-CBSA-WI-SPECIAL AND                                07600000
076100         P-NEW-CBSA-SPEC-WI-N NOT NUMERIC)                        07610000
076200         MOVE 52 TO IPF-RTC                                       07620000
076300         GOBACK.                                                  07630000
076400                                                                  07640000
076500     IF (P-NEW-CBSA-WI-SPECIAL AND                                07650000
076600         P-NEW-CBSA-SPEC-WI-N = ZEROES)                           07660000
076700         MOVE 52 TO IPF-RTC                                       07670000
076800         GOBACK.                                                  07680000
076900                                                                  07690000
077000     IF P-NEW-CBSA-WI-SPECIAL                                     07700000
077100        MOVE 'SPEC*'  TO W-CBSA-X                                 07710000
077200        MOVE P-NEW-EFF-DATE TO W-CBSA-EFF-DATE                    07720000
077300        MOVE P-NEW-CBSA-SPEC-WI TO W-CBSA-INDEX                   07730000
077400        GO TO 0550-EXIT.                                          07740000
077500                                                                  07750000
077600     PERFORM 0150-GET-CBSA THRU 0150-EXIT.                        07760000
077700                                                                  07770000
077800***     RTC = 52  --  CBSA NOT FOUND                              07780000
077900     IF IPF-RTC = 52    GOBACK.                                   07790000
078000                                                                  07800000
078100     IF IPF-RTC = 00                                              07810000
078200        PERFORM 0650-N-GET-WAGE-INDX                              07820000
078300           THRU 0650-N-EXIT VARYING MA2                           07830000
078400           FROM MA1 BY 1 UNTIL                                    07840000
078500           TB-CBSA (MA2) NOT = HOLD-PROV-CBSA.                    07850000
078600                                                                  07860000
078700***     RTC = 52  --  WAGE-INDEX NOT FOUND                        07870000
078800     IF IPF-RTC = 52    GOBACK.                                   07880000
078900                                                                  07890000
079000     IF W-CBSA-INDEX       = 00.0000                              07900000
079100        MOVE 52 TO IPF-RTC.                                       07910000
079200                                                                  07920000
079300 0550-EXIT.  EXIT.                                                07930000
079400                                                                  07940000
079500                                                                  07950000
079600 0600-N-GET-WAGE-INDX.                                            07960000
079700                                                                  07970000
079800     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)          07980000
079900         MOVE M-MSAX-MSA        (MU2) TO W-NEW-MSA                07990000
080000         MOVE M-MSAX-EFF-DATE   (MU2) TO W-NEW-EFF-DATE           08000000
080100         MOVE M-MSAX-WAGE-INDX1 (MU2) TO W-NEW-INDEX-RECORD       08010000
080200         IF P-NEW-CHG-CODE-INDEX  = 'Y'                           08020000
080300            MOVE M-MSAX-WAGE-INDX2 (MU2) TO W-NEW-INDEX-RECORD.   08030000
080400                                                                  08040000
080500 0600-N-EXIT.  EXIT.                                              08050000
080600                                                                  08060000
080700 0650-N-GET-WAGE-INDX.                                            08070000
080800                                                                  08080000
080900     IF  BILL-DISCHARGE-DATE NOT < TB-CBSA-EFF-DATE (MA2)         08090000
081000         MOVE TB-CBSA            (MA2) TO W-CBSA                  08100000
081100         MOVE TB-CBSA-EFF-DATE   (MA2) TO W-CBSA-EFF-DATE         08110000
081200         MOVE TB-CBSA-WAGE-INDX1 (MA2) TO W-CBSA-INDEX.           08120000
081300                                                                  08130000
081400 0650-N-EXIT.  EXIT.                                              08140000
081500                                                                  08150000
081600                                                                  08160000
081700 0700-N-GET-WAGE-SIZE.                                            08170000
081800                                                                  08180000
081900     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)          08190000
082000         IF  P-NEW-STD-RURAL-CHECK                                08200000
082100             MOVE 'R' TO W-NEW-SIZE                               08210000
082200         ELSE                                                     08220000
082300         IF  M-MSAX-SIZE (MU2) = 'L'                              08230000
082400             MOVE 'L' TO W-NEW-SIZE                               08240000
082500         ELSE                                                     08250000
082600             MOVE 'O' TO W-NEW-SIZE.                              08260000
082700                                                                  08270000
082800 0700-N-EXIT.  EXIT.                                              08280000
082900                                                                  08290000
083000 1350-N-CHECK-MSA.                                                08300000
083100     IF P-NEW-EFF-DATE < 20050701                                 08310000
083200        IF (P-NEW-WAGE-INDEX-LOC-MSA = '    ' OR                  08320000
083300            P-NEW-WAGE-INDEX-LOC-MSA = '0000')                    08330000
083400            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-WAGE-INDEX-LOC-MSA.  08340000
083500     IF P-NEW-EFF-DATE < 20050701                                 08350000
083600        IF (P-NEW-STAND-AMT-LOC-MSA = '    ' OR                   08360000
083700            P-NEW-STAND-AMT-LOC-MSA = '0000')                     08370000
083800            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-STAND-AMT-LOC-MSA.   08380000
083900                                                                  08390000
084000     IF P-NEW-EFF-DATE < 20050701                                 08400000
084100        IF (P-NEW-CBSA-RECLASS-LOC = '     ' OR                   08410000
084200            P-NEW-CBSA-RECLASS-LOC = '00000')                     08420000
084300            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-RECLASS-LOC.   08430000
084400     IF P-NEW-EFF-DATE < 20050701                                 08440000
084500        IF (P-NEW-CBSA-STAND-AMT-LOC = '     ' OR                 08450000
084600            P-NEW-CBSA-STAND-AMT-LOC = '00000')                   08460000
084700            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-STAND-AMT-LOC. 08470000
084800                                                                  08480000
084900 1350-N-EXIT.  EXIT.                                              08490000
085000                                                                  08500000
085100**==============================================================**08510000
085200**           L A S T   S O U R C E   S T A T E M E N T          **08520000
085300**==============================================================**08530000
