000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. LTOPN130.
000400*AUTHOR.     CENTERS FOR MEDICARE AND MEDICAID SERVICES
000600*REMARKS.    - OPENS THE PROV FILE, MSAX FILE, CBSAX FILE, AND
000700*              IPPS CBSAX FILE
000700*            - FINDS PROV RECORD FOR THE GIVEN BILL TO BE
000800*              PASSED TO THE LTDRV___ MODULE
000600*            - LOADS THE MSAX, CBSAX, & IPPS CBSAX TABLES
000700*            - CALLS THE LTDRV___ MODULE
001100 DATE-COMPILED.
001200****************************************************************
001200*                                                              *
001300*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *
001400*   AND MEDICAID SERVICES.                                     *
001500*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *
001600*   PAYMENT FOR LONG TERM CARE HOSPITALS.                      *
001700*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *
001800*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *
001900*   IS THAT OF THE USER.                                       *
002000*                  *  *  *  *  *  *  *  *                      *
002100*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *
002200*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *
002300*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *
002400*   THE PROGRAM WILL:                                          *
002500*       1. LOAD THE TABLES USED TO CALCULATE PPS.              *
002700*       2. PASS BACK RETURN CODES.                             *
003500*                                                              *
003700*                  *  *  *  *  *  *  *  *                      *
003800*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *
003900*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *
004000*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *
004100*                  *  *  *  *  *  *  *  *                      *
004200*                                                              *
004200*                                                              *
004200*--------------------------------------------------------------*
004200*   CHANGE LOG.                                                *
004200*--------------------------------------------------------------*
004200*                                                              *
004200*   04/07/2005 - AT THE REQUEST OF FISS, LTDRV___ MODIFIED TO  *
004200*                ONLY READ INPUT DATA AND LOAD TABLES FOR THE  *
004200*                PROVIDER SPECIFIC FILE & WAGE INDEX FILE      *
004200*                IT STILL RECEIVES THE BILL & PPS RECORDS      *
004200*                                                              *
004200*--------------------------------------------------------------*
004200*                                                              *
004200*   04/20/2005 - EFFECTIVE JULY 1, 2005, CBSA (CORE-BASED      *
004200*                STATISTICAL AREA) IS USED IN PLACE OF MSA     *
004200*                (METROPOLITAN STATISTICAL AREA), THE PROGRAM  *
004200*                DETERMINES WHETHER TO USE THE CBSA WAGE INDEX *
004200*                FILE OR MSA WAGE INDEX FILE BASED ON THE BILL *
004200*                DISCHARGE DATE                                *
004200*                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   05/02/2005 - ADDED PSF FIELDS - SPECIAL PAY INDICATOR &    *
      *                SPECIAL WAGE INDEX                            *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   01/17/2006 - MODIFIED FOR 1ST CICS PACKAGE RELEASE;        *
      *                TO BE RELEASED APRIL 1, 2006                  *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   01/19/2006 - PROGRAM NAME CHANGED FROM LTDRV___ TO LTOPN___*
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   05/02/2006 - ADD IPPS CBSA WAGE INDEX TABLE TO THE PROGRAM *
      *                FOR SHORT STAY PROVISION #4 - STORE & LOAD    *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   06/19/2006 - CHANGE VERSION FROM 07.0 TO 07.1              *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/09/2006 - UPDATE FOR OCTOBER 2006 VERSION 07.3          *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   09/06/2006 - UPDATE FOR OCTOBER 2006 VERSION 07.4          *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   11/16/2006 - CREATED VERSION 07.5 FOR OCTOBER 2006         *
      *                DUE TO CORRECTION OF THE IME                  *
      *                MULTIPLIER USED IN THE 4TH SSO                *
      *                PROVISION (IPPS PORTION), IPPS WAGE INDEX     *
      *                CHANGE, & REMOVAL OF PPS-RTC 23               *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   12/28/2006 - CREATED VERSION 07.6 FOR OCTOBER 2006         *
      *                DUE TO CBSA SIZE LOGIC CORRECTION             *
      *                ** THIS VERSION WAS NOT RELEASED **           *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   05/03/2007 - UPDATE FOR JULY 2007 VERSION 08.0             *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/13/2007 - UPDATE FOR OCTOBER 2007 VERSION 08.1          *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/23/2007 - UPDATE FOR OCTOBER 2007 VERSION 08.2          *
      *                (FOR REVISED IPPS RATES & WAGE INDEX TABLE)   *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   09/14/2007 - UPDATE FOR OCTOBER 2007 VERSION 08.3          *
      *                (FOR REVISED IPPS RATES & WAGE INDEX TABLE)   *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   09/28/2007 - UPDATE FOR OCTOBER 2007 VERSION 08.4          *
      *                (FOR REVISED IPPS RATES)                      *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   12/27/2007 - UPDATE FOR OCTOBER 2007 VERSION 08.5          *
      *                (FOR REVISED SHORT STAY OUTLIER LOGIC)        *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   02/06/2008 - UPDATE FOR OCTOBER 2007 VERSION 08.6          *
      *                (FOR REVISED STANDARD FEDERAL RATE &          *
      *                 FIXED LOSS AMOUNT FOR APRIL 2008)            *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   05/08/2008 - CREATED VERSION 09.0 FOR JULY 2008            *
      *                (FOR NEW RATE YEAR 2009, STILL FY 2008)       *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   05/19/2008 - CREATED VERSION 09.1 FOR JULY 2008            *
      *                REVISED IPPS PUERTO RICO RATES                *
      *                EFFECTIVE RETROACTIVE TO 10/01/2007           *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/11/2008 - CREATED VERSION 09.2 FOR OCTOBER 2008         *
      *                (FOR RATE YEAR 2009, FY 2009)                 *
      *                ADDED FIELD P-VAL-BASED-PURCH-SCORE TO THE    *
      *                PSF (TO BE USED IN IPPS 01/01/2008).          *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   09/09/2008 - CREATED VERSION 09.3 FOR OCTOBER 2008         *
      *                (FOR RATE YEAR 2009, FY 2009)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   02/17/2009 - CREATED VERSION 09.4 FOR OCTOBER 2008         *
      *                (FOR RATE YEAR 2009, FY 2009)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   05/18/2009 - CREATED VERSION 09.5 FOR JUNE 3 - SEPT 30 2009*
      *                (FOR RATE YEAR 2009, FY 2009)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/05/2009 - CREATED VERSION 10.0 FOR OCTOBER 2009         *
      *                (FOR RATE YEAR 2010, FY 2010)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   09/03/2009 - CREATED VERSION 10.1 FOR OCTOBER 2009         *
      *                (FOR RATE YEAR 2010, FY 2010)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   11/11/2009 - CREATED VERSION 10.2 FOR OCTOBER 2009         *
      *                (FOR RATE YEAR 2010, FY 2010)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   04/07/2010 - CREATED VERSION 10.3 FOR OCTOBER 2009         *
      *                (FOR RATE YEAR 2010, FY 2010)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   04/19/2010 - CREATED VERSION 10.4 FOR OCTOBER 2009         *
      *                (FOR RATE YEAR 2010, FY 2010)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/04/2010 - CREATED VERSION 11.0 FOR OCTOBER 2010         *
      *                (FOR RATE YEAR 2011, FY 2011)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   10/20/2010 - CREATED VERSION 11.1 FOR OCTOBER 2010         *
      *                (FOR RATE YEAR 2011, FY 2011)                 *
      *                ALLOWS DATES OF SERVICE OLDER THAN 5 YEARS    *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/01/2011 - CREATED VERSION 12.0 FOR OCTOBER 2011         *
      *                (FOR RATE YEAR 2012, FY 2012)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   08/31/2011 - CREATED VERSION 12.1 FOR OCTOBER 2011         *
      *                (FOR RATE YEAR 2012, FY 2012)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   10/28/2011 - CREATED VERSION 12.2 FOR OCTOBER 2011         *
      *                (FOR RATE YEAR 2012, FY 2012)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   12/09/2011 - CREATED VERSION 12.3 FOR OCTOBER 2011         *
      *                (FOR RATE YEAR 2012, FY 2012)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   07/31/2012 - CREATED VERSION 13.0 FOR OCTOBER 2012         *
      *                (FOR RATE YEAR 2013, FY 2013)                 *
      *                                                              *
      *--------------------------------------------------------------*
      *                                                              *
      *   11/16/2012 - IN VERSION 13.0 OF THE LTCH PPS PRICER        *
      *                CHANGED "T-CBSA-DATA  OCCURS 0 TO 4000 TIMES" *
      *                     TO "T-CBSA-DATA  OCCURS 0 TO 7000 TIMES" *
      *                FOR IPPS-CBSA-WI-TABLE IN RESPONSE TO         *
      *                HPAR CR8041H2 (R41212).  NO VERSION NUMBERS   *
      *                CHANGED AND ONLY MODULES LTDRV130 AND         *
      *                LTOPN130 CHANGED AS DESCRIBED ABOVE.          *
      *                                                              *
      ****************************************************************


