000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. IRDRV170.
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*   FOR FUTURE USE.                                            *
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 'V17.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  TABLES-LOADED-SW               PIC 9(01)  VALUE 0.
006130 01  EOF-SW                         PIC 9(01)  VALUE 0.
006140 01  EOF-SW1                        PIC 9(01)  VALUE 0.
006150
006160 01  W-PROV-NEW-HOLD.
006170     02  W-PROV-NEWREC-HOLD1.
006180         05  W-P-NEW-NPI10.
006190             10  W-P-NEW-NPI8           PIC X(08).
006200             10  W-P-NEW-NPI-FILLER     PIC X(02).
006300         05  W-P-NEW-PROVIDER-OSCAR-NO.
006400             10  W-P-NEW-STATE          PIC X(02).
006500             10  FILLER                 PIC X(04).
006600         05  W-P-NEW-DATE-DATA.
006700             10  W-P-NEW-EFF-DATE.
006800                 15  W-P-NEW-EFF-DT-CC    PIC 9(02).
006900                 15  W-P-NEW-EFF-DT-YY    PIC 9(02).
007000                 15  W-P-NEW-EFF-DT-MM    PIC 9(02).
007100                 15  W-P-NEW-EFF-DT-DD    PIC 9(02).
007200             10  W-P-NEW-FY-BEGIN-DATE.
007300                 15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).
007400                 15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).
007500                 15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).
007600                 15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).
007700             10  W-P-NEW-REPORT-DATE.
007800                 15  W-P-NEW-REPORT-DT-CC PIC 9(02).
007900                 15  W-P-NEW-REPORT-DT-YY PIC 9(02).
008000                 15  W-P-NEW-REPORT-DT-MM PIC 9(02).
008100                 15  W-P-NEW-REPORT-DT-DD PIC 9(02).
008200             10  W-P-NEW-TERMINATION-DATE.
008300                 15  W-P-NEW-TERM-DT-CC   PIC 9(02).
008400                 15  W-P-NEW-TERM-DT-YY   PIC 9(02).
008500                 15  W-P-NEW-TERM-DT-MM   PIC 9(02).
008600                 15  W-P-NEW-TERM-DT-DD   PIC 9(02).
008700         05  W-P-NEW-WAIVER-CODE          PIC X(01).
008800             88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.
008900         05  W-P-NEW-INTER-NO             PIC X(05).
009000         05  W-P-NEW-PROVIDER-TYPE        PIC X(02).
009100         05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).
009200         05  W-P-NEW-MSA-DATA.
009300             10  W-P-NEW-CHG-CODE-INDEX    PIC X.
009400             10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT.
009500             10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT.
009600             10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT.
009700             10  W-P-NEW-STAND-AMT-LOC-MSA9
009800       REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.
009900                 15  W-P-NEW-RURAL-1ST.
010000                     20  W-P-NEW-STAND-RURAL  PIC XX.
010100                 15  W-P-NEW-RURAL-2ND        PIC XX.
010200         05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
010300         05  W-P-NEW-LUGAR               PIC X.
010400         05  W-P-NEW-TEMP-RELIEF-IND     PIC X.
010500         05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.
010600         05  FILLER                      PIC X(05).
010700     02  W-PROV-NEWREC-HOLD2.
010800         05  W-P-NEW-VARIABLES.
010900             10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).
011000             10  W-P-NEW-COLA              PIC  X(04).
011100             10  W-P-NEW-INTERN-RATIO      PIC  X(05).
011200             10  W-P-NEW-BED-SIZE          PIC  X(05).
011300             10  W-P-NEW-CCR               PIC  X(04).
011400             10  W-P-NEW-CMI               PIC  X(05).
011500             10  W-P-NEW-SSI-RATIO         PIC  X(04).
011600             10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).
011700             10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
011800             10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
011900             10  W-P-NEW-DSH-PERCENT       PIC  V9(04).
012000             10  W-P-NEW-FYE-DATE.
012100                 15  W-P-NEW-FYE-CC        PIC 99.
012200                 15  W-P-NEW-FYE-YY        PIC 99.
012300                 15  W-P-NEW-FYE-MM        PIC 99.
012400                 15  W-P-NEW-FYE-DD        PIC 99.
012500         05  W-P-NEW-CBSA-DATA.
012600             10  W-P-NEW-CBSA-SPEC-PAY-IND   PIC X.
012700             10  W-P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
012800             10  W-P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.
012900             10  W-P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.
013000             10  W-P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.
013100             10  W-P-NEW-CBSA-STAND-AMT-LOC9
013200                 REDEFINES W-P-NEW-CBSA-STAND-AMT-LOC.
013300                 15  W-P-NEW-CBSA-RURAL-1ST.
013400                     20  W-P-NEW-CBSA-STAND-RURAL PIC 999.
013500                 15  W-P-NEW-CBSA-RURAL-2ND       PIC 99.
013600             10  W-P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).
013700     02  W-PROV-NEWREC-HOLD3.
013800         05  W-P-NEW-PASS-AMT-DATA.
013900             10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).
014000             10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).
014100             10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).
014200             10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).
014300         05  W-P-NEW-CAPI-DATA.
014400             15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.
014500             15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).
014600             15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).
014700             15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).
014800             15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).
014900             15  W-P-NEW-CAPI-NEW-HOSP       PIC X.
015000             15  W-P-NEW-CAPI-IME            PIC X(05).
015100             15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).
015200             15  W-P-VAL-BASED-PURCH-SCORE   PIC 9V999.
015300         05  FILLER                          PIC X(18).
015400
015500 01  PROV-STAT.
015600     02  PROV-STAT1                          PIC X.
015700     02  PROV-STAT2                          PIC X.
015800
015900 01  CBSAX-STAT.
016000     02  CBSAX-STAT1                         PIC X.
016100     02  CBSAX-STAT2                         PIC X.
016200
016300 01  MSAX-STAT.
016400     02  MSAX-STAT1                          PIC X.
016500     02  MSAX-STAT2                          PIC X.
016600
016700 01  HOLD-PROV-MSA.
016800     10  H-MSA-PROV-BLANK                    PIC X(2).
016900     10  H-MSA-PROV-STATE.
017000         15  FILLER                          PIC X.
017100         15  HOLD-LAST-MSA-POS               PIC X.
017200
017300 01  HOLD-PROV-CBSA.
017400     10  H-CBSA-PROV-BLANK                   PIC X(3).
017500     10  H-CBSA-PROV-STATE.
017600         15  FILLER                          PIC X.
017700         15  HOLD-LAST-CBSA-POS              PIC X.
017800
017900 01  WORK-COUNTERS.
018000     05  CBSA-CNT                            PIC 9(5) VALUE ZERO.
018100     05  MSA-CNT                             PIC 9(5) VALUE ZERO.
018200     05  PROV-CNT                            PIC 9(5) VALUE ZERO.
018300***************************************************************
018400*    THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY     *
018500*    SET TO OCCUR 2400 TIMES. THIS NUMBER SHOULD BE ADJUSTED  *
018600*    BY THE USER TO REFLECT THE NUMBER OF PROVIDER RECORDS    *
018700*    PLUS EXPANSION. EACH ENTRY COSTS 240 BYTES OF MEMORY.    *
018800*    THIS FILE MUST BE IN PROVIDER NUMBER, EFFECTIVE-DATE     *
018900*    SEQUENCE.                                                *
019000***************************************************************
019100*01  PROV-TABLE.
019200*    05  PROV-ENTRIES       OCCURS 0 TO 2400 TIMES
019300*                           DEPENDING ON PROV-CNT
019400*                           ASCENDING KEY IS PROV-NO
019500*                           INDEXED BY PX1.
019600 01  PROV-TABLE.
019700     05  PROV-ENTRIES       OCCURS 2400 TIMES
019800                            INDEXED BY PX1.
019900         10  PROV-DATA1.
020000             15  PROV-NPI10.
020100                 20  PROV-NPI8               PIC X(08).
020200                 20  PROV-NPI-FILLER         PIC X(02).
020300             15  PROV-NO                     PIC X(06).
020400             15  PROV-EFF-DATE               PIC X(08).
020500             15  FILLER                      PIC X(56).
020600 01  PROV-DATA-2.
020700     05  PROV-ENTRIES2      OCCURS 2400 TIMES
020800                            INDEXED BY PD2.
020900         10  PROV-DATA2                      PIC X(80).
021000 01  PROV-DATA-3.
021100     05  PROV-ENTRIES3      OCCURS 2400 TIMES
021200                            INDEXED BY PD3.
021300         10  PROV-DATA3                      PIC X(80).
021400
021500***************************************************************
021600*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
021700*      THE IRCAL___ PROGRAM FOR PROCESSING MSA'S              *
021800***************************************************************
021900 01  WAGE-NEW-INDEX-RECORD.
022000     05  W-NEW-MSA                           PIC 9(4).
022100     05  W-NEW-EFF-DATE.
022200          10  W-NEW-EFF-DATE-CC              PIC 9(2).
022300          10  W-NEW-EFF-DATE-YMD.
022400              15  W-NEW-EFF-DATE-YY          PIC 9(2).
022500              15  W-NEW-EFF-DATE-MM          PIC 9(2).
022600              15  W-NEW-EFF-DATE-DD          PIC 9(2).
022700     05  W-NEW-INDEX-RECORD                  PIC S9(02)V9(04).
022800
022900***************************************************************
023000*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
023100*      THE IRCAL___ PROGRAM FOR PROCESSING CBSA'S             *
023200***************************************************************
023300 01  WAGE-NEW-INDEX-RECORD-CBSA.
023400     05  W-NEW-CBSA                          PIC 9(5).
023500     05  W-NEW-EFF-DATE-C.
023600          10  W-NEW-EFF-DATE-CC-C            PIC 9(2).
023700          10  W-NEW-EFF-DATE-YMD-C.
023800              15  W-NEW-EFF-DATE-YY-C        PIC 9(2).
023900              15  W-NEW-EFF-DATE-MM-C        PIC 9(2).
024000              15  W-NEW-EFF-DATE-DD-C        PIC 9(2).
024100     05  W-NEW-INDEX-RECORD-C                PIC S9(02)V9(04).
024200
024300**************************************************************
024400*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *
024500*      THE IRCAL___ PROGRAM                                  *
024600**************************************************************
024700 01  PROV-NEW-HOLD.
024800     02  PROV-NEWREC-HOLD1.
024900         05  P-NEW-NPI10.
025000             10  P-NEW-NPI8                 PIC X(08).
025100             10  P-NEW-NPI-FILLER           PIC X(02).
025200         05  P-NEW-PROVIDER-NO.
025300             10  P-NEW-STATE                PIC 9(02).
025400             10  FILLER                     PIC X(04).
025500         05  P-NEW-DATE-DATA.
025600             10  P-NEW-EFF-DATE.
025700                 15  P-NEW-EFF-DT-CC        PIC 9(02).
025800                 15  P-NEW-EFF-DT-YY        PIC 9(02).
025900                 15  P-NEW-EFF-DT-MM        PIC 9(02).
026000                 15  P-NEW-EFF-DT-DD        PIC 9(02).
026100             10  P-NEW-FY-BEGIN-DATE.
026200                 15  P-NEW-FY-BEG-DT-CC     PIC 9(02).
026300                 15  P-NEW-FY-BEG-DT-YY     PIC 9(02).
026400                 15  P-NEW-FY-BEG-DT-MM     PIC 9(02).
026500                 15  P-NEW-FY-BEG-DT-DD     PIC 9(02).
026600             10  P-NEW-REPORT-DATE.
026700                 15  P-NEW-REPORT-DT-CC     PIC 9(02).
026800                 15  P-NEW-REPORT-DT-YY     PIC 9(02).
026900                 15  P-NEW-REPORT-DT-MM     PIC 9(02).
027000                 15  P-NEW-REPORT-DT-DD     PIC 9(02).
027100             10  P-NEW-TERMINATION-DATE.
027200                 15  P-NEW-TERM-DT-CC       PIC 9(02).
027300                 15  P-NEW-TERM-DT-YY       PIC 9(02).
027400                 15  P-NEW-TERM-DT-MM       PIC 9(02).
027500                 15  P-NEW-TERM-DT-DD       PIC 9(02).
027600         05  P-NEW-WAIVER-CODE              PIC X(01).
027700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
027800         05  P-NEW-INTER-NO                 PIC 9(05).
027900         05  P-NEW-PROVIDER-TYPE            PIC X(02).
028000         05  P-NEW-CURRENT-CENSUS-DIV       PIC 9(01).
028100         05  P-NEW-CURRENT-DIV   REDEFINES
028200                 P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
028300         05  P-NEW-MSA-DATA.
028400             10  P-NEW-CHG-CODE-INDEX       PIC X.
028500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
028600             10  P-NEW-GEO-LOC-MSA9   REDEFINES
028700                        P-NEW-GEO-LOC-MSAX  PIC 9(04).
028800             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
028900                        P-NEW-GEO-LOC-MSA9.
029000                 15  P-NEW-GEO-MSA-1ST      PIC X.
029100                 15  P-NEW-GEO-MSA-2ND      PIC X.
029200                 15  P-NEW-GEO-MSA-3RD      PIC X.
029300                 15  P-NEW-GEO-MSA-4TH      PIC X.
029400             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
029500             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
029600             10  P-NEW-STAND-AMT-LOC-MSA9
029700                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
029800                 15  P-NEW-RURAL-1ST.
029900                     20  P-NEW-STAND-RURAL  PIC XX.
030000                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
030100                 15  P-NEW-RURAL-2ND        PIC XX.
030200         05  P-NEW-SOL-COM-DEP-HOSP-YR      PIC XX.
030300                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
030400                 88  P-NEW-SCH-YR82       VALUE   '82'.
030500                 88  P-NEW-SCH-YR87       VALUE   '87'.
030600         05  P-NEW-LUGAR                    PIC X.
030700         05  P-NEW-TEMP-RELIEF-IND          PIC X.
030800         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
030900         05  FILLER                         PIC X(05).
031000     02  PROV-NEWREC-HOLD2.
031100         05  P-NEW-VARIABLES.
031200             10  P-NEW-FAC-SPEC-RATE        PIC  9(05)V9(02).
031300             10  P-NEW-COLA                 PIC  9(01)V9(03).
031400             10  P-NEW-INTERN-RATIO         PIC  9(01)V9(04).
031500             10  P-NEW-BED-SIZE             PIC  9(05).
031600             10  P-NEW-CCR                  PIC  9(01)V9(03).
031700             10  P-NEW-CMI                  PIC  9(01)V9(04).
031800             10  P-NEW-SSI-RATIO            PIC  V9(04).
031900             10  P-NEW-MEDICAID-RATIO       PIC  V9(04).
032000             10  P-NEW-PPS-BLEND-YR-IND     PIC  X(01).
032100             10  P-NEW-PRUP-UPDTE-FACTOR    PIC  9(01)V9(05).
032200             10  P-NEW-DSH-PERCENT          PIC  V9(04).
032300             10  P-NEW-FYE-DATE.
032400                 15  P-NEW-FYE-CC           PIC 99.
032500                 15  P-NEW-FYE-YY           PIC 99.
032600                 15  P-NEW-FYE-MM           PIC 99.
032700                 15  P-NEW-FYE-DD           PIC 99.
032800         05  P-NEW-CBSA-DATA.
032900             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
033000             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
033100             10  P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT.
033200             10  P-NEW-GEO-LOC-CBSA9   REDEFINES
033300                        P-NEW-CBSA-GEO-LOC  PIC 9(05).
033400             10  P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT.
033500             10  P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT.
033600             10  P-NEW-CBSA-STAND-AMT-LOC9
033700                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.
033800                 15  P-NEW-CBSA-RURAL-1ST.
033900                     20  P-NEW-CBSA-STAND-RURAL PIC 999.
034000                 15  P-NEW-CBSA-RURAL-2ND    PIC 99.
034100             10  P-NEW-CBSA-WAGE-INDEX       PIC 9(02)V9(04).
034200     02  PROV-NEWREC-HOLD3.
034300         05  P-NEW-PASS-AMT-DATA.
034400             10  P-NEW-PASS-AMT-CAPITAL     PIC 9(04)V99.
034500             10  P-NEW-PASS-AMT-DIR-MED-ED  PIC 9(04)V99.
034600             10  P-NEW-PASS-AMT-ORGAN-ACQ   PIC 9(04)V99.
034700             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
034800         05  P-NEW-CAPI-DATA.
034900             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
035000             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
035100             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
035200             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
035300             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
035400             15  P-NEW-CAPI-NEW-HOSP       PIC X.
035500             15  P-NEW-CAPI-IME            PIC 9V9999.
035600             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
035700         05  FILLER                        PIC X(22).
035800
035900***************************************************************
036000 LINKAGE SECTION.
036100
036200**************************************************************
036300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
036400*      THE IRCAL___ PROGRAM                                  *
036500**************************************************************
036600 01  BILL-NEW-DATA.
036700     05  B-NPI10.
036800         10  B-NPI8                   PIC X(08).
036900         10  B-NPI-FILLER             PIC X(02).
037000     05  B-PROVIDER-NO                PIC X(06).
037100     05  B-PATIENT-STATUS             PIC X(02).
037200     05  B-CMG-CODE                   PIC X(05).
037300     05  B-LOS                        PIC 9(03).
037400     05  B-COVERED-DAYS               PIC 9(03).
037500     05  B-LTR-DAYS                   PIC 9(02).
037600     05  B-SPEC-PYMT-IND              PIC X(01).
037700     05  B-DISCHARGE-DATE.
037800         10  B-DISCHG-CC              PIC 9(02).
037900         10  B-DISCHG-YY              PIC 9(02).
038000         10  B-DISCHG-MM              PIC 9(02).
038100         10  B-DISCHG-DD              PIC 9(02).
038200     05  B-COVERED-CHARGES            PIC 9(07)V9(02).
038300     05  FILLER                       PIC X(11).
038400
038500 01  PPS-DATA-ALL.
038600     05  PPS-RTC                      PIC 9(02).
038700     05  PPS-DATA.
038800         10  PPS-MSA                  PIC X(04).
038900         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
039000         10  PPS-AVG-LOS              PIC 9(02).
039100         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
039200         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).
039300         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
039400         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).
039500         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
039600         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).
039700         10  PPS-LIP-PCT              PIC 9(01)V9(04).
039800         10  PPS-LOS                  PIC 9(03).
039900         10  PPS-REG-DAYS-USED        PIC 9(03).
040000         10  PPS-LTR-DAYS-USED        PIC 9(03).
040100         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).
040200         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).
040300         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).
040400         10  PPS-FAC-COSTS            PIC 9(07)V9(02).
040500         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
040600         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).
040700         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).
040800         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).
040900         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).
041000         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).
041100         10  PPS-SUBM-CMG-CODE        PIC X(05).
041200         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.
041300             15  PPS-CMG-ALPHA        PIC X(01).
041400             15  PPS-CMG-NUMERIC.
041500                20  PPS-CMG-RIC       PIC X(02).
041600                20  FILLER            PIC X(02).
041700         10  PPS-PRICED-CMG-CODE      PIC X(05).
041800         10  PPS-CALC-VERS-CD         PIC X(05).
041900         10  PPS-CBSA                 PIC X(05).
042000         10  FILLER                   PIC X(08).
042100    05  PPS-OTHER-DATA.
042200         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
042300         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
042400         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).
042500         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).
042600         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).
042700         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).
042800         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).
042900         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).
043000         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).
043100         10  FILLER                   PIC X(02).
043200    05  PPS-PC-DATA.
043300         10  PPS-COT-IND              PIC X(01).
043400         10  FILLER                   PIC X(20).
043500
043600*****************************************************************
043700*            THESE ARE THE VERSIONS OF THE IRDRV050
043800*           PROGRAMS THAT WILL BE PASSED BACK----
043900*          ASSOCIATED WITH THE BILL BEING PROCESSED
044000*****************************************************************
044100
044200 01  PRICER-OPT-VERS-SW.
044300     05  PRICER-OPTION-SW               PIC X(01).
044400         88  ALL-TABLES-PASSED          VALUE 'A'.
044500         88  PROV-RECORD-PASSED         VALUE 'P'.
044600     05  PPS-VERSIONS.
044700         10  PPDRV-VERSION              PIC X(05).
044800
044900**************************************************************
045000*      PROVIDER SPECIFIC RECORD                              *
045100**************************************************************
045200 01  PROV-RECORD.
045300     05  PROV-REC1                  PIC X(80).
045400     05  PROV-REC2                  PIC X(80).
045500     05  PROV-REC3                  PIC X(80).
045600
045700**************************************************************
045800*      METROPOLITAN STATISTICAL AREA TABLE                   *
045900**************************************************************
046000*01  MSA-WI-TABLE.
046100*    05  M-MSA-DATA    OCCURS 0 TO 4000 TIMES
046200*                      DEPENDING ON MSA-CNT
046300*                      ASCENDING KEY IS MSAX-MSA
046400*                      INDEXED BY MU1 MU2.
046500 01  MSA-WI-TABLE.
046600     05  M-MSA-DATA    OCCURS 4000 TIMES
046700                       INDEXED BY MU1 MU2.
046800         10  MSAX-MSA                        PIC X(4).
046900         10  MSAX-EFF-DATE                   PIC X(08).
047000         10  MSAX-WAGE-INDEX                 PIC S9(02)V9(04).
047100
047200**************************************************************
047300*      CORE BASED STATISTICAL AREA TABLE                     *
047400**************************************************************
047500*01  CBSA-WI-TABLE.
047600*    05  M-CBSA-DATA   OCCURS 0 TO 6000 TIMES
047700*                      DEPENDING ON CBSA-CNT
047800*                      ASCENDING KEY IS CBSAX-CBSA
047900*                      INDEXED BY MU3 MU4.
048000 01  CBSA-WI-TABLE.
048100     05  M-CBSA-DATA   OCCURS 6000 TIMES
048200                       INDEXED BY MU3 MU4.
048300         10  CBSAX-CBSA                      PIC X(5).
048400         10  CBSAX-EFF-DATE                  PIC X(08).
048500         10  CBSAX-WAGE-INDEX                PIC S9(02)V9(04).
048600
048700 PROCEDURE DIVISION  USING BILL-NEW-DATA
048800                           PPS-DATA-ALL
048900                           PRICER-OPT-VERS-SW
049000                           PROV-RECORD
049100                           MSA-WI-TABLE
049200                           CBSA-WI-TABLE.
049300
049400******************************************************************
049500*    PROCESSING:
049600*        A. THIS MODULE WILL CALL THE IRCAL MODULES.
049700*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS
049800*           SUBROUTINE IS CALLED.
049900*        C. THE PROV-RECORD AND WAGE-INDEX-RECORD ASSOCIATED WITH
050000*           EACH BILL WILL BE PASSED TO THE IRCAL PROGRAMS.
050100******************************************************************
050200     INITIALIZE PPS-DATA-ALL.
050300     INITIALIZE PROV-NEW-HOLD.
050400     INITIALIZE WAGE-NEW-INDEX-RECORD-CBSA.
050500     MOVE DRV-VERSION TO PPDRV-VERSION.
050600     MOVE PROV-RECORD TO PROV-NEW-HOLD.
050700
050800******************************************************************
050900***     RTC = 98  --  THIS IS A BILL OLDER THAN 20020101       ***
051000******************************************************************
051100
051200     IF B-DISCHARGE-DATE > 20011231
051300        CONTINUE
051400     ELSE
051500         MOVE 98 TO PPS-RTC
051600         GOBACK.
051700
051800******************************************************************
051900***  GET THE WAGE-INDEX
052000******************************************************************
052100
052200     SET MU1 MU3 TO 1.
052300     IF B-DISCHARGE-DATE > 20050930
052400        PERFORM 0550-GET-CBSA THRU 0550-EXIT
052500     ELSE
052600        PERFORM 0500-GET-MSA THRU 0500-EXIT.
052700
052800***     RTC = 60  --  WAGE-INDEX NOT FOUND
052900     IF PPS-RTC = 60
053000          GOBACK.
053100
053200******************************************************************
053300**          THE NEXT LOGIC WILL PROCESS THE PROPER IRCAL MODULE
053400**          BASED ON THE DISCHARGE DATE.
053500******************************************************************
053600*                ADD LOGIC EVERY YEAR FOR NEW MODULE
053700
053800     IF (B-DISCHARGE-DATE > 20160930 AND
053900         B-DISCHARGE-DATE < 20171001)
054000         CALL  IRCAL170 USING BILL-NEW-DATA
054100                              PPS-DATA-ALL
054200                              PRICER-OPT-VERS-SW
054300                              PROV-NEW-HOLD
054400                              WAGE-NEW-INDEX-RECORD-CBSA.
054500
054600     IF (B-DISCHARGE-DATE > 20150930 AND
054700         B-DISCHARGE-DATE < 20161001)
054701         CALL  IRCAL160 USING BILL-NEW-DATA
054702                              PPS-DATA-ALL
054703                              PRICER-OPT-VERS-SW
054704                              PROV-NEW-HOLD
054705                              WAGE-NEW-INDEX-RECORD-CBSA.
054706
054707     IF (B-DISCHARGE-DATE > 20140930 AND
054708         B-DISCHARGE-DATE < 20151001)
054709         CALL  IRCAL150 USING BILL-NEW-DATA
054710                              PPS-DATA-ALL
054711                              PRICER-OPT-VERS-SW
054712                              PROV-NEW-HOLD
054713                              WAGE-NEW-INDEX-RECORD-CBSA.
054714
054715     IF (B-DISCHARGE-DATE > 20130930 AND
054716         B-DISCHARGE-DATE < 20141001)
054717         CALL  IRCAL140 USING BILL-NEW-DATA
054718                              PPS-DATA-ALL
054719                              PRICER-OPT-VERS-SW
054720                              PROV-NEW-HOLD
054721                              WAGE-NEW-INDEX-RECORD-CBSA.
054722
054723     IF (B-DISCHARGE-DATE > 20120930 AND
054724         B-DISCHARGE-DATE < 20131001)
054725         CALL  IRCAL130 USING BILL-NEW-DATA
054726                              PPS-DATA-ALL
054727                              PRICER-OPT-VERS-SW
054728                              PROV-NEW-HOLD
054729                              WAGE-NEW-INDEX-RECORD-CBSA.
054730
054731     IF (B-DISCHARGE-DATE > 20110930 AND
054732         B-DISCHARGE-DATE < 20121001)
054733         CALL  IRCAL120 USING BILL-NEW-DATA
054734                              PPS-DATA-ALL
054735                              PRICER-OPT-VERS-SW
054736                              PROV-NEW-HOLD
054737                              WAGE-NEW-INDEX-RECORD-CBSA.
054738
054739     IF (B-DISCHARGE-DATE > 20100930 AND
054740         B-DISCHARGE-DATE < 20111001)
054741         CALL  IRCAL110 USING BILL-NEW-DATA
054742                              PPS-DATA-ALL
054743                              PRICER-OPT-VERS-SW
054744                              PROV-NEW-HOLD
054745                              WAGE-NEW-INDEX-RECORD-CBSA.
054746
054747     IF (B-DISCHARGE-DATE > 20090930 AND
054748         B-DISCHARGE-DATE < 20101001)
054749         CALL  IRCAL100 USING BILL-NEW-DATA
054750                              PPS-DATA-ALL
054751                              PRICER-OPT-VERS-SW
054752                              PROV-NEW-HOLD
054753                              WAGE-NEW-INDEX-RECORD-CBSA.
054754
054755     IF (B-DISCHARGE-DATE > 20080930 AND
054756         B-DISCHARGE-DATE < 20091001)
054757         CALL  IRCAL090 USING BILL-NEW-DATA
054758                              PPS-DATA-ALL
054759                              PRICER-OPT-VERS-SW
054760                              PROV-NEW-HOLD
054761                              WAGE-NEW-INDEX-RECORD-CBSA.
054762
054763     IF (B-DISCHARGE-DATE > 20070930 AND
054764         B-DISCHARGE-DATE < 20081001)
054765         CALL  IRCAL080 USING BILL-NEW-DATA
054766                              PPS-DATA-ALL
054767                              PRICER-OPT-VERS-SW
054768                              PROV-NEW-HOLD
054769                              WAGE-NEW-INDEX-RECORD-CBSA.
054770
054780     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***************************************************************
