000100 IDENTIFICATION DIVISION.                                         00010001
000200 PROGRAM-ID. IRDRV180.                                            00020001
000300*AUTHOR.     PBG/DDS.                                             00030001
000400*      CENTERS FOR MEDICARE AND MEDICAID SERVICES                 00040001
000500*REMARKS.  - CALLS THE IRCAL__ MODULES                            00050001
000600*          - CONVERTED FOR CICS PROCESSING                        00060001
000700*          - FINDS PROV RECORD AND WAGE-INDEX RECORD FOR          00070001
000800*             GIVEN BILL TO BE PASSED TO IRCAL__ MODULES.         00080001
000900 DATE-COMPILED.                                                   00090001
001000****************************************************************  00100001
001010*                  *  *  *  *  *  *  *  *                      *  00101001
001100*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *  00110001
001200*   AND MEDICAID SERVICES.                                     *  00120001
001300*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *  00130001
001400*   PAYMENT FOR INPATIENT REHABILITATION FACILITIES.           *  00140001
001500*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *  00150001
001600*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *  00160001
001700*   IS THAT OF THE USER.                                       *  00170001
001800*                  *  *  *  *  *  *  *  *                      *  00180001
001900*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *  00190001
002000*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *  00200001
002100*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *  00210001
002200*   THE PROGRAM WILL:                                          *  00220001
002300*       1. FIND THE WAGE INDEX TO CALCULATE PPS.               *  00230001
002400*       2. EDIT THE BILL INFORMATION.                          *  00240001
002500*       3. PASS BACK RETURN CODES.                             *  00250001
002600*       4. CALCULATE WHEN APPLICABLE                           *  00260001
002700*          A. THE HOSPITAL SPECIFIC PART OF PAYMENT.           *  00270001
002800*          B. THE FEDERAL SPECIFIC PART OF PAYMENT.            *  00280001
002900*          C. THE OUTLIER PORTION.                             *  00290001
003000*          D. TOTAL PAYMENT (B + C + D  ABOVE).                *  00300001
003100*          E. DISPROPORTIONATE SHARE ADJUSTMENT                *  00310001
003200*                  *  *  *  *  *  *  *  *                      *  00320001
003300*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *  00330001
003400*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *  00340001
003500*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *  00350001
003600*                  *  *  *  *  *  *  *  *                      *  00360001
003700*   CHANGE LOG.                                                *  00370001
003800*                                                              *  00380001
003900*   FOR FUTURE USE.                                            *  00390001
004000*                                                              *  00400001
004100****************************************************************  00410001
004200 ENVIRONMENT DIVISION.                                            00420001
004300 CONFIGURATION SECTION.                                           00430001
004400 SOURCE-COMPUTER.            IBM-370.                             00440001
004500 OBJECT-COMPUTER.            IBM-370.                             00450001
004600 INPUT-OUTPUT  SECTION.                                           00460001
004700 FILE-CONTROL.                                                    00470001
004800 DATA DIVISION.                                                   00480001
004900 FILE SECTION.                                                    00490001
005100                                                                  00510001
005200 WORKING-STORAGE SECTION.                                         00520001
005300 77  W-STORAGE-REF                  PIC X(48)  VALUE              00530001
005400     'I R D R I V E R - W O R K I N G   S T O R A G E'.           00540001
005500 01  DRV-VERSION                    PIC X(05) VALUE 'V18.0'.      00550001
005600 01  IRCAL021                       PIC X(08) VALUE 'IRCAL021'.   00560001
005700 01  IRCAL031                       PIC X(08) VALUE 'IRCAL031'.   00570001
005800 01  IRCAL041                       PIC X(08) VALUE 'IRCAL041'.   00580001
005900 01  IRCAL051                       PIC X(08) VALUE 'IRCAL051'.   00590001
006000 01  IRCAL064                       PIC X(08) VALUE 'IRCAL064'.   00600001
006100 01  IRCAL070                       PIC X(08) VALUE 'IRCAL070'.   00610001
006110 01  IRCAL080                       PIC X(08) VALUE 'IRCAL080'.   00611001
006120 01  IRCAL090                       PIC X(08) VALUE 'IRCAL090'.   00612001
006130 01  IRCAL100                       PIC X(08) VALUE 'IRCAL100'.   00613001
006140 01  IRCAL110                       PIC X(08) VALUE 'IRCAL110'.   00614001
006150 01  IRCAL120                       PIC X(08) VALUE 'IRCAL120'.   00615001
006160 01  IRCAL130                       PIC X(08) VALUE 'IRCAL130'.   00616001
006170 01  IRCAL140                       PIC X(08) VALUE 'IRCAL140'.   00617001
006180 01  IRCAL150                       PIC X(08) VALUE 'IRCAL150'.   00618001
006190 01  IRCAL160                       PIC X(08) VALUE 'IRCAL160'.   00619001
006191 01  IRCAL170                       PIC X(08) VALUE 'IRCAL170'.   00619101
006192 01  IRCAL180                       PIC X(08) VALUE 'IRCAL180'.   00619201
006200 01  TABLES-LOADED-SW               PIC 9(01)  VALUE 0.           00620001
006300 01  EOF-SW                         PIC 9(01)  VALUE 0.           00630001
006400 01  EOF-SW1                        PIC 9(01)  VALUE 0.           00640001
006500                                                                  00650001
006600 01  W-PROV-NEW-HOLD.                                             00660001
006700     02  W-PROV-NEWREC-HOLD1.                                     00670001
006800         05  W-P-NEW-NPI10.                                       00680001
006900             10  W-P-NEW-NPI8           PIC X(08).                00690001
007000             10  W-P-NEW-NPI-FILLER     PIC X(02).                00700001
007100         05  W-P-NEW-PROVIDER-OSCAR-NO.                           00710001
007200             10  W-P-NEW-STATE          PIC X(02).                00720001
007300             10  FILLER                 PIC X(04).                00730001
007400         05  W-P-NEW-DATE-DATA.                                   00740001
007500             10  W-P-NEW-EFF-DATE.                                00750001
007600                 15  W-P-NEW-EFF-DT-CC    PIC 9(02).              00760001
007700                 15  W-P-NEW-EFF-DT-YY    PIC 9(02).              00770001
007800                 15  W-P-NEW-EFF-DT-MM    PIC 9(02).              00780001
007900                 15  W-P-NEW-EFF-DT-DD    PIC 9(02).              00790001
008000             10  W-P-NEW-FY-BEGIN-DATE.                           00800001
008100                 15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).              00810001
008200                 15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).              00820001
008300                 15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).              00830001
008400                 15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).              00840001
008500             10  W-P-NEW-REPORT-DATE.                             00850001
008600                 15  W-P-NEW-REPORT-DT-CC PIC 9(02).              00860001
008700                 15  W-P-NEW-REPORT-DT-YY PIC 9(02).              00870001
008800                 15  W-P-NEW-REPORT-DT-MM PIC 9(02).              00880001
008900                 15  W-P-NEW-REPORT-DT-DD PIC 9(02).              00890001
009000             10  W-P-NEW-TERMINATION-DATE.                        00900001
009100                 15  W-P-NEW-TERM-DT-CC   PIC 9(02).              00910001
009200                 15  W-P-NEW-TERM-DT-YY   PIC 9(02).              00920001
009300                 15  W-P-NEW-TERM-DT-MM   PIC 9(02).              00930001
009400                 15  W-P-NEW-TERM-DT-DD   PIC 9(02).              00940001
009500         05  W-P-NEW-WAIVER-CODE          PIC X(01).              00950001
009600             88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.            00960001
009700         05  W-P-NEW-INTER-NO             PIC X(05).              00970001
009800         05  W-P-NEW-PROVIDER-TYPE        PIC X(02).              00980001
009900         05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).              00990001
010000         05  W-P-NEW-MSA-DATA.                                    01000001
010100             10  W-P-NEW-CHG-CODE-INDEX    PIC X.                 01010001
010200             10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT. 01020001
010300             10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT. 01030001
010400             10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT. 01040001
010500             10  W-P-NEW-STAND-AMT-LOC-MSA9                       01050001
010600       REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.                       01060001
010700                 15  W-P-NEW-RURAL-1ST.                           01070001
010800                     20  W-P-NEW-STAND-RURAL  PIC XX.             01080001
010900                 15  W-P-NEW-RURAL-2ND        PIC XX.             01090001
011000         05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                  01100001
011100         05  W-P-NEW-LUGAR               PIC X.                   01110001
011200         05  W-P-NEW-TEMP-RELIEF-IND     PIC X.                   01120001
011300         05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.                   01130001
011400         05  FILLER                      PIC X(05).               01140001
011500     02  W-PROV-NEWREC-HOLD2.                                     01150001
011600         05  W-P-NEW-VARIABLES.                                   01160001
011700             10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).            01170001
011800             10  W-P-NEW-COLA              PIC  X(04).            01180001
011900             10  W-P-NEW-INTERN-RATIO      PIC  X(05).            01190001
012000             10  W-P-NEW-BED-SIZE          PIC  X(05).            01200001
012100             10  W-P-NEW-CCR               PIC  X(04).            01210001
012200             10  W-P-NEW-CMI               PIC  X(05).            01220001
012300             10  W-P-NEW-SSI-RATIO         PIC  X(04).            01230001
012400             10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).            01240001
012500             10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).            01250001
012600             10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).      01260001
012700             10  W-P-NEW-DSH-PERCENT       PIC  V9(04).           01270001
012800             10  W-P-NEW-FYE-DATE.                                01280001
012900                 15  W-P-NEW-FYE-CC        PIC 99.                01290001
013000                 15  W-P-NEW-FYE-YY        PIC 99.                01300001
013100                 15  W-P-NEW-FYE-MM        PIC 99.                01310001
013200                 15  W-P-NEW-FYE-DD        PIC 99.                01320001
013300         05  W-P-NEW-CBSA-DATA.                                   01330001
013400             10  W-P-NEW-CBSA-SPEC-PAY-IND   PIC X.               01340001
013500             10  W-P-NEW-CBSA-HOSP-QUAL-IND  PIC X.               01350001
013600             10  W-P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.01360001
013700             10  W-P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.01370001
013800             10  W-P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.01380001
013900             10  W-P-NEW-CBSA-STAND-AMT-LOC9                      01390001
014000                 REDEFINES W-P-NEW-CBSA-STAND-AMT-LOC.            01400001
014100                 15  W-P-NEW-CBSA-RURAL-1ST.                      01410001
014200                     20  W-P-NEW-CBSA-STAND-RURAL PIC 999.        01420001
014300                 15  W-P-NEW-CBSA-RURAL-2ND       PIC 99.         01430001
014400             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).01440001
014500     02  W-PROV-NEWREC-HOLD3.                                     01450001
014600         05  W-P-NEW-PASS-AMT-DATA.                               01460001
014700             10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).           01470001
014800             10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).           01480001
014900             10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).           01490001
015000             10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).           01500001
015100         05  W-P-NEW-CAPI-DATA.                                   01510001
015200             15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.               01520001
015300             15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).            01530001
015400             15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).            01540001
015500             15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).            01550001
015600             15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).           01560001
015700             15  W-P-NEW-CAPI-NEW-HOSP       PIC X.               01570001
015800             15  W-P-NEW-CAPI-IME            PIC X(05).           01580001
015900             15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).            01590001
015910             15  W-P-VAL-BASED-PURCH-SCORE   PIC 9V999.           01591001
016000         05  FILLER                          PIC X(18).           01600001
016100                                                                  01610001
016200 01  PROV-STAT.                                                   01620001
016300     02  PROV-STAT1                          PIC X.               01630001
016400     02  PROV-STAT2                          PIC X.               01640001
016500                                                                  01650001
016600 01  CBSAX-STAT.                                                  01660001
016700     02  CBSAX-STAT1                         PIC X.               01670001
016800     02  CBSAX-STAT2                         PIC X.               01680001
016900                                                                  01690001
017000 01  MSAX-STAT.                                                   01700001
017100     02  MSAX-STAT1                          PIC X.               01710001
017200     02  MSAX-STAT2                          PIC X.               01720001
017300                                                                  01730001
017400 01  HOLD-PROV-MSA.                                               01740001
017500     10  H-MSA-PROV-BLANK                    PIC X(2).            01750001
017600     10  H-MSA-PROV-STATE.                                        01760001
017700         15  FILLER                          PIC X.               01770001
017800         15  HOLD-LAST-MSA-POS               PIC X.               01780001
017900                                                                  01790001
018000 01  HOLD-PROV-CBSA.                                              01800001
018100     10  H-CBSA-PROV-BLANK                   PIC X(3).            01810001
018200     10  H-CBSA-PROV-STATE.                                       01820001
018300         15  FILLER                          PIC X.               01830001
018400         15  HOLD-LAST-CBSA-POS              PIC X.               01840001
018500                                                                  01850001
018600 01  WORK-COUNTERS.                                               01860001
018700     05  CBSA-CNT                            PIC 9(5) VALUE ZERO. 01870001
018800     05  MSA-CNT                             PIC 9(5) VALUE ZERO. 01880001
018900     05  PROV-CNT                            PIC 9(5) VALUE ZERO. 01890001
019000***************************************************************   01900001
019100*    THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY     *   01910001
019200*    SET TO OCCUR 2400 TIMES. THIS NUMBER SHOULD BE ADJUSTED  *   01920001
019300*    BY THE USER TO REFLECT THE NUMBER OF PROVIDER RECORDS    *   01930001
019400*    PLUS EXPANSION. EACH ENTRY COSTS 240 BYTES OF MEMORY.    *   01940001
019500*    THIS FILE MUST BE IN PROVIDER NUMBER, EFFECTIVE-DATE     *   01950001
019600*    SEQUENCE.                                                *   01960001
019700***************************************************************   01970001
019800*01  PROV-TABLE.                                                  01980001
019900*    05  PROV-ENTRIES       OCCURS 0 TO 2400 TIMES                01990001
020000*                           DEPENDING ON PROV-CNT                 02000001
020100*                           ASCENDING KEY IS PROV-NO              02010001
020200*                           INDEXED BY PX1.                       02020001
020300 01  PROV-TABLE.                                                  02030001
020400     05  PROV-ENTRIES       OCCURS 2400 TIMES                     02040001
020500                            INDEXED BY PX1.                       02050001
020600         10  PROV-DATA1.                                          02060001
020700             15  PROV-NPI10.                                      02070001
020800                 20  PROV-NPI8               PIC X(08).           02080001
020900                 20  PROV-NPI-FILLER         PIC X(02).           02090001
021000             15  PROV-NO                     PIC X(06).           02100001
021100             15  PROV-EFF-DATE               PIC X(08).           02110001
021200             15  FILLER                      PIC X(56).           02120001
021300 01  PROV-DATA-2.                                                 02130001
021400     05  PROV-ENTRIES2      OCCURS 2400 TIMES                     02140001
021500                            INDEXED BY PD2.                       02150001
021600         10  PROV-DATA2                      PIC X(80).           02160001
021700 01  PROV-DATA-3.                                                 02170001
021800     05  PROV-ENTRIES3      OCCURS 2400 TIMES                     02180001
021900                            INDEXED BY PD3.                       02190001
022000         10  PROV-DATA3                      PIC X(80).           02200001
022100                                                                  02210001
022200***************************************************************   02220001
022300*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   02230001
022400*      THE IRCAL___ PROGRAM FOR PROCESSING MSA'S              *   02240001
022500***************************************************************   02250001
022600 01  WAGE-NEW-INDEX-RECORD.                                       02260001
022700     05  W-NEW-MSA                           PIC 9(4).            02270001
022800     05  W-NEW-EFF-DATE.                                          02280001
022900          10  W-NEW-EFF-DATE-CC              PIC 9(2).            02290001
023000          10  W-NEW-EFF-DATE-YMD.                                 02300001
023100              15  W-NEW-EFF-DATE-YY          PIC 9(2).            02310001
023200              15  W-NEW-EFF-DATE-MM          PIC 9(2).            02320001
023300              15  W-NEW-EFF-DATE-DD          PIC 9(2).            02330001
023400     05  W-NEW-INDEX-RECORD                  PIC S9(02)V9(04).    02340001
023500                                                                  02350001
023600***************************************************************   02360001
023700*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   02370001
023800*      THE IRCAL___ PROGRAM FOR PROCESSING CBSA'S             *   02380001
023900***************************************************************   02390001
024000 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  02400001
024100     05  W-NEW-CBSA                          PIC 9(5).            02410001
024200     05  W-NEW-EFF-DATE-C.                                        02420001
024300          10  W-NEW-EFF-DATE-CC-C            PIC 9(2).            02430001
024400          10  W-NEW-EFF-DATE-YMD-C.                               02440001
024500              15  W-NEW-EFF-DATE-YY-C        PIC 9(2).            02450001
024600              15  W-NEW-EFF-DATE-MM-C        PIC 9(2).            02460001
024700              15  W-NEW-EFF-DATE-DD-C        PIC 9(2).            02470001
024800     05  W-NEW-INDEX-RECORD-C                PIC S9(02)V9(04).    02480001
024900                                                                  02490001
025000**************************************************************    02500001
025100*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *    02510001
025200*      THE IRCAL___ PROGRAM                                  *    02520001
025300**************************************************************    02530001
025400 01  PROV-NEW-HOLD.                                               02540001
025500     02  PROV-NEWREC-HOLD1.                                       02550001
025600         05  P-NEW-NPI10.                                         02560001
025700             10  P-NEW-NPI8                 PIC X(08).            02570001
025800             10  P-NEW-NPI-FILLER           PIC X(02).            02580001
025900         05  P-NEW-PROVIDER-NO.                                   02590001
026000             10  P-NEW-STATE                PIC 9(02).            02600001
026100             10  FILLER                     PIC X(04).            02610001
026200         05  P-NEW-DATE-DATA.                                     02620001
026300             10  P-NEW-EFF-DATE.                                  02630001
026400                 15  P-NEW-EFF-DT-CC        PIC 9(02).            02640001
026500                 15  P-NEW-EFF-DT-YY        PIC 9(02).            02650001
026600                 15  P-NEW-EFF-DT-MM        PIC 9(02).            02660001
026700                 15  P-NEW-EFF-DT-DD        PIC 9(02).            02670001
026800             10  P-NEW-FY-BEGIN-DATE.                             02680001
026900                 15  P-NEW-FY-BEG-DT-CC     PIC 9(02).            02690001
027000                 15  P-NEW-FY-BEG-DT-YY     PIC 9(02).            02700001
027100                 15  P-NEW-FY-BEG-DT-MM     PIC 9(02).            02710001
027200                 15  P-NEW-FY-BEG-DT-DD     PIC 9(02).            02720001
027300             10  P-NEW-REPORT-DATE.                               02730001
027400                 15  P-NEW-REPORT-DT-CC     PIC 9(02).            02740001
027500                 15  P-NEW-REPORT-DT-YY     PIC 9(02).            02750001
027600                 15  P-NEW-REPORT-DT-MM     PIC 9(02).            02760001
027700                 15  P-NEW-REPORT-DT-DD     PIC 9(02).            02770001
027800             10  P-NEW-TERMINATION-DATE.                          02780001
027900                 15  P-NEW-TERM-DT-CC       PIC 9(02).            02790001
028000                 15  P-NEW-TERM-DT-YY       PIC 9(02).            02800001
028100                 15  P-NEW-TERM-DT-MM       PIC 9(02).            02810001
028200                 15  P-NEW-TERM-DT-DD       PIC 9(02).            02820001
028300         05  P-NEW-WAIVER-CODE              PIC X(01).            02830001
028400             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              02840001
028500         05  P-NEW-INTER-NO                 PIC 9(05).            02850001
028600         05  P-NEW-PROVIDER-TYPE            PIC X(02).            02860001
028700         05  P-NEW-CURRENT-CENSUS-DIV       PIC 9(01).            02870001
028800         05  P-NEW-CURRENT-DIV   REDEFINES                        02880001
028900                 P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).            02890001
029000         05  P-NEW-MSA-DATA.                                      02900001
029100             10  P-NEW-CHG-CODE-INDEX       PIC X.                02910001
029200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02920001
029300             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02930001
029400                        P-NEW-GEO-LOC-MSAX  PIC 9(04).            02940001
029500             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  02950001
029600                        P-NEW-GEO-LOC-MSA9.                       02960001
029700                 15  P-NEW-GEO-MSA-1ST      PIC X.                02970001
029800                 15  P-NEW-GEO-MSA-2ND      PIC X.                02980001
029900                 15  P-NEW-GEO-MSA-3RD      PIC X.                02990001
030000                 15  P-NEW-GEO-MSA-4TH      PIC X.                03000001
030100             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 03010001
030200             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 03020001
030300             10  P-NEW-STAND-AMT-LOC-MSA9                         03030001
030400                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.             03040001
030500                 15  P-NEW-RURAL-1ST.                             03050001
030600                     20  P-NEW-STAND-RURAL  PIC XX.               03060001
030700                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    03070001
030800                 15  P-NEW-RURAL-2ND        PIC XX.               03080001
030900         05  P-NEW-SOL-COM-DEP-HOSP-YR      PIC XX.               03090001
031000                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           03100001
031100                 88  P-NEW-SCH-YR82       VALUE   '82'.           03110001
031200                 88  P-NEW-SCH-YR87       VALUE   '87'.           03120001
031300         05  P-NEW-LUGAR                    PIC X.                03130001
031400         05  P-NEW-TEMP-RELIEF-IND          PIC X.                03140001
031500         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                03150001
031600         05  FILLER                         PIC X(05).            03160001
031700     02  PROV-NEWREC-HOLD2.                                       03170001
031800         05  P-NEW-VARIABLES.                                     03180001
031900             10  P-NEW-FAC-SPEC-RATE        PIC  9(05)V9(02).     03190001
032000             10  P-NEW-COLA                 PIC  9(01)V9(03).     03200001
032100             10  P-NEW-INTERN-RATIO         PIC  9(01)V9(04).     03210001
032200             10  P-NEW-BED-SIZE             PIC  9(05).           03220001
032300             10  P-NEW-CCR                  PIC  9(01)V9(03).     03230001
032400             10  P-NEW-CMI                  PIC  9(01)V9(04).     03240001
032500             10  P-NEW-SSI-RATIO            PIC  V9(04).          03250001
032600             10  P-NEW-MEDICAID-RATIO       PIC  V9(04).          03260001
032700             10  P-NEW-PPS-BLEND-YR-IND     PIC  X(01).           03270001
032800             10  P-NEW-PRUP-UPDTE-FACTOR    PIC  9(01)V9(05).     03280001
032900             10  P-NEW-DSH-PERCENT          PIC  V9(04).          03290001
033000             10  P-NEW-FYE-DATE.                                  03300001
033100                 15  P-NEW-FYE-CC           PIC 99.               03310001
033200                 15  P-NEW-FYE-YY           PIC 99.               03320001
033300                 15  P-NEW-FYE-MM           PIC 99.               03330001
033400                 15  P-NEW-FYE-DD           PIC 99.               03340001
033500         05  P-NEW-CBSA-DATA.                                     03350001
033600             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                03360001
033700             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.                03370001
033800             10  P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT.   03380001
033900             10  P-NEW-GEO-LOC-CBSA9   REDEFINES                  03390001
034000                        P-NEW-CBSA-GEO-LOC  PIC 9(05).            03400001
034100             10  P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT.   03410001
034200             10  P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT.   03420001
034300             10  P-NEW-CBSA-STAND-AMT-LOC9                        03430001
034400                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              03440001
034500                 15  P-NEW-CBSA-RURAL-1ST.                        03450001
034600                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          03460001
034700                 15  P-NEW-CBSA-RURAL-2ND    PIC 99.              03470001
034800             10  P-NEW-CBSA-WAGE-INDEX       PIC 9(02)V9(04).     03480001
034900     02  PROV-NEWREC-HOLD3.                                       03490001
035000         05  P-NEW-PASS-AMT-DATA.                                 03500001
035100             10  P-NEW-PASS-AMT-CAPITAL     PIC 9(04)V99.         03510001
035200             10  P-NEW-PASS-AMT-DIR-MED-ED  PIC 9(04)V99.         03520001
035300             10  P-NEW-PASS-AMT-ORGAN-ACQ   PIC 9(04)V99.         03530001
035400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          03540001
035500         05  P-NEW-CAPI-DATA.                                     03550001
035600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 03560001
035700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          03570001
035800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          03580001
035900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        03590001
036000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             03600001
036100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 03610001
036200             15  P-NEW-CAPI-IME            PIC 9V9999.            03620001
036300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          03630001
036400         05  FILLER                        PIC X(22).             03640001
036500                                                                  03650001
036600***************************************************************   03660001
036700 LINKAGE SECTION.                                                 03670001
036800                                                                  03680001
036900**************************************************************    03690001
037000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *    03700001
037100*      THE IRCAL___ PROGRAM                                  *    03710001
037200**************************************************************    03720001
037300 01  BILL-NEW-DATA.                                               03730001
037400     05  B-NPI10.                                                 03740001
037500         10  B-NPI8                   PIC X(08).                  03750001
037600         10  B-NPI-FILLER             PIC X(02).                  03760001
037700     05  B-PROVIDER-NO                PIC X(06).                  03770001
037800     05  B-PATIENT-STATUS             PIC X(02).                  03780001
037900     05  B-CMG-CODE                   PIC X(05).                  03790001
038000     05  B-LOS                        PIC 9(03).                  03800001
038100     05  B-COVERED-DAYS               PIC 9(03).                  03810001
038200     05  B-LTR-DAYS                   PIC 9(02).                  03820001
038300     05  B-SPEC-PYMT-IND              PIC X(01).                  03830001
038400     05  B-DISCHARGE-DATE.                                        03840001
038500         10  B-DISCHG-CC              PIC 9(02).                  03850001
038600         10  B-DISCHG-YY              PIC 9(02).                  03860001
038700         10  B-DISCHG-MM              PIC 9(02).                  03870001
038800         10  B-DISCHG-DD              PIC 9(02).                  03880001
038900     05  B-COVERED-CHARGES            PIC 9(07)V9(02).            03890001
039000     05  FILLER                       PIC X(11).                  03900001
039100                                                                  03910001
039200 01  PPS-DATA-ALL.                                                03920001
039300     05  PPS-RTC                      PIC 9(02).                  03930001
039400     05  PPS-DATA.                                                03940001
039500         10  PPS-MSA                  PIC X(04).                  03950001
039600         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03960001
039700         10  PPS-AVG-LOS              PIC 9(02).                  03970001
039800         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03980001
039900         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03990001
040000         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            04000001
040100         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            04010001
040200         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            04020001
040300         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            04030001
040400         10  PPS-LIP-PCT              PIC 9(01)V9(04).            04040001
040500         10  PPS-LOS                  PIC 9(03).                  04050001
040600         10  PPS-REG-DAYS-USED        PIC 9(03).                  04060001
040700         10  PPS-LTR-DAYS-USED        PIC 9(03).                  04070001
040800         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            04080001
040900         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            04090001
041000         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            04100001
041100         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            04110001
041200         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            04120001
041300         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           04130001
041400         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            04140001
041500         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            04150001
041600         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            04160001
041700         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            04170001
041800         10  PPS-SUBM-CMG-CODE        PIC X(05).                  04180001
041900         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      04190001
042000             15  PPS-CMG-ALPHA        PIC X(01).                  04200001
042100             15  PPS-CMG-NUMERIC.                                 04210001
042200                20  PPS-CMG-RIC       PIC X(02).                  04220001
042300                20  FILLER            PIC X(02).                  04230001
042400         10  PPS-PRICED-CMG-CODE      PIC X(05).                  04240001
042500         10  PPS-CALC-VERS-CD         PIC X(05).                  04250001
042600         10  PPS-CBSA                 PIC X(05).                  04260001
042700         10  FILLER                   PIC X(08).                  04270001
042800    05  PPS-OTHER-DATA.                                           04280001
042900         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            04290001
043000         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            04300001
043100         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            04310001
043200         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            04320001
043300         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            04330001
043400         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            04340001
043500         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            04350001
043600         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            04360001
043700         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            04370001
043800         10  FILLER                   PIC X(02).                  04380001
043900    05  PPS-PC-DATA.                                              04390001
044000         10  PPS-COT-IND              PIC X(01).                  04400001
044100         10  FILLER                   PIC X(20).                  04410001
044200                                                                  04420001
044300***************************************************************** 04430001
044400*            THESE ARE THE VERSIONS OF THE IRDRV050               04440001
044500*           PROGRAMS THAT WILL BE PASSED BACK----                 04450001
044600*          ASSOCIATED WITH THE BILL BEING PROCESSED               04460001
044700***************************************************************** 04470001
044800                                                                  04480001
044900 01  PRICER-OPT-VERS-SW.                                          04490001
045000     05  PRICER-OPTION-SW               PIC X(01).                04500001
045100         88  ALL-TABLES-PASSED          VALUE 'A'.                04510001
045200         88  PROV-RECORD-PASSED         VALUE 'P'.                04520001
045300     05  PPS-VERSIONS.                                            04530001
045400         10  PPDRV-VERSION              PIC X(05).                04540001
045500                                                                  04550001
045600**************************************************************    04560001
045700*      PROVIDER SPECIFIC RECORD                              *    04570001
045800**************************************************************    04580001
045900 01  PROV-RECORD.                                                 04590001
046000     05  PROV-REC1                  PIC X(80).                    04600001
046100     05  PROV-REC2                  PIC X(80).                    04610001
046200     05  PROV-REC3                  PIC X(80).                    04620001
046300                                                                  04630001
046400**************************************************************    04640001
046500*      METROPOLITAN STATISTICAL AREA TABLE                   *    04650001
046600**************************************************************    04660001
046700*01  MSA-WI-TABLE.                                                04670001
046800*    05  M-MSA-DATA    OCCURS 0 TO 4000 TIMES                     04680001
046900*                      DEPENDING ON MSA-CNT                       04690001
047000*                      ASCENDING KEY IS MSAX-MSA                  04700001
047100*                      INDEXED BY MU1 MU2.                        04710001
047200 01  MSA-WI-TABLE.                                                04720001
047300     05  M-MSA-DATA    OCCURS 4000 TIMES                          04730001
047400                       INDEXED BY MU1 MU2.                        04740001
047500         10  MSAX-MSA                        PIC X(4).            04750001
047600         10  MSAX-EFF-DATE                   PIC X(08).           04760001
047700         10  MSAX-WAGE-INDEX                 PIC S9(02)V9(04).    04770001
047800                                                                  04780001
047900**************************************************************    04790001
048000*      CORE BASED STATISTICAL AREA TABLE                     *    04800001
048100**************************************************************    04810001
048200*01  CBSA-WI-TABLE.                                               04820001
048300*    05  M-CBSA-DATA   OCCURS 0 TO 6000 TIMES                     04830001
048400*                      DEPENDING ON CBSA-CNT                      04840001
048500*                      ASCENDING KEY IS CBSAX-CBSA                04850001
048600*                      INDEXED BY MU3 MU4.                        04860001
048700 01  CBSA-WI-TABLE.                                               04870001
048800     05  M-CBSA-DATA   OCCURS 6000 TIMES                          04880001
048900                       INDEXED BY MU3 MU4.                        04890001
049000         10  CBSAX-CBSA                      PIC X(5).            04900001
049100         10  CBSAX-EFF-DATE                  PIC X(08).           04910001
049200         10  CBSAX-WAGE-INDEX                PIC S9(02)V9(04).    04920001
049300                                                                  04930001
049400 PROCEDURE DIVISION  USING BILL-NEW-DATA                          04940001
049500                           PPS-DATA-ALL                           04950001
049600                           PRICER-OPT-VERS-SW                     04960001
049700                           PROV-RECORD                            04970001
049800                           MSA-WI-TABLE                           04980001
049900                           CBSA-WI-TABLE.                         04990001
050000                                                                  05000001
050100******************************************************************05010001
050200*    PROCESSING:                                                  05020001
050300*        A. THIS MODULE WILL CALL THE IRCAL MODULES.              05030001
050400*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  05040001
050500*           SUBROUTINE IS CALLED.                                 05050001
050600*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH 05060001
050700*           EACH BILL WILL BE PASSED TO THE IRCAL PROGRAMS.       05070001
050800******************************************************************05080001
050900     INITIALIZE PPS-DATA-ALL.                                     05090001
051000     INITIALIZE PROV-NEW-HOLD.                                    05100001
051010     INITIALIZE WAGE-NEW-INDEX-RECORD-CBSA.                       05101001
051100     MOVE DRV-VERSION TO PPDRV-VERSION.                           05110001
051200     MOVE PROV-RECORD TO PROV-NEW-HOLD.                           05120001
051300                                                                  05130001
051310******************************************************************05131001
051400***     RTC = 98  --  THIS IS A BILL OLDER THAN 20020101       ***05140001
051500******************************************************************05150001
051510                                                                  05151001
051520     IF B-DISCHARGE-DATE > 20011231                               05152001
051530        CONTINUE                                                  05153001
051540     ELSE                                                         05154001
051550         MOVE 98 TO PPS-RTC                                       05155001
051600         GOBACK.                                                  05160001
052000                                                                  05200001
052100******************************************************************05210001
052200***  GET THE WAGE-INDEX                                           05220001
052300******************************************************************05230001
052400                                                                  05240001
052500     SET MU1 MU3 TO 1.                                            05250001
052600     IF B-DISCHARGE-DATE > 20050930                               05260001
052700        PERFORM 0550-GET-CBSA THRU 0550-EXIT                      05270001
052800     ELSE                                                         05280001
052900        PERFORM 0500-GET-MSA THRU 0500-EXIT.                      05290001
053000                                                                  05300001
053100***     RTC = 60  --  WAGE-INDEX NOT FOUND                        05310001
053200     IF PPS-RTC = 60                                              05320001
053300          GOBACK.                                                 05330001
053400                                                                  05340001
053600******************************************************************05360001
053700**          THE NEXT LOGIC WILL PROCESS THE PROPER IRCAL MODULE   05370001
053800**          BASED ON THE DISCHARGE DATE.                          05380001
053900******************************************************************05390001
053910*                ADD LOGIC EVERY YEAR FOR NEW MODULE              05391001
054201                                                                  05420101
054220     IF (B-DISCHARGE-DATE > 20170930 AND                          05422001
054230         B-DISCHARGE-DATE < 20181001)                             05423001
054300         CALL  IRCAL180 USING BILL-NEW-DATA                       05430001
054400                              PPS-DATA-ALL                        05440001
054500                              PRICER-OPT-VERS-SW                  05450001
054600                              PROV-NEW-HOLD                       05460001
054700                              WAGE-NEW-INDEX-RECORD-CBSA.         05470001
054701                                                                  05470101
054702     IF (B-DISCHARGE-DATE > 20160930 AND                          05470201
054703         B-DISCHARGE-DATE < 20171001)                             05470301
054704         CALL  IRCAL170 USING BILL-NEW-DATA                       05470401
054705                              PPS-DATA-ALL                        05470501
054706                              PRICER-OPT-VERS-SW                  05470601
054707                              PROV-NEW-HOLD                       05470701
054708                              WAGE-NEW-INDEX-RECORD-CBSA.         05470801
054709                                                                  05470901
054710     IF (B-DISCHARGE-DATE > 20150930 AND                          05471001
054711         B-DISCHARGE-DATE < 20161001)                             05471101
054712         CALL  IRCAL160 USING BILL-NEW-DATA                       05471201
054713                              PPS-DATA-ALL                        05471301
054714                              PRICER-OPT-VERS-SW                  05471401
054715                              PROV-NEW-HOLD                       05471501
054716                              WAGE-NEW-INDEX-RECORD-CBSA.         05471601
054717                                                                  05471701
054718     IF (B-DISCHARGE-DATE > 20140930 AND                          05471801
054719         B-DISCHARGE-DATE < 20151001)                             05471901
054720         CALL  IRCAL150 USING BILL-NEW-DATA                       05472001
054721                              PPS-DATA-ALL                        05472101
054722                              PRICER-OPT-VERS-SW                  05472201
054723                              PROV-NEW-HOLD                       05472301
054724                              WAGE-NEW-INDEX-RECORD-CBSA.         05472401
054725                                                                  05472501
054726     IF (B-DISCHARGE-DATE > 20130930 AND                          05472601
054727         B-DISCHARGE-DATE < 20141001)                             05472701
054728         CALL  IRCAL140 USING BILL-NEW-DATA                       05472801
054729                              PPS-DATA-ALL                        05472901
054730                              PRICER-OPT-VERS-SW                  05473001
054731                              PROV-NEW-HOLD                       05473101
054732                              WAGE-NEW-INDEX-RECORD-CBSA.         05473201
054733                                                                  05473301
054734     IF (B-DISCHARGE-DATE > 20120930 AND                          05473401
054735         B-DISCHARGE-DATE < 20131001)                             05473501
054736         CALL  IRCAL130 USING BILL-NEW-DATA                       05473601
054737                              PPS-DATA-ALL                        05473701
054738                              PRICER-OPT-VERS-SW                  05473801
054739                              PROV-NEW-HOLD                       05473901
054740                              WAGE-NEW-INDEX-RECORD-CBSA.         05474001
054741                                                                  05474101
054742     IF (B-DISCHARGE-DATE > 20110930 AND                          05474201
054743         B-DISCHARGE-DATE < 20121001)                             05474301
054744         CALL  IRCAL120 USING BILL-NEW-DATA                       05474401
054745                              PPS-DATA-ALL                        05474501
054746                              PRICER-OPT-VERS-SW                  05474601
054747                              PROV-NEW-HOLD                       05474701
054748                              WAGE-NEW-INDEX-RECORD-CBSA.         05474801
054749                                                                  05474901
054750     IF (B-DISCHARGE-DATE > 20100930 AND                          05475001
054751         B-DISCHARGE-DATE < 20111001)                             05475101
054752         CALL  IRCAL110 USING BILL-NEW-DATA                       05475201
054753                              PPS-DATA-ALL                        05475301
054754                              PRICER-OPT-VERS-SW                  05475401
054755                              PROV-NEW-HOLD                       05475501
054756                              WAGE-NEW-INDEX-RECORD-CBSA.         05475601
054757                                                                  05475701
054758     IF (B-DISCHARGE-DATE > 20090930 AND                          05475801
054759         B-DISCHARGE-DATE < 20101001)                             05475901
054760         CALL  IRCAL100 USING BILL-NEW-DATA                       05476001
054761                              PPS-DATA-ALL                        05476101
054762                              PRICER-OPT-VERS-SW                  05476201
054763                              PROV-NEW-HOLD                       05476301
054764                              WAGE-NEW-INDEX-RECORD-CBSA.         05476401
054765                                                                  05476501
054766     IF (B-DISCHARGE-DATE > 20080930 AND                          05476601
054767         B-DISCHARGE-DATE < 20091001)                             05476701
054768         CALL  IRCAL090 USING BILL-NEW-DATA                       05476801
054769                              PPS-DATA-ALL                        05476901
054770                              PRICER-OPT-VERS-SW                  05477001
054771                              PROV-NEW-HOLD                       05477101
054772                              WAGE-NEW-INDEX-RECORD-CBSA.         05477201
054773                                                                  05477301
054774     IF (B-DISCHARGE-DATE > 20070930 AND                          05477401
054775         B-DISCHARGE-DATE < 20081001)                             05477501
054776         CALL  IRCAL080 USING BILL-NEW-DATA                       05477601
054777                              PPS-DATA-ALL                        05477701
054778                              PRICER-OPT-VERS-SW                  05477801
054779                              PROV-NEW-HOLD                       05477901
054780                              WAGE-NEW-INDEX-RECORD-CBSA.         05478001
054800                                                                  05480001
054810     IF (B-DISCHARGE-DATE > 20060930 AND                          05481001
054820         B-DISCHARGE-DATE < 20071001)                             05482001
054830         CALL  IRCAL070 USING BILL-NEW-DATA                       05483001
054840                              PPS-DATA-ALL                        05484001
054850                              PRICER-OPT-VERS-SW                  05485001
054860                              PROV-NEW-HOLD                       05486001
054870                              WAGE-NEW-INDEX-RECORD-CBSA.         05487001
054880                                                                  05488001
054900     IF (B-DISCHARGE-DATE > 20050930 AND                          05490001
055000         B-DISCHARGE-DATE < 20061001)                             05500001
055100         CALL  IRCAL064 USING BILL-NEW-DATA                       05510001
055200                              PPS-DATA-ALL                        05520001
055300                              PRICER-OPT-VERS-SW                  05530001
055400                              PROV-NEW-HOLD                       05540001
055500                              WAGE-NEW-INDEX-RECORD-CBSA.         05550001
055600                                                                  05560001
055700     IF (B-DISCHARGE-DATE > 20040930 AND                          05570001
055800         B-DISCHARGE-DATE < 20051001)                             05580001
055900         CALL  IRCAL051 USING BILL-NEW-DATA                       05590001
056000                              PPS-DATA-ALL                        05600001
056100                              PRICER-OPT-VERS-SW                  05610001
056200                              PROV-NEW-HOLD                       05620001
056300                              WAGE-NEW-INDEX-RECORD.              05630001
056400                                                                  05640001
056500     IF (B-DISCHARGE-DATE > 20030930 AND                          05650001
056600         B-DISCHARGE-DATE < 20041001)                             05660001
056700         CALL  IRCAL041 USING BILL-NEW-DATA                       05670001
056800                              PPS-DATA-ALL                        05680001
056900                              PRICER-OPT-VERS-SW                  05690001
057000                              PROV-NEW-HOLD                       05700001
057100                              WAGE-NEW-INDEX-RECORD.              05710001
057200                                                                  05720001
057300     IF (B-DISCHARGE-DATE > 20020930 AND                          05730001
057400         B-DISCHARGE-DATE < 20031001)                             05740001
057500         CALL  IRCAL031 USING BILL-NEW-DATA                       05750001
057600                              PPS-DATA-ALL                        05760001
057700                              PRICER-OPT-VERS-SW                  05770001
057800                              PROV-NEW-HOLD                       05780001
057900                              WAGE-NEW-INDEX-RECORD.              05790001
058000                                                                  05800001
058100     IF (B-DISCHARGE-DATE > 20011231 AND                          05810001
058200         B-DISCHARGE-DATE < 20021001)                             05820001
058300         CALL  IRCAL021 USING BILL-NEW-DATA                       05830001
058400                              PPS-DATA-ALL                        05840001
058500                              PRICER-OPT-VERS-SW                  05850001
058600                              PROV-NEW-HOLD                       05860001
058700                              WAGE-NEW-INDEX-RECORD.              05870001
058800         GOBACK.                                                  05880001
058900******************************************************************05890001
059000                                                                  05900001
059100 0500-GET-MSA.                                                    05910001
059200                                                                  05920001
059300     MOVE P-NEW-GEO-LOC-MSA9 TO HOLD-PROV-MSA.                    05930001
059400                                                                  05940001
059500     SEARCH M-MSA-DATA VARYING MU1                                05950001
059600       AT END                                                     05960001
059700          MOVE 60 TO PPS-RTC                                      05970001
059800          GO TO 0500-EXIT                                         05980001
059900       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA                        05990001
060000          SET MU2 TO MU1.                                         06000001
060100                                                                  06010001
060200       PERFORM 0600-N-GET-WAGE-INDX                               06020001
060300         THRU 0600-N-EXIT VARYING MU2                             06030001
060400           FROM MU1 BY 1 UNTIL                                    06040001
060500            MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.                   06050001
060600                                                                  06060001
060700 0500-EXIT.                                                       06070001
060800      EXIT.                                                       06080001
060900                                                                  06090001
061000 0550-GET-CBSA.                                                   06100001
061120                                                                  06112001
061200      IF P-NEW-CBSA-SPEC-PAY-IND = '1'                            06120001
061300         MOVE P-NEW-CBSA-WAGE-INDEX TO                            06130001
061400              W-NEW-INDEX-RECORD-C                                06140001
061500         MOVE P-NEW-GEO-LOC-CBSA9 TO W-NEW-CBSA                   06150001
061600         MOVE 00 TO PPS-RTC                                       06160001
061700         GO TO 0550-EXIT.                                         06170001
061800                                                                  06180001
061900      MOVE P-NEW-GEO-LOC-CBSA9 TO HOLD-PROV-CBSA.                 06190001
062000                                                                  06200001
062100      SEARCH M-CBSA-DATA VARYING MU3                              06210001
062200        AT END                                                    06220001
062300           MOVE 60 TO PPS-RTC                                     06230001
062400           GO TO 0550-EXIT                                        06240001
062500        WHEN CBSAX-CBSA (MU3) = HOLD-PROV-CBSA                    06250001
062600           SET MU4 TO MU3.                                        06260001
062700                                                                  06270001
062800      PERFORM 0650-N-GET-WAGE-INDX                                06280001
062900        THRU 0650-N-EXIT VARYING MU4                              06290001
063000          FROM MU3 BY 1 UNTIL                                     06300001
063100           CBSAX-CBSA (MU4) NOT = HOLD-PROV-CBSA.                 06310001
063200                                                                  06320001
063300 0550-EXIT.                                                       06330001
063400      EXIT.                                                       06340001
063500                                                                  06350001
063600 0600-N-GET-WAGE-INDX.                                            06360001
063700                                                                  06370001
063800     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)               06380001
063900         MOVE MSAX-MSA (MU2)        TO W-NEW-MSA                  06390001
064000         MOVE MSAX-EFF-DATE (MU2)   TO W-NEW-EFF-DATE             06400001
064100         MOVE MSAX-WAGE-INDEX (MU2) TO W-NEW-INDEX-RECORD.        06410001
064200                                                                  06420001
064300 0600-N-EXIT.                                                     06430001
064400     EXIT.                                                        06440001
064500                                                                  06450001
064600 0650-N-GET-WAGE-INDX.                                            06460001
064700                                                                  06470001
064800     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (MU4)              06480001
064900         MOVE CBSAX-CBSA (MU4)       TO W-NEW-CBSA                06490001
065000         MOVE CBSAX-EFF-DATE (MU4)   TO W-NEW-EFF-DATE-C          06500001
065100         MOVE CBSAX-WAGE-INDEX (MU4) TO W-NEW-INDEX-RECORD-C.     06510001
065200                                                                  06520001
065300 0650-N-EXIT.                                                     06530001
065400     EXIT.                                                        06540001
065500***************************************************************   06550001
065600******       L A S T   S O U R C E   S T A T E M E N T    *****   06560001
065700***************************************************************   06570001