060900 ENVIRONMENT DIVISION.
061000 CONFIGURATION SECTION.
061100 SOURCE-COMPUTER.            IBM-370.
061200 OBJECT-COMPUTER.            IBM-370.
061300 INPUT-OUTPUT  SECTION.
061400 FILE-CONTROL.
061500
061600     SELECT PROV-FILE ASSIGN       TO  UT-S-PPSPROV
061700            FILE STATUS IS PROV-STAT.
061800     SELECT CBSAX-FILE ASSIGN      TO  UT-S-PPSCBSAX
061900            FILE STATUS IS CBSAX-STAT.
061800     SELECT IPPS-CBSAX-FILE ASSIGN TO  UT-S-IPCBSAX
061900            FILE STATUS IS IPPS-CBSAX-STAT.
061800     SELECT MSAX-FILE ASSIGN       TO  UT-S-PPSMSAX
061900            FILE STATUS IS MSAX-STAT.
062000
062100 DATA DIVISION.
062200 FILE SECTION.
062300
062400 FD  PROV-FILE
062500     RECORDING MODE IS F
062600     LABEL RECORDS ARE STANDARD
062700     BLOCK CONTAINS 0 RECORDS.
062800 01  PROV-REC.
062900     05  PROV-PART1                 PIC X(80).
063000     05  PROV-PART2                 PIC X(80).
063100     05  PROV-PART3                 PIC X(80).
063200
063300 FD  CBSAX-FILE
063400     RECORDING MODE IS F
063500     LABEL RECORDS ARE STANDARD
063600     BLOCK CONTAINS 0 RECORDS.
063700***************************************************************
063800*    THIS RECORD IS SUPPLIED BY CMS AND CONTAINS              *
063900*    THE WAGE INDEX FOR THE STATES (RURAL) AND CBSA'S (URBAN).*
064000***************************************************************
064100 01  CBSAX-REC.
064200     05  X-CBSA-X.
064300         10  M-BLANK                PIC X(03).
064400         10  M-STATE                PIC 9(02).
064500     05  X-CBSA REDEFINES X-CBSA-X  PIC 9(05).
064600     05  FILLER                     PIC X(01).
064700     05  XE-DATE-C.
064800         10  XE-C-CC                PIC 9(02).
064900         10  XE-C-YY                PIC 9(02).
065000         10  XE-C-MM                PIC 9(02).
065100         10  XE-C-DD                PIC 9(02).
065200     05  FILLER                     PIC X(01).
065300     05  X-WAGE-INDEX1-C            PIC S9(02)V9(04).
065400     05  FILLER                     PIC X(01).
065450     05  X-WAGE-INDEX2-C            PIC S9(02)V9(04).
065500     05  FILLER                     PIC X(01).
065550     05  X-WAGE-INDEX3-C            PIC S9(02)V9(04).
065600     05  FILLER                     PIC X(01).
065700     05  X-STATE-CBSA-NAME          PIC X(39).
065800     05  FILLER                     PIC X(05).

       FD  IPPS-CBSAX-FILE
           RECORDING MODE IS F
           LABEL RECORDS ARE STANDARD
           BLOCK CONTAINS 0 RECORDS.
      ***************************************************************
      *    THIS RECORD IS SUPPLIED BY CMS AND CONTAINS THE IPPS     *
      *    WAGE INDEX FOR THE STATES (RURAL) AND CBSA'S (URBAN).    *
      ***************************************************************
       01  F-IPPS-CBSA-REC.
           05  F-CBSA.
               10  F-CBSA-BLANK                PIC X(03).
               10  F-CBSA-STATE                PIC 9(02).
           05  F-CBSA9  REDEFINES F-CBSA       PIC 9(05).
           05  F-CBSA-SIZE             PIC X(01).
           05  F-CBSA-EFF-DATE.
               10  F-CBSA-CC           PIC 9(02).
               10  F-CBSA-YY           PIC 9(02).
               10  F-CBSA-MM           PIC 9(02).
               10  F-CBSA-DD           PIC 9(02).
           05  FILLER                  PIC X(01).
           05  F-CBSA-WAGE-INDX1       PIC S9(02)V9(04).
           05  FILLER                  PIC X(01).
           05  F-CBSA-WAGE-INDX2       PIC S9(02)V9(04).
           05  FILLER                  PIC X(01).
           05  F-CBSA-STATE-NAME       PIC X(50).
           05  FILLER                  PIC X(01).
