000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IPDRV210.                                         00020001
000300******************************************************************00030001
000400* THIS PROGRAM CALLS THE IP CALC PROGRAM                          00040001
000500******************************************************************00050001
000600*--------------- U P D A T E S -----------------------------------00060001
000700*  ADDED SUPPLEMENTAL WAGE INDEX TO PROVIDER RECORD               00070001
000710*  ADDED 0560-SUPP-WAGE-INDEX PARAGRAPH                           00071003
000800******************************************************************00080001
000900 DATE-COMPILED.                                                   00090001
001000 ENVIRONMENT DIVISION.                                            00100001
001100 CONFIGURATION SECTION.                                           00110001
001200 SOURCE-COMPUTER.            IBM-370.                             00120001
001300 OBJECT-COMPUTER.            IBM-370.                             00130001
001400 INPUT-OUTPUT  SECTION.                                           00140001
001500 FILE-CONTROL.                                                    00150001
001600 DATA DIVISION.                                                   00160001
001700 FILE SECTION.                                                    00170001
001800                                                                  00180001
001900 WORKING-STORAGE SECTION.                                         00190001
002000 01  FILLER                PIC X(40)  VALUE                       00200004
002100     'IPDRV210 - W O R K I N G   S T O R A G E'.                  00210001
002200 01  DRV-VERSION           PIC X(05) VALUE 'D21.0'.               00220001
002300 01  IPCAL210              PIC X(08) VALUE 'IPCAL210'.            00230001
002400 01  IPCAL202              PIC X(08) VALUE 'IPCAL202'.            00240035
002500 01  IPCAL191              PIC X(08) VALUE 'IPCAL191'.            00250001
002600 01  IPCAL180              PIC X(08) VALUE 'IPCAL180'.            00260001
002700 01  IPCAL170              PIC X(08) VALUE 'IPCAL170'.            00270001
002800 01  IPCAL161              PIC X(08) VALUE 'IPCAL161'.            00280001
002900 01  IPCAL150              PIC X(08) VALUE 'IPCAL150'.            00290001
003000 01  IPCAL140              PIC X(08) VALUE 'IPCAL140'.            00300001
003100 01  IPCAL130              PIC X(08) VALUE 'IPCAL130'.            00310001
003200 01  IPCAL121              PIC X(08) VALUE 'IPCAL121'.            00320001
003300 01  IPCAL120              PIC X(08) VALUE 'IPCAL120'.            00330001
003400 01  IPCAL112              PIC X(08) VALUE 'IPCAL112'.            00340001
003500 01  IPCAL111              PIC X(08) VALUE 'IPCAL111'.            00350001
003600 01  IPCAL110              PIC X(08) VALUE 'IPCAL110'.            00360001
003700 01  IPCAL102              PIC X(08) VALUE 'IPCAL102'.            00370001
003800 01  IPCAL100              PIC X(08) VALUE 'IPCAL100'.            00380001
003900 01  IPCAL094              PIC X(08) VALUE 'IPCAL094'.            00390001
004000 01  IPCAL09A              PIC X(08) VALUE 'IPCAL09A'.            00400001
004100 01  IPCAL08A              PIC X(08) VALUE 'IPCAL08A'.            00410001
004200 01  IPCAL086              PIC X(08) VALUE 'IPCAL086'.            00420001
004300 01  IPCAL076              PIC X(08) VALUE 'IPCAL076'.            00430001
004400 01  IPCAL057              PIC X(08) VALUE 'IPCAL057'.            00440001
004500 01  W-WI-PCT-REDUC-FY2020 PIC S9(01)V9(02) VALUE -0.05.          00450001
004600 01  W-WI-PCT-ADJ-FY2020   PIC 9(01)V9(02)  VALUE 0.95.           00460001
004601 01  W-FY2021-BEGIN-DT     PIC 9(08) VALUE 20201001.              00460131
004602 01  W-FY2021-END-DT       PIC 9(08) VALUE 20210930.              00460231
004700 01  TABLES-LOADED-SW      PIC 9(01)  VALUE 0.                    00470001
004800 01  EOF-SW                PIC 9(01)  VALUE 0.                    00480001
004900 01  PROV-STAT.                                                   00490001
005000     02  PROV-STAT1     PIC X.                                    00500001
005100     02  PROV-STAT2     PIC X.                                    00510001
005200                                                                  00520001
005300 01  MSAX-STAT.                                                   00530001
005400     02  MSAX-STAT1     PIC X.                                    00540001
005500     02  MSAX-STAT2     PIC X.                                    00550001
005600                                                                  00560001
005700 01  CBSA-STAT.                                                   00570001
005800     02  CBSA-STAT1     PIC X.                                    00580001
005900     02  CBSA-STAT2     PIC X.                                    00590001
006000                                                                  00600001
006100 01  HOLD-PROV-MSAX.                                              00610001
006200         10  H-MSAX-PROV-BLANK   PIC X(2).                        00620001
006300         10  H-MSAX-PROV-STATE.                                   00630001
006400             15  FILLER          PIC X.                           00640001
006500             15  H-MSAX-LAST-POS PIC X.                           00650001
006600                                                                  00660001
006700 01  HOLD-PROV-CBSA.                                              00670001
006800         10  H-CBSA-PROV-BLANK   PIC X(3).                        00680001
006900         10  H-CBSA-PROV-STATE.                                   00690001
007000             15  FILLER          PIC X.                           00700001
007100             15  H-CBSA-LAST-POS PIC X.                           00710001
007200                                                                  00720001
007300**================================================================00730001
007400*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   00740001
007500*      THE IPCAL056 PROGRAM FOR PROCESSING                        00750001
007600**================================================================00760001
007700 01  WAGE-NEW-INDEX-RECORD.                                       00770001
007800     05  W-NEW-MSA               PIC 9(4).                        00780001
007900     05  W-NEW-SIZE              PIC X(01).                       00790001
008000         88  NEW-LARGE-URBAN       VALUE 'L'.                     00800001
008100         88  NEW-OTHER-URBAN       VALUE 'O'.                     00810001
008200         88  NEW-ALL-RURAL         VALUE 'R'.                     00820001
008300     05  W-NEW-EFF-DATE.                                          00830001
008400          10  W-NEW-EFF-DATE-CC   PIC 9(2).                       00840001
008500          10  W-NEW-EFF-DATE-YMD.                                 00850001
008600              15  W-NEW-EFF-DATE-YY   PIC 9(2).                   00860001
008700              15  W-NEW-EFF-DATE-MM   PIC 9(2).                   00870001
008800              15  W-NEW-EFF-DATE-DD   PIC 9(2).                   00880001
008900     05  FILLER              PIC X.                               00890001
009000     05  W-NEW-INDEX-RECORD      PIC S9(02)V9(04).                00900001
009100     05  FILLER                  PIC S9(02)V9(04).                00910001
009200                                                                  00920001
009300**================================================================00930001
009400*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   00940001
009500*      THE IPCAL    PROGRAM FOR PROCESSING                        00950001
009600**================================================================00960001
009700 01  CBSA-WAGE-INDEX-RECORD.                                      00970001
009800     05  W-CBSA               PIC 9(5).                           00980001
009900     05  W-CBSA-X  REDEFINES W-CBSA PIC X(05).                    00990001
010000     05  W-CBSA-SIZE             PIC X(01).                       01000001
010100         88  W-CBSA-LARGE-URBAN       VALUE 'L'.                  01010001
010200         88  W-CBSA-OTHER-URBAN       VALUE 'O'.                  01020001
010300         88  W-CBSA-ALL-RURAL         VALUE 'R'.                  01030001
010400     05  W-CBSA-EFF-DATE.                                         01040001
010500          10  W-CBSA-EFF-DATE-CC       PIC 9(2).                  01050001
010600          10  W-CBSA-EFF-DATE-YMD.                                01060001
010700              15  W-CBSA-EFF-DATE-YY   PIC 9(2).                  01070001
010800              15  W-CBSA-EFF-DATE-MM   PIC 9(2).                  01080001
010900              15  W-CBSA-EFF-DATE-DD   PIC 9(2).                  01090001
011000     05  FILLER             PIC X.                                01100001
011100     05  W-CBSA-INDEX       PIC S9(02)V9(04).                     01110001
011200     05  FILLER             PIC S9(02)V9(04).                     01120001
011300                                                                  01130001
011400                                                                  01140001
011500**==============================================================**01150001
011600*   MSAX RECORD PASSED OPTION B                                   01160001
011700**==============================================================**01170001
011800 01  MSAX-TABLE-FROM-USER.                                        01180001
011900     05  FILLER                     PIC X(32000).                 01190001
012000     05  FILLER                     PIC X(30000).                 01200001
012100     05  FILLER                     PIC X(30000).                 01210001
012200                                                                  01220001
012300**==============================================================**01230001
012400*   CBSA RECORD PASSED OPTION B                                   01240001
012500**==============================================================**01250001
012600 01  CBSA-TABLE-FROM-USER.                                        01260001
012700     05  FILLER                     PIC X(32000).                 01270001
012800     05  FILLER                     PIC X(30000).                 01280001
012900     05  FILLER                     PIC X(30000).                 01290001
013000                                                                  01300001
013100**==============================================================**01310001
013200*   PROV RECORD PASSED OPTION P                                   01320001
013300**==============================================================**01330001
013400 01  PROV-NEW-HOLD.                                               01340001
013500     02  PROV-NEWREC-HOLD1.                                       01350001
013600         05  P-NEW-NPI10.                                         01360001
013700             10  P-NEW-NPI8             PIC X(08).                01370001
013800             10  P-NEW-NPI-FILLER       PIC X(02).                01380001
013900         05  P-NEW-PROVIDER-NO.                                   01390001
014000             10  P-NEW-STATE            PIC 9(02).                01400001
014100             10  FILLER                 PIC X(04).                01410001
014200         05  P-NEW-DATE-DATA.                                     01420001
014300             10  P-NEW-EFF-DATE.                                  01430001
014400                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01440001
014500                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01450001
014600                 15  P-NEW-EFF-DT-MM    PIC 9(02).                01460001
014700                 15  P-NEW-EFF-DT-DD    PIC 9(02).                01470001
014800             10  P-NEW-FY-BEGIN-DATE.                             01480001
014900                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                01490001
015000                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                01500001
015100                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                01510001
015200                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                01520001
015300             10  P-NEW-REPORT-DATE.                               01530001
015400                 15  P-NEW-REPORT-DT-CC PIC 9(02).                01540001
015500                 15  P-NEW-REPORT-DT-YY PIC 9(02).                01550001
015600                 15  P-NEW-REPORT-DT-MM PIC 9(02).                01560001
015700                 15  P-NEW-REPORT-DT-DD PIC 9(02).                01570001
015800             10  P-NEW-TERMINATION-DATE.                          01580001
015900                 15  P-NEW-TERM-DT-CC   PIC 9(02).                01590001
016000                 15  P-NEW-TERM-DT-YY   PIC 9(02).                01600001
016100                 15  P-NEW-TERM-DT-MM   PIC 9(02).                01610001
016200                 15  P-NEW-TERM-DT-DD   PIC 9(02).                01620001
016300         05  P-NEW-WAIVER-CODE          PIC X(01).                01630001
016400             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              01640001
016500         05  P-NEW-INTER-NO             PIC 9(05).                01650001
016600         05  P-NEW-PROVIDER-TYPE        PIC X(02).                01660001
016700             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      01670001
016800             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       01680001
016900                                                  '15' '17'       01690001
017000                                                  '22'.           01700001
017100             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           01710001
017200             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           01720001
017300             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           01730001
017400             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           01740001
017500             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      01750001
017600             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           01760001
017700             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      01770001
017800             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           01780001
017900             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           01790001
018000             88  P-N-EACH                   VALUE '21' '22'.      01800001
018100             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           01810001
018200             88  P-N-NHCMQ-II-SNF           VALUE '32'.           01820001
018300             88  P-N-NHCMQ-III-SNF          VALUE '33'.           01830001
018400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                01840001
018500             88  P-N-NEW-ENGLAND            VALUE  1.             01850001
018600             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             01860001
018700             88  P-N-SOUTH-ATLANTIC         VALUE  3.             01870001
018800             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             01880001
018900             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             01890001
019000             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             01900001
019100             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             01910001
019200             88  P-N-MOUNTAIN               VALUE  8.             01920001
019300             88  P-N-PACIFIC                VALUE  9.             01930001
019400         05  P-NEW-CURRENT-DIV   REDEFINES                        01940001
019500                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         01950001
019600             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          01960001
019700         05  P-NEW-MSA-DATA.                                      01970001
019800             10  P-NEW-CHG-CODE-INDEX       PIC X.                01980001
019900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 01990001
020000             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02000001
020100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       02010001
020200             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  02020001
020300                             P-NEW-GEO-LOC-MSA9.                  02030001
020400                 15  P-NEW-GEO-MSA-1ST    PIC X.                  02040001
020500                 15  P-NEW-GEO-MSA-2ND    PIC X.                  02050001
020600                 15  P-NEW-GEO-MSA-3RD    PIC X.                  02060001
020700                 15  P-NEW-GEO-MSA-4TH    PIC X.                  02070001
020800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02080001
020900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02090001
021000             10  P-NEW-STAND-AMT-LOC-MSA9                         02100001
021100       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         02110001
021200                 15  P-NEW-RURAL-1ST.                             02120001
021300                     20  P-NEW-STAND-RURAL  PIC XX.               02130001
021400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02140001
021500                 15  P-NEW-RURAL-2ND        PIC XX.               02150001
021600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    02160001
021700                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           02170001
021800                 88  P-NEW-SCH-YR82       VALUE   '82'.           02180001
021900                 88  P-NEW-SCH-YR87       VALUE   '87'.           02190001
022000         05  P-NEW-LUGAR                    PIC X.                02200001
022100         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02210001
022200             88  P-NEW-LOW-VOL25PCT     VALUE 'Y'.                02220001
022300***          Y = LOW VOLUME PERCENTAGE  25 % ADD ON               02230001
022400         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02240001
022500         05  FILLER                         PIC X(05).            02250001
022600     02  PROV-NEWREC-HOLD2.                                       02260001
022700         05  P-NEW-VARIABLES.                                     02270001
022800             10  P-NEW-CMI-ADJ-CPD       PIC  9(05)V9(02).        02280001
022900             10  P-NEW-COLA              PIC  9(01)V9(03).        02290001
023000             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        02300001
023100             10  P-NEW-BED-SIZE          PIC  9(05).              02310001
023200             10  P-NEW-CCR               PIC  9(01)V9(03).        02320001
023300             10  P-NEW-CMI               PIC  9(01)V9(04).        02330001
023400             10  P-NEW-SSI-RATIO         PIC  V9(04).             02340001
023500             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             02350001
023600             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).              02360001
023700             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).        02370001
023800             10  P-NEW-DSH-PERCENT       PIC  V9(04).             02380001
023900             10  P-NEW-FYE-DATE.                                  02390001
024000                 15  P-NEW-FYE-CC        PIC 99.                  02400001
024100                 15  P-NEW-FYE-YY        PIC 99.                  02410001
024200                 15  P-NEW-FYE-MM        PIC 99.                  02420001
024300                 15  P-NEW-FYE-DD        PIC 99.                  02430001
024400         05  P-NEW-CBSA-DATA.                                     02440001
024500             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                02450001
024600                 88  P-NEW-CBSA-WI-GEO        VALUE 'N'.          02460001
024700                 88  P-NEW-CBSA-WI-RECLASS    VALUE 'Y'.          02470001
024800                 88  P-NEW-CBSA-WI-SPECIAL    VALUE '1' '2'.      02480001
024900***                  1 = ANYTHING OR HOLD HARMLESS WITH SPEC WI   02490001
025000***                  2 = RECLASS WITH SPEC WI                     02500001
025100             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 02510001
025200                 88  P-NEW-CBSA-HOSP-QUAL-MET   VALUE '1'.        02520001
025300                 88  P-NEW-CBSA-HOSP-QUAL-25PER VALUE '2'.        02530001
025400                 88  P-NEW-CBSA-HOSP-QUAL-BOTH  VALUE '3'.        02540001
025500             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  02550001
025600             10  P-NEW-CBSA-GEO-LOC9  REDEFINES                   02560001
025700                             P-NEW-CBSA-GEO-LOC  PIC 9(05).       02570001
025800             10  P-NEW-CBSA-GEO-LOC-AST REDEFINES                 02580001
025900                             P-NEW-CBSA-GEO-LOC9.                 02590001
026000                 15  P-NEW-CBSA-GEO-1ST    PIC X.                 02600001
026100                 15  P-NEW-CBSA-GEO-2ND    PIC X.                 02610001
026200                 15  P-NEW-CBSA-GEO-3RD    PIC X.                 02620001
026300                 15  P-NEW-CBSA-GEO-4TH    PIC X.                 02630001
026400                 15  P-NEW-CBSA-GEO-5TH    PIC X.                 02640001
026500             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  02650001
026600             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  02660001
026700             10  P-NEW-CBSA-STAND-AMT-LOC-MSA9                    02670001
026800       REDEFINES P-NEW-CBSA-STAND-AMT-LOC.                        02680001
026900               15  P-NEW-CBSA-RURAL-1ST.                          02690001
027000                   20  P-NEW-CBSA-STAND-RURAL  PIC XXX.           02700001
027100                      88  P-NEW-CBSA-STD-RURAL-CHECK VALUE '   '. 02710001
027200               15  P-NEW-CBSA-RURAL-2ND    PIC XX.                02720001
027300             10  P-NEW-CBSA-SPEC-WI          PIC 9(02)V9(04).     02730001
027400             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  02740001
027500                 P-NEW-CBSA-SPEC-WI          PIC 9(06).           02750001
027600     02  PROV-NEWREC-HOLD3.                                       02760001
027700         05  P-NEW-PASS-AMT-DATA.                                 02770001
027800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02780001
027900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02790001
028000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02800001
028100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02810001
028200         05  P-NEW-CAPI-DATA.                                     02820001
028300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02830001
028400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02840001
028500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02850001
028600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02860001
028700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02870001
028800             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02880001
028900             15  P-NEW-CAPI-IME            PIC 9V9999.            02890001
029000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02900001
029100             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            02910001
029200*-----------------------------------------------------------------02920001
029300*                SUPPLEMENTAL WAGE INDEX                          02930001
029400*    1=PRIOR YEAR WAGE INDEX                                      02940001
029500*    2=CURRENT YEAR IPPS-COMPARABLE WAGE INDEX (LTCHS ONLY)       02950001
029600*    3=FUTURE USE                                                 02960001
029700*    4=FUTURE USE                                                 02970001
029800         05  P-NEW-SUPPLEMENTAL-WI.                               02980001
029900             10  P-NEW-SUPP-WI-IND         PIC X.                 02990001
030000                 88 SUPP-WI-PRIOR-YEAR     VALUE '1'.             03000001
030100             10  P-NEW-SUPP-WI             PIC 9(2)V9(04).        03010001
030200         05  FILLER                        PIC X(11).             03020001
030300**================================================================03030001
030400                                                                  03040001
030500 LINKAGE SECTION.                                                 03050001
030600                                                                  03060001
030700**========================================================        03070001
030800*    PASSED AND RETURNED BY IPCAL                     *           03080001
030900**==============================*========================*        03090001
031000 01  BILL-INPUT-DATA.                                             03100001
031100     05  BILL-IN-DATA.                                            03110001
031200         10  BILL-NPI-NUMBER.                                     03120001
031300             15  BILL-NPI            PIC X(08).                   03130001
031400             15  BILL-NPI-FILLER     PIC X(02).                   03140001
031500         10  BILL-PROVIDER-NO        PIC X(06).                   03150001
031600         10  BILL-HIC-NO             PIC X(12).                   03160001
031700         10  BILL-DISCHARGE-DATE.                                 03170001
031800             15  BILL-D-CC           PIC 9(02).                   03180001
031900             15  BILL-D-YY           PIC 9(02).                   03190001
032000             15  BILL-D-MM           PIC 9(02).                   03200001
032100             15  BILL-D-DD           PIC 9(02).                   03210001
032200         10  BILL-PATIENT-STATUS     PIC X(02).                   03220001
032300         10  BILL-AGE                PIC 9(03).                   03230001
032400         10  BILL-DRG                PIC 9(03).                   03240001
032500         10  BILL-LOS                PIC 9(05).                   03250001
032600         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   03260001
032700         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   03270001
032800         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   03280001
032900         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             03290001
033000         10  BILL-OTHER-DIAG-DATA    PIC X(175).                  03300001
033100         10  BILL-OTHER-PROC-DATA    PIC X(175).                  03310001
033200         10  BILL-PRIOR-DAYS         PIC 9(03).                   03320001
033300**========================================================        03330001
033400*    PASSED AND RETURNED BY IPCAL                     *           03340001
033500**======================================================**        03350001
033600 01  IPF-DATA-VARIABLES.                                          03360001
033700         10  IPF-RTC                 PIC 9(02).                   03370001
033800         10  IPF-MSA-CBSA            PIC X(05).                   03380001
033900         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 03390001
034000             15  IPF-MSA             PIC X(04).                   03400001
034100             15  FILLER              PIC X.                       03410001
034200         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                03420001
034300             15  IPF-CBSA            PIC X(05).                   03430001
034400         10  IPF-WAGE-INDX           PIC 9(02)V9(04).             03440001
034500         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             03450001
034600         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             03460001
034700         10  IPF-COLA                PIC 9(01)V9(03).             03470001
034800         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             03480001
034900         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             03490001
035000         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             03500001
035100         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             03510001
035200         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             03520001
035300         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             03530001
035400         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             03540001
035500         10  IPF-FED-PPS-BLEND-IND   PIC X.                       03550001
035600         10  IPF-CAL-VERSION         PIC X(05).                   03560001
035700         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             03570001
035800         10  FILLER                  PIC X(08).                   03580001
035900                                                                  03590001
036000**======================================================**        03600001
036100*    PASSED AND RETURNED BY IPCAL                     *           03610001
036200**======================================================**        03620001
036300 01  IPF-ADDITIONAL-VARIABLES.                                    03630001
036400     02  IPF-MF-VARIABLES.                                        03640001
036500         10  IPF-100PCT-STOPLOS-AMT     PIC 9(07)V9(02).          03650001
036600         10  IPF-TOT-PAYMENT            PIC 9(07)V9(02).          03660001
036700         10  IPF-FED-PAYMENT            PIC 9(07)V9(02).          03670001
036800         10  IPF-FAC-PAYMENT            PIC 9(07)V9(02).          03680001
036900         10  IPF-ECT-PAYMENT            PIC 9(07)V9(02).          03690001
037000         10  IPF-OUTLIER-PAYMENT        PIC 9(07)V9(02).          03700001
037100         10  IPF-OUTL-COST              PIC 9(07)V9(02).          03710001
037200         10  IPF-OUTL-ADJ-COST          PIC 9(07)V9(02).          03720001
037300         10  IPF-OUTL-PER-DIEM-AMT      PIC 9(07)V9(02).          03730001
037400         10  IPF-OUTL-THRES-AMT         PIC 9(07)V9(02).          03740001
037500         10  IPF-OUTL-THRES-ADJ-AMT     PIC 9(07)V9(02).          03750001
037600         10  IPF-ADJUSTED-PER-DIEM-AMT  PIC 9(07)V9(02).          03760001
037700         10  IPF-WAGE-ADJ-AMT           PIC 9(07)V9(02).          03770001
037800         10  IPF-LABOR-BASE-AMT         PIC 9(07)V9(05).          03780001
037900         10  IPF-NLABOR-BASE-AMT        PIC 9(07)V9(05).          03790001
038000         10  IPF-OUTL-LABOR-BASE-AMT    PIC 9(07)V9(05).          03800001
038100         10  IPF-OUTL-NLABOR-BASE-AMT   PIC 9(07)V9(05).          03810001
038200         10  IPF-BUDGNUT-RATE-AMT       PIC 9(05)V9(02).          03820001
038300         10  IPF-ECT-RATE-AMT           PIC 9(05)V9(02).          03830001
038400         10  IPF-TEACH-PAYMENT          PIC 9(07)V9(02).          03840001
038500         10  FILLER                     PIC X(01).                03850001
038600      02 IPF-PC-VARIABLES.                                        03860001
038700         10  IPF-PC-DATA                PIC X(44).                03870001
038800                                                                  03880001
038900 01  PRICER-OPT-VERS-SW.                                          03890001
039000     02  PRICER-OPTION-SW               PIC X(01).                03900001
039100         88  VARIABLES                  VALUE 'S'.                03910001
039200         88  PROV-RECORD-PASSED         VALUE 'P'.                03920001
039300         88  ALL-TABLES-PASSED          VALUE 'B'.                03930001
039400     02  IPF-VERSIONS.                                            03940001
039500         10  IPDRV-VERSION              PIC X(05).                03950001
039600                                                                  03960001
039700**===============================================================*03970001
039800* THE PROVIDER SPECIFIC PASSED FROM CALLING PROGRAM              *03980001
039900**===============================================================*03990001
040000 01  PROV-RECORD-FROM-USER.                                       04000001
040100     02  PROV-FROM-USER-HOLD1           PIC X(80).                04010001
040200     02  PROV-FROM-USER-HOLD2           PIC X(80).                04020001
040300     02  PROV-FROM-USER-HOLD3           PIC X(80).                04030001
040400                                                                  04040001
040500 01  MSAX-WI-TABLE.                                               04050001
040600     05  M-MSAX-DATA                OCCURS 4000                   04060001
040700                                    INDEXED BY MU1 MU2 MU3.       04070001
040800         10  M-MSAX-MSA             PIC X(4).                     04080001
040900         10  M-MSAX-SIZE            PIC X(01).                    04090001
041000         10  M-MSAX-EFF-DATE        PIC X(08).                    04100001
041100         10  M-MSAX-WAGE-INDX1      PIC S9(02)V9(04).             04110001
041200         10  M-MSAX-WAGE-INDX2      PIC S9(02)V9(04).             04120001
041300                                                                  04130001
041400 01  CBSA-WI-TABLE.                                               04140001
041500     05  TB-CBSA-DATA                OCCURS 7000                  04150001
041600                                    INDEXED BY MA1 MA2 MA3.       04160001
041700         10  TB-CBSA                PIC X(5).                     04170001
041800         10  TB-CBSA-SIZE           PIC X(01).                    04180001
041900         10  TB-CBSA-EFF-DATE       PIC X(08).                    04190001
042000         10  TB-CBSA-WAGE-INDX1     PIC S9(02)V9(04).             04200001
042100         10  TB-CBSA-WAGE-INDX2     PIC S9(02)V9(04).             04210001
042200                                                                  04220001
042300**============================================================    04230001
042400 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        04240001
042500                           IPF-DATA-VARIABLES                     04250001
042600                           IPF-ADDITIONAL-VARIABLES               04260001
042700                           PRICER-OPT-VERS-SW                     04270001
042800                           PROV-RECORD-FROM-USER                  04280001
042900                           MSAX-WI-TABLE                          04290001
043000                           CBSA-WI-TABLE.                         04300001
043100                                                                  04310001
043200**==============================================================**04320001
043300*    PROCESSING:                                                  04330001
043400*        A. THIS MODULE WILL CALL THE IPCAL MODULES.              04340001
043500*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  04350001
043600*           SUBROUTINE IS CALLED.                                 04360001
043700*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH*04370001
043800*           EACH BILL WILL BE PASSED TO THE IPCAL PROGRAMS.       04380001
043900*        D. CALL COMORBIDITY GROUPER AND RETURN A                 04390001
044000*           APPLIED COMORBIDITY ADJUSTER                          04400001
044100**==============================================================**04410001
044220                                                                  04422018
044300     MOVE DRV-VERSION TO IPDRV-VERSION.                           04430001
044400                                                                  04440001
044500     MOVE ALL '0' TO IPF-ADDITIONAL-VARIABLES                     04450001
044600                     IPF-DATA-VARIABLES.                          04460001
044700                                                                  04470033
044800**==============================================================**04480001
044900***     RTC = 98 >> A BILL LESS THEN 20050101                     04490001
045000                                                                  04500001
045100     IF BILL-DISCHARGE-DATE < 20050101                            04510001
045200             MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES            04520001
045300                              IPF-DATA-VARIABLES                  04530001
045400             MOVE 98 TO IPF-RTC                                   04540001
045500             GOBACK.                                              04550001
045600**==============================================================**04560001
045700                                                                  04570001
045800 0010-PROCESS-RECORDS.                                            04580001
045900**==============================================================**04590001
046000***  GET THE PROVIDER RECORD                                      04600001
046100                                                                  04610001
046200     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 04620001
046300     IF PROV-RECORD-FROM-USER <= SPACES                           04630001
046400        MOVE 51 TO IPF-RTC                                        04640001
046500        MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES                 04650001
046600        GOBACK                                                    04660001
046700     END-IF.                                                      04670001
046999                                                                  04699908
047000     PERFORM 1350-N-CHECK-MSA THRU 1350-N-EXIT.                   04700008
047010                                                                  04701008
047100     IF BILL-DISCHARGE-DATE < P-NEW-EFF-DATE                      04710001
047200        MOVE 55 TO IPF-RTC                                        04720001
047300        GOBACK.                                                   04730001
047400                                                                  04740001
047500     IF BILL-DISCHARGE-DATE > 20060630 AND                        04750001
047600        P-NEW-EFF-DATE < 20060701                                 04760001
047700        MOVE 55 TO IPF-RTC                                        04770001
047800        GOBACK.                                                   04780001
047900                                                                  04790001
048000     IF P-NEW-EFF-DATE < 20060701                                 04800001
048100        PERFORM 0500-GET-MSA THRU 0500-EXIT                       04810001
048200     ELSE                                                         04820001
048300        PERFORM 0550-GET-CBSA THRU 0550-EXIT.                     04830001
048400                                                                  04840001
048500***     RTC = 52  --  WAGE-INDEX NOT FOUND                        04850001
048600                                                                  04860001
048700     IF IPF-RTC = 52                                              04870001
048800          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               04880001
048900          GOBACK.                                                 04890001
049000                                                                  04900001
049100**==============================================================**04910001
049200** MAKE SURE DATE IS CODED THE DAY BEFORE THE EFFECTIVE DATE    **04920001
049300**==============================================================**04930001
049400**          THIS NEXT CALL WILL PROCESS 2021 BILLS WITH           04940001
049500**              A DISCHARGE DATE ON OR AFTER 20201001             04950001
049600**==============================================================**04960001
049700     IF BILL-DISCHARGE-DATE                                       04970001
049800              > 20200930                                          04980001
049900         CALL  IPCAL210 USING BILL-INPUT-DATA                     04990001
050000                              IPF-DATA-VARIABLES                  05000001
050100                              IPF-ADDITIONAL-VARIABLES            05010001
050200                              PRICER-OPT-VERS-SW                  05020001
050300                              PROV-NEW-HOLD                       05030001
050400                              CBSA-WAGE-INDEX-RECORD              05040001
050500         GOBACK.                                                  05050001
050600**==============================================================**05060001
050700**          THIS NEXT CALL WILL PROCESS 2020 BILLS WITH           05070001
050800**              A DISCHARGE DATE ON OR AFTER 20191001             05080001
050900**==============================================================**05090001
051000     IF BILL-DISCHARGE-DATE                                       05100001
051100              > 20190930                                          05110001
051200         CALL  IPCAL202 USING BILL-INPUT-DATA                     05120035
051300                              IPF-DATA-VARIABLES                  05130001
051400                              IPF-ADDITIONAL-VARIABLES            05140001
051500                              PRICER-OPT-VERS-SW                  05150001
051600                              PROV-NEW-HOLD                       05160001
051700                              CBSA-WAGE-INDEX-RECORD              05170001
051701         GOBACK.                                                  05170135
051702                                                                  05170234
051900**==============================================================**05190001
052000**          THIS NEXT CALL WILL PROCESS 2019 BILLS WITH           05200001
052100**              A DISCHARGE DATE ON OR AFTER 20181001             05210001
052200**==============================================================**05220001
052300     IF BILL-DISCHARGE-DATE                                       05230001
052400              > 20180930                                          05240001
052500         CALL  IPCAL191 USING BILL-INPUT-DATA                     05250001
052600                              IPF-DATA-VARIABLES                  05260001
052700                              IPF-ADDITIONAL-VARIABLES            05270001
052800                              PRICER-OPT-VERS-SW                  05280001
052900                              PROV-NEW-HOLD                       05290001
053000                              CBSA-WAGE-INDEX-RECORD              05300001
053100         GOBACK.                                                  05310001
053200**==============================================================**05320001
053300**          THIS NEXT CALL WILL PROCESS 2018 BILLS WITH           05330001
053400**              A DISCHARGE DATE ON OR AFTER 20171001             05340001
053500**==============================================================**05350001
053600     IF BILL-DISCHARGE-DATE                                       05360001
053700              > 20170930                                          05370001
053800         CALL  IPCAL180 USING BILL-INPUT-DATA                     05380001
053900                              IPF-DATA-VARIABLES                  05390001
054000                              IPF-ADDITIONAL-VARIABLES            05400001
054100                              PRICER-OPT-VERS-SW                  05410001
054200                              PROV-NEW-HOLD                       05420001
054300                              CBSA-WAGE-INDEX-RECORD              05430001
054400         GOBACK.                                                  05440001
054500**==============================================================**05450001
054600**          THIS NEXT CALL WILL PROCESS 2017 BILLS WITH           05460001
054700**              A DISCHARGE DATE ON OR AFTER 20161001             05470001
054800**==============================================================**05480001
054900     IF BILL-DISCHARGE-DATE                                       05490001
055000              > 20160930                                          05500001
055100         CALL  IPCAL170 USING BILL-INPUT-DATA                     05510001
055200                              IPF-DATA-VARIABLES                  05520001
055300                              IPF-ADDITIONAL-VARIABLES            05530001
055400                              PRICER-OPT-VERS-SW                  05540001
055500                              PROV-NEW-HOLD                       05550001
055600                              CBSA-WAGE-INDEX-RECORD              05560001
055700         GOBACK.                                                  05570001
055800**==============================================================**05580001
055900**          THIS NEXT CALL WILL PROCESS 2016 BILLS WITH           05590001
056000**              A DISCHARGE DATE ON OR AFTER 20151001             05600001
056100**==============================================================**05610001
056200     IF BILL-DISCHARGE-DATE                                       05620001
056300              > 20150930                                          05630001
056400         CALL  IPCAL161 USING BILL-INPUT-DATA                     05640001
056500                              IPF-DATA-VARIABLES                  05650001
056600                              IPF-ADDITIONAL-VARIABLES            05660001
056700                              PRICER-OPT-VERS-SW                  05670001
056800                              PROV-NEW-HOLD                       05680001
056900                              CBSA-WAGE-INDEX-RECORD              05690001
057000         GOBACK.                                                  05700001
057100**==============================================================**05710001
057200**          THIS NEXT CALL WILL PROCESS 2015 BILLS WITH           05720001
057300**              A DISCHARGE DATE ON OR AFTER 20141001             05730001
057400**==============================================================**05740001
057500     IF BILL-DISCHARGE-DATE                                       05750001
057600              > 20140930                                          05760001
057700         CALL  IPCAL150 USING BILL-INPUT-DATA                     05770001
057800                              IPF-DATA-VARIABLES                  05780001
057900                              IPF-ADDITIONAL-VARIABLES            05790001
058000                              PRICER-OPT-VERS-SW                  05800001
058100                              PROV-NEW-HOLD                       05810001
058200                              CBSA-WAGE-INDEX-RECORD              05820001
058300         GOBACK.                                                  05830001
058400**==============================================================**05840001
058500**          THIS NEXT CALL WILL PROCESS 2014 BILLS WITH           05850001
058600**              A DISCHARGE DATE ON OR AFTER 20131001             05860001
058700**==============================================================**05870001
058800     IF BILL-DISCHARGE-DATE                                       05880001
058900              > 20130930                                          05890001
059000         CALL  IPCAL140 USING BILL-INPUT-DATA                     05900001
059100                              IPF-DATA-VARIABLES                  05910001
059200                              IPF-ADDITIONAL-VARIABLES            05920001
059300                              PRICER-OPT-VERS-SW                  05930001
059400                              PROV-NEW-HOLD                       05940001
059500                              CBSA-WAGE-INDEX-RECORD              05950001
059600         GOBACK.                                                  05960001
059700**==============================================================**05970001
059800**          THIS NEXT CALL WILL PROCESS 2013 BILLS WITH           05980001
059900**              A DISCHARGE DATE ON OR AFTER 20121001             05990001
060000**==============================================================**06000001
060100     IF BILL-DISCHARGE-DATE                                       06010001
060200              > 20120930                                          06020001
060300         CALL  IPCAL130 USING BILL-INPUT-DATA                     06030001
060400                              IPF-DATA-VARIABLES                  06040001
060500                              IPF-ADDITIONAL-VARIABLES            06050001
060600                              PRICER-OPT-VERS-SW                  06060001
060700                              PROV-NEW-HOLD                       06070001
060800                              CBSA-WAGE-INDEX-RECORD              06080001
060900         GOBACK.                                                  06090001
061000**==============================================================**06100001
061100**          THIS NEXT CALL WILL PROCESS 2012 BILLS WITH           06110001
061200**              A DISCHARGE DATE ON OR AFTER 20111001             06120001
061300**==============================================================**06130001
061400     IF BILL-DISCHARGE-DATE                                       06140001
061500              > 20110930                                          06150001
061600         CALL  IPCAL121 USING BILL-INPUT-DATA                     06160001
061700                              IPF-DATA-VARIABLES                  06170001
061800                              IPF-ADDITIONAL-VARIABLES            06180001
061900                              PRICER-OPT-VERS-SW                  06190001
062000                              PROV-NEW-HOLD                       06200001
062100                              CBSA-WAGE-INDEX-RECORD              06210001
062200         GOBACK.                                                  06220001
062300**==============================================================**06230001
062400**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH           06240001
062500**              A DISCHARGE DATE ON OR AFTER 20110701             06250001
062600**==============================================================**06260001
062700     IF BILL-DISCHARGE-DATE                                       06270001
062800              > 20110630                                          06280001
062900         CALL  IPCAL120 USING BILL-INPUT-DATA                     06290001
063000                              IPF-DATA-VARIABLES                  06300001
063100                              IPF-ADDITIONAL-VARIABLES            06310001
063200                              PRICER-OPT-VERS-SW                  06320001
063300                              PROV-NEW-HOLD                       06330001
063400                              CBSA-WAGE-INDEX-RECORD              06340001
063500         GOBACK.                                                  06350001
063600**==============================================================**06360001
063700**          THIS NEXT CALL WILL PROCESS 2011 BILLS WITH           06370001
063800**              A DISCHARGE DATE ON OR AFTER 20110101             06380001
063900**==============================================================**06390001
064000     IF BILL-DISCHARGE-DATE                                       06400001
064100              > 20101231                                          06410001
064200         CALL  IPCAL112 USING BILL-INPUT-DATA                     06420001
064300                              IPF-DATA-VARIABLES                  06430001
064400                              IPF-ADDITIONAL-VARIABLES            06440001
064500                              PRICER-OPT-VERS-SW                  06450001
064600                              PROV-NEW-HOLD                       06460001
064700                              CBSA-WAGE-INDEX-RECORD              06470001
064800         GOBACK.                                                  06480001
064900**==============================================================**06490001
065000**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH          06500001
065100**              A DISCHARGE DATE ON OR AFTER 20101001             06510001
065200**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06520001
065300**              USES THE CBSA FOR WAGE INDEXES                    06530001
065400**      FOR RY 2011 10/01/2010 TO 06/30/2011                      06540001
065500**==============================================================**06550001
065600     IF BILL-DISCHARGE-DATE                                       06560001
065700              > 20100930                                          06570001
065800         CALL  IPCAL111 USING BILL-INPUT-DATA                     06580001
065900                              IPF-DATA-VARIABLES                  06590001
066000                              IPF-ADDITIONAL-VARIABLES            06600001
066100                              PRICER-OPT-VERS-SW                  06610001
066200                              PROV-NEW-HOLD                       06620001
066300                              CBSA-WAGE-INDEX-RECORD              06630001
066400         GOBACK.                                                  06640001
066500                                                                  06650001
066600**==============================================================**06660001
066700**          THIS NEXT CALL WILL PROCESS 2010 BILLS  WITH          06670001
066800**              A DISCHARGE DATE ON OR AFTER 20101001             06680001
066900**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06690001
067000**              USES THE CBSA FOR WAGE INDEXES                    06700001
067100**      FOR RY 2011 07/01/2010 TO 06/30/2011                      06710001
067200**==============================================================**06720001
067300     IF BILL-DISCHARGE-DATE                                       06730001
067400              > 20100630                                          06740001
067500         CALL  IPCAL110 USING BILL-INPUT-DATA                     06750001
067600                              IPF-DATA-VARIABLES                  06760001
067700                              IPF-ADDITIONAL-VARIABLES            06770001
067800                              PRICER-OPT-VERS-SW                  06780001
067900                              PROV-NEW-HOLD                       06790001
068000                              CBSA-WAGE-INDEX-RECORD              06800001
068100         GOBACK.                                                  06810001
068200**==============================================================**06820001
068300**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          06830001
068400**              A DISCHARGE DATE ON OR AFTER 20091001             06840001
068500**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   06850001
068600**              USES THE CBSA FOR WAGE INDEXES                    06860001
068700**      FOR RY 2010 10/01/2010 TO 06/30/2010                      06870001
068800**==============================================================**06880001
068900     IF BILL-DISCHARGE-DATE                                       06890001
069000              > 20090930                                          06900001
069100         CALL  IPCAL102 USING BILL-INPUT-DATA                     06910001
069200                              IPF-DATA-VARIABLES                  06920001
069300                              IPF-ADDITIONAL-VARIABLES            06930001
069400                              PRICER-OPT-VERS-SW                  06940001
069500                              PROV-NEW-HOLD                       06950001
069600                              CBSA-WAGE-INDEX-RECORD              06960001
069700         GOBACK.                                                  06970001
069800**==============================================================**06980001
069900**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          06990001
070000**              A DISCHARGE DATE ON OR AFTER 20090701             07000001
070100**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   07010001
070200**              USES THE CBSA FOR WAGE INDEXES                    07020001
070300**      FOR RY 2010 07/01/2009 TO 06/30/2010                      07030001
070400**==============================================================**07040001
070500     IF BILL-DISCHARGE-DATE                                       07050001
070600              > 20090630                                          07060001
070700         CALL  IPCAL100 USING BILL-INPUT-DATA                     07070001
070800                              IPF-DATA-VARIABLES                  07080001
070900                              IPF-ADDITIONAL-VARIABLES            07090001
071000                              PRICER-OPT-VERS-SW                  07100001
071100                              PROV-NEW-HOLD                       07110001
071200                              CBSA-WAGE-INDEX-RECORD              07120001
071300         GOBACK.                                                  07130001
071400**==============================================================**07140001
071500**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          07150001
071600**              A DISCHARGE DATE ON OR AFTER 20080930             07160001
071700**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   07170001
071800**              USES THE CBSA FOR WAGE INDEXES                    07180001
071900**      FOR RY 2009 10/01/2008 TO 06/30/2009                      07190001
072000**==============================================================**07200001
072100     IF BILL-DISCHARGE-DATE                                       07210001
072200              > 20080930                                          07220001
072300         CALL  IPCAL094 USING BILL-INPUT-DATA                     07230001
072400                              IPF-DATA-VARIABLES                  07240001
072500                              IPF-ADDITIONAL-VARIABLES            07250001
072600                              PRICER-OPT-VERS-SW                  07260001
072700                              PROV-NEW-HOLD                       07270001
072800                              CBSA-WAGE-INDEX-RECORD              07280001
072900         GOBACK.                                                  07290001
073000**==============================================================**07300001
073100**          THIS NEXT CALL WILL PROCESS 2009 BILLS  WITH          07310001
073200**              A DISCHARGE DATE ON OR AFTER 20080630             07320001
073300**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   07330001
073400**              USES THE CBSA FOR WAGE INDEXES                    07340001
073500**      FOR RY 2009 07/01/2008 TO 09/30/2009                      07350001
073600**==============================================================**07360001
073700     IF BILL-DISCHARGE-DATE                                       07370001
073800              > 20080630                                          07380001
073900         CALL  IPCAL09A USING BILL-INPUT-DATA                     07390001
074000                              IPF-DATA-VARIABLES                  07400001
074100                              IPF-ADDITIONAL-VARIABLES            07410001
074200                              PRICER-OPT-VERS-SW                  07420001
074300                              PROV-NEW-HOLD                       07430001
074400                              CBSA-WAGE-INDEX-RECORD              07440001
074500         GOBACK.                                                  07450001
074600**==============================================================**07460001
074700**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH          07470001
074800**              A DISCHARGE DATE ON OR AFTER 20070630             07480001
074900**              TO TAKE ADVANTAGE OF THE DRG' CHANGES EFFECTIVE   07490001
075000**              USES THE CBSA FOR WAGE INDEXES                    07500001
075100**      FOR RY 2008 10/01/2007 TO 07/01/2008                      07510001
075200**==============================================================**07520001
075300     IF BILL-DISCHARGE-DATE                                       07530001
075400              > 20070930                                          07540001
075500         CALL  IPCAL086 USING BILL-INPUT-DATA                     07550001
075600                              IPF-DATA-VARIABLES                  07560001
075700                              IPF-ADDITIONAL-VARIABLES            07570001
075800                              PRICER-OPT-VERS-SW                  07580001
075900                              PROV-NEW-HOLD                       07590001
076000                              CBSA-WAGE-INDEX-RECORD              07600001
076100         GOBACK.                                                  07610001
076200**==============================================================**07620001
076300**          THIS NEXT CALL WILL PROCESS 2008 BILLS  WITH          07630001
076400**              A DISCHARGE DATE ON OR AFTER 20070630             07640001
076500**              BUT BEFORE 20071001 WHEN DRG'S ARE REVISED        07650001
076600**              USES THE CBSA FOR WAGE INDEXES                    07660001
076700**      FOR RY 2008 07/01/2007 TO 10/01/2007                      07670001
076800**==============================================================**07680001
076900     IF BILL-DISCHARGE-DATE                                       07690001
077000              > 20070630                                          07700001
077100         CALL  IPCAL08A USING BILL-INPUT-DATA                     07710001
077200                              IPF-DATA-VARIABLES                  07720001
077300                              IPF-ADDITIONAL-VARIABLES            07730001
077400                              PRICER-OPT-VERS-SW                  07740001
077500                              PROV-NEW-HOLD                       07750001
077600                              CBSA-WAGE-INDEX-RECORD              07760001
077700         GOBACK.                                                  07770001
077800**==============================================================**07780001
077900**          THIS NEXT CALL WILL PROCESS 2007 BILLS  WITH          07790001
078000**              A DISCHARGE DATE ON OR AFTER 20060630             07800001
078100**              USES THE CBSA FOR WAGE INDEXES                    07810001
078200**      FOR RY 2007                                               07820001
078300**==============================================================**07830001
078400     IF BILL-DISCHARGE-DATE                                       07840001
078500              > 20060630                                          07850001
078600         CALL  IPCAL076 USING BILL-INPUT-DATA                     07860001
078700                              IPF-DATA-VARIABLES                  07870001
078800                              IPF-ADDITIONAL-VARIABLES            07880001
078900                              PRICER-OPT-VERS-SW                  07890001
079000                              PROV-NEW-HOLD                       07900001
079100                              CBSA-WAGE-INDEX-RECORD              07910001
079200         GOBACK.                                                  07920001
079300**==============================================================**07930001
079400**          THIS NEXT CALL WILL PROCESS 2005 BILLS  WITH          07940001
079500**              A DISCHARGE DATE ON OR AFTER 20050101             07950001
079600**              USES MSA FILE FOR WAGE INDEX                      07960001
079700**==============================================================**07970001
079800     IF BILL-DISCHARGE-DATE                                       07980001
079900              > 20041231                                          07990001
080000         CALL  IPCAL057 USING BILL-INPUT-DATA                     08000001
080100                              IPF-DATA-VARIABLES                  08010001
080200                              IPF-ADDITIONAL-VARIABLES            08020001
080300                              PRICER-OPT-VERS-SW                  08030001
080400                              PROV-NEW-HOLD                       08040001
080500                              WAGE-NEW-INDEX-RECORD               08050001
080600         GOBACK.                                                  08060001
080700**==============================================================**08070001
080800     MOVE 98 TO IPF-RTC.                                          08080001
080900     GOBACK.                                                      08090001
081000                                                                  08100001
081100 0100-GET-MSA.                                                    08110001
081200     SET MU1 TO 1.                                                08120001
081300                                                                  08130001
081400     SEARCH M-MSAX-DATA VARYING MU1                               08140001
081500     AT END                                                       08150001
081600          MOVE 999999 TO P-NEW-PROVIDER-NO                        08160001
081700          MOVE 52     TO IPF-RTC                                  08170001
081800          GO TO 0100-EXIT                                         08180001
081900     WHEN M-MSAX-MSA (MU1) = HOLD-PROV-MSAX                       08190001
082000          SET MU2 TO MU1.                                         08200001
082100                                                                  08210001
082200 0100-EXIT.  EXIT.                                                08220001
082300                                                                  08230001
082400 0150-GET-CBSA.                                                   08240001
082500     SET MA1 TO 1.                                                08250001
082600                                                                  08260001
082700     SEARCH TB-CBSA-DATA VARYING MA1                              08270001
082800     AT END                                                       08280001
082900          MOVE 999999 TO P-NEW-PROVIDER-NO                        08290001
083000          MOVE 52     TO IPF-RTC                                  08300001
083100          GO TO 0150-EXIT                                         08310001
083200     WHEN TB-CBSA (MA1) = HOLD-PROV-CBSA                          08320001
083300          SET MA2 TO MA1.                                         08330001
083400                                                                  08340001
083500 0150-EXIT.  EXIT.                                                08350001
083600                                                                  08360001
083700 0500-GET-MSA.                                                    08370001
083800     IF P-NEW-CHG-CODE-INDEX = 'Y'                                08380001
083900        MOVE P-NEW-WAGE-INDEX-LOC-MSA TO HOLD-PROV-MSAX           08390001
084000                                         IPF-MSA                  08400001
084100     ELSE                                                         08410001
084200        MOVE P-NEW-GEO-LOC-MSA9 TO HOLD-PROV-MSAX                 08420001
084300                                   IPF-MSA.                       08430001
084400                                                                  08440001
084500     PERFORM 0100-GET-MSA THRU 0100-EXIT.                         08450001
084600                                                                  08460001
084700***     RTC = 52  --  MSA NOT FOUND                               08470001
084800     IF IPF-RTC = 52    GOBACK.                                   08480001
084900                                                                  08490001
085000     IF IPF-RTC = 00                                              08500001
085100        PERFORM 0600-N-GET-WAGE-INDX                              08510001
085200           THRU 0600-N-EXIT VARYING MU2                           08520001
085300           FROM MU1 BY 1 UNTIL                                    08530001
085400           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.                 08540001
085500                                                                  08550001
085600***     RTC = 52  --  WAGE-INDEX NOT FOUND                        08560001
085700     IF IPF-RTC = 52    GOBACK.                                   08570001
085800                                                                  08580001
085900     IF W-NEW-INDEX-RECORD = 00.0000                              08590001
086000        MOVE 52 TO IPF-RTC.                                       08600001
086100                                                                  08610001
086200***  GET THE WAGE-SIZE                                            08620001
086300                                                                  08630001
086400     MOVE P-NEW-STAND-AMT-LOC-MSA TO HOLD-PROV-MSAX.              08640001
086500                                                                  08650001
086600     PERFORM 0100-GET-MSA THRU 0100-EXIT.                         08660001
086700                                                                  08670001
086800     IF IPF-RTC = 00                                              08680001
086900         PERFORM 0700-N-GET-WAGE-SIZE                             08690001
087000           THRU 0700-N-EXIT VARYING MU2                           08700001
087100           FROM MU1 BY 1 UNTIL                                    08710001
087200           M-MSAX-MSA (MU2) NOT = HOLD-PROV-MSAX.                 08720001
087300                                                                  08730001
087400***     RTC = 52  --  PR-WAGE-INDEX NOT FOUND                     08740001
087500     IF IPF-RTC = 52                                              08750001
087600          MOVE ALL '0' TO  IPF-ADDITIONAL-VARIABLES               08760001
087700          GOBACK.                                                 08770001
087800                                                                  08780001
087900 0500-EXIT.  EXIT.                                                08790001
088000                                                                  08800001
088100 0550-GET-CBSA.                                                   08810001
088200                                                                  08820001
088300     MOVE P-NEW-CBSA-GEO-LOC TO HOLD-PROV-CBSA                    08830001
088400                                IPF-CBSA.                         08840001
088500                                                                  08850001
088520*    SPECIAL WAGE INDEX EDIT                                      08852006
088530                                                                  08853006
088600     IF (P-NEW-CBSA-WI-SPECIAL AND                                08860001
088700         P-NEW-CBSA-SPEC-WI-N NOT NUMERIC)                        08870001
088800         MOVE 52 TO IPF-RTC                                       08880001
088900         GOBACK.                                                  08890001
089000                                                                  08900001
089100     IF (P-NEW-CBSA-WI-SPECIAL AND                                08910001
089200         P-NEW-CBSA-SPEC-WI-N = ZEROES)                           08920001
089300         MOVE 52 TO IPF-RTC                                       08930001
089400         GOBACK.                                                  08940001
089410                                                                  08941010
089411     IF P-NEW-CBSA-WI-SPECIAL                                     08941110
089412        MOVE 'SPEC*'  TO W-CBSA-X                                 08941210
089413        MOVE P-NEW-EFF-DATE TO W-CBSA-EFF-DATE                    08941310
089414        MOVE P-NEW-CBSA-SPEC-WI TO W-CBSA-INDEX                   08941410
089415        GO TO 0550-EXIT.                                          08941510
089416                                                                  08941619
089417*    SUPPLEMENTAL WAGE INDEX EDIT                                 08941706
089418                                                                  08941819
089420     IF BILL-DISCHARGE-DATE > W-FY2021-BEGIN-DT                   08942021
089421     OR BILL-DISCHARGE-DATE = W-FY2021-BEGIN-DT                   08942128
089424        IF P-NEW-SUPP-WI-IND = '1'                                08942421
089430           IF P-NEW-SUPP-WI  > ZERO                               08943021
089431               NEXT SENTENCE                                      08943119
089432           ELSE                                                   08943221
089440               MOVE 52 TO IPF-RTC                                 08944019
089450               GOBACK.                                            08945019
089460                                                                  08946010
089461     IF BILL-DISCHARGE-DATE > W-FY2021-BEGIN-DT                   08946131
089462     OR BILL-DISCHARGE-DATE = W-FY2021-BEGIN-DT                   08946231
089470        IF P-NEW-SUPP-WI-IND = '1'                                08947031
089480           IF P-NEW-EFF-DATE < W-FY2021-BEGIN-DT                  08948031
089490           OR P-NEW-EFF-DATE > W-FY2021-END-DT                    08949031
089500               MOVE 52 TO IPF-RTC                                 08950019
089600               GOBACK.                                            08960019
089610                                                                  08961010
089700*    RETRIEVE THE CBSA DATA                                       08970010
090100                                                                  09010001
090200     PERFORM 0150-GET-CBSA THRU 0150-EXIT.                        09020001
090300                                                                  09030001
090400***     RTC = 52  --  CBSA NOT FOUND                              09040001
090500     IF IPF-RTC = 52    GOBACK.                                   09050001
090600                                                                  09060001
090700     IF IPF-RTC = 00                                              09070001
090800        PERFORM 0650-N-GET-WAGE-INDX                              09080001
090900           THRU 0650-N-EXIT VARYING MA2                           09090001
091000           FROM MA1 BY 1 UNTIL                                    09100001
091100           TB-CBSA (MA2) NOT = HOLD-PROV-CBSA.                    09110001
091200                                                                  09120001
091300***     RTC = 52  --  WAGE-INDEX NOT FOUND                        09130001
091400     IF IPF-RTC = 52    GOBACK.                                   09140001
091500                                                                  09150001
091600     IF W-CBSA-INDEX       = 00.0000                              09160001
091700        MOVE 52 TO IPF-RTC.                                       09170001
091900***  CHECK IF SUPPLMENTAL WAGE INDEX SHOULD BE USED               09190010
091901***  TO CALCULATE THE EFFECTIVE WAGE INDEX                        09190110
091902***           ONLY FOR FY20201                                    09190210
091910                                                                  09191010
092000     IF IPF-RTC = 00                                              09200010
092010        IF BILL-DISCHARGE-DATE > W-FY2021-BEGIN-DT                09201020
092020        OR BILL-DISCHARGE-DATE = W-FY2021-BEGIN-DT                09202028
092100           PERFORM 0560-SUPP-WAGE-INDEX THRU 0560-EXIT.           09210010
092200                                                                  09220001
092300 0550-EXIT.  EXIT.                                                09230001
092400                                                                  09240001
092500 0560-SUPP-WAGE-INDEX.                                            09250001
092600                                                                  09260026
092700     IF SUPP-WI-PRIOR-YEAR                                        09270001
092800                                                                  09280032
092900        IF (( W-CBSA-INDEX - P-NEW-SUPP-WI) / P-NEW-SUPP-WI )     09290002
093000            < W-WI-PCT-REDUC-FY2020                               09300001
093100                                                                  09310032
093200            COMPUTE W-CBSA-INDEX ROUNDED = P-NEW-SUPP-WI *        09320001
093300                                           W-WI-PCT-ADJ-FY2020    09330001
093400            END-COMPUTE                                           09340001
093410                                                                  09341032
093500        END-IF                                                    09350001
093510                                                                  09351032
093600     END-IF.                                                      09360001
093700                                                                  09370001
093800 0560-EXIT.  EXIT.                                                09380001
093900                                                                  09390001
094000 0600-N-GET-WAGE-INDX.                                            09400001
094100                                                                  09410001
094200     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)          09420001
094300         MOVE M-MSAX-MSA        (MU2) TO W-NEW-MSA                09430001
094400         MOVE M-MSAX-EFF-DATE   (MU2) TO W-NEW-EFF-DATE           09440001
094500         MOVE M-MSAX-WAGE-INDX1 (MU2) TO W-NEW-INDEX-RECORD       09450001
094600         IF P-NEW-CHG-CODE-INDEX  = 'Y'                           09460001
094700            MOVE M-MSAX-WAGE-INDX2 (MU2) TO W-NEW-INDEX-RECORD.   09470001
094800                                                                  09480001
094900 0600-N-EXIT.  EXIT.                                              09490001
095000                                                                  09500001
095100 0650-N-GET-WAGE-INDX.                                            09510001
095200                                                                  09520001
095300     IF  BILL-DISCHARGE-DATE NOT < TB-CBSA-EFF-DATE (MA2)         09530001
095400         MOVE TB-CBSA            (MA2) TO W-CBSA                  09540001
095500         MOVE TB-CBSA-EFF-DATE   (MA2) TO W-CBSA-EFF-DATE         09550001
095600         MOVE TB-CBSA-WAGE-INDX1 (MA2) TO W-CBSA-INDEX.           09560001
095700                                                                  09570001
095800 0650-N-EXIT.  EXIT.                                              09580001
095900                                                                  09590001
096000                                                                  09600001
096100 0700-N-GET-WAGE-SIZE.                                            09610001
096200                                                                  09620001
096300     IF  BILL-DISCHARGE-DATE NOT < M-MSAX-EFF-DATE (MU2)          09630001
096400         IF  P-NEW-STD-RURAL-CHECK                                09640001
096500             MOVE 'R' TO W-NEW-SIZE                               09650001
096600         ELSE                                                     09660001
096700         IF  M-MSAX-SIZE (MU2) = 'L'                              09670001
096800             MOVE 'L' TO W-NEW-SIZE                               09680001
096900         ELSE                                                     09690001
097000             MOVE 'O' TO W-NEW-SIZE.                              09700001
097100                                                                  09710001
097200 0700-N-EXIT.  EXIT.                                              09720001
097300                                                                  09730001
097400 1350-N-CHECK-MSA.                                                09740001
097500     IF P-NEW-EFF-DATE < 20050701                                 09750001
097600        IF (P-NEW-WAGE-INDEX-LOC-MSA = '    ' OR                  09760001
097700            P-NEW-WAGE-INDEX-LOC-MSA = '0000')                    09770001
097800            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-WAGE-INDEX-LOC-MSA.  09780001
097900     IF P-NEW-EFF-DATE < 20050701                                 09790001
098000        IF (P-NEW-STAND-AMT-LOC-MSA = '    ' OR                   09800001
098100            P-NEW-STAND-AMT-LOC-MSA = '0000')                     09810001
098200            MOVE P-NEW-GEO-LOC-MSA9 TO P-NEW-STAND-AMT-LOC-MSA.   09820001
098300                                                                  09830001
098400     IF P-NEW-EFF-DATE < 20050701                                 09840001
098500        IF (P-NEW-CBSA-RECLASS-LOC = '     ' OR                   09850001
098600            P-NEW-CBSA-RECLASS-LOC = '00000')                     09860001
098700            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-RECLASS-LOC.   09870001
098800     IF P-NEW-EFF-DATE < 20050701                                 09880001
098900        IF (P-NEW-CBSA-STAND-AMT-LOC = '     ' OR                 09890001
099000            P-NEW-CBSA-STAND-AMT-LOC = '00000')                   09900001
099100            MOVE P-NEW-CBSA-GEO-LOC9 TO P-NEW-CBSA-STAND-AMT-LOC. 09910001
099200                                                                  09920001
099300 1350-N-EXIT.  EXIT.                                              09930001
099400                                                                  09940001
099500**==============================================================**09950001
099600**           L A S T   S O U R C E   S T A T E M E N T          **09960001
099700**==============================================================**09970001
