000100 IDENTIFICATION DIVISION.                                         00010003
000200 PROGRAM-ID.    IPDRV190.                                         00020003
000300*=================================================================00030003
000400*REMARKS.  - CALLS THE IPCAL__ MODULES                            00040003
000500*          - CBSA FILE REPLACES THE MSA FILE ON JULY1, 2006       00050003
000600*          - LOADS THE IPF TABLES                                 00060003
000700*          - LOADS THE SNF MSA TABLES UNTIL JULY 1, 2006          00070003
000800*          - LOADS THE SNF CBSA TABLES STARTING JULY 1, 2006      00080003
000900*          - FINDS PROV RECORD AND WAGE-INDEX RECORD FOR          00090003
001000*             GIVEN BILL TO BE PASSED TO IPCAL__ MODULES.         00100003
001100*=================================================================00110003
001200 DATE-COMPILED.                                                   00120003
001300 ENVIRONMENT DIVISION.                                            00130003
001400 CONFIGURATION SECTION.                                           00140003
001500 SOURCE-COMPUTER.            IBM-370.                             00150003
001600 OBJECT-COMPUTER.            IBM-370.                             00160003
001700 INPUT-OUTPUT  SECTION.                                           00170003
001800 FILE-CONTROL.                                                    00180003
001900 DATA DIVISION.                                                   00190003
002000 FILE SECTION.                                                    00200003
002100                                                                  00210003
002200 WORKING-STORAGE SECTION.                                         00220003
002300 77  W-STORAGE-REF         PIC X(48)  VALUE                       00230003
002400     'IPF D R I V E R - W O R K I N G   S T O R A G E'.           00240003
002500 01  DRV-VERSION           PIC X(05) VALUE 'D19.0'.               00250003
002600 01  IPCAL190              PIC X(08) VALUE 'IPCAL190'.            00260003
002601 01  IPCAL180              PIC X(08) VALUE 'IPCAL180'.            00260103
002602 01  IPCAL170              PIC X(08) VALUE 'IPCAL170'.            00260203
002603 01  IPCAL161              PIC X(08) VALUE 'IPCAL161'.            00260303
002604 01  IPCAL150              PIC X(08) VALUE 'IPCAL150'.            00260403
002605 01  IPCAL140              PIC X(08) VALUE 'IPCAL140'.            00260503
002606 01  IPCAL130              PIC X(08) VALUE 'IPCAL130'.            00260603
002607 01  IPCAL121              PIC X(08) VALUE 'IPCAL121'.            00260703
002608 01  IPCAL120              PIC X(08) VALUE 'IPCAL120'.            00260803
002609 01  IPCAL112              PIC X(08) VALUE 'IPCAL112'.            00260903
002610 01  IPCAL111              PIC X(08) VALUE 'IPCAL111'.            00261003
002620 01  IPCAL110              PIC X(08) VALUE 'IPCAL110'.            00262003
002630 01  IPCAL102              PIC X(08) VALUE 'IPCAL102'.            00263003
002640 01  IPCAL100              PIC X(08) VALUE 'IPCAL100'.            00264003
002650 01  IPCAL094              PIC X(08) VALUE 'IPCAL094'.            00265003
002660 01  IPCAL09A              PIC X(08) VALUE 'IPCAL09A'.            00266003
002670 01  IPCAL08A              PIC X(08) VALUE 'IPCAL08A'.            00267003
002680 01  IPCAL086              PIC X(08) VALUE 'IPCAL086'.            00268003
002690 01  IPCAL076              PIC X(08) VALUE 'IPCAL076'.            00269003
002700 01  IPCAL057              PIC X(08) VALUE 'IPCAL057'.            00270003
002800 01  TABLES-LOADED-SW      PIC 9(01)  VALUE 0.                    00280003
002900 01  EOF-SW                PIC 9(01)  VALUE 0.                    00290003
002910 01  PROV-STAT.                                                   00291003
002911     02  PROV-STAT1     PIC X.                                    00291103
002912     02  PROV-STAT2     PIC X.                                    00291203
002913                                                                  00291303
002914 01  MSAX-STAT.                                                   00291403
002915     02  MSAX-STAT1     PIC X.                                    00291503
002916     02  MSAX-STAT2     PIC X.                                    00291603
002917                                                                  00291703
002918 01  CBSA-STAT.                                                   00291803
002919     02  CBSA-STAT1     PIC X.                                    00291903
002920     02  CBSA-STAT2     PIC X.                                    00292003
002930                                                                  00293003
002940 01  HOLD-PROV-MSAX.                                              00294003
002950         10  H-MSAX-PROV-BLANK   PIC X(2).                        00295003
002960         10  H-MSAX-PROV-STATE.                                   00296003
002970             15  FILLER          PIC X.                           00297003
002980             15  H-MSAX-LAST-POS PIC X.                           00298003
002990                                                                  00299003
003000 01  HOLD-PROV-CBSA.                                              00300003
003100         10  H-CBSA-PROV-BLANK   PIC X(3).                        00310003
003200         10  H-CBSA-PROV-STATE.                                   00320003
003300             15  FILLER          PIC X.                           00330003
003400             15  H-CBSA-LAST-POS PIC X.                           00340003
003500                                                                  00350003
003600**================================================================00360003
003700*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   00370003
003800*      THE IPCAL056 PROGRAM FOR PROCESSING                        00380003
003900**================================================================00390003
004000 01  WAGE-NEW-INDEX-RECORD.                                       00400003
004100     05  W-NEW-MSA               PIC 9(4).                        00410003
004200     05  W-NEW-SIZE              PIC X(01).                       00420003
004300         88  NEW-LARGE-URBAN       VALUE 'L'.                     00430003
004400         88  NEW-OTHER-URBAN       VALUE 'O'.                     00440003
004500         88  NEW-ALL-RURAL         VALUE 'R'.                     00450003
004600     05  W-NEW-EFF-DATE.                                          00460003
004700          10  W-NEW-EFF-DATE-CC   PIC 9(2).                       00470003
004800          10  W-NEW-EFF-DATE-YMD.                                 00480003
004900              15  W-NEW-EFF-DATE-YY   PIC 9(2).                   00490003
005000              15  W-NEW-EFF-DATE-MM   PIC 9(2).                   00500003
005100              15  W-NEW-EFF-DATE-DD   PIC 9(2).                   00510003
005200     05  FILLER              PIC X.                               00520003
005300     05  W-NEW-INDEX-RECORD      PIC S9(02)V9(04).                00530003
005400     05  FILLER                  PIC S9(02)V9(04).                00540003
005500                                                                  00550003
005600**================================================================00560003
005700*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   00570003
005800*      THE IPCAL    PROGRAM FOR PROCESSING                        00580003
005900**================================================================00590003
006000 01  CBSA-WAGE-INDEX-RECORD.                                      00600003
006100     05  W-CBSA               PIC 9(5).                           00610003
006200     05  W-CBSA-X  REDEFINES W-CBSA PIC X(05).                    00620003
006300     05  W-CBSA-SIZE             PIC X(01).                       00630003
006400         88  W-CBSA-LARGE-URBAN       VALUE 'L'.                  00640003
006500         88  W-CBSA-OTHER-URBAN       VALUE 'O'.                  00650003
006600         88  W-CBSA-ALL-RURAL         VALUE 'R'.                  00660003
006700     05  W-CBSA-EFF-DATE.                                         00670003
006800          10  W-CBSA-EFF-DATE-CC       PIC 9(2).                  00680003
006900          10  W-CBSA-EFF-DATE-YMD.                                00690003
007000              15  W-CBSA-EFF-DATE-YY   PIC 9(2).                  00700003
007100              15  W-CBSA-EFF-DATE-MM   PIC 9(2).                  00710003
007200              15  W-CBSA-EFF-DATE-DD   PIC 9(2).                  00720003
007300     05  FILLER             PIC X.                                00730003
007400     05  W-CBSA-INDEX       PIC S9(02)V9(04).                     00740003
007500     05  FILLER             PIC S9(02)V9(04).                     00750003
007600                                                                  00760003
007700                                                                  00770003
007800**==============================================================**00780003
007900*   MSAX RECORD PASSED OPTION B                                   00790003
008000**==============================================================**00800003
008100 01  MSAX-TABLE-FROM-USER.                                        00810003
008200     05  FILLER                     PIC X(32000).                 00820003
008300     05  FILLER                     PIC X(30000).                 00830003
008400     05  FILLER                     PIC X(30000).                 00840003
008500                                                                  00850003
008600**==============================================================**00860003
008700*   CBSA RECORD PASSED OPTION B                                   00870003
008800**==============================================================**00880003
008900 01  CBSA-TABLE-FROM-USER.                                        00890003
009000     05  FILLER                     PIC X(32000).                 00900003
009100     05  FILLER                     PIC X(30000).                 00910003
009200     05  FILLER                     PIC X(30000).                 00920003
009300                                                                  00930003
009400**==============================================================**00940003
009500*   PROV RECORD PASSED OPTION P                                   00950003
009600**==============================================================**00960003
009700 01  PROV-NEW-HOLD.                                               00970003
009800     02  PROV-NEWREC-HOLD1.                                       00980003
009900         05  P-NEW-NPI10.                                         00990003
010000             10  P-NEW-NPI8             PIC X(08).                01000003
010100             10  P-NEW-NPI-FILLER       PIC X(02).                01010003
010200         05  P-NEW-PROVIDER-NO.                                   01020003
010300             10  P-NEW-STATE            PIC 9(02).                01030003
010400             10  FILLER                 PIC X(04).                01040003
010500         05  P-NEW-DATE-DATA.                                     01050003
010600             10  P-NEW-EFF-DATE.                                  01060003
010700                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01070003
010800                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01080003
010900                 15  P-NEW-EFF-DT-MM    PIC 9(02).                01090003
011000                 15  P-NEW-EFF-DT-DD    PIC 9(02).                01100003
011100             10  P-NEW-FY-BEGIN-DATE.                             01110003
011200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                01120003
011300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                01130003
011400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                01140003
011500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                01150003
011600             10  P-NEW-REPORT-DATE.                               01160003
011700                 15  P-NEW-REPORT-DT-CC PIC 9(02).                01170003
011800                 15  P-NEW-REPORT-DT-YY PIC 9(02).                01180003
011900                 15  P-NEW-REPORT-DT-MM PIC 9(02).                01190003
012000                 15  P-NEW-REPORT-DT-DD PIC 9(02).                01200003
012100             10  P-NEW-TERMINATION-DATE.                          01210003
012200                 15  P-NEW-TERM-DT-CC   PIC 9(02).                01220003
012300                 15  P-NEW-TERM-DT-YY   PIC 9(02).                01230003
012400                 15  P-NEW-TERM-DT-MM   PIC 9(02).                01240003
012500                 15  P-NEW-TERM-DT-DD   PIC 9(02).                01250003
012600         05  P-NEW-WAIVER-CODE          PIC X(01).                01260003
012700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              01270003
012800         05  P-NEW-INTER-NO             PIC 9(05).                01280003
012900         05  P-NEW-PROVIDER-TYPE        PIC X(02).                01290003
013000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      01300003
013100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       01310003
013200                                                  '15' '17'       01320003
013300                                                  '22'.           01330003
013400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           01340003
013500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           01350003
013600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           01360003
013700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           01370003
013800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      01380003
013900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           01390003
014000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      01400003
014100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           01410003
014200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           01420003
014300             88  P-N-EACH                   VALUE '21' '22'.      01430003
014400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           01440003
014500             88  P-N-NHCMQ-II-SNF           VALUE '32'.           01450003
014600             88  P-N-NHCMQ-III-SNF          VALUE '33'.           01460003
014700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                01470003
014800             88  P-N-NEW-ENGLAND            VALUE  1.             01480003
014900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             01490003
015000             88  P-N-SOUTH-ATLANTIC         VALUE  3.             01500003
015100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             01510003
015200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             01520003
015300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             01530003
015400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             01540003
015500             88  P-N-MOUNTAIN               VALUE  8.             01550003
015600             88  P-N-PACIFIC                VALUE  9.             01560003
015700         05  P-NEW-CURRENT-DIV   REDEFINES                        01570003
015800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         01580003
015900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          01590003
016000         05  P-NEW-MSA-DATA.                                      01600003
016100             10  P-NEW-CHG-CODE-INDEX       PIC X.                01610003
016200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 01620003
016300             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   01630003
016400                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       01640003
016500             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  01650003
016600                             P-NEW-GEO-LOC-MSA9.                  01660003
016700                 15  P-NEW-GEO-MSA-1ST    PIC X.                  01670003
016800                 15  P-NEW-GEO-MSA-2ND    PIC X.                  01680003
016900                 15  P-NEW-GEO-MSA-3RD    PIC X.                  01690003
017000                 15  P-NEW-GEO-MSA-4TH    PIC X.                  01700003
017100             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 01710003
017200             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 01720003
017300             10  P-NEW-STAND-AMT-LOC-MSA9                         01730003
017400       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         01740003
017500                 15  P-NEW-RURAL-1ST.                             01750003
017600                     20  P-NEW-STAND-RURAL  PIC XX.               01760003
017700                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    01770003
017800                 15  P-NEW-RURAL-2ND        PIC XX.               01780003
017900         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    01790003
018000                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           01800003
018100                 88  P-NEW-SCH-YR82       VALUE   '82'.           01810003
018200                 88  P-NEW-SCH-YR87       VALUE   '87'.           01820003
018300         05  P-NEW-LUGAR                    PIC X.                01830003
018400         05  P-NEW-TEMP-RELIEF-IND          PIC X.                01840003
018500             88  P-NEW-LOW-VOL25PCT     VALUE 'Y'.                01850003
018600***          Y = LOW VOLUME PERCENTAGE  25 % ADD ON               01860003
018700         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                01870003
018800         05  FILLER                         PIC X(05).            01880003
018900     02  PROV-NEWREC-HOLD2.                                       01890003
019000         05  P-NEW-VARIABLES.                                     01900003
019100             10  P-NEW-CMI-ADJ-CPD       PIC  9(05)V9(02).        01910003
019200             10  P-NEW-COLA              PIC  9(01)V9(03).        01920003
019300             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        01930003
019400             10  P-NEW-BED-SIZE          PIC  9(05).              01940003
019500             10  P-NEW-CCR               PIC  9(01)V9(03).        01950003
019600             10  P-NEW-CMI               PIC  9(01)V9(04).        01960003
019700             10  P-NEW-SSI-RATIO         PIC  V9(04).             01970003
019800             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             01980003
019900             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).              01990003
020000             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).        02000003
020100             10  P-NEW-DSH-PERCENT       PIC  V9(04).             02010003
020200             10  P-NEW-FYE-DATE.                                  02020003
020300                 15  P-NEW-FYE-CC        PIC 99.                  02030003
020400                 15  P-NEW-FYE-YY        PIC 99.                  02040003
020500                 15  P-NEW-FYE-MM        PIC 99.                  02050003
020600                 15  P-NEW-FYE-DD        PIC 99.                  02060003
020700         05  P-NEW-CBSA-DATA.                                     02070003
020800             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                02080003
020900                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.          02090003
021000                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.          02100003
021100                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.      02110003
021200***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI   02120003
021300***                  2 = RECLASS WITH SPEC WI                     02130003
021400             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 02140003
021500                 88  P-NEW-CBSA-HOSP-QUAL-MET   VALUE '1'.        02150003
021600                 88  P-NEW-CBSA-HOSP-QUAL-25PER VALUE '2'.        02160003
021700                 88  P-NEW-CBSA-HOSP-QUAL-BOTH  VALUE '3'.        02170003
021800             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  02180003
021900             10  P-NEW-CBSA-GEO-LOC9  REDEFINES                   02190003
022000                             P-NEW-CBSA-GEO-LOC  PIC 9(05).       02200003
022100             10  P-NEW-CBSA-GEO-LOC-AST REDEFINES                 02210003
022200                             P-NEW-CBSA-GEO-LOC9.                 02220003
022300                 15  P-NEW-CBSA-GEO-1ST    PIC X.                 02230003
022400                 15  P-NEW-CBSA-GEO-2ND    PIC X.                 02240003
022500                 15  P-NEW-CBSA-GEO-3RD    PIC X.                 02250003
022600                 15  P-NEW-CBSA-GEO-4TH    PIC X.                 02260003
022700                 15  P-NEW-CBSA-GEO-5TH    PIC X.                 02270003
022800             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  02280003
022900             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  02290003
023000             10  P-NEW-CBSA-STAND-AMT-LOC-MSA9                    02300003
023100       REDEFINES P-NEW-CBSA-STAND-AMT-LOC.                        02310003
023200               15  P-NEW-CBSA-RURAL-1ST.                          02320003
023300                   20  P-NEW-CBSA-STAND-RURAL  PIC XXX.           02330003
023400                      88  P-NEW-CBSA-STD-RURAL-CHECK VALUE '   '. 02340003
023500               15  P-NEW-CBSA-RURAL-2ND    PIC XX.                02350003
023600             10  P-NEW-CBSA-SPEC-WI          PIC 9(02)V9(04).     02360003
023700             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  02370003
023800                 P-NEW-CBSA-SPEC-WI          PIC 9(06).           02380003
023900     02  PROV-NEWREC-HOLD3.                                       02390003
024000         05  P-NEW-PASS-AMT-DATA.                                 02400003
024100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02410003
024200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02420003
024300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02430003
024400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02440003
024500         05  P-NEW-CAPI-DATA.                                     02450003
024600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02460003
024700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02470003
024800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02480003
024900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02490003
025000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02500003
025100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02510003
025200             15  P-NEW-CAPI-IME            PIC 9V9999.            02520003
025300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02530003
025400             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            02540003
025500         05  FILLER                         PIC X(18).            02550003
025600                                                                  02560003
025700**================================================================02570003
025800 LINKAGE SECTION.                                                 02580003
025900                                                                  02590003
026000**========================================================        02600003
026100*    PASSED AND RETURNED BY IPCAL                     *           02610003
026200**==============================*========================*        02620003
026300 01  BILL-INPUT-DATA.                                             02630003
026400     05  BILL-IN-DATA.                                            02640003
026500         10  BILL-NPI-NUMBER.                                     02650003
026600             15  BILL-NPI            PIC X(08).                   02660003
026700             15  BILL-NPI-FILLER     PIC X(02).                   02670003
026800         10  BILL-PROVIDER-NO        PIC X(06).                   02680003
026900         10  BILL-HIC-NO             PIC X(12).                   02690003
027000         10  BILL-DISCHARGE-DATE.                                 02700003
027100             15  BILL-D-CC           PIC 9(02).                   02710003
027200             15  BILL-D-YY           PIC 9(02).                   02720003
027300             15  BILL-D-MM           PIC 9(02).                   02730003
027400             15  BILL-D-DD           PIC 9(02).                   02740003
027500         10  BILL-PATIENT-STATUS     PIC X(02).                   02750003
027600         10  BILL-AGE                PIC 9(03).                   02760003
027700         10  BILL-DRG                PIC 9(03).                   02770003
027800         10  BILL-LOS                PIC 9(05).                   02780003
027900         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   02790003
028000         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   02800003
028100         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   02810003
028200         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             02820003
028300         10  BILL-OTHER-DIAG-DATA    PIC X(175).                  02830003
028400         10  BILL-OTHER-PROC-DATA    PIC X(175).                  02840003
028500         10  BILL-PRIOR-DAYS         PIC 9(03).                   02850003
028600**========================================================        02860003
028700*    PASSED AND RETURNED BY IPCAL                     *           02870003
028800**======================================================**        02880003
028900 01  IPF-DATA-VARIABLES.                                          02890003
029000         10  IPF-RTC                 PIC 9(02).                   02900003
029100         10  IPF-MSA-CBSA            PIC X(05).                   02910003
029200         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 02920003
029300             15  IPF-MSA             PIC X(04).                   02930003
029400             15  FILLER              PIC X.                       02940003
029500         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                02950003
029600             15  IPF-CBSA            PIC X(05).                   02960003
029700         10  IPF-WAGE-INDX           PIC 9(02)V9(04).             02970003
029800         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             02980003
029900         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             02990003
030000         10  IPF-COLA                PIC 9(01)V9(03).             03000003
030100         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             03010003
030200         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             03020003
030300         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             03030003
030400         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             03040003
030500         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             03050003
030600         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             03060003
030700         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             03070003
030800         10  IPF-FED-PPS-BLEND-IND   PIC X.                       03080003
030900         10  IPF-CAL-VERSION         PIC X(05).                   03090003
031000         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             03100003
031100         10  FILLER                  PIC X(08).                   03110003
031200                                                                  03120003
031300**======================================================**        03130003
031400*    PASSED AND RETURNED BY IPCAL                     *           03140003
031500**======================================================**        03150003
031600 01  IPF-ADDITIONAL-VARIABLES.                                    03160003
031700     02  IPF-MF-VARIABLES.                                        03170003
031800         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).          03180003
031900         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).          03190003
032000         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).          03200003
032100         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).          03210003
032200         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).          03220003
032300         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).          03230003
032400         10  IPF-OUTL-COST              PIC 9(07)V9(02).          03240003
032500         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).          03250003
032600         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).          03260003
032700         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).          03270003
032800         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).          03280003
032900         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).          03290003
033000         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).          03300003
033100         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).          03310003
033200         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).          03320003
033300         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).          03330003
033400         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).          03340003
033500         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).          03350003
033600         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).          03360003
033700         10  IPF-TEACH-PAYMENT          PIC 9(07)V9(02).          03370003
033800         10  FILLER                     PIC X(01).                03380003
033900      02 IPF-PC-VARIABLES.                                        03390003
034000         10  IPF-PC-DATA                PIC X(44).                03400003
034100                                                                  03410003
034200 01  PRICER-OPT-VERS-SW.                                          03420003
034300     02  PRICER-OPTION-SW               PIC X(01).                03430003
034400         88  VARIABLES                  VALUE 'S'.                03440003
034500         88  PROV-RECORD-PASSED         VALUE 'P'.                03450003
034600         88  ALL-TABLES-PASSED          VALUE 'B'.                03460003
034700     02  IPF-VERSIONS.                                            03470003
034800         10  IPDRV-VERSION              PIC X(05).                03480003
034900                                                                  03490003
035000**===============================================================*03500003
035100* THE PROVIDER SPECIFIC PASSED FROM CALLING PROGRAM              *03510003
035200**===============================================================*03520003
035300 01  PROV-RECORD-FROM-USER.                                       03530003
035400     02  PROV-FROM-USER-HOLD1           PIC X(80).                03540003
035500     02  PROV-FROM-USER-HOLD2           PIC X(80).                03550003
035600     02  PROV-FROM-USER-HOLD3           PIC X(80).                03560003
035700                                                                  03570003
035800 01  MSAX-WI-TABLE.                                               03580003
035900     05  M-MSAX-DATA                OCCURS 4000                   03590003
036000                                    INDEXED BY MU1 MU2 MU3.       03600003
036100         10  M-MSAX-MSA             PIC X(4).                     03610003
036200         10  M-MSAX-SIZE            PIC X(01).                    03620003
036300         10  M-MSAX-EFF-DATE        PIC X(08).                    03630003
036400         10  M-MSAX-WAGE-INDX1      PIC S9(02)V9(04).             03640003
036500         10  M-MSAX-WAGE-INDX2      PIC S9(02)V9(04).             03650003
036600                                                                  03660003
036700 01  CBSA-WI-TABLE.                                               03670003
036800     05  TB-CBSA-DATA                OCCURS 6000                  03680003
036900                                    INDEXED BY MA1 MA2 MA3.       03690003
037000         10  TB-CBSA                PIC X(5).                     03700003
037100         10  TB-CBSA-SIZE           PIC X(01).                    03710003
037200         10  TB-CBSA-EFF-DATE       PIC X(08).                    03720003
037300         10  TB-CBSA-WAGE-INDX1     PIC S9(02)V9(04).             03730003
037400         10  TB-CBSA-WAGE-INDX2     PIC S9(02)V9(04).             03740003
037500                                                                  03750003
037600**============================================================    03760003
037700 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        03770003
037800                           IPF-DATA-VARIABLES                     03780003
037900                           IPF-ADDITIONAL-VARIABLES               03790003
038000                           PRICER-OPT-VERS-SW                     03800003
038100                           PROV-RECORD-FROM-USER                  03810003
038200                           MSAX-WI-TABLE                          03820003
038300                           CBSA-WI-TABLE.                         03830003
038400                                                                  03840003
038500**==============================================================**03850003
038600*    PROCESSING:                                                  03860003
038700*        A. THIS MODULE WILL CALL THE IPCAL MODULES.              03870003
038800*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  03880003
038900*           SUBROUTINE IS CALLED.                                 03890003
039000*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH*03900003
039100*           EACH BILL WILL BE PASSED TO THE IPCAL PROGRAMS.       03910003
039200*        D. CALL COMORBIDITY GROUPER AND RETURN A                 03920003
039300*           APPLIED COMORBIDITY ADJUSTER                          03930003
039400**==============================================================**03940003
039500                                                                  03950003
039600     MOVE DRV-VERSION TO IPDRV-VERSION.                           03960003
039700                                                                  03970003
039800     MOVE ALL '0' TO IPF-ADDITIONAL-VARIABLES                     03980003
039900                     IPF-DATA-VARIABLES.                          03990003
040000                                                                  04000003
040100**==============================================================**04010003
040200***     RTC = 98 >> A BILL LESS THEN 20050101                     04020003
040300                                                                  04030003
040400     IF BILL-DISCHARGE-DATE < 20050101                            04040003
040500             MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES            04050003
040600                              IPF-DATA-VARIABLES                  04060003
040700             MOVE 98 TO IPF-RTC                                   04070003
040800             GOBACK.                                              04080003
040900**==============================================================**04090003
041000                                                                  04100003
041100 0010-PROCESS-RECORDS.                                            04110003
041200**==============================================================**04120003
041300***  GET THE PROVIDER RECORD                                      04130003
041400                                                                  04140003
041500     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 04150003
041600     IF PROV-RECORD-FROM-USER <= SPACES                           04160003
041700        MOVE 51 TO IPF-RTC                                        04170003
041800        MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES                 04180003
041900        GOBACK                                                    04190003
042000     END-IF.                                                      04200003
042100                                                                  04210003
042200     PERFORM 1350-N-CHECK-MSA THRU 1350-N-EXIT.                   04220003
042300                                                                  04230003
042400     IF BILL-DISCHARGE-DATE < P-NEW-EFF-DATE                      04240003
042500        MOVE 55 TO IPF-RTC                                        04250003
042600        GOBACK.                                                   04260003
042700                                                                  04270003
042800     IF BILL-DISCHARGE-DATE > 20060630 AND                        04280003
042900        P-NEW-EFF-DATE < 20060701                                 04290003
043000        MOVE 55 TO IPF-RTC                                        04300003
043100        GOBACK.                                                   04310003
043200                                                                  04320003
043300     IF P-NEW-EFF-DATE < 20060701                                 04330003
043400        PERFORM 0500-GET-MSA THRU 0500-EXIT                       04340003
043500     ELSE                                                         04350003
043600        PERFORM 0550-GET-CBSA THRU 0550-EXIT.                     04360003
043700                                                                  04370003
043800***     RTC = 52  --  WAGE-INDEX NOT FOUND                        04380003
043900                                                                  04390003
044000     IF IPF-RTC = 52                                              04400003
044100          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               04410003
044200          GOBACK.                                                 04420003
044300                                                                  04430003
044400**==============================================================**04440003
044500** MAKE SURE DATE IS CODED THE DAY BEFORE THE EFFECTIVE DATE    **04450003
044600**==============================================================**04460003
044700**          THIS NEXT CALL WILL PROCESS 2019 BILLS WITH           04470003
044800**              A DISCHARGE DATE ON OR AFTER 20181001             04480003
044900**==============================================================**04490003
045000     IF BILL-DISCHARGE-DATE                                       04500003
045100              > 20180930                                          04510003
045200         CALL  IPCAL190 USING BILL-INPUT-DATA                     04520003
045300                              IPF-DATA-VARIABLES                  04530003
045400                              IPF-ADDITIONAL-VARIABLES            04540003
045500                              PRICER-OPT-VERS-SW                  04550003
045600                              PROV-NEW-HOLD                       04560003
045700                              CBSA-WAGE-INDEX-RECORD              04570003
045800         GOBACK.                                                  04580003
045900**==============================================================**04590003
046000**          THIS NEXT CALL WILL PROCESS 2018 BILLS WITH           04600003
046100**              A DISCHARGE DATE ON OR AFTER 20171001             04610003
046200**==============================================================**04620003
046300     IF BILL-DISCHARGE-DATE                                       04630003
046301              > 20170930                                          04630103
046302         CALL  IPCAL180 USING BILL-INPUT-DATA                     04630203
046303                              IPF-DATA-VARIABLES                  04630303
046304                              IPF-ADDITIONAL-VARIABLES            04630403
046305                              PRICER-OPT-VERS-SW                  04630503
046306                              PROV-NEW-HOLD                       04630603
046307                              CBSA-WAGE-INDEX-RECORD              04630703
046308         GOBACK.                                                  04630803
046309**==============================================================**04630903
046310**          THIS NEXT CALL WILL PROCESS 2017 BILLS WITH           04631003
046311**              A DISCHARGE DATE ON OR AFTER 20161001             04631103
046312**==============================================================**04631203
046313     IF BILL-DISCHARGE-DATE                                       04631303
046314              > 20160930                                          04631403
046315         CALL  IPCAL170 USING BILL-INPUT-DATA                     04631503
046316                              IPF-DATA-VARIABLES                  04631603
046317                              IPF-ADDITIONAL-VARIABLES            04631703
046318                              PRICER-OPT-VERS-SW                  04631803
046319                              PROV-NEW-HOLD                       04631903
046320                              CBSA-WAGE-INDEX-RECORD              04632003
046321         GOBACK.                                                  04632103
046322**==============================================================**04632203
046323**          THIS NEXT CALL WILL PROCESS 2016 BILLS WITH           04632303
046324**              A DISCHARGE DATE ON OR AFTER 20151001             04632403
046325**==============================================================**04632503
046326     IF BILL-DISCHARGE-DATE                                       04632603
046327              > 20150930                                          04632703
046328         CALL  IPCAL161 USING BILL-INPUT-DATA                     04632803
046329                              IPF-DATA-VARIABLES                  04632903
046330                              IPF-ADDITIONAL-VARIABLES            04633003
046331                              PRICER-OPT-VERS-SW                  04633103
046332                              PROV-NEW-HOLD                       04633203
046333                              CBSA-WAGE-INDEX-RECORD              04633303
046334         GOBACK.                                                  04633403
046335**==============================================================**04633503
046336**          THIS NEXT CALL WILL PROCESS 2015 BILLS WITH           04633603
046337**              A DISCHARGE DATE ON OR AFTER 20141001             04633703
046338**==============================================================**04633803
046339     IF BILL-DISCHARGE-DATE                                       04633903
046340              > 20140930                                          04634003
046350         CALL  IPCAL150 USING BILL-INPUT-DATA                     04635003
046360                              IPF-DATA-VARIABLES                  04636003
046370                              IPF-ADDITIONAL-VARIABLES            04637003
046380                              PRICER-OPT-VERS-SW                  04638003
046390                              PROV-NEW-HOLD                       04639003
046391                              CBSA-WAGE-INDEX-RECORD              04639103
046392         GOBACK.                                                  04639203
046393**==============================================================**04639303
046394**          THIS NEXT CALL WILL PROCESS 2014 BILLS WITH           04639403
046395**              A DISCHARGE DATE ON OR AFTER 20131001             04639503
046396**==============================================================**04639603
046397     IF BILL-DISCHARGE-DATE                                       04639703
046398              > 20130930                                          04639803
046399         CALL  IPCAL140 USING BILL-INPUT-DATA                     04639903
046400                              IPF-DATA-VARIABLES                  04640003
046500                              IPF-ADDITIONAL-VARIABLES            04650003
046600                              PRICER-OPT-VERS-SW                  04660003
046700                              PROV-NEW-HOLD                       04670003
046800                              CBSA-WAGE-INDEX-RECORD              04680003
046900         GOBACK.                                                  04690003
047000**==============================================================**04700003
047100**          THIS NEXT CALL WILL PROCESS 2013 BILLS WITH           04710003
047200**              A DISCHARGE DATE ON OR AFTER 20121001             04720003
047300**==============================================================**04730003
047400     IF BILL-DISCHARGE-DATE                                       04740003
047500              > 20120930                                          04750003
047600         CALL  IPCAL130 USING BILL-INPUT-DATA                     04760003
047700                              IPF-DATA-VARIABLES                  04770003
047800                              IPF-ADDITIONAL-VARIABLES            04780003
047900                              PRICER-OPT-VERS-SW                  04790003
048000                              PROV-NEW-HOLD                       04800003
048100                              CBSA-WAGE-INDEX-RECORD              04810003
048200         GOBACK.                                                  04820003
048300**==============================================================**04830003
048400**          THIS NEXT CALL WILL PROCESS 2012 BILLS WITH           04840003
048500**              A DISCHARGE DATE ON OR AFTER 20111001             04850003
048600**==============================================================**04860003
048700     IF BILL-DISCHARGE-DATE                                       04870003
048800              > 20110930                                          04880003
048900         CALL  IPCAL121 USING BILL-INPUT-DATA                     04890003
049000                              IPF-DATA-VARIABLES                  04900003
049100                              IPF-ADDITIONAL-VARIABLES            04910003
049200                              PRICER-OPT-VERS-SW                  04920003
049300                              PROV-NEW-HOLD                       04930003
049400                              CBSA-WAGE-INDEX-RECORD              04940003
049500         GOBACK.                                                  04950003
049600**==============================================================**04960003
049700**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH           04970003
049800**              A DISCHARGE DATE ON OR AFTER 20110701             04980003
049900**==============================================================**04990003
050000     IF BILL-DISCHARGE-DATE                                       05000003
050100              > 20110630                                          05010003
050200         CALL  IPCAL120 USING BILL-INPUT-DATA                     05020003
050300                              IPF-DATA-VARIABLES                  05030003
050400                              IPF-ADDITIONAL-VARIABLES            05040003
050500                              PRICER-OPT-VERS-SW                  05050003
050600                              PROV-NEW-HOLD                       05060003
050700                              CBSA-WAGE-INDEX-RECORD              05070003
050800         GOBACK.                                                  05080003
050900**==============================================================**05090003
051000**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH           05100003
051100**              A DISCHARGE DATE ON OR AFTER 20110101             05110003
051200**==============================================================**05120003
051300     IF BILL-DISCHARGE-DATE                                       05130003
051400              > 20101231                                          05140003
051500         CALL  IPCAL112 USING BILL-INPUT-DATA                     05150003
051600                              IPF-DATA-VARIABLES                  05160003
051700                              IPF-ADDITIONAL-VARIABLES            05170003
051800                              PRICER-OPT-VERS-SW                  05180003
051900                              PROV-NEW-HOLD                       05190003
052000                              CBSA-WAGE-INDEX-RECORD              05200003
052100         GOBACK.                                                  05210003
052200**==============================================================**05220003
052300**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH          05230003
052400**              A DISCHARGE DATE ON OR AFTER 20101001             05240003
052500**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05250003
052600**              USES THE CBSA FOR WAGE INDEXES                    05260003
052700**      FOR RY 2011 10/01/2010 TO 06/30/2011                      05270003
052800**==============================================================**05280003
052900     IF BILL-DISCHARGE-DATE                                       05290003
053000              > 20100930                                          05300003
053100         CALL  IPCAL111 USING BILL-INPUT-DATA                     05310003
053200                              IPF-DATA-VARIABLES                  05320003
053300                              IPF-ADDITIONAL-VARIABLES            05330003
053400                              PRICER-OPT-VERS-SW                  05340003
053500                              PROV-NEW-HOLD                       05350003
053600                              CBSA-WAGE-INDEX-RECORD              05360003
053700         GOBACK.                                                  05370003
053800                                                                  05380003
053900**==============================================================**05390003
054000**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH          05400003
054100**              A DISCHARGE DATE ON OR AFTER 20101001             05410003
054200**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05420003
054300**              USES THE CBSA FOR WAGE INDEXES                    05430003
054400**      FOR RY 2011 07/01/2010 TO 06/30/2011                      05440003
054500**==============================================================**05450003
054600     IF BILL-DISCHARGE-DATE                                       05460003
054700              > 20100630                                          05470003
054800         CALL  IPCAL110 USING BILL-INPUT-DATA                     05480003
054900                              IPF-DATA-VARIABLES                  05490003
055000                              IPF-ADDITIONAL-VARIABLES            05500003
055100                              PRICER-OPT-VERS-SW                  05510003
055200                              PROV-NEW-HOLD                       05520003
055300                              CBSA-WAGE-INDEX-RECORD              05530003
055400         GOBACK.                                                  05540003
055500**==============================================================**05550003
055600**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          05560003
055700**              A DISCHARGE DATE ON OR AFTER 20091001             05570003
055800**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05580003
055900**              USES THE CBSA FOR WAGE INDEXES                    05590003
056000**      FOR RY 2010 10/01/2010 TO 06/30/2010                      05600003
056100**==============================================================**05610003
056200     IF BILL-DISCHARGE-DATE                                       05620003
056300              > 20090930                                          05630003
056400         CALL  IPCAL102 USING BILL-INPUT-DATA                     05640003
056500                              IPF-DATA-VARIABLES                  05650003
056600                              IPF-ADDITIONAL-VARIABLES            05660003
056700                              PRICER-OPT-VERS-SW                  05670003
056800                              PROV-NEW-HOLD                       05680003
056900                              CBSA-WAGE-INDEX-RECORD              05690003
057000         GOBACK.                                                  05700003
057100**==============================================================**05710003
057200**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          05720003
057300**              A DISCHARGE DATE ON OR AFTER 20090701             05730003
057400**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05740003
057500**              USES THE CBSA FOR WAGE INDEXES                    05750003
057600**      FOR RY 2010 07/01/2009 TO 06/30/2010                      05760003
057700**==============================================================**05770003
057800     IF BILL-DISCHARGE-DATE                                       05780003
057900              > 20090630                                          05790003
058000         CALL  IPCAL100 USING BILL-INPUT-DATA                     05800003
058100                              IPF-DATA-VARIABLES                  05810003
058200                              IPF-ADDITIONAL-VARIABLES            05820003
058300                              PRICER-OPT-VERS-SW                  05830003
058400                              PROV-NEW-HOLD                       05840003
058500                              CBSA-WAGE-INDEX-RECORD              05850003
058600         GOBACK.                                                  05860003
058700**==============================================================**05870003
058800**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          05880003
058900**              A DISCHARGE DATE ON OR AFTER 20080930             05890003
059000**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   05900003
059100**              USES THE CBSA FOR WAGE INDEXES                    05910003
059200**      FOR RY 2009 10/01/2008 TO 06/30/2009                      05920003
059300**==============================================================**05930003
059400     IF BILL-DISCHARGE-DATE                                       05940003
059500              > 20080930                                          05950003
059600         CALL  IPCAL094 USING BILL-INPUT-DATA                     05960003
059700                              IPF-DATA-VARIABLES                  05970003
059800                              IPF-ADDITIONAL-VARIABLES            05980003
059900                              PRICER-OPT-VERS-SW                  05990003
060000                              PROV-NEW-HOLD                       06000003
060100                              CBSA-WAGE-INDEX-RECORD              06010003
060200         GOBACK.                                                  06020003
060300**==============================================================**06030003
060400**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          06040003
060500**              A DISCHARGE DATE ON OR AFTER 20080630             06050003
060600**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06060003
060700**              USES THE CBSA FOR WAGE INDEXES                    06070003
060800**      FOR RY 2009 07/01/2008 TO 09/30/2009                      06080003
060900**==============================================================**06090003
061000     IF BILL-DISCHARGE-DATE                                       06100003
061100              > 20080630                                          06110003
061200         CALL  IPCAL09A USING BILL-INPUT-DATA                     06120003
061300                              IPF-DATA-VARIABLES                  06130003
061400                              IPF-ADDITIONAL-VARIABLES            06140003
061500                              PRICER-OPT-VERS-SW                  06150003
061600                              PROV-NEW-HOLD                       06160003
061700                              CBSA-WAGE-INDEX-RECORD              06170003
061800         GOBACK.                                                  06180003
061900**==============================================================**06190003
062000**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH          06200003
062100**              A DISCHARGE DATE ON OR AFTER 20070630             06210003
062200**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06220003
062300**              USES THE CBSA FOR WAGE INDEXES                    06230003
062400**      FOR RY 2008 10/01/2007 TO 07/01/2008                      06240003
062500**==============================================================**06250003
062600     IF BILL-DISCHARGE-DATE                                       06260003
062700              > 20070930                                          06270003
062800         CALL  IPCAL086 USING BILL-INPUT-DATA                     06280003
062900                              IPF-DATA-VARIABLES                  06290003
063000                              IPF-ADDITIONAL-VARIABLES            06300003
063100                              PRICER-OPT-VERS-SW                  06310003
063200                              PROV-NEW-HOLD                       06320003
063300                              CBSA-WAGE-INDEX-RECORD              06330003
063400         GOBACK.                                                  06340003
063500**==============================================================**06350003
063600**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH          06360003
063700**              A DISCHARGE DATE ON OR AFTER 20070630             06370003
063800**              BUT BEFORE 20071001 WHEN DRG'S ARE REVISED        06380003
063900**              USES THE CBSA FOR WAGE INDEXES                    06390003
064000**      FOR RY 2008 07/01/2007 TO 10/01/2007                      06400003
064100**==============================================================**06410003
064200     IF BILL-DISCHARGE-DATE                                       06420003
064300              > 20070630                                          06430003
064400         CALL  IPCAL08A USING BILL-INPUT-DATA                     06440003
064500                              IPF-DATA-VARIABLES                  06450003
064600                              IPF-ADDITIONAL-VARIABLES            06460003
064700                              PRICER-OPT-VERS-SW                  06470003
064800                              PROV-NEW-HOLD                       06480003
064900                              CBSA-WAGE-INDEX-RECORD              06490003
065000         GOBACK.                                                  06500003
065100**==============================================================**06510003
065200**          THIS NEXT CALL WILL PROCESS 2007 BILLS  WITH          06520003
065300**              A DISCHARGE DATE ON OR AFTER 20060630             06530003
065400**              USES THE CBSA FOR WAGE INDEXES                    06540003
065500**      FOR RY 2007                                               06550003
065600**==============================================================**06560003
065700     IF BILL-DISCHARGE-DATE                                       06570003
065800              > 20060630                                          06580003
065900         CALL  IPCAL076 USING BILL-INPUT-DATA                     06590003
066000                              IPF-DATA-VARIABLES                  06600003
066100                              IPF-ADDITIONAL-VARIABLES            06610003
066200                              PRICER-OPT-VERS-SW                  06620003
066300                              PROV-NEW-HOLD                       06630003
066400                              CBSA-WAGE-INDEX-RECORD              06640003
066500         GOBACK.                                                  06650003
066600**==============================================================**06660003
066700**          THIS NEXT CALL WILL PROCESS 2005 BILLS  WITH          06670003
066800**              A DISCHARGE DATE ON OR AFTER 20050101             06680003
066900**              USES MSA FILE FOR WAGE INDEX                      06690003
067000**==============================================================**06700003
067100     IF BILL-DISCHARGE-DATE                                       06710003
067200              > 20041231                                          06720003
067300         CALL  IPCAL057 USING BILL-INPUT-DATA                     06730003
067400                              IPF-DATA-VARIABLES                  06740003
067500                              IPF-ADDITIONAL-VARIABLES            06750003
067600                              PRICER-OPT-VERS-SW                  06760003
067700                              PROV-NEW-HOLD                       06770003
067800                              WAGE-NEW-INDEX-RECORD               06780003
067900         GOBACK.                                                  06790003
068000**==============================================================**06800003
068100     MOVE 98 TO IPF-RTC.                                          06810003
068200     GOBACK.                                                      06820003
068300                                                                  06830003
068400 0100-GET-MSA.                                                    06840003
068500     SET MU1 TO 1.                                                06850003
068600                                                                  06860003
068700     SEARCH M-MSAX-DATA VARYING MU1                               06870003
068800     AT END                                                       06880003
068900          MOVE 999999 TO P-NEW-PROVIDER-NO                        06890003
069000          MOVE 52     TO IPF-RTC                                  06900003
069100          GO TO 0100-EXIT                                         06910003
069200     WHEN M-MSAX-MSA (MU1) = HOLD-PROV-MSAX                       06920003
069300          SET MU2 TO MU1.                                         06930003
069400                                                                  06940003
069500 0100-EXIT.  EXIT.                                                06950003
069600                                                                  06960003
069700 0150-GET-CBSA.                                                   06970003
069800     SET MA1 TO 1.                                                06980003
069900                                                                  06990003
070000     SEARCH TB-CBSA-DATA VARYING MA1                              07000003
070100     AT END                                                       07010003
070200          MOVE 999999 TO P-NEW-PROVIDER-NO                        07020003
070300          MOVE 52     TO IPF-RTC                                  07030003
070400          GO TO 0150-EXIT                                         07040003
070500     WHEN TB-CBSA (MA1) = HOLD-PROV-CBSA                          07050003
070600          SET MA2 TO MA1.                                         07060003
070700                                                                  07070003
070800 0150-EXIT.  EXIT.                                                07080003
070900                                                                  07090003
071000 0500-GET-MSA.                                                    07100003
071100     IF P-NEW-CHG-CODE-INDEX = 'Y'                                07110003
071200        MOVE P-NEW-WAGE-INDEX-LOC-MSA TO HOLD-PROV-MSAX           07120003
071300                                         IPF-MSA                  07130003
071400     ELSE                                                         07140003
071500        MOVE P-NEW-GEO-LOC-MSA9 TO HOLD-PROV-MSAX                 07150003
071600                                   IPF-MSA.                       07160003
071700                                                                  07170003
071800     PERFORM 0100-GET-MSA THRU 0100-EXIT.                         07180003
071900                                                                  07190003
072000***     RTC = 52  --  MSA NOT FOUND                               07200003
072100     IF IPF-RTC = 52    GOBACK.                                   07210003
072200                                                                  07220003
072300     IF IPF-RTC = 00                                              07230003
072400        PERFORM 0600-N-GET-WAGE-INDX                              07240003
072500           THRU 0600-N-EXIT VARYING MU2                           07250003
072600           FROM MU1 BY 1 UNTIL                                    07260003
072700           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.                 07270003
072800                                                                  07280003
072900***     RTC = 52  --  WAGE-INDEX NOT FOUND                        07290003
073000     IF IPF-RTC = 52    GOBACK.                                   07300003
073100                                                                  07310003
073200     IF W-NEW-INDEX-RECORD = 00.0000                              07320003
073300        MOVE 52 TO IPF-RTC.                                       07330003
073400                                                                  07340003
073500***  GET THE WAGE-SIZE                                            07350003
073600                                                                  07360003
073700     MOVE P-NEW-STAND-AMT-LOC-MSA TO HOLD-PROV-MSAX.              07370003
073800                                                                  07380003
073900     PERFORM 0100-GET-MSA THRU 0100-EXIT.                         07390003
074000                                                                  07400003
074100     IF IPF-RTC = 00                                              07410003
074200         PERFORM 0700-N-GET-WAGE-SIZE                             07420003
074300           THRU 0700-N-EXIT VARYING MU2                           07430003
074400           FROM MU1 BY 1 UNTIL                                    07440003
074500           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.                 07450003
074600                                                                  07460003
074700***     RTC = 52  --  PR-WAGE-INDEX NOT FOUND                     07470003
074800     IF IPF-RTC = 52                                              07480003
074900          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               07490003
075000          GOBACK.                                                 07500003
075100                                                                  07510003
075200 0500-EXIT.  EXIT.                                                07520003
075300                                                                  07530003
075400 0550-GET-CBSA.                                                   07540003
075500                                                                  07550003
075600     MOVE P-NEW-CBSA-GEO-LOC TO HOLD-PROV-CBSA                    07560003
075700                                IPF-CBSA.                         07570003
075800                                                                  07580003
075900     IF (P-NEW-CBSA-WI-SPECIAL AND                                07590003
076000         P-NEW-CBSA-SPEC-WI-N NOT NUMERIC)                        07600003
076100         MOVE 52 TO IPF-RTC                                       07610003
076200         GOBACK.                                                  07620003
076300                                                                  07630003
076400     IF (P-NEW-CBSA-WI-SPECIAL AND                                07640003
076500         P-NEW-CBSA-SPEC-WI-N = ZEROES)                           07650003
076600         MOVE 52 TO IPF-RTC                                       07660003
076700         GOBACK.                                                  07670003
076800                                                                  07680003
076900     IF P-NEW-CBSA-WI-SPECIAL                                     07690003
077000        MOVE 'SPEC*'  TO W-CBSA-X                                 07700003
077100        MOVE P-NEW-EFF-DATE TO W-CBSA-EFF-DATE                    07710003
077200        MOVE P-NEW-CBSA-SPEC-WI TO W-CBSA-INDEX                   07720003
077300        GO TO 0550-EXIT.                                          07730003
077400                                                                  07740003
077500     PERFORM 0150-GET-CBSA THRU 0150-EXIT.                        07750003
077600                                                                  07760003
077700***     RTC = 52  --  CBSA NOT FOUND                              07770003
077800     IF IPF-RTC = 52    GOBACK.                                   07780003
077900                                                                  07790003
078000     IF IPF-RTC = 00                                              07800003
078100        PERFORM 0650-N-GET-WAGE-INDX                              07810003
078200           THRU 0650-N-EXIT VARYING MA2                           07820003
078300           FROM MA1 BY 1 UNTIL                                    07830003
078400           TB-CBSA (MA2) NOT = HOLD-PROV-CBSA.                    07840003
078500                                                                  07850003
078600***     RTC = 52  --  WAGE-INDEX NOT FOUND                        07860003
078700     IF IPF-RTC = 52    GOBACK.                                   07870003
078800                                                                  07880003
078900     IF W-CBSA-INDEX       = 00.0000                              07890003
079000        MOVE 52 TO IPF-RTC.                                       07900003
079100                                                                  07910003
079200 0550-EXIT.  EXIT.                                                07920003
079300                                                                  07930003
079400                                                                  07940003
079500 0600-N-GET-WAGE-INDX.                                            07950003
079600                                                                  07960003
079700     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)          07970003
079800         MOVE M-MSAX-MSA        (MU2) TO W-NEW-MSA                07980003
079900         MOVE M-MSAX-EFF-DATE   (MU2) TO W-NEW-EFF-DATE           07990003
080000         MOVE M-MSAX-WAGE-INDX1 (MU2) TO W-NEW-INDEX-RECORD       08000003
080100         IF P-NEW-CHG-CODE-INDEX  = 'Y'                           08010003
080200            MOVE M-MSAX-WAGE-INDX2 (MU2) TO W-NEW-INDEX-RECORD.   08020003
080300                                                                  08030003
080400 0600-N-EXIT.  EXIT.                                              08040003
080500                                                                  08050003
080600 0650-N-GET-WAGE-INDX.                                            08060003
080700                                                                  08070003
080800     IF  BILL-DISCHARGE-DATE NOT < TB-CBSA-EFF-DATE (MA2)         08080003
080900         MOVE TB-CBSA            (MA2) TO W-CBSA                  08090003
081000         MOVE TB-CBSA-EFF-DATE   (MA2) TO W-CBSA-EFF-DATE         08100003
081100         MOVE TB-CBSA-WAGE-INDX1 (MA2) TO W-CBSA-INDEX.           08110003
081200                                                                  08120003
081300 0650-N-EXIT.  EXIT.                                              08130003
081400                                                                  08140003
081500                                                                  08150003
081600 0700-N-GET-WAGE-SIZE.                                            08160003
081700                                                                  08170003
081800     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)          08180003
081900         IF  P-NEW-STD-RURAL-CHECK                                08190003
082000             MOVE 'R' TO W-NEW-SIZE                               08200003
082100         ELSE                                                     08210003
082200         IF  M-MSAX-SIZE (MU2) = 'L'                              08220003
082300             MOVE 'L' TO W-NEW-SIZE                               08230003
082400         ELSE                                                     08240003
082500             MOVE 'O' TO W-NEW-SIZE.                              08250003
082600                                                                  08260003
082700 0700-N-EXIT.  EXIT.                                              08270003
082800                                                                  08280003
082900 1350-N-CHECK-MSA.                                                08290003
083000     IF P-NEW-EFF-DATE < 20050701                                 08300003
083100        IF (P-NEW-WAGE-INDEX-LOC-MSA = '    ' OR                  08310003
083200            P-NEW-WAGE-INDEX-LOC-MSA = '0000')                    08320003
083300            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-WAGE-INDEX-LOC-MSA.  08330003
083400     IF P-NEW-EFF-DATE < 20050701                                 08340003
083500        IF (P-NEW-STAND-AMT-LOC-MSA = '    ' OR                   08350003
083600            P-NEW-STAND-AMT-LOC-MSA = '0000')                     08360003
083700            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-STAND-AMT-LOC-MSA.   08370003
083800                                                                  08380003
083900     IF P-NEW-EFF-DATE < 20050701                                 08390003
084000        IF (P-NEW-CBSA-RECLASS-LOC = '     ' OR                   08400003
084100            P-NEW-CBSA-RECLASS-LOC = '00000')                     08410003
084200            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-RECLASS-LOC.   08420003
084300     IF P-NEW-EFF-DATE < 20050701                                 08430003
084400        IF (P-NEW-CBSA-STAND-AMT-LOC = '     ' OR                 08440003
084500            P-NEW-CBSA-STAND-AMT-LOC = '00000')                   08450003
084600            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-STAND-AMT-LOC. 08460003
084700                                                                  08470003
084800 1350-N-EXIT.  EXIT.                                              08480003
084900                                                                  08490003
085000**==============================================================**08500003
085100**           L A S T   S O U R C E   S T A T E M E N T          **08510003
085200**==============================================================**08520003