065900
063300 FD  MSAX-FILE
063400     RECORDING MODE IS F
063500     LABEL RECORDS ARE STANDARD
063600     BLOCK CONTAINS 0 RECORDS.
063700***************************************************************
063800*    THIS RECORD IS SUPPLIED BY CMS AND CONTAINS              *
063900*    THE WAGE INDEX FOR THE STATES (RURAL) AND MSA'S (URBAN). *
064000***************************************************************
064100 01  MSAX-REC.
064200     05  X-MSA-X.
064300         10  M-BLANK                PIC X(02).
064400         10  M-STATE                PIC 9(02).
064500     05  X-MSA REDEFINES X-MSA-X    PIC 9(04).
064600     05  FILLER                     PIC X(01).
064700     05  XE-DATE-M.
064800         10  XE-M-CC                PIC 9(02).
064900         10  XE-M-YY                PIC 9(02).
065000         10  XE-M-MM                PIC 9(02).
065100         10  XE-M-DD                PIC 9(02).
065200     05  FILLER                     PIC X(01).
065300     05  X-WAGE-INDEX1-M            PIC S9(02)V9(04).
065400     05  FILLER                     PIC X(01).
065450     05  X-WAGE-INDEX2-M            PIC S9(02)V9(04).
065500     05  FILLER                     PIC X(01).
065550     05  X-WAGE-INDEX3-M            PIC S9(02)V9(04).
065600     05  FILLER                     PIC X(01).
065700     05  X-STATE-MSA-NAME           PIC X(44).
065800     05  FILLER                     PIC X(01).
065900
066000 WORKING-STORAGE SECTION.
066100 77  W-STORAGE-REF                  PIC X(48) VALUE
066200     'L T O P N _ _ _ - W O R K I N G   S T O R A G E'.
066300 01  OPN-VERSION                    PIC X(05) VALUE 'O13.0'.
066400 01  LTDRV130                       PIC X(08) VALUE 'LTDRV130'.
066900 01  TABLES-LOADED-SW               PIC 9(01) VALUE 0.
067000 01  EOF-SW                         PIC 9(01) VALUE 0.
067100
067100*****************************************************
067100* PROVIDER RECORD THAT CAN BE PASSED IN FROM THE    *
067100* USER                                              *
067100*****************************************************
074500 01  W-PROV-NEW-HOLD.
074600     02  W-PROV-NEWREC-HOLD1.
074700         05  W-P-NEW-NPI10.
074800             10  W-P-NEW-NPI8             PIC X(08).
074900             10  W-P-NEW-NPI-FILLER       PIC X(02).
075000         05  W-P-NEW-PROVIDER-OSCAR-NO.
075100             10  W-P-NEW-STATE            PIC X(02).
075200             10  FILLER                   PIC X(04).
075300         05  W-P-NEW-DATE-DATA.
075400             10  W-P-NEW-EFF-DATE.
075500                 15  W-P-NEW-EFF-DT-CC    PIC 9(02).
075600                 15  W-P-NEW-EFF-DT-YY    PIC 9(02).
075700                 15  W-P-NEW-EFF-DT-MM    PIC 9(02).
075800                 15  W-P-NEW-EFF-DT-DD    PIC 9(02).
075900             10  W-P-NEW-FY-BEGIN-DATE.
076000                 15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).
076100                 15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).
076200                 15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).
076300                 15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).
076400             10  W-P-NEW-REPORT-DATE.
076500                 15  W-P-NEW-REPORT-DT-CC PIC 9(02).
076600                 15  W-P-NEW-REPORT-DT-YY PIC 9(02).
076700                 15  W-P-NEW-REPORT-DT-MM PIC 9(02).
076800                 15  W-P-NEW-REPORT-DT-DD PIC 9(02).
076900             10  W-P-NEW-TERMINATION-DATE.
077000                 15  W-P-NEW-TERM-DT-CC   PIC 9(02).
077100                 15  W-P-NEW-TERM-DT-YY   PIC 9(02).
077200                 15  W-P-NEW-TERM-DT-MM   PIC 9(02).
077300                 15  W-P-NEW-TERM-DT-DD   PIC 9(02).
077400         05  W-P-NEW-WAIVER-CODE          PIC X(01).
077500             88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.
077600         05  W-P-NEW-INTER-NO             PIC X(05).
077700         05  W-P-NEW-PROVIDER-TYPE        PIC X(02).
077800         05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).
077900         05  W-P-NEW-MSA-DATA.
078000             10  W-P-NEW-CHG-CODE-INDEX    PIC X.
078100             10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT.
078200             10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT.
078300             10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT.
078400             10  W-P-NEW-STAND-AMT-LOC-MSA9
078500       REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.
078600                 15  W-P-NEW-RURAL-1ST.
078700                     20  W-P-NEW-STAND-RURAL  PIC XX.
078800                 15  W-P-NEW-RURAL-2ND        PIC XX.
078900         05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
079000         05  W-P-NEW-LUGAR               PIC X.
079100         05  W-P-NEW-TEMP-RELIEF-IND     PIC X.
079200         05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.
079300         05  FILLER                      PIC X(05).
079400     02  W-PROV-NEWREC-HOLD2.
079500         05  W-P-NEW-VARIABLES.
079600             10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).
079700             10  W-P-NEW-COLA              PIC  X(04).
079800             10  W-P-NEW-INTERN-RATIO      PIC  X(05).
079900             10  W-P-NEW-BED-SIZE          PIC  X(05).
080000             10  W-P-NEW-CCR               PIC  X(04).
080100             10  W-P-NEW-CMI               PIC  X(05).
080200             10  W-P-NEW-SSI-RATIO         PIC  X(04).
080300             10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).
080400             10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
080500             10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
080600             10  W-P-NEW-DSH-PERCENT       PIC  V9(04).
080700             10  W-P-NEW-FYE-DATE.
080800                 15  W-P-NEW-FYE-CC        PIC 99.
080900                 15  W-P-NEW-FYE-YY        PIC 99.
081000                 15  W-P-NEW-FYE-MM        PIC 99.
081100                 15  W-P-NEW-FYE-DD        PIC 99.
081105         05  W-P-NEW-SPECIAL-PAY-IND       PIC X(01).
081110         05  FILLER                        PIC X(01).
081120         05  W-P-NEW-GEO-LOC-CBSAX         PIC X(05).
081130         05  W-P-NEW-GEO-LOC-CBSA9 REDEFINES
081140                         W-P-NEW-GEO-LOC-CBSAX PIC 9(05).
081150         05  W-P-NEW-GEO-LOC-CBSA-AST REDEFINES
081160                         W-P-NEW-GEO-LOC-CBSA9.
081170             10 W-P-NEW-GEO-LOC-CBSA-1ST   PIC X.
081180             10 W-P-NEW-GEO-LOC-CBSA-2ND   PIC X.
081190             10 W-P-NEW-GEO-LOC-CBSA-3RD   PIC X.
081200             10 W-P-NEW-GEO-LOC-CBSA-4TH   PIC X.
081210             10 W-P-NEW-GEO-LOC-CBSA-5TH   PIC X.
081220         05  FILLER                        PIC X(10).
081230         05  W-P-NEW-SPECIAL-WAGE-INDEX    PIC 9(02)V9(04).
081300     02  W-PROV-NEWREC-HOLD3.
081400         05  W-P-NEW-PASS-AMT-DATA.
081500             10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).
081600             10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).
081700             10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).
081800             10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).
081900         05  W-P-NEW-CAPI-DATA.
082000             15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.
082100             15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).
082200             15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).
082300             15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).
082400             15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).
082500             15  W-P-NEW-CAPI-NEW-HOSP       PIC X.
082600             15  W-P-NEW-CAPI-IME            PIC X(05).
082700             15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).
082700             15  W-P-VAL-BASED-PURCH-SCORE   PIC X(4).
082800         05  FILLER                        PIC X(18).
083200
083200***************************************************************
083200* FILE STATUS VARIABLES                                       *
083200***************************************************************
083200 01  PROV-STAT.
083200     02  PROV-STAT1          PIC X.
083200     02  PROV-STAT2          PIC X.
083200
083200 01  MSAX-STAT.
083200     02  MSAX-STAT1          PIC X.
083200     02  MSAX-STAT2          PIC X.
083200
083200 01  CBSAX-STAT.
083200     02  CBSAX-STAT1         PIC X.
083200     02  CBSAX-STAT2         PIC X.
083200
083200 01  IPPS-CBSAX-STAT.
083200     02  IPPS-CBSAX-STAT1    PIC X.
083200     02  IPPS-CBSAX-STAT2    PIC X.
084930
084940***************************************************************
084945* CBSA WAGE INDEX TABLE                                       *
084950***************************************************************
084955 01  CBSA-WI-TABLE.
084960     05  C-CBSA-DATA  OCCURS 0 TO 4000 TIMES
084970                      DEPENDING ON CBSA-CNT
084980                      ASCENDING KEY IS CBSAX-CBSA
084985                      INDEXED BY CU1 CU2.
084990         10  CBSAX-CBSA         PIC X(05).
085010         10  CBSAX-EFF-DATE     PIC X(08).
085020         10  CBSAX-WAGE-INDEX1  PIC S9(02)V9(04).
085030         10  CBSAX-WAGE-INDEX2  PIC S9(02)V9(04).
085040         10  CBSAX-WAGE-INDEX3  PIC S9(02)V9(04).
084930
084940***************************************************************
084945* IPPS CBSA WAGE INDEX TABLE                                  *
084950***************************************************************
084955 01  IPPS-CBSA-WI-TABLE.
084960     05  T-CBSA-DATA  OCCURS 0 TO 7000 TIMES
084970                      DEPENDING ON IPPS-CBSA-CNT
084980                      ASCENDING KEY IS T-CBSA
084970                      INDEXED BY MA1 MA2 MA3.
084980         10  T-CBSA             PIC X(5).
084985         10  T-CBSA-SIZE        PIC X(01).
084990         10  T-CBSA-EFF-DATE    PIC X(08).
085010         10  T-CBSA-WAGE-INDX1  PIC S9(02)V9(04).
085020         10  T-CBSA-WAGE-INDX2  PIC S9(02)V9(04).
084200
084220***************************************************************
084240* MSA WAGE INDEX TABLE                                        *
084260***************************************************************
084300 01  MSA-WI-TABLE.
084400     05  M-MSA-DATA   OCCURS 0 TO 4000 TIMES
084420                      DEPENDING ON MSA-CNT
084460                      ASCENDING KEY IS MSAX-MSA
084500                      INDEXED BY MU1 MU2.
084600         10  MSAX-MSA          PIC X(4).
084800         10  MSAX-EFF-DATE     PIC X(08).
084900         10  MSAX-WAGE-INDEX1  PIC S9(02)V9(04).
084910         10  MSAX-WAGE-INDEX2  PIC S9(02)V9(04).
084920         10  MSAX-WAGE-INDEX3  PIC S9(02)V9(04).
085050
085060***************************************************************
085070* RECORD COUNT VARIABLES                                      *
085075***************************************************************
085080 01  WORK-COUNTERS.
085085     05  CBSA-CNT              PIC 9(5) VALUE ZERO.
085090     05  MSA-CNT               PIC 9(5) VALUE ZERO.
085095     05  PROV-CNT              PIC 9(5) VALUE ZERO.
085098     05  IPPS-CBSA-CNT         PIC 9(5) VALUE ZERO.
085100
085200***************************************************************
085300*    THE PROVIDER SPECIFIC INFORMATION TABLE IS INITIALLY     *
085400*    SET TO OCCUR 2400 TIMES. THIS NUMBER SHOULD BE ADJUSTED  *
085500*    BY THE USER TO REFLECT THE NUMBER OF PROVIDER RECORDS    *
085600*    PLUS EXPANSION. EACH ENTRY COSTS 240 BYTES OF MEMORY.    *
085700*    THIS FILE MUST BE IN PROVIDER NUMBER, EFFECTIVE-DATE     *
085800*    SEQUENCE.                                                *
085900***************************************************************
086000 01  PROV-TABLE.
086100     05  PROV-ENTRIES       OCCURS 0 TO 2400 TIMES
086150                            DEPENDING ON PROV-CNT
086200                            ASCENDING KEY IS PROV-NO
086300                            INDEXED BY PX1.
086400         10  PROV-DATA1.
086500             15  PROV-NPI10.
086600                 20  PROV-NPI8       PIC X(08).
086700                 20  PROV-NPI-FILLER PIC X(02).
086800             15  PROV-NO             PIC X(06).
086900             15  PROV-EFF-DATE       PIC X(08).
087000             15  FILLER              PIC X(56).
087050
087100 01  PROV-DATA-2.
087200     05  PROV-ENTRIES2      OCCURS 0 TO 2400 TIMES
087250                            DEPENDING ON PROV-CNT
087300                            INDEXED BY PD2.
087400         10  PROV-DATA2              PIC X(80).
087450
087500 01  PROV-DATA-3.
087600     05  PROV-ENTRIES3      OCCURS 0 TO 2400 TIMES
087650                            DEPENDING ON PROV-CNT
087700                            INDEXED BY PD3.
087800         10  PROV-DATA3              PIC X(80).
087900
089900
091600**************************************************************
091800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED TO        *
091900*      THE LTDRV___ PROGRAM                                  *
092100**************************************************************
092200 01  PROV-NEW-HOLD.
092300     02  PROV-NEWREC-HOLD1.
092400         05  P-NEW-NPI10.
092500             10  P-NEW-NPI8             PIC X(08).
092600             10  P-NEW-NPI-FILLER       PIC X(02).
092700         05  P-NEW-PROVIDER-NO.
092800             10  P-NEW-STATE            PIC 9(02).
092900             10  FILLER                 PIC X(04).
093000         05  P-NEW-DATE-DATA.
093100             10  P-NEW-EFF-DATE.
093200                 15  P-NEW-EFF-DT-CC    PIC 9(02).
093300                 15  P-NEW-EFF-DT-YY    PIC 9(02).
093400                 15  P-NEW-EFF-DT-MM    PIC 9(02).
093500                 15  P-NEW-EFF-DT-DD    PIC 9(02).
093600             10  P-NEW-FY-BEGIN-DATE.
093700                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
093800                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
093900                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
094000                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
094100             10  P-NEW-REPORT-DATE.
094200                 15  P-NEW-REPORT-DT-CC PIC 9(02).
094300                 15  P-NEW-REPORT-DT-YY PIC 9(02).
094400                 15  P-NEW-REPORT-DT-MM PIC 9(02).
094500                 15  P-NEW-REPORT-DT-DD PIC 9(02).
094600             10  P-NEW-TERMINATION-DATE.
094700                 15  P-NEW-TERM-DT-CC   PIC 9(02).
094800                 15  P-NEW-TERM-DT-YY   PIC 9(02).
094900                 15  P-NEW-TERM-DT-MM   PIC 9(02).
095000                 15  P-NEW-TERM-DT-DD   PIC 9(02).
095100         05  P-NEW-WAIVER-CODE          PIC X(01).
095200             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
095300         05  P-NEW-INTER-NO             PIC 9(05).
095400         05  P-NEW-PROVIDER-TYPE        PIC X(02).
097200         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
098200         05  P-NEW-CURRENT-DIV   REDEFINES
098300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
098500         05  P-NEW-MSA-DATA.
098600             10  P-NEW-CHG-CODE-INDEX       PIC X.
098700             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
098800             10  P-NEW-GEO-LOC-MSA9   REDEFINES
098900                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
099000             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
099100                             P-NEW-GEO-LOC-MSA9.
099200                 15  P-NEW-GEO-MSA-1ST    PIC X.
099300                 15  P-NEW-GEO-MSA-2ND    PIC X.
099400                 15  P-NEW-GEO-MSA-3RD    PIC X.
099500                 15  P-NEW-GEO-MSA-4TH    PIC X.
099600             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
099700             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
099800             10  P-NEW-STAND-AMT-LOC-MSA9
099900                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
100000                 15  P-NEW-RURAL-1ST.
100100                     20  P-NEW-STAND-RURAL  PIC XX.
100200                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
100300                 15  P-NEW-RURAL-2ND        PIC XX.
100400         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
100500                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
100600                 88  P-NEW-SCH-YR82       VALUE   '82'.
100700                 88  P-NEW-SCH-YR87       VALUE   '87'.
100800         05  P-NEW-LUGAR                    PIC X.
100900         05  P-NEW-TEMP-RELIEF-IND          PIC X.
101000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
101100         05  FILLER                         PIC X(05).
101200     02  PROV-NEWREC-HOLD2.
101300         05  P-NEW-VARIABLES.
101400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
101500             10  P-NEW-COLA              PIC  9(01)V9(03).
101600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
101700             10  P-NEW-BED-SIZE          PIC  9(05).
101800             10  P-NEW-CCR               PIC  9(01)V9(03).
101900             10  P-NEW-CMI               PIC  9(01)V9(04).
102000             10  P-NEW-SSI-RATIO         PIC  V9(04).
102100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
102200             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
102300             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
102400             10  P-NEW-DSH-PERCENT       PIC  V9(04).
102500             10  P-NEW-FYE-DATE.
102600                 15  P-NEW-FYE-CC        PIC 99.
102700                 15  P-NEW-FYE-YY        PIC 99.
102800                 15  P-NEW-FYE-MM        PIC 99.
102900                 15  P-NEW-FYE-DD        PIC 99.
102905         05  P-NEW-SPECIAL-PAY-IND         PIC X(01).
102910         05  FILLER                        PIC X(01).
102915         05  P-NEW-GEO-LOC-CBSAX           PIC X(05) JUST RIGHT.
102920         05  P-NEW-GEO-LOC-CBSA9 REDEFINES
102925                       P-NEW-GEO-LOC-CBSAX PIC 9(05).
102930         05  P-NEW-GEO-LOC-CBSA-AST REDEFINES
102935                       P-NEW-GEO-LOC-CBSA9.
102940             10 P-NEW-GEO-LOC-CBSA-1ST     PIC X.
102945             10 P-NEW-GEO-LOC-CBSA-2ND     PIC X.
102950             10 P-NEW-GEO-LOC-CBSA-3RD     PIC X.
102955             10 P-NEW-GEO-LOC-CBSA-4TH     PIC X.
102960             10 P-NEW-GEO-LOC-CBSA-STH     PIC X.
102965         05  FILLER                        PIC X(10).
102970         05  P-NEW-SPECIAL-WAGE-INDEX      PIC 9(02)V9(04).
103100     02  PROV-NEWREC-HOLD3.
103200         05  P-NEW-PASS-AMT-DATA.
103300             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
103400             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
103500             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
103600             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
103700         05  P-NEW-CAPI-DATA.
103800             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
103900             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
104000             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
104100             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
104200             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
104300             15  P-NEW-CAPI-NEW-HOSP       PIC X.
104400             15  P-NEW-CAPI-IME            PIC 9V9999.
104500             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
104600         05  FILLER                        PIC X(22).
104700
104800
116900***************************************************************
117000 LINKAGE SECTION.
116900***************************************************************
117100
117200***************************************************************
117400*      THIS IS THE BILL-RECORD THAT IS PASSED TO THIS PROGRAM *
117500*      AND WILL BE PASSED TO PROGRAM LTDRV___                 *
117700***************************************************************
117800 01  BILL-NEW-DATA.
117900     05  B-NPI10.
118000         10  B-NPI8                   PIC X(08).
118100         10  B-NPI-FILLER             PIC X(02).
118200     05  B-PROVIDER-NO                PIC X(06).
118300     05  B-PATIENT-STATUS             PIC X(02).
120600     05  B-DRG-CODE                   PIC X(03).
120600     05  B-LOS                        PIC 9(03).
120600     05  B-COV-DAYS                   PIC 9(03).
120600     05  B-LTR-DAYS                   PIC 9(02).
120600     05  B-DISCHARGE-DATE.
120600         10  B-DISCHG-CC              PIC 9(02).
120600         10  B-DISCHG-YY              PIC 9(02).
120000         10  B-DISCHG-MM              PIC 9(02).
120100         10  B-DISCHG-DD              PIC 9(02).
120200     05  B-COV-CHARGES                PIC 9(07)V9(02).
120200     05  B-SPEC-PAY-IND               PIC X(01).
120300     05  FILLER                       PIC X(13).
120400
117200**************************************************************
117400*      THIS IS THE PPS DATA THAT IS PASSED TO THIS PROGRAM   *
117500*      AND WILL BE PASSED TO PROGRAM LTDRV___                *
117700**************************************************************
       01  PPS-DATA-ALL.
           05  PPS-RTC                      PIC 9(02).
           05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
           05  PPS-DATA.
               10  PPS-MSA                  PIC X(04).
               10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
               10  PPS-AVG-LOS              PIC 9(02)V9(01).
               10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
               10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
               10  PPS-LOS                  PIC 9(03).
               10  PPS-DRG-ADJ-PAY-AMT      PIC 9(07)V9(02).
               10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
               10  PPS-FINAL-PAY-AMT        PIC 9(07)V9(02).
               10  PPS-FAC-COSTS            PIC 9(07)V9(02).
               10  PPS-NEW-FAC-SPEC-RATE    PIC 9(07)V9(02).
               10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
               10  PPS-SUBM-DRG-CODE        PIC X(03).
               10  PPS-CALC-VERS-CD         PIC X(05).
               10  PPS-REG-DAYS-USED        PIC 9(03).
               10  PPS-LTR-DAYS-USED        PIC 9(03).
               10  PPS-BLEND-YEAR           PIC 9(01).
               10  PPS-COLA                 PIC 9(01)V9(03).
               10  FILLER                   PIC X(04).
          05  PPS-OTHER-DATA.
               10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
               10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
               10  PPS-STD-FED-RATE         PIC 9(05)V9(02).
               10  PPS-BDGT-NEUT-RATE       PIC 9(01)V9(03).
               10  FILLER                   PIC X(20).
          05  PPS-PC-DATA.
               10  PPS-COT-IND              PIC X(01).
               10  FILLER                   PIC X(20).

       01  PPS-CBSA                         PIC X(05).

      *****************************************************************
      *            THESE ARE THE VERSIONS OF THE LTDRV___             *
      *           PROGRAMS THAT WILL BE PASSED BACK----               *
      *          ASSOCIATED WITH THE BILL BEING PROCESSED             *
      *****************************************************************
