000100 IDENTIFICATION DIVISION.                                         00010007
000200 PROGRAM-ID.  IROPN180.                                           00020033
000300*AUTHOR.      PBG/DDS.                                            00030014
000400*      CENTERS FOR MEDICARE AND MEDICAID SERVICES                 00040007
000500*REMARKS.  - CALLS THE IRDRV__ MODULE                             00050007
000600*          - LOADS THE PPS TABLES AND THE MSAX TABLES             00060007
000700*          - FINDS PROV RECORD AND WAGE-INDEX RECORD FOR          00070007
000800*             GIVEN BILL TO BE PASSED TO IRDRV__ MODULE.          00080007
000900 DATE-COMPILED.                                                   00090007
001000****************************************************************  00100007
001010*                  *  *  *  *  *  *  *  *                      *  00101029
001100*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *  00110007
001200*   AND MEDICAID SERVICES.                                     *  00120007
001300*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *  00130007
001400*   PAYMENT FOR INPATIENT REHABILITATION FACILITIES.           *  00140007
001500*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *  00150007
001600*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *  00160007
001700*   IS THAT OF THE USER.                                       *  00170007
001800*                  *  *  *  *  *  *  *  *                      *  00180007
001900*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *  00190007
002000*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *  00200007
002100*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *  00210007
002200*   THE PROGRAM WILL:                                          *  00220007
002300*       1. LOAD THE TABLES USED TO CALCULATE PPS.              *  00230007
002400*       2. EDIT THE BILL INFORMATION.                          *  00240007
002500*       3. PASS BACK RETURN CODES.                             *  00250007
002600*       4. CALCULATE WHEN APPLICABLE                           *  00260007
002700*          A. THE HOSPITAL SPECIFIC PART OF PAYMENT.           *  00270007
002800*          B. THE FEDERAL SPECIFIC PART OF PAYMENT.            *  00280007
002900*          C. THE OUTLIER PORTION.                             *  00290007
003000*          D. TOTAL PAYMENT (B + C + D  ABOVE).                *  00300007
003100*          E. DISPROPORTIONATE SHARE ADJUSTMENT                *  00310007
003200*                  *  *  *  *  *  *  *  *                      *  00320007
003300*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *  00330007
003400*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *  00340007
003500*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *  00350007
003600*                  *  *  *  *  *  *  *  *                      *  00360007
003700*   CHANGE LOG.                                                *  00370007
003800*                                                              *  00380007
003900*   FOR FUTURE USE.                                            *  00390007
004000*                                                              *  00400007
004100****************************************************************  00410007
004200 ENVIRONMENT DIVISION.                                            00420007
004300 CONFIGURATION SECTION.                                           00430007
004400 SOURCE-COMPUTER.            IBM-370.                             00440007
004500 OBJECT-COMPUTER.            IBM-370.                             00450007
004600 INPUT-OUTPUT  SECTION.                                           00460007
004700 FILE-CONTROL.                                                    00470007
004800                                                                  00480007
004900     SELECT PROV-FILE ASSIGN      TO  UT-S-PPSPROV                00490007
005000            FILE STATUS IS PROV-STAT.                             00500007
005100     SELECT MSAX-FILE ASSIGN      TO  UT-S-PPSMSAX                00510007
005200            FILE STATUS IS MSAX-STAT.                             00520007
005300     SELECT CBSAX-FILE ASSIGN     TO  UT-S-PPSCBSAX               00530007
005400            FILE STATUS IS CBSAX-STAT.                            00540007
005500                                                                  00550007
005600 DATA DIVISION.                                                   00560007
005700 FILE SECTION.                                                    00570007
005800                                                                  00580007
005900 FD  PROV-FILE                                                    00590007
006000     RECORDING MODE IS F                                          00600007
006100     LABEL RECORDS ARE STANDARD                                   00610007
006200     BLOCK CONTAINS 0 RECORDS.                                    00620007
006300 01  PROV-REC.                                                    00630007
006400     05  PROV-PART1                 PIC X(80).                    00640007
006500     05  PROV-PART2                 PIC X(80).                    00650007
006600     05  PROV-PART3                 PIC X(80).                    00660007
006700                                                                  00670007
006800 FD  MSAX-FILE                                                    00680007
006900     RECORDING MODE IS F                                          00690007
007000     LABEL RECORDS ARE STANDARD                                   00700007
007100     BLOCK CONTAINS 0 RECORDS.                                    00710007
007200***************************************************************   00720007
007300*    THIS RECORD IS SUPPLIED BY CMS AND CONTAINS              *   00730007
007400*    THE WAGE INDEX FOR THE STATES (RURAL) AND MSA'S (URBAN). *   00740007
007500***************************************************************   00750007
007600 01  MSAX-REC.                                                    00760007
007700     05  X-MSA-X.                                                 00770007
007800         10  M-BLANK                PIC X(02).                    00780007
007900         10  M-STATE                PIC 9(02).                    00790007
008000     05  X-MSA REDEFINES X-MSA-X    PIC 9(04).                    00800007
008100     05  FILLER                     PIC X(01).                    00810007
008200     05  XE-DATE.                                                 00820007
008300         10  XE-CC                  PIC 9(02).                    00830007
008400         10  XE-YY                  PIC 9(02).                    00840007
008500         10  XE-MM                  PIC 9(02).                    00850007
008600         10  XE-DD                  PIC 9(02).                    00860007
008700     05  FILLER                     PIC X(01).                    00870007
008800     05  X-WAGE-INDEX               PIC S9(02)V9(04).             00880007
008900     05  FILLER                     PIC X(08).                    00890007
009000     05  X-STATE-MSA-NAME           PIC X(51).                    00900007
009100     05  FILLER                     PIC X(01).                    00910007
009200                                                                  00920007
009300 FD  CBSAX-FILE                                                   00930007
009400     RECORDING MODE IS F                                          00940007
009500     LABEL RECORDS ARE STANDARD                                   00950007
009600     BLOCK CONTAINS 0 RECORDS.                                    00960007
009700***************************************************************   00970007
009800*    THIS RECORD IS SUPPLIED BY CMS AND CONTAINS              *   00980007
009900*    THE WAGE INDEX FOR THE STATES (RURAL) AND CBSA'S (URBAN).*   00990007
010000***************************************************************   01000007
010100 01  CBSAX-REC.                                                   01010007
010200     05  X-CBSA-X.                                                01020007
010300         10  C-BLANK                PIC X(03).                    01030007
010400         10  C-STATE                PIC 9(02).                    01040007
010500     05  X-CBSA REDEFINES X-CBSA-X  PIC 9(05).                    01050007
010600     05  FILLER                     PIC X(01).                    01060007
010700     05  CE-DATE.                                                 01070007
010800         10  CE-CC                  PIC 9(02).                    01080007
010900         10  CE-YY                  PIC 9(02).                    01090007
011000         10  CE-MM                  PIC 9(02).                    01100007
011100         10  CE-DD                  PIC 9(02).                    01110007
011200     05  FILLER                     PIC X(01).                    01120007
011300     05  C-WAGE-INDEX               PIC S9(02)V9(04).             01130007
011400     05  FILLER                     PIC X(08).                    01140007
011500     05  C-STATE-CBSA-NAME          PIC X(50).                    01150007
011600     05  FILLER                     PIC X(01).                    01160007
011700                                                                  01170007
011800 WORKING-STORAGE SECTION.                                         01180007
011900 77  W-STORAGE-REF                  PIC X(48)  VALUE              01190007
012000     'I R O P N - W O R K I N G   S T O R A G E'.                 01200007
012100 01  OPN-VERSION                    PIC X(05) VALUE 'V18.0'.      01210033
012200 01  IRDRV180                       PIC X(08) VALUE 'IRDRV180'.   01220033
012300 01  TABLES-LOADED-SW               PIC 9(01)  VALUE 0.           01230007
012400 01  EOF-SW                         PIC 9(01)  VALUE 0.           01240007
012500 01  EOF-SW1                        PIC 9(01)  VALUE 0.           01250007
012600                                                                  01260007
012700 01  PROV-STAT.                                                   01270007
012800     02  PROV-STAT1                          PIC X.               01280007
012900     02  PROV-STAT2                          PIC X.               01290007
013000                                                                  01300007
013100 01  CBSAX-STAT.                                                  01310007
013200     02  CBSAX-STAT1                         PIC X.               01320007
013300     02  CBSAX-STAT2                         PIC X.               01330007
013400                                                                  01340007
013500 01  MSAX-STAT.                                                   01350007
013600     02  MSAX-STAT1                          PIC X.               01360007
013700     02  MSAX-STAT2                          PIC X.               01370007
013800                                                                  01380007
013900 01  HOLD-PROV-MSA.                                               01390007
014000     10  H-MSA-PROV-BLANK                    PIC X(2).            01400007
014100     10  H-MSA-PROV-STATE.                                        01410007
014200         15  FILLER                          PIC X.               01420007
014300         15  HOLD-LAST-MSA-POS               PIC X.               01430007
014400                                                                  01440007
014500 01  HOLD-PROV-CBSA.                                              01450007
014600     10  H-CBSA-PROV-BLANK                   PIC X(3).            01460007
014700     10  H-CBSA-PROV-STATE.                                       01470007
014800         15  FILLER                          PIC X.               01480007
014900         15  HOLD-LAST-CBSA-POS              PIC X.               01490007
015000                                                                  01500007
015100 01  MSA-WI-TABLE.                                                01510007
015200     05  M-MSA-DATA    OCCURS 4000 TIMES                          01520007
015300                       INDEXED BY MU1 MU2.                        01530007
015400         10  MSAX-MSA                        PIC X(4).            01540007
015500         10  MSAX-EFF-DATE                   PIC X(08).           01550007
015600         10  MSAX-WAGE-INDEX                 PIC S9(02)V9(04).    01560007
015700                                                                  01570007
015800 01  CBSA-WI-TABLE.                                               01580007
015900     05  M-CBSA-DATA   OCCURS 6000 TIMES                          01590024
016000                       INDEXED BY MU3 MU4.                        01600007
016100         10  CBSAX-CBSA                      PIC X(5).            01610007
016200         10  CBSAX-EFF-DATE                  PIC X(08).           01620007
016300         10  CBSAX-WAGE-INDEX                PIC S9(02)V9(04).    01630007
016400                                                                  01640007
016500 01  WORK-COUNTERS.                                               01650007
016600     05  CBSA-CNT                            PIC 9(5) VALUE ZERO. 01660007
016700     05  MSA-CNT                             PIC 9(5) VALUE ZERO. 01670007
016800     05  PROV-CNT                            PIC 9(5) VALUE ZERO. 01680007
016900***************************************************************   01690007
017000*    THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY     *   01700007
017100*    SET TO OCCUR 2400 TIMES. THIS NUMBER SHOULD BE ADJUSTED  *   01710007
017200*    BY THE USER TO REFLECT THE NUMBER OF PROVIDER RECORDS    *   01720007
017300*    PLUS EXPANSION. EACH ENTRY COSTS 240 BYTES OF MEMORY.    *   01730007
017400*    THIS FILE MUST BE IN PROVIDER NUMBER, EFFECTIVE-DATE     *   01740007
017500*    SEQUENCE.                                                *   01750007
017600***************************************************************   01760007
017700 01  PROV-TABLE.                                                  01770007
017800     05  PROV-ENTRIES       OCCURS 0 TO 2400 TIMES                01780007
017900                            DEPENDING ON PROV-CNT                 01790007
018000                            ASCENDING KEY IS PROV-NO              01800007
018100                            INDEXED BY PX1.                       01810007
018200         10  PROV-DATA1.                                          01820007
018300             15  PROV-NPI10.                                      01830007
018400                 20  PROV-NPI8               PIC X(08).           01840007
018500                 20  PROV-NPI-FILLER         PIC X(02).           01850007
018600             15  PROV-NO                     PIC X(06).           01860007
018700             15  PROV-EFF-DATE               PIC X(08).           01870007
018800             15  FILLER                      PIC X(56).           01880007
018900 01  PROV-DATA-2.                                                 01890007
019000     05  PROV-ENTRIES2      OCCURS 0 TO 2400 TIMES                01900007
019100                            DEPENDING ON PROV-CNT                 01910007
019200                            INDEXED BY PD2.                       01920007
019300         10  PROV-DATA2                      PIC X(80).           01930007
019400 01  PROV-DATA-3.                                                 01940007
019500     05  PROV-ENTRIES3      OCCURS 0 TO 2400 TIMES                01950007
019600                            DEPENDING ON PROV-CNT                 01960007
019700                            INDEXED BY PD3.                       01970007
019800         10  PROV-DATA3                      PIC X(80).           01980007
019900                                                                  01990007
020000***************************************************************   02000007
020100*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   02010007
020200*      THE IRCAL___ PROGRAM FOR PROCESSING MSA'S              *   02020007
020300***************************************************************   02030007
020400 01  WAGE-NEW-INDEX-RECORD.                                       02040007
020500     05  W-NEW-MSA                           PIC 9(4).            02050007
020600     05  W-NEW-EFF-DATE.                                          02060007
020700          10  W-NEW-EFF-DATE-CC              PIC 9(2).            02070007
020800          10  W-NEW-EFF-DATE-YMD.                                 02080007
020900              15  W-NEW-EFF-DATE-YY          PIC 9(2).            02090007
021000              15  W-NEW-EFF-DATE-MM          PIC 9(2).            02100007
021100              15  W-NEW-EFF-DATE-DD          PIC 9(2).            02110007
021200     05  W-NEW-INDEX-RECORD                  PIC S9(02)V9(04).    02120007
021300                                                                  02130007
021400***************************************************************   02140007
021500*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *   02150007
021600*      THE IRCAL___ PROGRAM FOR PROCESSING CBSA'S             *   02160007
021700***************************************************************   02170007
021800 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  02180007
021900     05  W-NEW-CBSA                          PIC 9(5).            02190007
022000     05  W-NEW-EFF-DATE-C.                                        02200007
022100          10  W-NEW-EFF-DATE-CC-C            PIC 9(2).            02210007
022200          10  W-NEW-EFF-DATE-YMD-C.                               02220007
022300              15  W-NEW-EFF-DATE-YY-C        PIC 9(2).            02230007
022400              15  W-NEW-EFF-DATE-MM-C        PIC 9(2).            02240007
022500              15  W-NEW-EFF-DATE-DD-C        PIC 9(2).            02250007
022600     05  W-NEW-INDEX-RECORD-C                PIC S9(02)V9(04).    02260007
022700                                                                  02270007
022800**************************************************************    02280007
022900*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *    02290007
023000*      THE IRCAL___ PROGRAM                                  *    02300007
023100**************************************************************    02310007
023200 01  PROV-NEW-HOLD.                                               02320007
023300     02  PROV-NEWREC-HOLD1.                                       02330007
023400         05  P-NEW-NPI10.                                         02340007
023500             10  P-NEW-NPI8                 PIC X(08).            02350007
023600             10  P-NEW-NPI-FILLER           PIC X(02).            02360007
023700         05  P-NEW-PROVIDER-NO.                                   02370007
023800             10  P-NEW-STATE                PIC 9(02).            02380007
023900             10  FILLER                     PIC X(04).            02390007
024000         05  P-NEW-DATE-DATA.                                     02400007
024100             10  P-NEW-EFF-DATE.                                  02410007
024200                 15  P-NEW-EFF-DT-CC        PIC 9(02).            02420007
024300                 15  P-NEW-EFF-DT-YY        PIC 9(02).            02430007
024400                 15  P-NEW-EFF-DT-MM        PIC 9(02).            02440007
024500                 15  P-NEW-EFF-DT-DD        PIC 9(02).            02450007
024600             10  P-NEW-FY-BEGIN-DATE.                             02460007
024700                 15  P-NEW-FY-BEG-DT-CC     PIC 9(02).            02470007
024800                 15  P-NEW-FY-BEG-DT-YY     PIC 9(02).            02480007
024900                 15  P-NEW-FY-BEG-DT-MM     PIC 9(02).            02490007
025000                 15  P-NEW-FY-BEG-DT-DD     PIC 9(02).            02500007
025100             10  P-NEW-REPORT-DATE.                               02510007
025200                 15  P-NEW-REPORT-DT-CC     PIC 9(02).            02520007
025300                 15  P-NEW-REPORT-DT-YY     PIC 9(02).            02530007
025400                 15  P-NEW-REPORT-DT-MM     PIC 9(02).            02540007
025500                 15  P-NEW-REPORT-DT-DD     PIC 9(02).            02550007
025600             10  P-NEW-TERMINATION-DATE.                          02560007
025700                 15  P-NEW-TERM-DT-CC       PIC 9(02).            02570007
025800                 15  P-NEW-TERM-DT-YY       PIC 9(02).            02580007
025900                 15  P-NEW-TERM-DT-MM       PIC 9(02).            02590007
026000                 15  P-NEW-TERM-DT-DD       PIC 9(02).            02600007
026100         05  P-NEW-WAIVER-CODE              PIC X(01).            02610007
026200             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              02620007
026300         05  P-NEW-INTER-NO                 PIC 9(05).            02630007
026400         05  P-NEW-PROVIDER-TYPE            PIC X(02).            02640007
026500         05  P-NEW-CURRENT-CENSUS-DIV       PIC 9(01).            02650007
026600         05  P-NEW-CURRENT-DIV   REDEFINES                        02660007
026700                 P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).            02670007
026800         05  P-NEW-MSA-DATA.                                      02680007
026900             10  P-NEW-CHG-CODE-INDEX       PIC X.                02690007
027000             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02700007
027100             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02710007
027200                        P-NEW-GEO-LOC-MSAX  PIC 9(04).            02720007
027300             10  P-NEW-GEO-LOC-MSA-AST REDEFINES                  02730007
027400                        P-NEW-GEO-LOC-MSA9.                       02740007
027500                 15  P-NEW-GEO-MSA-1ST      PIC X.                02750007
027600                 15  P-NEW-GEO-MSA-2ND      PIC X.                02760007
027700                 15  P-NEW-GEO-MSA-3RD      PIC X.                02770007
027800                 15  P-NEW-GEO-MSA-4TH      PIC X.                02780007
027900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02790007
028000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02800007
028100             10  P-NEW-STAND-AMT-LOC-MSA9                         02810007
028200                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.             02820007
028300                 15  P-NEW-RURAL-1ST.                             02830007
028400                     20  P-NEW-STAND-RURAL  PIC XX.               02840007
028500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02850007
028600                 15  P-NEW-RURAL-2ND        PIC XX.               02860007
028700         05  P-NEW-SOL-COM-DEP-HOSP-YR      PIC XX.               02870007
028800                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           02880007
028900                 88  P-NEW-SCH-YR82       VALUE   '82'.           02890007
029000                 88  P-NEW-SCH-YR87       VALUE   '87'.           02900007
029100         05  P-NEW-LUGAR                    PIC X.                02910007
029200         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02920007
029300         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02930007
029400         05  FILLER                         PIC X(05).            02940007
029500     02  PROV-NEWREC-HOLD2.                                       02950007
029600         05  P-NEW-VARIABLES.                                     02960007
029700             10  P-NEW-FAC-SPEC-RATE        PIC  9(05)V9(02).     02970007
029800             10  P-NEW-COLA                 PIC  9(01)V9(03).     02980007
029900             10  P-NEW-INTERN-RATIO         PIC  9(01)V9(04).     02990007
030000             10  P-NEW-BED-SIZE             PIC  9(05).           03000007
030100             10  P-NEW-CCR                  PIC  9(01)V9(03).     03010007
030200             10  P-NEW-CMI                  PIC  9(01)V9(04).     03020007
030300             10  P-NEW-SSI-RATIO            PIC  V9(04).          03030007
030400             10  P-NEW-MEDICAID-RATIO       PIC  V9(04).          03040007
030500             10  P-NEW-PPS-BLEND-YR-IND     PIC  X(01).           03050007
030600             10  P-NEW-PRUP-UPDTE-FACTOR    PIC  9(01)V9(05).     03060007
030700             10  P-NEW-DSH-PERCENT          PIC  V9(04).          03070007
030800             10  P-NEW-FYE-DATE.                                  03080007
030900                 15  P-NEW-FYE-CC           PIC 99.               03090007
031000                 15  P-NEW-FYE-YY           PIC 99.               03100007
031100                 15  P-NEW-FYE-MM           PIC 99.               03110007
031200                 15  P-NEW-FYE-DD           PIC 99.               03120007
031300         05  P-NEW-CBSA-DATA.                                     03130007
031400             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                03140007
031500             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.                03150007
031600             10  P-NEW-CBSA-GEO-LOC       PIC X(05) JUST RIGHT.   03160007
031700             10  P-NEW-GEO-LOC-CBSA9   REDEFINES                  03170007
031800                        P-NEW-CBSA-GEO-LOC  PIC 9(05).            03180007
031900             10  P-NEW-CBSA-RECLASS-LOC   PIC X(05) JUST RIGHT.   03190007
032000             10  P-NEW-CBSA-STAND-AMT-LOC PIC X(05) JUST RIGHT.   03200007
032100             10  P-NEW-CBSA-STAND-AMT-LOC9                        03210007
032200                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              03220007
032300                 15  P-NEW-CBSA-RURAL-1ST.                        03230007
032400                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          03240007
032500                 15  P-NEW-CBSA-RURAL-2ND    PIC 99.              03250007
032600             10  P-NEW-CBSA-WAGE-INDEX       PIC 9(02)V9(04).     03260007
032700     02  PROV-NEWREC-HOLD3.                                       03270007
032800         05  P-NEW-PASS-AMT-DATA.                                 03280007
032900             10  P-NEW-PASS-AMT-CAPITAL     PIC 9(04)V99.         03290007
033000             10  P-NEW-PASS-AMT-DIR-MED-ED  PIC 9(04)V99.         03300007
033100             10  P-NEW-PASS-AMT-ORGAN-ACQ   PIC 9(04)V99.         03310007
033200             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          03320007
033300         05  P-NEW-CAPI-DATA.                                     03330007
033400             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 03340007
033500             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          03350007
033600             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          03360007
033700             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        03370007
033800             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             03380007
033900             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 03390007
034000             15  P-NEW-CAPI-IME            PIC 9V9999.            03400007
034100             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          03410007
034110             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             03411011
034200         05  FILLER                        PIC X(18).             03420011
034300                                                                  03430007
034500 LINKAGE SECTION.                                                 03450007
034700**************************************************************    03470007
034800*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *    03480007
034900*      THE IRCAL___ PROGRAM                                  *    03490007
035000**************************************************************    03500007
035100 01  BILL-NEW-DATA.                                               03510007
035200     05  B-NPI10.                                                 03520007
035300         10  B-NPI8                   PIC X(08).                  03530007
035400         10  B-NPI-FILLER             PIC X(02).                  03540007
035500     05  B-PROVIDER-NO                PIC X(06).                  03550007
035600     05  B-PATIENT-STATUS             PIC X(02).                  03560007
035700     05  B-CMG-CODE                   PIC X(05).                  03570007
035800     05  B-LOS                        PIC 9(03).                  03580007
035900     05  B-COVERED-DAYS               PIC 9(03).                  03590007
036000     05  B-LTR-DAYS                   PIC 9(02).                  03600007
036100     05  B-SPEC-PYMT-IND              PIC X(01).                  03610007
036200     05  B-DISCHARGE-DATE.                                        03620007
036300         10  B-DISCHG-CC              PIC 9(02).                  03630007
036400         10  B-DISCHG-YY              PIC 9(02).                  03640007
036500         10  B-DISCHG-MM              PIC 9(02).                  03650007
036600         10  B-DISCHG-DD              PIC 9(02).                  03660007
036700     05  B-COVERED-CHARGES            PIC 9(07)V9(02).            03670007
036800     05  FILLER                       PIC X(11).                  03680007
036900                                                                  03690007
037000 01  PPS-DATA-ALL.                                                03700007
037100     05  PPS-RTC                      PIC 9(02).                  03710007
037200     05  PPS-DATA.                                                03720007
037300         10  PPS-MSA                  PIC X(04).                  03730007
037400         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03740007
037500         10  PPS-AVG-LOS              PIC 9(02).                  03750007
037600         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03760007
037700         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03770007
037800         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03780007
037900         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03790007
038000         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03800007
038100         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03810007
038200         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03820007
038300         10  PPS-LOS                  PIC 9(03).                  03830007
038400         10  PPS-REG-DAYS-USED        PIC 9(03).                  03840007
038500         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03850007
038600         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03860007
038700         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03870007
038800         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03880007
038900         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03890007
039000         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03900007
039100         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03910007
039200         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03920007
039300         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03930007
039400         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03940007
039500         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03950007
039600         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03960007
039700         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03970007
039800             15  PPS-CMG-ALPHA        PIC X(01).                  03980007
039900             15  PPS-CMG-NUMERIC.                                 03990007
040000                20  PPS-CMG-RIC       PIC X(02).                  04000007
040100                20  FILLER            PIC X(02).                  04010007
040200         10  PPS-PRICED-CMG-CODE      PIC X(05).                  04020007
040300         10  PPS-CALC-VERS-CD         PIC X(05).                  04030007
040400         10  PPS-CBSA                 PIC X(05).                  04040007
040500         10  FILLER                   PIC X(08).                  04050007
040600    05  PPS-OTHER-DATA.                                           04060007
040700         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            04070007
040800         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            04080007
040900         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            04090007
041000         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            04100007
041100         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            04110007
041200         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            04120007
041300         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            04130007
041400         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            04140007
041500         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            04150007
041600         10  FILLER                   PIC X(02).                  04160007
041700    05  PPS-PC-DATA.                                              04170007
041800         10  PPS-COT-IND              PIC X(01).                  04180007
041900         10  FILLER                   PIC X(20).                  04190007
042000                                                                  04200007
042100***************************************************************** 04210007
042200*            THESE ARE THE VERSIONS OF THE IRDRV___               04220007
042300*           PROGRAMS THAT WILL BE PASSED BACK----                 04230007
042400*          ASSOCIATED WITH THE BILL BEING PROCESSED               04240007
042500***************************************************************** 04250007
042600                                                                  04260007
042700 01  PRICER-OPT-VERS-SW.                                          04270007
042800     05  PRICER-OPTION-SW               PIC X(01).                04280007
042900         88  ALL-TABLES-PASSED          VALUE 'A'.                04290007
043000         88  PROV-RECORD-PASSED         VALUE 'P'.                04300007
043100     05  PPS-VERSIONS.                                            04310007
043200         10  PPDRV-VERSION              PIC X(05).                04320007
043300                                                                  04330007
043400**************************************************************    04340007
043500*      PROVIDER SPECIFIC RECORD                           *       04350007
043600**************************************************************    04360007
043700 01  PROV-RECORD-FROM-USER.                                       04370007
043800     05  PROV-REC1                  PIC X(80).                    04380007
043900     05  PROV-REC2                  PIC X(80).                    04390007
044000     05  PROV-REC3                  PIC X(80).                    04400007
044100                                                                  04410007
044200**************************************************************    04420007
044300*      METROPOLITAN STATISTICAL AREA RECORD                 *     04430007
044400**************************************************************    04440007
044500 01  MSAX-TABLE-FROM-USER.                                        04450007
044600     05  FILLER                     PIC X(32000).                 04460007
044700     05  FILLER                     PIC X(30000).                 04470007
044800     05  FILLER                     PIC X(30000).                 04480007
044900                                                                  04490007
045000**************************************************************    04500007
045100*      CBSA RECORD                                           *    04510007
045200**************************************************************    04520007
045300 01  CBSAX-TABLE-FROM-USER.                                       04530007
045400     05  FILLER                     PIC X(32000).                 04540007
045500     05  FILLER                     PIC X(30000).                 04550007
045600     05  FILLER                     PIC X(30000).                 04560007
045700                                                                  04570007
045800 PROCEDURE DIVISION  USING BILL-NEW-DATA                          04580007
045900                           PPS-DATA-ALL                           04590007
046000                           PRICER-OPT-VERS-SW                     04600007
046100                           PROV-RECORD-FROM-USER                  04610007
046200                           MSAX-TABLE-FROM-USER                   04620007
046300                           CBSAX-TABLE-FROM-USER.                 04630007
046400                                                                  04640007
046500******************************************************************04650007
046600*    PROCESSING:                                                  04660007
046700*        A. THIS MODULE WILL CALL THE IRDRV MODULE.               04670007
046800*        B. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  04680007
046900*           SUBROUTINE IS CALLED.                                 04690007
047000*        C. ALL FILES WILL BE PASSED TO THE IRDRV___ PROGRAM.     04700007
047100******************************************************************04710007
047200     MOVE OPN-VERSION TO PPDRV-VERSION.                           04720007
047300                                                                  04730007
047400     INITIALIZE PPS-DATA-ALL.                                     04740007
047500     INITIALIZE PROV-NEW-HOLD.                                    04750007
047600                                                                  04760007
047700******************************************************************04770007
047800 0000-TEST-PRICER-OPTION-SW.                                      04780007
047810                                                                  04781028
047900     IF  PRICER-OPTION-SW  = 'A'                                  04790007
048000         PERFORM 1900-OPTION-SW-A THRU 1900-EXIT                  04800007
048100     ELSE                                                         04810007
048200     IF  PRICER-OPTION-SW  = 'P'                                  04820007
048300         PERFORM 2000-OPTION-SW-P THRU 2000-EXIT                  04830007
048400     ELSE                                                         04840007
048500         PERFORM 2100-OPTION-SW THRU 2100-EXIT.                   04850007
048600                                                                  04860007
048700******************************************************************04870007
048800***  GET THE PROVIDER RECORD                                      04880007
048900                                                                  04890007
049000     IF PROV-RECORD-PASSED OR ALL-TABLES-PASSED                   04900007
049100        MOVE 00 TO PPS-RTC                                        04910007
049200     ELSE                                                         04920007
049300        PERFORM 1200-GET-THIS-PROVIDER THRU 1200-EXIT.            04930007
049400                                                                  04940007
049500***     RTC = 59  --  PROVIDER NOT FOUND                          04950007
049600     IF PPS-RTC = 59                                              04960007
049700          GOBACK.                                                 04970007
049800                                                                  04980007
049900******************************************************************04990007
050100**  THE NEXT LOGIC WILL PROCESS THE PROPER IRCAL MODULE         **05010028
050200**      BASED ON THE DISCHARGE DATE.                            **05020028
050210**  CHANGE TO NEW MODULE NAME EVERY YEAR.                       **05021028
050300******************************************************************05030007
050400                                                                  05040007
050500     CALL  IRDRV180 USING BILL-NEW-DATA                           05050033
050600                              PPS-DATA-ALL                        05060007
050700                              PRICER-OPT-VERS-SW                  05070007
050800                              PROV-NEW-HOLD                       05080007
050900                              MSA-WI-TABLE                        05090007
051000                              CBSA-WI-TABLE.                      05100007
051100                                                                  05110007
051200         GOBACK.                                                  05120007
051400                                                                  05140007
051500 1200-GET-THIS-PROVIDER.                                          05150007
051600***************************************************************   05160007
051700*    ON A PROVIDER BREAK:                                     *   05170007
051800*        FIND THE NEW PROVIDER SPECIFIC DATA ELEMENTS         *   05180007
051900*    NOTE: IF BILLS ARE SORTED/BATCHED BY PROVIDER, FEWER     *   05190007
052000*             TABLE SEARCHES WILL BE NECESSARY.               *   05200007
052100***************************************************************   05210007
052110                                                                  05211025
052200     IF B-PROVIDER-NO NOT = P-NEW-PROVIDER-NO                     05220007
052300        SEARCH ALL PROV-ENTRIES                                   05230007
052400          AT END                                                  05240007
052500             MOVE 59 TO PPS-RTC                                   05250007
052600             GO TO 1200-EXIT                                      05260007
052700        WHEN PROV-NO (PX1) = B-PROVIDER-NO                        05270007
052800           MOVE 00 TO PPS-RTC.                                    05280007
052900                                                                  05290007
053000        MOVE PROV-DATA1 (PX1) TO PROV-NEWREC-HOLD1.               05300007
053100        SET PD2 TO PX1.                                           05310007
053200        SET PD3 TO PX1.                                           05320007
053300        MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2.               05330007
053400        MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.               05340007
053500                                                                  05350007
053600        PERFORM 1300-GET-CURR-PROV THRU 1300-EXIT                 05360007
053700          VARYING PX1 FROM PX1 BY 1                               05370007
053800            UNTIL PROV-NO (PX1) NOT = B-PROVIDER-NO               05380007
053900              OR PROV-NO (PX1) = '999999'.                        05390007
054000                                                                  05400007
054100 1200-EXIT.                                                       05410007
054200      EXIT.                                                       05420007
054300                                                                  05430007
054400 1300-GET-CURR-PROV.                                              05440007
054500                                                                  05450007
054600     IF B-DISCHARGE-DATE NOT < PROV-EFF-DATE (PX1)                05460028
054700         MOVE PROV-DATA1 (PX1) TO PROV-NEWREC-HOLD1               05470007
054800         SET PD2 TO PX1                                           05480007
054900         SET PD3 TO PX1                                           05490007
055000         MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2               05500007
055100         MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3.              05510007
055200                                                                  05520007
055300 1300-EXIT.                                                       05530007
055400      EXIT.                                                       05540007
055500                                                                  05550007
055700 1500-LOAD-BOTH-TABLES.                                           05570007
055800***************************************************************   05580007
055900*    THE FIRST TIME CALLED:                                   *   05590007
056000*        LOAD MSA TABLE SUPPLIED BY CMS                       *   05600007
056100*        LOAD THE PROVIDER SPECIFIC TABLE SUPPLIED BY         *   05610007
056200*             THE INTERMEDIARY/USER.                          *   05620007
056300***************************************************************   05630007
056400     MOVE HIGH-VALUES TO MSA-WI-TABLE.                            05640007
056500     MOVE HIGH-VALUES TO CBSA-WI-TABLE.                           05650007
056600     MOVE ALL '9' TO PROV-NEW-HOLD.                               05660007
056700     MOVE ALL '9' TO PROV-TABLE.                                  05670007
056800     MOVE ALL '9' TO PROV-DATA-2.                                 05680007
056900     MOVE ALL '9' TO PROV-DATA-3.                                 05690007
056910                                                                  05691028
057000     OPEN INPUT PROV-FILE.                                        05700007
057010                                                                  05701028
057100     MOVE 0 TO EOF-SW EOF-SW1.                                    05710007
057200     SET PX1 TO EOF-SW.                                           05720007
057300                                                                  05730007
057400     PERFORM 1600-READ-PROV-FILE THRU 1600-EXIT                   05740007
057500                           UNTIL EOF-SW = 1.                      05750007
057510                                                                  05751028
057600     CLOSE PROV-FILE.                                             05760007
057700                                                                  05770007
057800     PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT.                  05780007
057900                                                                  05790007
058000 1500-EXIT.                                                       05800007
058100      EXIT.                                                       05810007
058200                                                                  05820007
058300 1600-READ-PROV-FILE.                                             05830007
058400                                                                  05840007
058500     READ PROV-FILE                                               05850007
058600         AT END                                                   05860007
058700             SET PX1 UP BY 1                                      05870007
058800             MOVE ALL '9' TO PROV-DATA1 (PX1)                     05880007
058900             SET PD2 TO PX1                                       05890007
059000             SET PD3 TO PX1                                       05900007
059100             MOVE ALL '9' TO PROV-DATA2 (PD2)                     05910007
059200             MOVE ALL '9' TO PROV-DATA3 (PD3)                     05920007
059300             MOVE 1 TO EOF-SW                                     05930007
059400             DISPLAY 'NUMBER OF PROVIDERS   = ' PROV-CNT.         05940007
059500                                                                  05950007
059600     IF  EOF-SW = 0                                               05960007
059700         ADD 1 TO PROV-CNT                                        05970007
059800         SET PX1 UP BY 1                                          05980007
059900         MOVE PROV-PART1 TO PROV-DATA1 (PX1)                      05990007
060000         SET PD2 TO PX1                                           06000007
060100         SET PD3 TO PX1                                           06010007
060200         MOVE PROV-PART2 TO PROV-DATA2 (PD2)                      06020007
060300         MOVE PROV-PART3 TO PROV-DATA3 (PD3).                     06030007
060400                                                                  06040007
060500 1600-EXIT.                                                       06050007
060600      EXIT.                                                       06060007
060700                                                                  06070007
060800 1700-LOAD-MSAX-FILE.                                             06080007
060900                                                                  06090007
061000      OPEN INPUT MSAX-FILE.                                       06100007
061100      MOVE 0 TO EOF-SW.                                           06110007
061200      SET MU1 TO EOF-SW.                                          06120007
061300                                                                  06130007
061400      PERFORM 1800-READ-MSAX-FILE THRU 1800-EXIT                  06140007
061500                      UNTIL EOF-SW = 1.                           06150007
061600                                                                  06160007
061700      CLOSE MSAX-FILE.                                            06170007
061800                                                                  06180007
061900      OPEN INPUT CBSAX-FILE.                                      06190007
062000      MOVE 0 TO EOF-SW1.                                          06200007
062100      SET MU3 TO EOF-SW1.                                         06210007
062200                                                                  06220007
062300      PERFORM 1850-READ-CBSAX-FILE THRU 1850-EXIT                 06230007
062400                      UNTIL EOF-SW1 = 1.                          06240007
062500      CLOSE CBSAX-FILE.                                           06250007
062600                                                                  06260007
062700 1700-EXIT.                                                       06270007
062800      EXIT.                                                       06280007
062900                                                                  06290007
063000 1800-READ-MSAX-FILE.                                             06300007
063100                                                                  06310007
063200     READ MSAX-FILE                                               06320007
063300         AT END                                                   06330007
063400             MOVE 1 TO EOF-SW                                     06340007
063500             DISPLAY 'NUMBER OF MSA RECORDS = ' MSA-CNT.          06350007
063600                                                                  06360007
063700     IF EOF-SW = 0                                                06370007
063800        ADD 1 TO MSA-CNT                                          06380007
063900        SET MU1 UP BY 1                                           06390007
064000        MOVE X-MSA-X      TO MSAX-MSA        (MU1)                06400007
064100        MOVE XE-DATE      TO MSAX-EFF-DATE   (MU1)                06410007
064200        MOVE X-WAGE-INDEX TO MSAX-WAGE-INDEX (MU1).               06420007
064300                                                                  06430007
064400 1800-EXIT.                                                       06440007
064500      EXIT.                                                       06450007
064600                                                                  06460007
064700 1850-READ-CBSAX-FILE.                                            06470007
064800                                                                  06480007
064900     READ CBSAX-FILE                                              06490007
065000         AT END                                                   06500007
065100             MOVE 1 TO EOF-SW1                                    06510007
065200             DISPLAY 'NUMBER OF CBSA RECORDS = ' CBSA-CNT.        06520007
065300                                                                  06530007
065400     IF EOF-SW1 = 0                                               06540007
065500        ADD 1 TO CBSA-CNT                                         06550007
065600        SET MU3 UP BY 1                                           06560007
065700        MOVE X-CBSA-X     TO CBSAX-CBSA (MU3)                     06570007
065800        MOVE CE-DATE      TO CBSAX-EFF-DATE   (MU3)               06580007
065900        MOVE C-WAGE-INDEX TO CBSAX-WAGE-INDEX (MU3).              06590007
066000                                                                  06600007
066100 1850-EXIT.                                                       06610007
066200      EXIT.                                                       06620007
066300                                                                  06630007
066400 1900-OPTION-SW-A.                                                06640007
066500                                                                  06650007
066600     MOVE ALL '9'               TO PROV-NEW-HOLD.                 06660007
066700     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 06670007
066800     IF (TABLES-LOADED-SW = 0) AND                                06680007
066900        (B-DISCHARGE-DATE < 20051001)                             06690007
067000         MOVE HIGH-VALUES           TO MSA-WI-TABLE               06700007
067100         MOVE MSAX-TABLE-FROM-USER  TO MSA-WI-TABLE               06710007
067200         MOVE 1 TO TABLES-LOADED-SW                               06720007
067300     ELSE                                                         06730007
067400        IF (TABLES-LOADED-SW = 0) AND                             06740007
067500           (B-DISCHARGE-DATE > 20050930)                          06750007
067600            MOVE HIGH-VALUES           TO CBSA-WI-TABLE           06760007
067700            MOVE CBSAX-TABLE-FROM-USER  TO CBSA-WI-TABLE          06770007
067800            MOVE 1 TO TABLES-LOADED-SW.                           06780007
067900                                                                  06790007
068000 1900-EXIT.                                                       06800007
068100      EXIT.                                                       06810007
068200                                                                  06820007
068300 2000-OPTION-SW-P.                                                06830007
068400                                                                  06840007
068500     MOVE ALL '9'               TO PROV-NEW-HOLD.                 06850007
068600     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.                 06860007
068700     IF TABLES-LOADED-SW = 0                                      06870028
068800         MOVE HIGH-VALUES TO MSA-WI-TABLE                         06880007
068900         PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT               06890007
069000         MOVE 1 TO TABLES-LOADED-SW.                              06900007
069100                                                                  06910007
069200 2000-EXIT.                                                       06920007
069300      EXIT.                                                       06930007
069400                                                                  06940007
069500 2100-OPTION-SW.                                                  06950007
069600                                                                  06960007
069700     IF TABLES-LOADED-SW = 0                                      06970028
069800         PERFORM 1500-LOAD-BOTH-TABLES THRU 1500-EXIT             06980007
069900         MOVE 1 TO TABLES-LOADED-SW.                              06990007
070000                                                                  07000007
070100 2100-EXIT.                                                       07010007
070200      EXIT.                                                       07020007
070400***************************************************************   07040007
070500******       L A S T   S O U R C E   S T A T E M E N T    *****   07050007
070600***************************************************************   07060027
