000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. IRDRV190.
000300*AUTHOR.     PBG/DDS.
000400*      CENTERS FOR MEDICARE AND MEDICAID SERVICES
000500*REMARKS.  - CALLS THE IRCAL__ MODULES
000600*          - CONVERTED FOR CICS PROCESSING
000700*          - FINDS PROV RECORD AND WAGE-INDEX RECORD FOR
000800*             GIVEN BILL TO BE PASSED TO IRCAL__ MODULES.
000900 DATE-COMPILED.
001000****************************************************************
001010*                  *  *  *  *  *  *  *  *                      *
001020*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *
001030*   AND MEDICAID SERVICES.                                     *
001040*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *
001050*   PAYMENT FOR INPATIENT REHABILITATION FACILITIES.           *
001060*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *
001070*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *
001080*   IS THAT OF THE USER.                                       *
001090*                  *  *  *  *  *  *  *  *                      *
001100*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *
001200*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *
001300*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *
001400*   THE PROGRAM WILL:                                          *
001500*       1. FIND THE WAGE INDEX TO CALCULATE PPS.               *
001600*       2. EDIT THE BILL INFORMATION.                          *
001700*       3. PASS BACK RETURN CODES.                             *
001800*       4. CALCULATE WHEN APPLICABLE                           *
001900*          A. THE HOSPITAL SPECIFIC PART OF PAYMENT.           *
002000*          B. THE FEDERAL SPECIFIC PART OF PAYMENT.            *
002100*          C. THE OUTLIER PORTION.                             *
002200*          D. TOTAL PAYMENT (B + C + D  ABOVE).                *
002300*          E. DISPROPORTIONATE SHARE ADJUSTMENT                *
002400*                  *  *  *  *  *  *  *  *                      *
002500*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *
002600*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *
002700*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *
002800*                  *  *  *  *  *  *  *  *                      *
002900*   CHANGE LOG:                                                *
003000*                                                              *
003100*   V190 - EXPANDED CBSA TABLE FROM 6000 TO 7000               *
003200*                                                              *
003300****************************************************************
003400 ENVIRONMENT DIVISION.
003500 CONFIGURATION SECTION.
003600 SOURCE-COMPUTER.            IBM-370.
003700 OBJECT-COMPUTER.            IBM-370.
003800 INPUT-OUTPUT  SECTION.
003900 FILE-CONTROL.
004000 DATA DIVISION.
004100 FILE SECTION.
004200
004300 WORKING-STORAGE SECTION.
004400 77  W-STORAGE-REF                  PIC X(48)  VALUE
004500     'I R D R I V E R - W O R K I N G   S T O R A G E'.
004600 01  DRV-VERSION                    PIC X(05) VALUE 'V19.0'.
004700 01  IRCAL021                       PIC X(08) VALUE 'IRCAL021'.
004800 01  IRCAL031                       PIC X(08) VALUE 'IRCAL031'.
004900 01  IRCAL041                       PIC X(08) VALUE 'IRCAL041'.
005000 01  IRCAL051                       PIC X(08) VALUE 'IRCAL051'.
005100 01  IRCAL064                       PIC X(08) VALUE 'IRCAL064'.
005200 01  IRCAL070                       PIC X(08) VALUE 'IRCAL070'.
005300 01  IRCAL080                       PIC X(08) VALUE 'IRCAL080'.
005400 01  IRCAL090                       PIC X(08) VALUE 'IRCAL090'.
005500 01  IRCAL100                       PIC X(08) VALUE 'IRCAL100'.
005600 01  IRCAL110                       PIC X(08) VALUE 'IRCAL110'.
005700 01  IRCAL120                       PIC X(08) VALUE 'IRCAL120'.
005800 01  IRCAL130                       PIC X(08) VALUE 'IRCAL130'.
005900 01  IRCAL140                       PIC X(08) VALUE 'IRCAL140'.
006000 01  IRCAL150                       PIC X(08) VALUE 'IRCAL150'.
006100 01  IRCAL160                       PIC X(08) VALUE 'IRCAL160'.
006110 01  IRCAL170                       PIC X(08) VALUE 'IRCAL170'.
006120 01  IRCAL180                       PIC X(08) VALUE 'IRCAL180'.
006130 01  IRCAL190                       PIC X(08) VALUE 'IRCAL190'.
006140 01  TABLES-LOADED-SW               PIC 9(01)  VALUE 0.
006150 01  EOF-SW                         PIC 9(01)  VALUE 0.
006160 01  EOF-SW1                        PIC 9(01)  VALUE 0.
006170
006180 01  W-PROV-NEW-HOLD.
006190     02  W-PROV-NEWREC-HOLD1.
006200         05  W-P-NEW-NPI10.
006300             10  W-P-NEW-NPI8           PIC X(08).
006400             10  W-P-NEW-NPI-FILLER     PIC X(02).
006500         05  W-P-NEW-PROVIDER-OSCAR-NO.
006600             10  W-P-NEW-STATE          PIC X(02).
006700             10  FILLER                 PIC X(04).
006800         05  W-P-NEW-DATE-DATA.
006900             10  W-P-NEW-EFF-DATE.
007000                 15  W-P-NEW-EFF-DT-CC    PIC 9(02).
007100                 15  W-P-NEW-EFF-DT-YY    PIC 9(02).
007200                 15  W-P-NEW-EFF-DT-MM    PIC 9(02).
007300                 15  W-P-NEW-EFF-DT-DD    PIC 9(02).
007400             10  W-P-NEW-FY-BEGIN-DATE.
007500                 15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).
007600                 15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).
007700                 15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).
007800                 15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).
007900             10  W-P-NEW-REPORT-DATE.
008000                 15  W-P-NEW-REPORT-DT-CC PIC 9(02).
008100                 15  W-P-NEW-REPORT-DT-YY PIC 9(02).
008200                 15  W-P-NEW-REPORT-DT-MM PIC 9(02).
008300                 15  W-P-NEW-REPORT-DT-DD PIC 9(02).
008400             10  W-P-NEW-TERMINATION-DATE.
008500                 15  W-P-NEW-TERM-DT-CC   PIC 9(02).
008600                 15  W-P-NEW-TERM-DT-YY   PIC 9(02).
008700                 15  W-P-NEW-TERM-DT-MM   PIC 9(02).
008800                 15  W-P-NEW-TERM-DT-DD   PIC 9(02).
008900         05  W-P-NEW-WAIVER-CODE          PIC X(01).
009000             88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.
009100         05  W-P-NEW-INTER-NO             PIC X(05).
009200         05  W-P-NEW-PROVIDER-TYPE        PIC X(02).
009300         05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).
009400         05  W-P-NEW-MSA-DATA.
009500             10  W-P-NEW-CHG-CODE-INDEX    PIC X.
009600             10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT.
009700             10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT.
009800             10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT.
009900             10  W-P-NEW-STAND-AMT-LOC-MSA9
010000       REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.
010100                 15  W-P-NEW-RURAL-1ST.
010200                     20  W-P-NEW-STAND-RURAL  PIC XX.
010300                 15  W-P-NEW-RURAL-2ND        PIC XX.
010400         05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
010500         05  W-P-NEW-LUGAR               PIC X.
010600         05  W-P-NEW-TEMP-RELIEF-IND     PIC X.
010700         05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.
010800         05  FILLER                      PIC X(05).
010900     02  W-PROV-NEWREC-HOLD2.
011000         05  W-P-NEW-VARIABLES.
011100             10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).
011200             10  W-P-NEW-COLA              PIC  X(04).
011300             10  W-P-NEW-INTERN-RATIO      PIC  X(05).
011400             10  W-P-NEW-BED-SIZE          PIC  X(05).
011500             10  W-P-NEW-CCR               PIC  X(04).
011600             10  W-P-NEW-CMI               PIC  X(05).
011700             10  W-P-NEW-SSI-RATIO         PIC  X(04).
011800             10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).
011900             10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
012000             10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
012100             10  W-P-NEW-DSH-PERCENT       PIC  V9(04).
012200             10  W-P-NEW-FYE-DATE.
012300                 15  W-P-NEW-FYE-CC        PIC 99.
012400                 15  W-P-NEW-FYE-YY        PIC 99.
012500                 15  W-P-NEW-FYE-MM        PIC 99.
012600                 15  W-P-NEW-FYE-DD        PIC 99.
012700         05  W-P-NEW-CBSA-DATA.
012800             10  W-P-NEW-CBSA-SPEC-PAY-IND   PIC X.
012900             10  W-P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
013000             10  W-P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.
013100             10  W-P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.
013200             10  W-P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.
013300             10  W-P-NEW-CBSA-STAND-AMT-LOC9
013400                 REDEFINES W-P-NEW-CBSA-STAND-AMT-LOC.
013500                 15  W-P-NEW-CBSA-RURAL-1ST.
013600                     20  W-P-NEW-CBSA-STAND-RURAL PIC 999.
013700                 15  W-P-NEW-CBSA-RURAL-2ND       PIC 99.
013800             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).
013900     02  W-PROV-NEWREC-HOLD3.
014000         05  W-P-NEW-PASS-AMT-DATA.
014100             10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).
014200             10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).
014300             10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).
014400             10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).
014500         05  W-P-NEW-CAPI-DATA.
014600             15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.
014700             15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).
014800             15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).
014900             15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).
015000             15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).
015100             15  W-P-NEW-CAPI-NEW-HOSP       PIC X.
015200             15  W-P-NEW-CAPI-IME            PIC X(05).
015300             15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).
015400             15  W-P-VAL-BASED-PURCH-SCORE   PIC 9V999.
015500         05  FILLER                          PIC X(18).
015600
015700 01  PROV-STAT.
015800     02  PROV-STAT1                          PIC X.
015900     02  PROV-STAT2                          PIC X.
016000
016100 01  CBSAX-STAT.
016200     02  CBSAX-STAT1                         PIC X.
016300     02  CBSAX-STAT2                         PIC X.
016400
016500 01  MSAX-STAT.
016600     02  MSAX-STAT1                          PIC X.
016700     02  MSAX-STAT2                          PIC X.
016800
016900 01  HOLD-PROV-MSA.
017000     10  H-MSA-PROV-BLANK                    PIC X(2).
017100     10  H-MSA-PROV-STATE.
017200         15  FILLER                          PIC X.
017300         15  HOLD-LAST-MSA-POS               PIC X.
017400
017500 01  HOLD-PROV-CBSA.
017600     10  H-CBSA-PROV-BLANK                   PIC X(3).
017700     10  H-CBSA-PROV-STATE.
017800         15  FILLER                          PIC X.
017900         15  HOLD-LAST-CBSA-POS              PIC X.
018000
018100 01  WORK-COUNTERS.
018200     05  CBSA-CNT                            PIC 9(5) VALUE ZERO.
018300     05  MSA-CNT                             PIC 9(5) VALUE ZERO.
018400     05  PROV-CNT                            PIC 9(5) VALUE ZERO.
018500***************************************************************
018600*    THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY     *
018700*    SET TO OCCUR 2400 TIMES. THIS NUMBER SHOULD BE ADJUSTED  *
018800*    BY THE USER TO REFLECT THE NUMBER OF PROVIDER RECORDS    *
018900*    PLUS EXPANSION. EACH ENTRY COSTS 240 BYTES OF MEMORY.    *
019000*    THIS FILE MUST BE IN PROVIDER NUMBER, EFFECTIVE-DATE     *
019100*    SEQUENCE.                                                *
019200***************************************************************
019300*01  PROV-TABLE.
019400*    05  PROV-ENTRIES       OCCURS 0 TO 2400 TIMES
019500*                           DEPENDING ON PROV-CNT
019600*                           ASCENDING KEY IS PROV-NO
019700*                           INDEXED BY PX1.
019800 01  PROV-TABLE.
019900     05  PROV-ENTRIES       OCCURS 2400 TIMES
020000                            INDEXED BY PX1.
020100         10  PROV-DATA1.
020200             15  PROV-NPI10.
020300                 20  PROV-NPI8               PIC X(08).
020400                 20  PROV-NPI-FILLER         PIC X(02).
020500             15  PROV-NO                     PIC X(06).
020600             15  PROV-EFF-DATE               PIC X(08).
020700             15  FILLER                      PIC X(56).
020800 01  PROV-DATA-2.
020900     05  PROV-ENTRIES2      OCCURS 2400 TIMES
021000                            INDEXED BY PD2.
021100         10  PROV-DATA2                      PIC X(80).
021200 01  PROV-DATA-3.
021300     05  PROV-ENTRIES3      OCCURS 2400 TIMES
021400                            INDEXED BY PD3.
021500         10  PROV-DATA3                      PIC X(80).
021600
021700***************************************************************
021800*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
021900*      THE IRCAL___ PROGRAM FOR PROCESSING MSA'S              *
022000***************************************************************
022100 01  WAGE-NEW-INDEX-RECORD.
022200     05  W-NEW-MSA                           PIC 9(4).
022300     05  W-NEW-EFF-DATE.
022400          10  W-NEW-EFF-DATE-CC              PIC 9(2).
022500          10  W-NEW-EFF-DATE-YMD.
022600              15  W-NEW-EFF-DATE-YY          PIC 9(2).
022700              15  W-NEW-EFF-DATE-MM          PIC 9(2).
022800              15  W-NEW-EFF-DATE-DD          PIC 9(2).
022900     05  W-NEW-INDEX-RECORD                  PIC S9(02)V9(04).
023000
023100***************************************************************
023200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
023300*      THE IRCAL___ PROGRAM FOR PROCESSING CBSA'S             *
023400***************************************************************
023500 01  WAGE-NEW-INDEX-RECORD-CBSA.
023600     05  W-NEW-CBSA                          PIC 9(5).
023700     05  W-NEW-EFF-DATE-C.
023800          10  W-NEW-EFF-DATE-CC-C            PIC 9(2).
023900          10  W-NEW-EFF-DATE-YMD-C.
024000              15  W-NEW-EFF-DATE-YY-C        PIC 9(2).
024100              15  W-NEW-EFF-DATE-MM-C        PIC 9(2).
024200              15  W-NEW-EFF-DATE-DD-C        PIC 9(2).
024300     05  W-NEW-INDEX-RECORD-C                PIC S9(02)V9(04).
024400
024500**************************************************************
024600*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *
024700*      THE IRCAL___ PROGRAM                                  *
024800**************************************************************
024900 01  PROV-NEW-HOLD.
025000     02  PROV-NEWREC-HOLD1.
025100         05  P-NEW-NPI10.
025200             10  P-NEW-NPI8                 PIC X(08).
025300             10  P-NEW-NPI-FILLER           PIC X(02).
025400         05  P-NEW-PROVIDER-NO.
025500             10  P-NEW-STATE                PIC 9(02).
025600             10  FILLER                     PIC X(04).
025700         05  P-NEW-DATE-DATA.
025800             10  P-NEW-EFF-DATE.
025900                 15  P-NEW-EFF-DT-CC        PIC 9(02).
026000                 15  P-NEW-EFF-DT-YY        PIC 9(02).
026100                 15  P-NEW-EFF-DT-MM        PIC 9(02).
026200                 15  P-NEW-EFF-DT-DD        PIC 9(02).
026300             10  P-NEW-FY-BEGIN-DATE.
026400                 15  P-NEW-FY-BEG-DT-CC     PIC 9(02).
026500                 15  P-NEW-FY-BEG-DT-YY     PIC 9(02).
026600                 15  P-NEW-FY-BEG-DT-MM     PIC 9(02).
026700                 15  P-NEW-FY-BEG-DT-DD     PIC 9(02).
026800             10  P-NEW-REPORT-DATE.
026900                 15  P-NEW-REPORT-DT-CC     PIC 9(02).
027000                 15  P-NEW-REPORT-DT-YY     PIC 9(02).
027100                 15  P-NEW-REPORT-DT-MM     PIC 9(02).
027200                 15  P-NEW-REPORT-DT-DD     PIC 9(02).
027300             10  P-NEW-TERMINATION-DATE.
027400                 15  P-NEW-TERM-DT-CC       PIC 9(02).
027500                 15  P-NEW-TERM-DT-YY       PIC 9(02).
027600                 15  P-NEW-TERM-DT-MM       PIC 9(02).
027700                 15  P-NEW-TERM-DT-DD       PIC 9(02).
027800         05  P-NEW-WAIVER-CODE              PIC X(01).
027900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
028000         05  P-NEW-INTER-NO                 PIC 9(05).
028100         05  P-NEW-PROVIDER-TYPE            PIC X(02).
028200         05  P-NEW-CURRENT-CENSUS-DIV       PIC 9(01).
028300         05  P-NEW-CURRENT-DIV   REDEFINES
028400                 P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
028500         05  P-NEW-MSA-DATA.
028600             10  P-NEW-CHG-CODE-INDEX       PIC X.
028700             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
028800             10  P-NEW-GEO-LOC-MSA9   REDEFINES
028900                        P-NEW-GEO-LOC-MSAX  PIC 9(04).
029000             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
029100                        P-NEW-GEO-LOC-MSA9.
029200                 15  P-NEW-GEO-MSA-1ST      PIC X.
029300                 15  P-NEW-GEO-MSA-2ND      PIC X.
029400                 15  P-NEW-GEO-MSA-3RD      PIC X.
029500                 15  P-NEW-GEO-MSA-4TH      PIC X.
029600             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
029700             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
029800             10  P-NEW-STAND-AMT-LOC-MSA9
029900                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
030000                 15  P-NEW-RURAL-1ST.
030100                     20  P-NEW-STAND-RURAL  PIC XX.
030200                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
030300                 15  P-NEW-RURAL-2ND        PIC XX.
030400         05  P-NEW-SOL-COM-DEP-HOSP-YR      PIC XX.
030500                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
030600                 88  P-NEW-SCH-YR82       VALUE   '82'.
030700                 88  P-NEW-SCH-YR87       VALUE   '87'.
030800         05  P-NEW-LUGAR                    PIC X.
030900         05  P-NEW-TEMP-RELIEF-IND          PIC X.
031000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
031100         05  FILLER                         PIC X(05).
031200     02  PROV-NEWREC-HOLD2.
031300         05  P-NEW-VARIABLES.
031400             10  P-NEW-FAC-SPEC-RATE        PIC  9(05)V9(02).
031500             10  P-NEW-COLA                 PIC  9(01)V9(03).
031600             10  P-NEW-INTERN-RATIO         PIC  9(01)V9(04).
031700             10  P-NEW-BED-SIZE             PIC  9(05).
031800             10  P-NEW-CCR                  PIC  9(01)V9(03).
031900             10  P-NEW-CMI                  PIC  9(01)V9(04).
032000             10  P-NEW-SSI-RATIO            PIC  V9(04).
032100             10  P-NEW-MEDICAID-RATIO       PIC  V9(04).
032200             10  P-NEW-PPS-BLEND-YR-IND     PIC  X(01).
032300             10  P-NEW-PRUP-UPDTE-FACTOR    PIC  9(01)V9(05).
032400             10  P-NEW-DSH-PERCENT          PIC  V9(04).
032500             10  P-NEW-FYE-DATE.
032600                 15  P-NEW-FYE-CC           PIC 99.
032700                 15  P-NEW-FYE-YY           PIC 99.
032800                 15  P-NEW-FYE-MM           PIC 99.
032900                 15  P-NEW-FYE-DD           PIC 99.
033000         05  P-NEW-CBSA-DATA.
033100             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
033200             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
033300             10  P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT.
033400             10  P-NEW-GEO-LOC-CBSA9   REDEFINES
033500                        P-NEW-CBSA-GEO-LOC  PIC 9(05).
033600             10  P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT.
033700             10  P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT.
033800             10  P-NEW-CBSA-STAND-AMT-LOC9
033900                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.
034000                 15  P-NEW-CBSA-RURAL-1ST.
034100                     20  P-NEW-CBSA-STAND-RURAL PIC 999.
034200                 15  P-NEW-CBSA-RURAL-2ND    PIC 99.
034300             10  P-NEW-CBSA-WAGE-INDEX       PIC 9(02)V9(04).
034400     02  PROV-NEWREC-HOLD3.
034500         05  P-NEW-PASS-AMT-DATA.
034600             10  P-NEW-PASS-AMT-CAPITAL     PIC 9(04)V99.
034700             10  P-NEW-PASS-AMT-DIR-MED-ED  PIC 9(04)V99.
034800             10  P-NEW-PASS-AMT-ORGAN-ACQ   PIC 9(04)V99.
034900             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
035000         05  P-NEW-CAPI-DATA.
035100             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
035200             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
035300             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
035400             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
035500             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
035600             15  P-NEW-CAPI-NEW-HOSP       PIC X.
035700             15  P-NEW-CAPI-IME            PIC 9V9999.
035800             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
035900         05  FILLER                        PIC X(22).
036000
036100***************************************************************
036200 LINKAGE SECTION.
036300
036400**************************************************************
036500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
036600*      THE IRCAL___ PROGRAM                                  *
036700**************************************************************
036800 01  BILL-NEW-DATA.
036900     05  B-NPI10.
037000         10  B-NPI8                   PIC X(08).
037100         10  B-NPI-FILLER             PIC X(02).
037200     05  B-PROVIDER-NO                PIC X(06).
037300     05  B-PATIENT-STATUS             PIC X(02).
037400     05  B-CMG-CODE                   PIC X(05).
037500     05  B-LOS                        PIC 9(03).
037600     05  B-COVERED-DAYS               PIC 9(03).
037700     05  B-LTR-DAYS                   PIC 9(02).
037800     05  B-SPEC-PYMT-IND              PIC X(01).
037900     05  B-DISCHARGE-DATE.
038000         10  B-DISCHG-CC              PIC 9(02).
038100         10  B-DISCHG-YY              PIC 9(02).
038200         10  B-DISCHG-MM              PIC 9(02).
038300         10  B-DISCHG-DD              PIC 9(02).
038400     05  B-COVERED-CHARGES            PIC 9(07)V9(02).
038500     05  FILLER                       PIC X(11).
038600
038700 01  PPS-DATA-ALL.
038800     05  PPS-RTC                      PIC 9(02).
038900     05  PPS-DATA.
039000         10  PPS-MSA                  PIC X(04).
039100         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
039200         10  PPS-AVG-LOS              PIC 9(02).
039300         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
039400         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).
039500         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
039600         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).
039700         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
039800         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).
039900         10  PPS-LIP-PCT              PIC 9(01)V9(04).
040000         10  PPS-LOS                  PIC 9(03).
040100         10  PPS-REG-DAYS-USED        PIC 9(03).
040200         10  PPS-LTR-DAYS-USED        PIC 9(03).
040300         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).
040400         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).
040500         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).
040600         10  PPS-FAC-COSTS            PIC 9(07)V9(02).
040700         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
040800         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).
040900         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).
041000         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).
041100         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).
041200         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).
041300         10  PPS-SUBM-CMG-CODE        PIC X(05).
041400         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.
041500             15  PPS-CMG-ALPHA        PIC X(01).
041600             15  PPS-CMG-NUMERIC.
041700                20  PPS-CMG-RIC       PIC X(02).
041800                20  FILLER            PIC X(02).
041900         10  PPS-PRICED-CMG-CODE      PIC X(05).
042000         10  PPS-CALC-VERS-CD         PIC X(05).
042100         10  PPS-CBSA                 PIC X(05).
042200         10  FILLER                   PIC X(08).
042300    05  PPS-OTHER-DATA.
042400         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
042500         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
042600         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).
042700         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).
042800         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).
042900         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).
043000         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).
043100         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).
043200         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).
043300         10  FILLER                   PIC X(02).
043400    05  PPS-PC-DATA.
043500         10  PPS-COT-IND              PIC X(01).
043600         10  FILLER                   PIC X(20).
043700
043800*****************************************************************
043900*            THESE ARE THE VERSIONS OF THE IRDRV050
044000*           PROGRAMS THAT WILL BE PASSED BACK----
044100*          ASSOCIATED WITH THE BILL BEING PROCESSED
044200*****************************************************************
044300
044400 01  PRICER-OPT-VERS-SW.
044500     05  PRICER-OPTION-SW               PIC X(01).
044600         88  ALL-TABLES-PASSED          VALUE 'A'.
044700         88  PROV-RECORD-PASSED         VALUE 'P'.
044800     05  PPS-VERSIONS.
044900         10  PPDRV-VERSION              PIC X(05).
045000
045100**************************************************************
045200*      PROVIDER SPECIFIC RECORD                              *
045300**************************************************************
045400 01  PROV-RECORD.
045500     05  PROV-REC1                  PIC X(80).
045600     05  PROV-REC2                  PIC X(80).
045700     05  PROV-REC3                  PIC X(80).
045800
045900**************************************************************
046000*      METROPOLITAN STATISTICAL AREA TABLE                   *
046100**************************************************************
046200*01  MSA-WI-TABLE.
046300*    05  M-MSA-DATA    OCCURS 0 TO 4000 TIMES
046400*                      DEPENDING ON MSA-CNT
046500*                      ASCENDING KEY IS MSAX-MSA
046600*                      INDEXED BY MU1 MU2.
046700 01  MSA-WI-TABLE.
046800     05  M-MSA-DATA    OCCURS 4000 TIMES
046900                       INDEXED BY MU1 MU2.
047000         10  MSAX-MSA                        PIC X(4).
047100         10  MSAX-EFF-DATE                   PIC X(08).
047200         10  MSAX-WAGE-INDEX                 PIC S9(02)V9(04).
047300
047400**************************************************************
047500*      CORE BASED STATISTICAL AREA TABLE                     *
047600**************************************************************
047700*01  CBSA-WI-TABLE.
047800*    05  M-CBSA-DATA   OCCURS 0 TO 6000 TIMES
047900*                      DEPENDING ON CBSA-CNT
048000*                      ASCENDING KEY IS CBSAX-CBSA
048100*                      INDEXED BY MU3 MU4.
048200 01  CBSA-WI-TABLE.
048300     05  M-CBSA-DATA   OCCURS 7000 TIMES
048400                       INDEXED BY MU3 MU4.
048500         10  CBSAX-CBSA                      PIC X(5).
048600         10  CBSAX-EFF-DATE                  PIC X(08).
048700         10  CBSAX-WAGE-INDEX                PIC S9(02)V9(04).
048800
048900 PROCEDURE DIVISION  USING BILL-NEW-DATA
049000                           PPS-DATA-ALL
049100                           PRICER-OPT-VERS-SW
049200                           PROV-RECORD
049300                           MSA-WI-TABLE
049400                           CBSA-WI-TABLE.
049500
049600******************************************************************
049700*    PROCESSING:
049800*        A. THIS MODULE WILL CALL THE IRCAL MODULES.
049900*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS
050000*           SUBROUTINE IS CALLED.
050100*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH
050200*           EACH BILL WILL BE PASSED TO THE IRCAL PROGRAMS.
050300******************************************************************
050400     INITIALIZE PPS-DATA-ALL.
050500     INITIALIZE PROV-NEW-HOLD.
050600     INITIALIZE WAGE-NEW-INDEX-RECORD-CBSA.
050700     MOVE DRV-VERSION TO PPDRV-VERSION.
050800     MOVE PROV-RECORD TO PROV-NEW-HOLD.
050900
051000******************************************************************
051100***     RTC = 98  --  THIS IS A BILL OLDER THAN 20020101       ***
051200******************************************************************
051300
051400     IF B-DISCHARGE-DATE > 20011231
051500        CONTINUE
051510     ELSE
051520         MOVE 98 TO PPS-RTC
051530         GOBACK.
051540
051550******************************************************************
051560***  GET THE WAGE-INDEX
051570******************************************************************
051580
051590     SET MU1 MU3 TO 1.
051600     IF B-DISCHARGE-DATE > 20050930
051700        PERFORM 0550-GET-CBSA THRU 0550-EXIT
051800     ELSE
051900        PERFORM 0500-GET-MSA THRU 0500-EXIT.
052000
052100***     RTC = 60  --  WAGE-INDEX NOT FOUND
052200     IF PPS-RTC = 60
052300          GOBACK.
052400
052500******************************************************************
052600**          THE NEXT LOGIC WILL PROCESS THE PROPER IRCAL MODULE
052700**          BASED ON THE DISCHARGE DATE.
052800******************************************************************
052900*                ADD LOGIC EVERY YEAR FOR NEW MODULE
053000
053100     IF (B-DISCHARGE-DATE > 20180930 AND
053200         B-DISCHARGE-DATE < 20191001)
053300         CALL  IRCAL190 USING BILL-NEW-DATA
053400                              PPS-DATA-ALL
053500                              PRICER-OPT-VERS-SW
053600                              PROV-NEW-HOLD
053700                              WAGE-NEW-INDEX-RECORD-CBSA.
053800
053900     IF (B-DISCHARGE-DATE > 20170930 AND
054000         B-DISCHARGE-DATE < 20181001)
054100         CALL  IRCAL180 USING BILL-NEW-DATA
054200                              PPS-DATA-ALL
054300                              PRICER-OPT-VERS-SW
054400                              PROV-NEW-HOLD
054500                              WAGE-NEW-INDEX-RECORD-CBSA.
054600
054700     IF (B-DISCHARGE-DATE > 20160930 AND
054710         B-DISCHARGE-DATE < 20171001)
054711         CALL  IRCAL170 USING BILL-NEW-DATA
054712                              PPS-DATA-ALL
054713                              PRICER-OPT-VERS-SW
054714                              PROV-NEW-HOLD
054715                              WAGE-NEW-INDEX-RECORD-CBSA.
054716
054717     IF (B-DISCHARGE-DATE > 20150930 AND
054718         B-DISCHARGE-DATE < 20161001)
054719         CALL  IRCAL160 USING BILL-NEW-DATA
054720                              PPS-DATA-ALL
054721                              PRICER-OPT-VERS-SW
054722                              PROV-NEW-HOLD
054723                              WAGE-NEW-INDEX-RECORD-CBSA.
054724
054725     IF (B-DISCHARGE-DATE > 20140930 AND
054726         B-DISCHARGE-DATE < 20151001)
054727         CALL  IRCAL150 USING BILL-NEW-DATA
054728                              PPS-DATA-ALL
054729                              PRICER-OPT-VERS-SW
054730                              PROV-NEW-HOLD
054731                              WAGE-NEW-INDEX-RECORD-CBSA.
054732
054733     IF (B-DISCHARGE-DATE > 20130930 AND
054734         B-DISCHARGE-DATE < 20141001)
054735         CALL  IRCAL140 USING BILL-NEW-DATA
054736                              PPS-DATA-ALL
054737                              PRICER-OPT-VERS-SW
054738                              PROV-NEW-HOLD
054739                              WAGE-NEW-INDEX-RECORD-CBSA.
054740
054741     IF (B-DISCHARGE-DATE > 20120930 AND
054742         B-DISCHARGE-DATE < 20131001)
054743         CALL  IRCAL130 USING BILL-NEW-DATA
054744                              PPS-DATA-ALL
054745                              PRICER-OPT-VERS-SW
054746                              PROV-NEW-HOLD
054747                              WAGE-NEW-INDEX-RECORD-CBSA.
054748
054749     IF (B-DISCHARGE-DATE > 20110930 AND
054750         B-DISCHARGE-DATE < 20121001)
054751         CALL  IRCAL120 USING BILL-NEW-DATA
054752                              PPS-DATA-ALL
054753                              PRICER-OPT-VERS-SW
054754                              PROV-NEW-HOLD
054755                              WAGE-NEW-INDEX-RECORD-CBSA.
054756
054757     IF (B-DISCHARGE-DATE > 20100930 AND
054758         B-DISCHARGE-DATE < 20111001)
054759         CALL  IRCAL110 USING BILL-NEW-DATA
054760                              PPS-DATA-ALL
054761                              PRICER-OPT-VERS-SW
054762                              PROV-NEW-HOLD
054763                              WAGE-NEW-INDEX-RECORD-CBSA.
054764
054765     IF (B-DISCHARGE-DATE > 20090930 AND
054766         B-DISCHARGE-DATE < 20101001)
054767         CALL  IRCAL100 USING BILL-NEW-DATA
054768                              PPS-DATA-ALL
054769                              PRICER-OPT-VERS-SW
054770                              PROV-NEW-HOLD
054771                              WAGE-NEW-INDEX-RECORD-CBSA.
054772
054773     IF (B-DISCHARGE-DATE > 20080930 AND
054774         B-DISCHARGE-DATE < 20091001)
054775         CALL  IRCAL090 USING BILL-NEW-DATA
054776                              PPS-DATA-ALL
054777                              PRICER-OPT-VERS-SW
054778                              PROV-NEW-HOLD
054779                              WAGE-NEW-INDEX-RECORD-CBSA.
054780
054781     IF (B-DISCHARGE-DATE > 20070930 AND
054782         B-DISCHARGE-DATE < 20081001)
054783         CALL  IRCAL080 USING BILL-NEW-DATA
054784                              PPS-DATA-ALL
054785                              PRICER-OPT-VERS-SW
054786                              PROV-NEW-HOLD
054787                              WAGE-NEW-INDEX-RECORD-CBSA.
054788
054789     IF (B-DISCHARGE-DATE > 20060930 AND
054790         B-DISCHARGE-DATE < 20071001)
054800         CALL  IRCAL070 USING BILL-NEW-DATA
054810                              PPS-DATA-ALL
054820                              PRICER-OPT-VERS-SW
054830                              PROV-NEW-HOLD
054840                              WAGE-NEW-INDEX-RECORD-CBSA.
054850
054860     IF (B-DISCHARGE-DATE > 20050930 AND
054870         B-DISCHARGE-DATE < 20061001)
054880         CALL  IRCAL064 USING BILL-NEW-DATA
054890                              PPS-DATA-ALL
054900                              PRICER-OPT-VERS-SW
055000                              PROV-NEW-HOLD
055100                              WAGE-NEW-INDEX-RECORD-CBSA.
055200
055300     IF (B-DISCHARGE-DATE > 20040930 AND
055400         B-DISCHARGE-DATE < 20051001)
055500         CALL  IRCAL051 USING BILL-NEW-DATA
055600                              PPS-DATA-ALL
055700                              PRICER-OPT-VERS-SW
055800                              PROV-NEW-HOLD
055900                              WAGE-NEW-INDEX-RECORD.
056000
056100     IF (B-DISCHARGE-DATE > 20030930 AND
056200         B-DISCHARGE-DATE < 20041001)
056300         CALL  IRCAL041 USING BILL-NEW-DATA
056400                              PPS-DATA-ALL
056500                              PRICER-OPT-VERS-SW
056600                              PROV-NEW-HOLD
056700                              WAGE-NEW-INDEX-RECORD.
056800
056900     IF (B-DISCHARGE-DATE > 20020930 AND
057000         B-DISCHARGE-DATE < 20031001)
057100         CALL  IRCAL031 USING BILL-NEW-DATA
057200                              PPS-DATA-ALL
057300                              PRICER-OPT-VERS-SW
057400                              PROV-NEW-HOLD
057500                              WAGE-NEW-INDEX-RECORD.
057600
057700     IF (B-DISCHARGE-DATE > 20011231 AND
057800         B-DISCHARGE-DATE < 20021001)
057900         CALL  IRCAL021 USING BILL-NEW-DATA
058000                              PPS-DATA-ALL
058100                              PRICER-OPT-VERS-SW
058200                              PROV-NEW-HOLD
058300                              WAGE-NEW-INDEX-RECORD.
058400         GOBACK.
058500******************************************************************
058600
058700 0500-GET-MSA.
058800
058900     MOVE P-NEW-GEO-LOC-MSA9 TO HOLD-PROV-MSA.
059000
059100     SEARCH M-MSA-DATA VARYING MU1
059200       AT END
059300          MOVE 60 TO PPS-RTC
059400          GO TO 0500-EXIT
059500       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA
059600          SET MU2 TO MU1.
059700
059800       PERFORM 0600-N-GET-WAGE-INDX
059900         THRU 0600-N-EXIT VARYING MU2
060000           FROM MU1 BY 1 UNTIL
060100            MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.
060200
060300 0500-EXIT.
060400      EXIT.
060500
060600 0550-GET-CBSA.
060700
060800      IF P-NEW-CBSA-SPEC-PAY-IND = '1'
060900         MOVE P-NEW-CBSA-WAGE-INDEX TO
061000              W-NEW-INDEX-RECORD-C
061100         MOVE P-NEW-GEO-LOC-CBSA9 TO W-NEW-CBSA
061200         MOVE 00 TO PPS-RTC
061300         GO TO 0550-EXIT.
061400
061500      MOVE P-NEW-GEO-LOC-CBSA9 TO HOLD-PROV-CBSA.
061600
061700      SEARCH M-CBSA-DATA VARYING MU3
061800        AT END
061900           MOVE 60 TO PPS-RTC
062000           GO TO 0550-EXIT
062100        WHEN CBSAX-CBSA (MU3) = HOLD-PROV-CBSA
062200           SET MU4 TO MU3.
062300
062400      PERFORM 0650-N-GET-WAGE-INDX
062500        THRU 0650-N-EXIT VARYING MU4
062600          FROM MU3 BY 1 UNTIL
062700           CBSAX-CBSA (MU4) NOT = HOLD-PROV-CBSA.
062800
062900 0550-EXIT.
063000      EXIT.
063100
063200 0600-N-GET-WAGE-INDX.
063300
063400     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)
063500         MOVE MSAX-MSA (MU2)        TO W-NEW-MSA
063600         MOVE MSAX-EFF-DATE (MU2)   TO W-NEW-EFF-DATE
063700         MOVE MSAX-WAGE-INDEX (MU2) TO W-NEW-INDEX-RECORD.
063800
063900 0600-N-EXIT.
064000     EXIT.
064100
064200 0650-N-GET-WAGE-INDX.
064300
064400     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (MU4)
064500         MOVE CBSAX-CBSA (MU4)       TO W-NEW-CBSA
064600         MOVE CBSAX-EFF-DATE (MU4)   TO W-NEW-EFF-DATE-C
064700         MOVE CBSAX-WAGE-INDEX (MU4) TO W-NEW-INDEX-RECORD-C.
064800
064900 0650-N-EXIT.
065000     EXIT.
065100***************************************************************
065200******       L A S T   S O U R C E   S T A T E M E N T    *****
065300***************************************************************