122300 01  PRICER-OPT-VERS-SW.
122400     05  PRICER-OPTION-SW               PIC X(01).
122500         88  ALL-TABLES-PASSED          VALUE 'A'.
122600         88  PROV-RECORD-PASSED         VALUE 'P'.
122800     05  PPS-VERSIONS.
122900         10  PPDRV-VERSION              PIC X(05).
123000
127500**************************************************************
127700*      PROVIDER SPECIFIC RECORD                              *
127800**************************************************************
127900 01  PROV-RECORD-FROM-USER.
128000     05  PROV-REC1                  PIC X(80).
128100     05  PROV-REC2                  PIC X(80).
128200     05  PROV-REC3                  PIC X(80).
128300
128400*****************************************************************
128600*      CORE-BASED STATISTICAL AREA RECORD FROM USER (CBSA)      *
128700*****************************************************************
128800 01  CBSAX-TABLE-FROM-USER.
128900     05  FILLER                     PIC X(32000).
129000     05  FILLER                     PIC X(30000).
129100     05  FILLER                     PIC X(30000).
128300
128400*****************************************************************
128600*      IPPS CORE-BASED STATISTICAL AREA RECORD FROM USER (CBSA) *
128700*****************************************************************
128800 01  IPPS-CBSAX-TABLE-FROM-USER.
128900     05  FILLER                     PIC X(32000).
129000     05  FILLER                     PIC X(30000).
129100     05  FILLER                     PIC X(30000).
128300
128400*****************************************************************
128600*      METROPOLITAN STATISTICAL AREA RECORD FROM USER (MSA)     *
128700*****************************************************************
128800 01  MSAX-TABLE-FROM-USER.
128900     05  FILLER                     PIC X(32000).
129000     05  FILLER                     PIC X(30000).
129100     05  FILLER                     PIC X(30000).
129200
129200
129200
129200
129300 PROCEDURE DIVISION  USING BILL-NEW-DATA
129400                           PPS-DATA-ALL
129400                           PPS-CBSA
129500                           PRICER-OPT-VERS-SW
129700                           PROV-RECORD-FROM-USER
129800                           CBSAX-TABLE-FROM-USER
129800                           IPPS-CBSAX-TABLE-FROM-USER
129800                           MSAX-TABLE-FROM-USER.
129900
129900
130000******************************************************************
130050*                                                                *
130100*    PROCESSING:                                                 *
130300*       A. THIS MODULE WILL LOAD ALL TABLES THE FIRST TIME THIS  *
130400*          SUBROUTINE IS CALLED.                                 *
130200*       B. THIS MODULE WILL CALL THE LTDRV MODULE.               *
130500*       C. THE PROVIDER TABLE AND WAGE INDEX MSA AND CBSA        *
130550*          TABLES WILL BE PASSED TO THE LTDRV PROGRAM.           *
130600*                                                                *
130700******************************************************************
130900
131000     INITIALIZE PPS-DATA-ALL.
131000     INITIALIZE PPS-CBSA.
131300
131350*----------------------------------------------------------*
131400*  RTC = 98  --  BILL DISCHARGE DATE BEFORE 10/01/2002     *
131550*----------------------------------------------------------*
131600     IF B-DISCHARGE-DATE < 20021001
131800        MOVE 98 TO PPS-RTC
131900        GOBACK.
132000
132000
132100******************************************************************
132200 0000-TEST-PRICER-OPTION-SW.
132100******************************************************************
132200
      *-----------------------------------------------------*
      * DETERMINE WHICH FILES HAVE BEEN PASSED IN AND CALL  *
      * THE APPROPRIATE PARAGRAPH                           *
      *-----------------------------------------------------*
132300     IF PRICER-OPTION-SW  = 'A'
132400        PERFORM 1900-OPTION-SW-A THRU 1900-EXIT
132500     ELSE
132600       IF PRICER-OPTION-SW  = 'P'
132700          PERFORM 2000-OPTION-SW-P THRU 2000-EXIT
132800       ELSE
132900          PERFORM 2100-OPTION-SW THRU 2100-EXIT
132920       END-IF
132950     END-IF.
133000
133100*-----------------------------------------------------*
133200***  GET THE PROVIDER RECORD IF NEEDED                *
133300*-----------------------------------------------------*
133400     IF PROV-RECORD-PASSED OR ALL-TABLES-PASSED
133600        MOVE 00 TO PPS-RTC
133700     ELSE
133800        PERFORM 1200-GET-THIS-PROVIDER THRU 1200-EXIT
133850     END-IF.
133900
134000***  RTC = 59  --  PROVIDER NOT FOUND
134100     IF PPS-RTC = 59
134300        GOBACK.

           IF P-NEW-GEO-LOC-CBSAX = SPACES
              MOVE ZEROS TO P-NEW-GEO-LOC-CBSAX
           END-IF.

           IF P-NEW-GEO-LOC-MSAX = SPACES
              MOVE ZEROS TO P-NEW-GEO-LOC-MSAX
           END-IF.

      *-----------------------------------------------------*
      ***  CALL LTDRV___ PROGRAM                            *
      *-----------------------------------------------------*
           CALL LTDRV130 USING BILL-NEW-DATA
                               PPS-DATA-ALL
                               PPS-CBSA
                               PRICER-OPT-VERS-SW
                               PROV-NEW-HOLD
                               CBSA-WI-TABLE
                               IPPS-CBSA-WI-TABLE
                               MSA-WI-TABLE
                               WORK-COUNTERS.

           GOBACK.


134500******************************************************************
163000 1200-GET-THIS-PROVIDER.
163100******************************************************************
163200*    ON A PROVIDER BREAK:                                        *
163300*        FIND THE NEW PROVIDER SPECIFIC DATA ELEMENTS            *
163400*    NOTE: IF BILLS ARE SORTED/BATCHED BY PROVIDER, FEWER        *
163500*             TABLE SEARCHES WILL BE NECESSARY.                  *
163600******************************************************************
163700     IF B-PROVIDER-NO NOT = P-NEW-PROVIDER-NO
163900        SEARCH ALL PROV-ENTRIES
164000          AT END
164100             MOVE 59 TO PPS-RTC
164200             GO TO 1200-EXIT
164300          WHEN PROV-NO (PX1) = B-PROVIDER-NO
164400             MOVE 00 TO PPS-RTC
164600             MOVE PROV-DATA1 (PX1) TO PROV-NEWREC-HOLD1
164700             SET PD2 TO PX1
164800             SET PD3 TO PX1
164900             MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2
165000             MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3
165400             PERFORM 1300-GET-CURR-PROV THRU 1300-EXIT
165400               VARYING PX1 FROM PX1 BY 1
165500                 UNTIL PROV-NO (PX1) NOT = B-PROVIDER-NO
165600                   OR PROV-NO (PX1) = '999999'.
165700
165800 1200-EXIT.
165850      EXIT.
165860
165870
165880******************************************************************
166000 1300-GET-CURR-PROV.
166050******************************************************************
166100     IF  B-DISCHARGE-DATE NOT < PROV-EFF-DATE (PX1)
166200         MOVE PROV-DATA1 (PX1) TO PROV-NEWREC-HOLD1
166300         SET PD2 TO PX1
166400         SET PD3 TO PX1
166500         MOVE PROV-DATA2 (PD2) TO PROV-NEWREC-HOLD2
166600         MOVE PROV-DATA3 (PD3) TO PROV-NEWREC-HOLD3
166650     END-IF.
165700
166800
166900 1300-EXIT.
166900      EXIT.
167000
165800
168300******************************************************************
168400 1500-LOAD-ALL-TABLES.
168500******************************************************************
168600*    THE FIRST TIME CALLED:                                      *
168800*        LOAD THE PROVIDER SPECIFIC TABLE SUPPLIED BY            *
168900*             THE INTERMEDIARY/USER.                             *
168700*        LOAD MSA, CBSA, & IPPS CBSA TABLES SUPPLIED BY CMS      *
169000******************************************************************
169200     MOVE ALL '9' TO PROV-NEW-HOLD.
169300     MOVE ALL '9' TO PROV-TABLE.
169400     MOVE ALL '9' TO PROV-DATA-2.
169500     MOVE ALL '9' TO PROV-DATA-3.
169600     OPEN INPUT PROV-FILE.
169700     MOVE 0 TO EOF-SW.
169800     SET PX1 TO EOF-SW.
169900
169910*----------------------------------------------------*
169920* LOAD THE PROVIDER TABLE                            *
169930*----------------------------------------------------*
170000     PERFORM 1600-READ-PROV-FILE THRU 1600-EXIT
170100             UNTIL EOF-SW = 1.
170300     CLOSE PROV-FILE.
170200
      *----------------------------------------------------*
      * LOAD THE MSA TABLE                                 *
      *----------------------------------------------------*
           MOVE HIGH-VALUES TO MSA-WI-TABLE.
           PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT.

      *----------------------------------------------------*
      * LOAD THE CBSA TABLE                                *
      *----------------------------------------------------*
           MOVE HIGH-VALUES TO CBSA-WI-TABLE.
           PERFORM 1750-LOAD-CBSAX-FILE THRU 1750-EXIT.

      *----------------------------------------------------*
      * LOAD THE IPPS CBSA TABLE                           *
      *----------------------------------------------------*
           MOVE HIGH-VALUES TO IPPS-CBSA-WI-TABLE.
           PERFORM 1775-LOAD-IPPS-CBSAX-FILE THRU 1775-EXIT.


170500
170600 1500-EXIT.
170600      EXIT.
170700
170700
168300******************************************************************
170800 1600-READ-PROV-FILE.
168300******************************************************************
170900     READ PROV-FILE
171000         AT END
171100             SET PX1 UP BY 1
171200             MOVE ALL '9' TO PROV-DATA1 (PX1)
171300             SET PD2 TO PX1
171400             SET PD3 TO PX1
171500             MOVE ALL '9' TO PROV-DATA2 (PD2)
171600             MOVE ALL '9' TO PROV-DATA3 (PD3)
171800             MOVE 1 TO EOF-SW
171850             DISPLAY 'NUMBER OF PROVIDERS   = ' PROV-CNT.
171900
172000     IF  EOF-SW = 0
172050         ADD 1 TO PROV-CNT
172100         SET PX1 UP BY 1
172200         MOVE PROV-PART1 TO PROV-DATA1 (PX1)
172300         SET PD2 TO PX1
172400         SET PD3 TO PX1
172500         MOVE PROV-PART2 TO PROV-DATA2 (PD2)
172600         MOVE PROV-PART3 TO PROV-DATA3 (PD3)
172650     END-IF.
172700
172800 1600-EXIT.
172800      EXIT.
172900
172910
172920******************************************************************
173000 1700-LOAD-MSAX-FILE.
173050******************************************************************
173100     OPEN INPUT MSAX-FILE.
173200     MOVE 0 TO EOF-SW.
173300     SET MU1 TO EOF-SW.
173400
173500     PERFORM 1800-READ-MSAX-FILE THRU 1800-EXIT
173600                      UNTIL EOF-SW = 1.
173700     CLOSE MSAX-FILE.
173800
173900 1700-EXIT.
173900      EXIT.
174000
174010
174020******************************************************************
174030 1750-LOAD-CBSAX-FILE.
174040******************************************************************
174100     OPEN INPUT CBSAX-FILE.
174200     MOVE 0 TO EOF-SW.
173300     SET CU1 TO EOF-SW.
173400
173500     PERFORM 1850-READ-CBSAX-FILE THRU 1850-EXIT
173600                      UNTIL EOF-SW = 1.
173700     CLOSE CBSAX-FILE.
173800
173900 1750-EXIT.
173900      EXIT.
174000
174010
174020******************************************************************
174030 1775-LOAD-IPPS-CBSAX-FILE.
174040******************************************************************
174100     OPEN INPUT IPPS-CBSAX-FILE.
174200     MOVE 0 TO EOF-SW.
173300     SET MA3 TO EOF-SW.
173400
173500     PERFORM 1875-READ-IPPS-CBSAX-FILE THRU 1875-EXIT
173600                      UNTIL EOF-SW = 1.
173700     CLOSE IPPS-CBSAX-FILE.
173800
173900 1775-EXIT.
173900      EXIT.
174000
174050
174060******************************************************************
174100 1800-READ-MSAX-FILE.
174150******************************************************************
174200     READ MSAX-FILE
174300         AT END
174400             MOVE 1 TO EOF-SW
174450             DISPLAY 'NUMBER OF MSA RECORDS = ' MSA-CNT.
174500
174600     IF EOF-SW = 0
174650        ADD 1 TO MSA-CNT
174900        SET MU1 UP BY 1
175000        MOVE X-MSA-X         TO MSAX-MSA         (MU1)
175200        MOVE XE-DATE-M       TO MSAX-EFF-DATE    (MU1)
175300        MOVE X-WAGE-INDEX1-M TO MSAX-WAGE-INDEX1 (MU1)
175300        MOVE X-WAGE-INDEX2-M TO MSAX-WAGE-INDEX2 (MU1)
175350        MOVE X-WAGE-INDEX3-M TO MSAX-WAGE-INDEX3 (MU1)
175400     END-IF.
175500
175600 1800-EXIT.
175600      EXIT.


      ******************************************************************
       1850-READ-CBSAX-FILE.
      ******************************************************************
           READ CBSAX-FILE
               AT END
                   MOVE 1 TO EOF-SW
                   DISPLAY 'NUMBER OF CBSA RECORDS = ' CBSA-CNT.

           IF EOF-SW = 0
              ADD 1 TO CBSA-CNT
              SET CU1 UP BY 1
              MOVE X-CBSA-X        TO CBSAX-CBSA        (CU1)
              MOVE XE-DATE-C       TO CBSAX-EFF-DATE    (CU1)
              MOVE X-WAGE-INDEX1-C TO CBSAX-WAGE-INDEX1 (CU1)
              MOVE X-WAGE-INDEX2-C TO CBSAX-WAGE-INDEX2 (CU1)
              MOVE X-WAGE-INDEX3-C TO CBSAX-WAGE-INDEX3 (CU1)
           END-IF.

       1850-EXIT.
            EXIT.


      ******************************************************************
       1875-READ-IPPS-CBSAX-FILE.
      ******************************************************************
           READ IPPS-CBSAX-FILE
               AT END
                   MOVE 1 TO EOF-SW
                   DISPLAY 'NUMBER OF IP CBSA RECORDS = ' IPPS-CBSA-CNT.

           IF EOF-SW = 0
              ADD 1 TO IPPS-CBSA-CNT
              SET MA3 UP BY 1
              MOVE F-CBSA            TO T-CBSA            (MA3)
              MOVE F-CBSA-SIZE       TO T-CBSA-SIZE       (MA3)
              MOVE F-CBSA-EFF-DATE   TO T-CBSA-EFF-DATE   (MA3)
              MOVE F-CBSA-WAGE-INDX1 TO T-CBSA-WAGE-INDX1 (MA3)
              MOVE F-CBSA-WAGE-INDX2 TO T-CBSA-WAGE-INDX2 (MA3)
           END-IF.

       1875-EXIT.
            EXIT.


175750******************************************************************
175800 1900-OPTION-SW-A.
175850******************************************************************
175900     MOVE ALL '9' TO PROV-NEW-HOLD.
176000     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.
176050
176100     IF TABLES-LOADED-SW = 0
176110
176120*---------------------------------------------------------------*
176130*      MOVE THE MSA FILE FROM USER INTO MSA TABLE               *
176140*---------------------------------------------------------------*
176200          MOVE HIGH-VALUES                TO MSA-WI-TABLE
176300          MOVE MSAX-TABLE-FROM-USER       TO MSA-WI-TABLE
176310
176320*---------------------------------------------------------------*
176330*      MOVE THE CBSA FILE FROM USER INTO CBSA TABLE             *
176340*---------------------------------------------------------------*
176350          MOVE HIGH-VALUES                TO CBSA-WI-TABLE
176360          MOVE CBSAX-TABLE-FROM-USER      TO CBSA-WI-TABLE
176310
176320*---------------------------------------------------------------*
176330*      MOVE THE IPPS CBSA FILE FROM USER INTO CBSA TABLE        *
176340*---------------------------------------------------------------*
176350          MOVE HIGH-VALUES                TO IPPS-CBSA-WI-TABLE
176360          MOVE IPPS-CBSAX-TABLE-FROM-USER TO IPPS-CBSA-WI-TABLE
176370
176400          MOVE 1 TO TABLES-LOADED-SW
176450
176380     END-IF.
176390
176500
176600 1900-EXIT.
176600      EXIT.
176700
176700
176750******************************************************************
176800 2000-OPTION-SW-P.
176850******************************************************************
176900     MOVE ALL '9' TO PROV-NEW-HOLD.
177000     MOVE PROV-RECORD-FROM-USER TO PROV-NEW-HOLD.
177050
177100     IF TABLES-LOADED-SW = 0
      *---------------------------------------------------------*
      *      LOAD MSA TABLE                                     *
      *---------------------------------------------------------*
                MOVE HIGH-VALUES TO MSA-WI-TABLE
                PERFORM 1700-LOAD-MSAX-FILE THRU 1700-EXIT

      *---------------------------------------------------------*
      *      LOAD CBSA TABLE                                    *
      *---------------------------------------------------------*
                MOVE HIGH-VALUES TO CBSA-WI-TABLE
                PERFORM 1750-LOAD-CBSAX-FILE THRU 1750-EXIT

      *---------------------------------------------------------*
      *      LOAD IPPS CBSA TABLE                               *
      *---------------------------------------------------------*
                MOVE HIGH-VALUES TO IPPS-CBSA-WI-TABLE
                PERFORM 1775-LOAD-IPPS-CBSAX-FILE THRU 1775-EXIT

                MOVE 1 TO TABLES-LOADED-SW

           END-IF.

177500
177600 2000-EXIT.
177600      EXIT.
177700
177700
177750******************************************************************
177800 2100-OPTION-SW.
177850******************************************************************
177900     IF  TABLES-LOADED-SW = 0
178000         PERFORM 1500-LOAD-ALL-TABLES THRU 1500-EXIT
178100         MOVE 1 TO TABLES-LOADED-SW
178150     END-IF.
178200
178300 2100-EXIT.
178300      EXIT.
178400
201900*********************  END OF PROGRAM   **************************
