000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. ESDRV180.
000300*AUTHOR.     CMS.
000400*       EFFECTIVE JANUARY 1, 2018
000500* This subroutine CALLs the appropriate Calculation Subprogram
000600* according to the bill's date
000700******************************************************************
000800*   This subroutine is furnished by the Centers for Medicare     *
000900*   and Medicaid Services.                                       *
001000*   It is to be used as an AID in implementing the Prospective   *
001100*   Payment System for ESRD claims.                              *
001200*                  *  *  *  *  *  *  *  *                        *
001300*   THE PROGRAM WILL:                                            *
001400*       1. Include the MSA Wage Adjusted Rate table.   (ESWRT151)*
001500*       2. Include the COMPOSITE CBSA Wage Index table.(ESCOM151)*
001600*       3. Include the BUNDLED CBSA Wage Index table.  (ESBUN180)*
001700*       4. Include a special Copylib used to switch between the  *
001800*          mainframe and PC portions of the code.                *
001900*       5. Do some edits on the bill information.                *
002000*       6. Pass back return codes.                               *
002100*       7. Create a final payment WHEN that info is on the claim.*
002200*       8. CALL a calculate subroutine when applicable based on  *
002300*          claim date.                                           *
002400*                                                                *
002500*                  *  *  *  *  *  *  *  *                        *
002600*   CHANGE LOG.                                                  *
002700*                                                                *
002800*   The following changes made by DDS                            *
002900* 10/20/06 - NEW CBSA TABLE FOR CY2007 (I.E. COPY EXCBS070)      *
003000*          - ADDED DATE CHECKS FOR CY2007 AND CALL ESCAL070      *
003100* 12/28/06 - ADDED DATE CHECKS FOR CY2007 APRIL AND CALL ESCAL071*
003200*          - CREATED ENTER AND EXIT PARAGRAPHS FOR CLARITY       *
003300*          - STREAMLINED THE PROCESSING SO THAT IT IS MORE       *
003400*            EFFICIENT                                           *
003500*          - PROVIDED A DRIVER VERSION NUMBER WHICH WILL BE      *
003600*            PASSED BACK (IN THE PPS-CALC-VERS-CD) INDICATING AN *
003700*            INTERNAL ERROR THAT IS FOUND AND THUS THE CALCULATE *
003800*            SUBROUTINE IS NOT CALLED                            *
003900* 01/30/07 - NEW MSA AND CBSA TABLES WHICH INCLUDE THE LATEST    *
004000*            ADDITIONS TO THE STATE CODES PER CR#5490 AND CMSO   *
004100*            DATA ON WEB SITE                                    *
004200* 11/27/07 - ADDED SEVERAL 'IF' TESTS TO CHECK FOR WHEN CBSAS ARE*
004300*            DELETED OR ADDED IN VARIOUS CLAIM YEARS.  THIS WAS  *
004400*            NECESSARY SINCE I DISCOVERED BY ACCIDENT THAT BOB   *
004500*            CHRISTY NEGLECTED TO ACCOUNT FOR CBSAS CHANGING OVER*
004600*            TIME.  THESE TESTS ARE TEMPORARY SO THAT THE PRICER *
004700*            CAN BE DELIVERED TO THE FISCAL INTERMEDIARIES ON    *
004800*            TIME RATHER THAN TRYING TO TAKE THE TIME TO DEVISE A*
004900*            SEARCH-ALL TABLE WHICH WOULD TAKE ACCOUNT OF CBSAS  *
005000*            CHANGING OVER TIME.                                 *
005100* 06/04/08 - Added Copylib which enables this subprogram to act  *
005200*            the same on the IBM mainframe as well as on the PC  *
005300*            under MicroFocus COBOL.  The Copylib is technically *
005400*            slightly different on both systems which enables the*
005500*            test switch to operate correctly without any        *
005600*            standard COBOL changes between the systems.  The    *
005700*            EXACT same code shown in this listing (minus the    *
005800*            Copylib) WILL operate on both systems.  Therefore   *
005900*            there are no problems with synchronizing two        *
006000*            different source codes - - which, from experience,  *
006100*            will get out of sync over time.                     *
006200*          - Added different return codes to differentiate the   *
006300*            errors encountered.  These additional return codes  *
006400*            affect only the manager main-program which runs on  *
006500*            the PC.  They do not affect the running of this     *
006600*            subroutine on the IBM mainframe and will NOT impact *
006700*            'FISS' because only those codes contained in the    *
006800*            manual (IOM) are returned to 'FISS'.                *
006900*          - New CBSA Table for CY2009 (I.E. Copy EXCBS091       *
007000*          - Added date checks for CY2009 and CALL ESCAL091      *
007100* 12/03/08 - Renamed this subroutine ESDRV091 and changed the    *
007200*            appropriate version information.  The 9.0 version of*
007300*            the driver was sent out in November.  Afterwards the*
007400*            policy people who set the wage indexes, changed     *
007500*            their minds about CBSA 16700 and rescinded the new  *
007600*            wage index. This necessitated a re-release of the   *
007700*            ESRD dirver in order to make sure that the FI'S are *
007800*            using the latest version at the start of CY2009.    *
007900* 11/01/09 - Renamed this subroutine ESDRV100 and changed the    *
008000*            appropriate version information.  The 10.0 version  *
008100*            of the driver was sent out in November.             *
008200*          - Removed the ability to process 2005 claims.         *
008300*          - Added features which will make the driver able to   *
008400*            handle the new Bundled wage-index table and process *
008500*            those claims.  However, for this release, these     *
008600*            added features were commented out to speed up       *
008700*            processing.  There are other additions that need    *
008800*            to be made such as the length of the input record   *
008900*            in order for the 2011 driver and pricer to work.    *
009000* 01/08/10 - Renamed this subroutine ESDRV101 and changed the    *
009100*            appropriate version information.  The 10.1 version  *
009200*            of the driver was sent out in mid January.          *
009300*          - Because of a request by FISS and the MACs due to    *
009400*            requirements mandated by the OIG and CWF, the       *
009500*            ability to process 2005 claims was restored.  In    *
009600*            addition, to make this pricer conform to the rules  *
009700*            established with the IPPS Pricer, the ESRD Pricer   *
009800*            will be a 10 year rolling pricer.                   *
009900* 01/21/10 - Renamed this subroutine ESDRV102 and changed the    *
010000*            appropriate version information.  The 10.2 version  *
010100*            of the driver was sent out in late January.         *
010200*          - Fixed a slip-up in restoring the capability to      *
010300*            process 2005 claims.  My test file had real CBSA    *
010400*            values when it should have had blank values in that *
010500*            field, which is the case for 2005 claims.           *
010600* 08/04/10 - Renamed this subroutine ESRDRV110 and changed the   *
010700*            input and output file layout.  Installed the new    *
010800*            bundled (now called just PPS - the old methodology  *
010900*            will now be called composite rate) wage index table.*
011000* 11/09/10   Corrected the problem with CBSA 16700 for 2009 in   *
011100*            the composite rate table.  The latest wage indexes  *
011200*            from Suzanne Asplen's spreadsheet dated 10/27/2010  *
011300*            installed for both Bundled (PPS) and Composite Rate *
011400*            tables.  Updated the 0400-CHECK-CBSA-ADDS-DELETES   *
011500*            paragraph with 2011 CBSA changes.                   *
011600* 03/09/11   Renamed this subroutine ESDRV116 due to conformitity*
011700*            with the Calculate subroutine and also due to the   *
011800*            reworking of the copylib so that it used the same   *
011900*            ones that the calculate subroutines use.            *
012000* 10/28/11   Renamed this subroutine ESDRV120 due to conformitity*
012100*            with the Calculate subroutine.                      *
012200* 12/02/11   Renamed this subroutine ESDRV121 due to conformitity*
012300*            with the Calculate subroutine.                      *
012400* 10/19/12   ESDRV130 created for the CY 2013 ESRD Pricer.
012500*            - Added comments concerning this release
012600*            - Changed W-STORAGE-REF to ESRD D13.0
012700*            - Added  the following line to the WORKING-STORAGE
012800*              SECTION to add the name of the new Calculation
012900*              subprogram -->
013000*                 01  ESCAL130       PIC X(08) VALUE 'ESCAL130'.
013100*            - Changed COPY ESWRT121. to COPY ESWRT130. For MSA
013200*              Wage Index, which is no longer updated, just
013300*              renamed.
013400*            - Changed COPY ESCOM121. to COPY ESCOM130. to use
013500*              the latest Composite Wage Index.
013600*            - Changed COPY ESBUN121. to COPY ESBUN130. To use
013700*              the latest Bundled (PPS) Wage Index.
013800*            - Added section to code to CALL the new Calculation
013900*              Subprogram (ESCAL130)
014000*            - Since the CY 2013 ESRD Pricer update included
014100*              changes to the Calculation subprograms for
014200*              both 2012 and 2011, replaced
014300*              ESCAL116 with ESCAL117, and ESCAL121 with
014400*              ESCAL122 where needed.
014500* 11/15/13 ESDRV14B - TEST ONLY BETA VERSION
014600*          CREATED TO GIVE FISS SOMETHING TO TEST NOW BECAUSE
014700*          THE FINAL RULE WILL NOT BE AVAILABLE FOR ANOTHER
014800*          MONTH
014900*          MADE CHANGES TO ENSURE THAT PACIFIC RIM FACILITIES
015000*          ARE NOW PAID USING THE SAME CALCULATIONS AS
015100*          FACILITIES FROM OTHER AREAS
015200* 11/18/13 ESDRV140 - normal yearly release
015300*       This Driver module includes new logic
015400*       that directs Pacific Rim providers to flow through the
015500*       same pricing calculation as all other providers. This
015600*       logic was tested in the Beta version (ESDRV14B).
015700* 11/15/14 ESDRV150 - normal yearly release
015800*       added code to the 0800-FIND-BUNDLED-CBSA-WI to check to
015900*       make sure that the Wage Index being used to price the
016000*       claim is equal to the year of the claim in B-THRU-DATE
016100* 12/23/14 ESDRV151 - implement use of Special Wage Indexes for
016200*       certain Children's Hospitals
016300* 11/16/15 UPDATED FOR CY 2016 VERSION 0
016400* Stop using 0400-CHECK-CBSA-ADDS-DELETES.
016500* 09/07/16 - VERSION 17.B FOR TESTING ONLY
016600* 10/19/16 - VERSION 17.0 - CR9807 - CY 2017 ANNUAL UPDATE
016700* 03/16/17 - VERSION 17.1 - CR9609 - ADD RETRAINING - JULY 1, 2017
016800* 06/15/17 - VERSION 18.B - BETA VERSION TO TEST TDAPA
016900* 10/02/18 - VERSION 18.C - 2ND BETA VERSION TO TEST TDAPA
017000* 10/24/18 - VERSION 18.0 - CR10312 - CY2018 ANNUAL UPDATE
017100*
017200******************************************************************
017300
017400 ENVIRONMENT DIVISION.
017500 CONFIGURATION SECTION.
017600 SOURCE-COMPUTER.            IBM-Z990.
017700 OBJECT-COMPUTER.            IBM.
017800 INPUT-OUTPUT  SECTION.
017900 FILE-CONTROL.
018000
018100 DATA DIVISION.
018200 FILE SECTION.
018300/
018400 WORKING-STORAGE SECTION.
018500 01  W-STORAGE-REF                  PIC X(48)  VALUE
018600     'ESRD D18.0    -    W O R K I N G   S T O R A G E'.
018700
018800 01  DRIVER-VERSION                 PIC X(05) VALUE 'D18.0'.
018900
019000 01  ESCAL056                       PIC X(08) VALUE 'ESCAL056'.
019100 01  ESCAL062                       PIC X(08) VALUE 'ESCAL062'.
019200 01  ESCAL070                       PIC X(08) VALUE 'ESCAL070'.
019300 01  ESCAL071                       PIC X(08) VALUE 'ESCAL071'.
019400 01  ESCAL080                       PIC X(08) VALUE 'ESCAL080'.
019500*01  ESCAL090 does not exist        PIC X(08) VALUE 'ESCAL090'.
019600 01  ESCAL091                       PIC X(08) VALUE 'ESCAL091'.
019700 01  ESCAL100                       PIC X(08) VALUE 'ESCAL100'.
019800*01  ESCAL110 only for FISS testing PIC X(08) VALUE 'ESCAL110'.
019900*01  ESCAL111 only for FISS testing PIC X(08) VALUE 'ESCAL111'.
020000*01  ESCAL112 only for FISS testing PIC X(08) VALUE 'ESCAL112'.
020100*01  ESCAL113 only for FISS testing PIC X(08) VALUE 'ESCAL113'.
020200*01  ESCAL114 only for FISS testing PIC X(08) VALUE 'ESCAL114'.
020300*01  ESCAL115 still under CR7064... PIC X(08) VALUE 'ESCAL115'.
020400 01  ESCAL117                       PIC X(08) VALUE 'ESCAL117'.
020500*01  ESCAL120 does not exist        PIC X(08) VALUE 'ESCAL120'.
020600 01  ESCAL122                       PIC X(08) VALUE 'ESCAL122'.
020700 01  ESCAL130                       PIC X(08) VALUE 'ESCAL130'.
020800 01  ESCAL140                       PIC X(08) VALUE 'ESCAL140'.
020900 01  ESCAL151                       PIC X(08) VALUE 'ESCAL151'.
021000 01  ESCAL160                       PIC X(08) VALUE 'ESCAL160'.
021100 01  ESCAL170                       PIC X(08) VALUE 'ESCAL170'.
021200 01  ESCAL171                       PIC X(08) VALUE 'ESCAL171'.
021300 01  ESCAL180                       PIC X(08) VALUE 'ESCAL180'.
021400
021500 01  DISPLAY-LINE-MEASUREMENT.
021600     05  FILLER                     PIC X(50) VALUE
021700         '....:...10....:...20....:...30....:...40....:...50'.
021800     05  FILLER                     PIC X(50) VALUE
021900         '....:...60....:...70....:...80....:...90....:..100'.
022000     05  FILLER                     PIC X(20) VALUE
022100         '....:..110....:..120'.
022200
022300 01  PRINT-LINE-MEASUREMENT.
022400     05  FILLER                     PIC X(51) VALUE
022500         'X....:...10....:...20....:...30....:...40....:...50'.
022600     05  FILLER                     PIC X(50) VALUE
022700         '....:...60....:...70....:...80....:...90....:..100'.
022800     05  FILLER                     PIC X(32) VALUE
022900         '....:..110....:..120....:..130..'.
023000
023100 01  WORK-AREA.
023200     05  W-SUB1                     PIC S9(07) COMP-3 VALUE ZERO.
023300     05  W-SUB2                     PIC S9(07) COMP-3 VALUE ZERO.
023400     05  W-SUB3                     PIC S9(07) COMP-3 VALUE ZERO.
023500
023600*ADDED B-THRU-YEAR-CODE TO COMPARE COMPARE BILL YEAR TO WI YEAR
023700 01  B-THRU-YEAR-CODE                 PIC  9(03) VALUE 0.
023800
023900/
024000 COPY DSCNTRL.
024100*COPY "DSCNTRL.CPY".
024200/
024300*The Pricer is required to handle claims for the current year and
024400*three prior years in order for claims to be processed in a timely
024500*manner.  However, because claims can be reopened due to requireme
024600*by the OIG or CWF, the pricer needs to be able to process claims
024700*for a total of TEN years running.  Therefore, a diagram is
024800*necessary to figure out which tables need to be kept and which re
024900*from the driver in order to save space and increase efficiency.
025000*An asterisk beside the word 'yes' (below) indicates that the tabl
025100*does not need to be updated (even though it is still needed for
025200*for prior year claims).  Example:  A claim dated Dec. 31, 2008 ne
025300*the MSA table to price the claim items using a blend of 25% MSA 7
025400*CBSA.  Therefore the 2018 pricer needs the MSA table to process a
025500*year old claim.  Beginning in 2019 the MSA table can then be remo
025600*
025700*
025800*                                                        Call
025900*                 Wage index tables needed            Calculate
026000*                                                     Subroutine
026100*
026200*                 Need    Need      Need             2222222222222
026300*20xx                   Composite  Bundled           0000000000000
026400*Year blend      MSA-tbl CBSA-tbl  CBSA-tbl Pricer   1111111111222
026500*                                           Version  0123456789012
026600*
026700*05 100%MSA       yes                        05.6    XXXXXX
026800*06  25%Composite yes*    yes                06.2    XXXXXXX
026900*07  50%  "       yes*    yes                07.0    XXXXXXXX
027000*07  50%  "       yes*    yes                07.1    XXXXXXXX
027100*08  75%  "       yes*    yes                08.0    XXXXXXXXX
027200*09 100%  "       yes*    yes                09.1    XXXXXXXXXX
027300*10 100%  "       yes*    yes                10.0    XXXXXXXXXXX
027400*11  25%Bundled   yes*    yes        yes     11.0    XXXXXXXXXXXX
027500*12  50%  "       yes*    yes        yes     12.0    XXXXXXXXXXXXX
027600*13  75%  "       yes*    yes        yes     13.0    XXXXXXXXXXXXX
027700*14 100%  "       yes*    yes*       yes     14.0    XXXXXXXXXXXXX
027800*15 100%  "       yes*    yes*       yes     15.0    XXXXXXXXXXXXX
027900*16 100%  "       yes*    yes*       yes     16.0     XXXXXXXXXXXX
028000*17 100%  "       yes*    yes*       yes     17.0      XXXXXXXXXXX
028100*18 100%  "       yes*    yes*       yes     18.0       XXXXXXXXXX
028200*19 100%  "        no     yes*       yes     19.0        XXXXXXXXX
028300*20 100%  "        no     yes*       yes     20.0         XXXXXXXX
028400*21 100%  "        no     yes*       yes     21.0          XXXXXXX
028500*22 100%  "        no     yes*       yes     22.0           XXXXXX
028600*23 100%  "        no     yes*       yes     23.0            XXXXX
028700*24 100%  "        no      no        yes     24.0             XXXX
028800*25 100%  "        no      no        yes     25.0              XXX
028900*26 100%  "        no      no        yes     26.0               XX
029000*27 100%  "        no      no        yes     27.0                X
029100*28 100%  "        no      no        yes     28.0
029200*29 100%  "        no      no        yes     29.0
029300/
029400*  The following COPYLIB will NOT change (it's for MSA in 2005). *
029500*  Any wage adjustments are made in the calculation sub-programs.*
029600*  This COPYLIB will be removed in 2019 since it will no longer  *
029700*  be used.                                                      *
029800 COPY ESWRT151.
029900*COPY "ESWRT121.CPY".
030000/
030100*  The following COPYLIB is for the Composite Rate payment       *
030200*  system.  It will cease to be updated beginning in 2014,       *
030300*  although it will still be used through calendar year 2024.    *
030400*  Unless policies change, this table will be limited to ten     *
030500*  calendar years worth of data in order to cut down on the      *
030600*  amount of memory space used by the program.                   *
030700*  This COPYLIB will be removed in 2024 since it will no longer  *
030800*  be used.                                                      *
030900 COPY ESCOM151.
031000*COPY "ESCOM121.CPY".
031100/
031200*  The following COPYLIB is for the new Bundled payment system.  *
031300*  It is effective January 1, 2011 and will be changed on a      *
031400*  yearly basis from then on.  Although it looks similiar to the *
031500*  CBSA COPYLIB below it and also uses CBSAs, the wage indices   *
031600*  are derived in a different manner and while in the blend      *
031700*  period, they have to remain distinct because of the need to   *
031800*  process prior year's bills which use the old single CBSA index*
031900*  This table will superceed the old CBSA table below starting in*
032000*  calendar year 2014.  Unless policies change, this table will  *
032100*  be limited to TEN calendar years worth of data in order to    *
032200*  cut down on the amount of memory space used by the program.   *
032300 COPY ESBUN180.
032400*COPY "ESBUN121.CPY".
032500/
032600 COPY ESCHI151.
032700/
032800 COPY WAGECPY.
032900*COPY "WAGECPY.CPY".
033000/
033100 COPY RTCCPY.
033200*COPY "RTCCPY.CPY".
033300/
033400 LINKAGE SECTION.
033500 COPY BILLCPY.
033600*COPY "BILLCPY.CPY".
033700/
033800 PROCEDURE DIVISION  USING BILL-NEW-DATA
033900                           PPS-DATA-ALL.
034000
034100******************************************************************
034200*    THIS SUBROUTINE WILL...                                     *
034300*        A. Validate BILL-THRU-DATE and P-ESRD-RATE.             *
034400*        B. When P-ESRD-RATE > ZERO, then Rate on the bill is put*
034500*           in the PPS-FINAL-PAY-AMT area and then the record is *
034600*           passed back to the calling program without calling   *
034700*           any Calculate subroutine.                            *
034800*        C. Get MSA WAGE-RATE and/or CBSA WAGE-INDEX from the    *
034900*           appropriate internal Indexed Tables.                 *
035000*        D. Call ONE of various calculate subroutines based on   *
035100*           the date shown on the bill record.  Will not call any*
035200*           calculate subroutines if BILL-THRU-DATE exceeds the  *
035300*           driver design date.  Return code will be "00" and the*
035400*           Driver Version number will be present after 2010.    *
035500*        E. Pass back the Driver Version if no MSA/CBSA and date *
035600*           comtination are found in the Indexed Tables.         *
035700*           Otherwise the calculate subroutine supplies the      *
035800*           Version Number since no further processing in this   *
035900*           program is done after the call to the calculate      *
036000*           subroutine.                                          *
036100******************************************************************
036200
036300 0100-ENTER-DRIVER.
036400     INITIALIZE PPS-DATA-ALL.
036500     MOVE ZEROS TO COM-CBSA-WAGE-RECORD.
036600     MOVE DRIVER-VERSION          TO PPS-CALC-VERS-CD.
036700     MOVE 00                      TO PPS-RTC.
036800*
036900* Propose moving 99 to PPS-RTC so that when claims with a date
037000* greater than the year that the DRIVER is designed for, will
037100* return a RTC=99 rather than RTC=00 which is does currently.
037200* i.e. B-THRU-DATE > 2011 for the current DRIVER will get RTC=99.
037300*
037400*    MOVE 99                      TO PPS-RTC.
037500* You may uncomment the above line to test it out it you wish.
037600*
037700*    DISPLAY '***Entering DRIVER, Bill-New-Data follows'.
037800*    DISPLAY BILL-NEW-DATA.
037900
038000     IF (B-THRU-DATE < 20050401) OR (B-THRU-DATE NOT NUMERIC)
038100        MOVE 98                   TO PPS-RTC
038200        GO TO 0100-EXIT-DRIVER
038300     END-IF.
038400
038500     IF P-ESRD-RATE NOT NUMERIC
038600        MOVE 50                   TO PPS-RTC
038700        GO TO 0100-EXIT-DRIVER
038800     END-IF.
038900
039000*P-ESRD-RATE, also called the Exception Rate, will not be granted*
039100*in full beginning in 2011 (the beginning of the Bundled method) *
039200*and will be eliminated entirely beginning in 2014 which is the  *
039300*end of the blending period.  For 2011, those providers who elect*
039400*to be in the blend, will get only 75% of the exception rate.    *
039500*The exception to this 'Exception Rate' is for those providers   *
039600*located within one of the Pacific Island Trust Territories.     *
039700*These providers are paid at cost and so a new variable is needed*
039800*to allow them to be paid the same way as before, but still allow*
039900*the pediatric providers who had the Exception Rate to be        *
040000*processed under the blended PPS if they chose to elect to be in *
040100*the blend.                                                      *
040200
040300     IF (B-THRU-DATE < 20110101)  AND  (P-ESRD-RATE > ZERO)
040400        MOVE P-ESRD-RATE          TO PPS-FINAL-PAY-AMT
040500        MOVE 01                   TO PPS-RTC
040600        GO TO 0100-EXIT-DRIVER
040700     END-IF.
040800
040900     IF (B-THRU-DATE > 20101231)        AND
041000        (B-THRU-DATE < 20140101)        AND
041100        (P-PACIFIC-IS-TRUST-TERR = '2') AND
041200        (P-ESRD-RATE > ZERO)
041300        MOVE P-ESRD-RATE                TO PPS-FINAL-PAY-AMT
041400        MOVE 01                         TO PPS-RTC
041500        GO TO 0100-EXIT-DRIVER
041600     END-IF.
041700
041800******************************************************************
041900* Check for additions and deletions in CBSAs for each year.      *
042000*CY 2016 COMMENTED OUT
042100******************************************************************
042200
042300*    PERFORM 0400-CHECK-CBSA-ADDS-DELETES
042400*       THRU 0400-ADD-DELETE-EXIT.
042500
042600*    IF PPS-RTC > 00  THEN
042700*       GO TO 0100-EXIT-DRIVER
042800*    END-IF.
042900
043000/
043100******************************************************************
043200* Get the Wage Adjusted Rate as well as                          *
043300*     the COMposite and BUNdled budget neutralized Wage Indexes. *
043400******************************************************************
043500
043600* This driver will NOT CALL any calculate subroutine beyond the
043700* year for which the the driver is designed, and therefore a claim
043800* will not be paid correctly despite the RTC having a value of"00"
043900* A return code of "00" was only valid from 2005 thru 2010.
044000* Beginning in 2011 the return code
044100* should be greater than "01" for paid and unpaid claims.
044200*    FISS has the responsibility to insure that claims beyond the
044300* driver design date are not permitted.  Therefore for 2011, no
044400* claims should have a date beyond 2011.
044500*    FISS also has the responsibility of insuring that the claims
044600* do not have future dates beyond the "TODAYS-DATE"
044700* (which can be accepted from the IBM computer).
044800
044900     IF (B-THRU-DATE > 20131231) THEN
045000* Process 2014 and later claims.
045100        MOVE ZERO                TO W-NEW-RATE1-RECORD
045200                                    W-NEW-RATE2-RECORD
045300        PERFORM 0800-FIND-BUNDLED-CBSA-WI
045400           THRU 0800-FIND-EXIT
045500     ELSE
045600        IF (B-THRU-DATE > 20101231) THEN
045700* Process 2011 - 2013 claims.
045800            MOVE ZERO                TO W-NEW-RATE1-RECORD
045900                                        W-NEW-RATE2-RECORD
046000            PERFORM 0700-FIND-COMPOSITE-CBSA-WI
046100               THRU 0700-FIND-EXIT
046200            PERFORM 0800-FIND-BUNDLED-CBSA-WI
046300               THRU 0800-FIND-EXIT
046400        ELSE
046500           IF (B-THRU-DATE > 20081231)  THEN
046600* Process 2009 - 2010 claims.
046700              MOVE ZERO              TO W-NEW-RATE1-RECORD
046800                                        W-NEW-RATE2-RECORD
046900              PERFORM 0700-FIND-COMPOSITE-CBSA-WI
047000                 THRU 0700-FIND-EXIT
047100           ELSE
047200              IF (B-THRU-DATE > 20051231 AND
047300                  B-THRU-DATE < 20090101)  THEN
047400* Process 2006 - 08 claims.
047500                    PERFORM 0500-FIND-MSA-WAGE-ADJ-RATE
047600                       THRU 0500-FIND-EXIT
047700                    PERFORM 0700-FIND-COMPOSITE-CBSA-WI
047800                       THRU 0700-FIND-EXIT
047900              ELSE
048000                 IF (B-THRU-DATE > 20050331 AND
048100                     B-THRU-DATE < 20060101)  THEN
048200* Process 2005 claims.
048300                     PERFORM 0500-FIND-MSA-WAGE-ADJ-RATE
048400                        THRU 0500-FIND-EXIT
048500                 ELSE
048600                     MOVE 98         TO PPS-RTC
048700                 END-IF
048800              END-IF
048900           END-IF
049000        END-IF
049100     END-IF.
049200*RTC > 00  --  WAGE ADJUSTED RATE NOT FOUND.
049300     IF PPS-RTC > 00  THEN
049400        GO TO 0100-EXIT-DRIVER
049500     END-IF.
049600
049700
049800******************************************************************
049900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
050000*           THRU DATE BETWEEN 20180101 AND 20181231              *
050100******************************************************************
050200
050300     IF (B-THRU-DATE > 20171231  AND
050400         B-THRU-DATE < 20190101)  THEN
050500        CALL ESCAL180 USING BILL-NEW-DATA
050600                            PPS-DATA-ALL
050700                            WAGE-NEW-RATE-RECORD
050800                            COM-CBSA-WAGE-RECORD
050900                            BUN-CBSA-WAGE-RECORD
051000        GO TO 0100-EXIT-DRIVER
051100     END-IF.
051200
051300******************************************************************
051400*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
051500*           THRU DATE BETWEEN 20170701 AND 20171231              *
051600******************************************************************
051700
051800     IF (B-THRU-DATE > 20170630  AND
051900         B-THRU-DATE < 20180101)  THEN
052000        CALL ESCAL171 USING BILL-NEW-DATA
052100                            PPS-DATA-ALL
052200                            WAGE-NEW-RATE-RECORD
052300                            COM-CBSA-WAGE-RECORD
052400                            BUN-CBSA-WAGE-RECORD
052500        GO TO 0100-EXIT-DRIVER
052600     END-IF.
052700
052800******************************************************************
052900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
053000*           THRU DATE BETWEEN 20170101 AND 20170630              *
053100******************************************************************
053200
053300     IF (B-THRU-DATE > 20161231  AND
053400         B-THRU-DATE < 20170701)  THEN
053500        CALL ESCAL170 USING BILL-NEW-DATA
053600                            PPS-DATA-ALL
053700                            WAGE-NEW-RATE-RECORD
053800                            COM-CBSA-WAGE-RECORD
053900                            BUN-CBSA-WAGE-RECORD
054000        GO TO 0100-EXIT-DRIVER
054100     END-IF.
054200
054300******************************************************************
054400*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
054500*           THRU DATE BETWEEN 20160101 AND 20161231              *
054600******************************************************************
054700
054800     IF (B-THRU-DATE > 20151231  AND
054900         B-THRU-DATE < 20170101)  THEN
055000        CALL ESCAL160 USING BILL-NEW-DATA
055100                            PPS-DATA-ALL
055200                            WAGE-NEW-RATE-RECORD
055300                            COM-CBSA-WAGE-RECORD
055400                            BUN-CBSA-WAGE-RECORD
055500        GO TO 0100-EXIT-DRIVER
055600     END-IF.
055700
055800******************************************************************
055900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
056000*           THRU DATE BETWEEN 20150101 AND 20151231              *
056100******************************************************************
056200
056300     IF (B-THRU-DATE > 20141231  AND
056400         B-THRU-DATE < 20160101)  THEN
056500        CALL ESCAL151 USING BILL-NEW-DATA
056600                            PPS-DATA-ALL
056700                            WAGE-NEW-RATE-RECORD
056800                            COM-CBSA-WAGE-RECORD
056900                            BUN-CBSA-WAGE-RECORD
057000        GO TO 0100-EXIT-DRIVER
057100     END-IF.
057200
057300******************************************************************
057400*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
057500*           THRU DATE BETWEEN 20140101 AND 20141231              *
057600******************************************************************
057700
057800     IF (B-THRU-DATE > 20131231  AND
057900         B-THRU-DATE < 20150101)  THEN
058000        CALL ESCAL140 USING BILL-NEW-DATA
058100                            PPS-DATA-ALL
058200                            WAGE-NEW-RATE-RECORD
058300                            COM-CBSA-WAGE-RECORD
058400                            BUN-CBSA-WAGE-RECORD
058500        GO TO 0100-EXIT-DRIVER
058600     END-IF.
058700
058800******************************************************************
058900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
059000*           THRU DATE BETWEEN 20130101 AND 20131231              *
059100******************************************************************
059200
059300     IF (B-THRU-DATE > 20121231  AND
059400         B-THRU-DATE < 20140101)  THEN
059500        CALL ESCAL130 USING BILL-NEW-DATA
059600                            PPS-DATA-ALL
059700                            WAGE-NEW-RATE-RECORD
059800                            COM-CBSA-WAGE-RECORD
059900                            BUN-CBSA-WAGE-RECORD
060000        GO TO 0100-EXIT-DRIVER
060100     END-IF.
060200
060300******************************************************************
060400*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
060500*           THRU DATE BETWEEN 20120101 AND 20121231              *
060600*                  Remove this CALL in 2022.                     *
060700******************************************************************
060800
060900     IF (B-THRU-DATE > 20111231  AND
061000         B-THRU-DATE < 20130101)  THEN
061100        CALL ESCAL122 USING BILL-NEW-DATA
061200                            PPS-DATA-ALL
061300                            WAGE-NEW-RATE-RECORD
061400                            COM-CBSA-WAGE-RECORD
061500                            BUN-CBSA-WAGE-RECORD
061600        GO TO 0100-EXIT-DRIVER
061700     END-IF.
061800
061900******************************************************************
062000*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
062100*           THRU DATE BETWEEN 20110101 AND 20111231              *
062200*                  Remove this CALL in 2022.                     *
062300******************************************************************
062400
062500     IF (B-THRU-DATE > 20101231  AND
062600         B-THRU-DATE < 20120101)  THEN
062700        CALL ESCAL117 USING BILL-NEW-DATA
062800                            PPS-DATA-ALL
062900                            WAGE-NEW-RATE-RECORD
063000                            COM-CBSA-WAGE-RECORD
063100                            BUN-CBSA-WAGE-RECORD
063200        GO TO 0100-EXIT-DRIVER
063300     END-IF.
063400
063500******************************************************************
063600*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
063700*           THRU DATE BETWEEN 20100101 AND 20101231              *
063800*                  Remove this CALL in 2021.                     *
063900******************************************************************
064000
064100     IF (B-THRU-DATE > 20091231  AND
064200         B-THRU-DATE < 20110101)  THEN
064300        CALL ESCAL100 USING BILL-NEW-DATA
064400                            PPS-DATA-ALL
064500                            WAGE-NEW-RATE-RECORD
064600                            COM-CBSA-WAGE-RECORD
064700        GO TO 0100-EXIT-DRIVER
064800     END-IF.
064900
065000******************************************************************
065100*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
065200*           THRU DATE BETWEEN 20090101 AND 20091231              *
065300* NOTE:  THERE IS NO ESCAL090 DUE TO THIS VERSION BEING RELEASED *
065400*        BEFORE JANUARY 2009 (AND AFTER THE INITIAL 9.0 RELEASE) *
065500*                  Remove this CALL in 2020.                     *
065600******************************************************************
065700
065800     IF (B-THRU-DATE > 20081231  AND
065900         B-THRU-DATE < 20100101)  THEN
066000        CALL ESCAL091 USING BILL-NEW-DATA
066100                            PPS-DATA-ALL
066200                            WAGE-NEW-RATE-RECORD
066300                            COM-CBSA-WAGE-RECORD
066400        GO TO 0100-EXIT-DRIVER
066500     END-IF.
066600
066700******************************************************************
066800*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
066900*           THRU DATE BETWEEN 20080101 AND 20081231              *
067000*                  Remove this CALL in 2019.                     *
067100******************************************************************
067200
067300     IF (B-THRU-DATE > 20071231  AND
067400         B-THRU-DATE < 20090101)  THEN
067500        CALL ESCAL080 USING BILL-NEW-DATA
067600                            PPS-DATA-ALL
067700                            WAGE-NEW-RATE-RECORD
067800                            COM-CBSA-WAGE-RECORD
067900        GO TO 0100-EXIT-DRIVER
068000     END-IF.
068100
068200******************************************************************
068300*           THE NEXT CALL WILL PROCESS BILLS WITH  A             *
068400*           THRU DATE BETWEEN 20070401 AND 20071231              *
068500*                  Remove this CALL in 2018.                     *
068600******************************************************************
068700
068800     IF (B-THRU-DATE > 20070331  AND
068900         B-THRU-DATE < 20080101)  THEN
069000        CALL ESCAL071 USING BILL-NEW-DATA
069100                            PPS-DATA-ALL
069200                            WAGE-NEW-RATE-RECORD
069300                            COM-CBSA-WAGE-RECORD
069400        GO TO 0100-EXIT-DRIVER
069500     END-IF.
069600
069700******************************************************************
069800*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
069900*           THRU DATE BETWEEN 20070101 AND 20070331              *
070000*                  Remove this CALL in 2018.                     *
070100******************************************************************
070200
070300     IF (B-THRU-DATE > 20061231  AND
070400         B-THRU-DATE < 20070401)  THEN
070500        CALL ESCAL070 USING BILL-NEW-DATA
070600                            PPS-DATA-ALL
070700                            WAGE-NEW-RATE-RECORD
070800                            COM-CBSA-WAGE-RECORD
070900        GO TO 0100-EXIT-DRIVER
071000     END-IF.
071100
071200******************************************************************
071300*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
071400*           THRU DATE BETWEEN 20060101 AND 20061231              *
071500*                  Remove this CALL in 2017.                     *
071600******************************************************************
071700
071800     IF (B-THRU-DATE > 20051231  AND
071900         B-THRU-DATE < 20070101)  THEN
072000        CALL ESCAL062 USING BILL-NEW-DATA
072100                            PPS-DATA-ALL
072200                            WAGE-NEW-RATE-RECORD
072300                            COM-CBSA-WAGE-RECORD
072400        GO TO 0100-EXIT-DRIVER
072500     END-IF.
072600
072700******************************************************************
072800*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
072900*           THRU DATE BETWEEN 20050401 AND 20051231              *
073000*                  Remove this CALL in 2016.                     *
073100******************************************************************
073200
073300     IF (B-THRU-DATE > 20050331  AND
073400         B-THRU-DATE < 20060101)  THEN
073500        CALL ESCAL056 USING BILL-NEW-DATA
073600                            PPS-DATA-ALL
073700                            WAGE-NEW-RATE-RECORD
073800        GO TO 0100-EXIT-DRIVER
073900     END-IF.
074000
074100
074200
074300 0100-EXIT-DRIVER.
074400*    DISPLAY 'GOING BACK'.
074500     GOBACK.
074600******************************************************************
074700/
074800*0400-CHECK-CBSA-ADDS-DELETES.
074900*
075000*    IF B-THRU-CCYY > 2010  THEN
075100** These CBSAs Deleted starting in 2011                          *
075200** Note that '14600' also appears when   < 2009                  *
075300** There is no CBSA that was deleted starting in 2010            *
075400*       IF P-GEO-CBSA = '14600' OR  '23020'  OR  '48260'  THEN
075500*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
075600*             MOVE 60             TO PPS-RTC
075700*             GO TO 0400-ADD-DELETE-EXIT
075800*          ELSE
075900*             MOVE 62             TO PPS-RTC
076000*             GO TO 0400-ADD-DELETE-EXIT
076100*          END-IF
076200*       END-IF
076300*    END-IF.
076400*
076500*    IF B-THRU-CCYY > 2008  THEN
076600** This CBSA Deleted starting in 2009                            *
076700*       IF P-GEO-CBSA = '42260'  THEN
076800*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
076900*             MOVE 60             TO PPS-RTC
077000*             GO TO 0400-ADD-DELETE-EXIT
077100*          ELSE
077200*             MOVE 62             TO PPS-RTC
077300*             GO TO 0400-ADD-DELETE-EXIT
077400*          END-IF
077500*       END-IF
077600*    END-IF.
077700*
077800*    IF B-THRU-CCYY > 2007  THEN
077900** This CBSA Deleted starting in 2008                            *
078000*       IF P-GEO-CBSA = '21604'  THEN
078100*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
078200*             MOVE 60             TO PPS-RTC
078300*             GO TO 0400-ADD-DELETE-EXIT
078400*          ELSE
078500*             MOVE 62             TO PPS-RTC
078600*             GO TO 0400-ADD-DELETE-EXIT
078700*          END-IF
078800*       END-IF
078900*    END-IF.
079000*
079100*    IF B-THRU-CCYY > 2006  THEN
079200** This CBSA Deleted starting in 2007                            *
079300*       IF P-GEO-CBSA = '46940'  THEN
079400*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
079500*             MOVE 60             TO PPS-RTC
079600*             GO TO 0400-ADD-DELETE-EXIT
079700*          ELSE
079800*             MOVE 62             TO PPS-RTC
079900*             GO TO 0400-ADD-DELETE-EXIT
080000*          END-IF
080100*       END-IF
080200*    END-IF.
080300*
080400*    IF B-THRU-CCYY < 2011  THEN
080500** These CBSAs Added starting in 2011                            *
080600*      IF P-GEO-CBSA = '18880'  OR
080700*                      '35840'  OR
080800*                      '44600'  THEN
080900*        IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
081000*          MOVE 60                TO PPS-RTC
081100*          GO TO 0400-ADD-DELETE-EXIT
081200*        ELSE
081300*          MOVE 62                TO PPS-RTC
081400*          GO TO 0400-ADD-DELETE-EXIT
081500*        END-IF
081600*      ELSE
081700*        IF B-THRU-CCYY < 2010  THEN
081800** These CBSAs Added starting in 2010                            *
081900*          IF P-GEO-CBSA = '31740'  OR
082000*                          '31860'  THEN
082100*            IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
082200*              MOVE 60            TO PPS-RTC
082300*              GO TO 0400-ADD-DELETE-EXIT
082400*            ELSE
082500*              MOVE 62            TO PPS-RTC
082600*              GO TO 0400-ADD-DELETE-EXIT
082700*            END-IF
082800*          ELSE
082900*            IF B-THRU-CCYY < 2009  THEN
083000** This CBSA Added starting in 2009                            *
083100*              IF P-GEO-CBSA = '14600'  THEN
083200*                IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
083300*                  MOVE 60        TO PPS-RTC
083400*                  GO TO 0400-ADD-DELETE-EXIT
083500*                ELSE
083600*                  MOVE 62        TO PPS-RTC
083700*                  GO TO 0400-ADD-DELETE-EXIT
083800*                END-IF
083900*              ELSE
084000*                IF B-THRU-CCYY < 2008  THEN
084100** These CBSAs Added in 2008                                     *
084200*                  IF P-GEO-CBSA = '29420' OR
084300*                                  '37380' OR
084400*                                  '37764' THEN
084500*                    IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
084600*                      MOVE 60    TO PPS-RTC
084700*                      GO TO 0400-ADD-DELETE-EXIT
084800*                    ELSE
084900*                      MOVE 62    TO PPS-RTC
085000*                      GO TO 0400-ADD-DELETE-EXIT
085100*                    END-IF
085200*                  ELSE
085300*                    IF B-THRU-CCYY < 2007  THEN
085400** This CBSA Added in 2007                                       *
085500*                      IF P-GEO-CBSA = '42680'  THEN
085600*                      IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE THEN
085700*                          MOVE 60 TO PPS-RTC
085800*                          GO TO 0400-ADD-DELETE-EXIT
085900*                        ELSE
086000*                          MOVE 62 TO PPS-RTC
086100*                          GO TO 0400-ADD-DELETE-EXIT
086200*                        END-IF
086300*                      END-IF
086400*                    END-IF
086500*                  END-IF
086600*                END-IF
086700*              END-IF
086800*            END-IF
086900*          END-IF
087000*        END-IF
087100*      END-IF
087200*    END-IF.
087300*
087400*0400-ADD-DELETE-EXIT.
087500*    EXIT.
087600/
087700 0500-FIND-MSA-WAGE-ADJ-RATE.
087800     MOVE WWD-MAX                 TO WWD-SUB.
087900
088000     PERFORM UNTIL B-THRU-DATE NOT < WWD-DATE (WWD-SUB)
088100         SUBTRACT 1 FROM WWD-SUB
088200     END-PERFORM.
088300
088400     SEARCH ALL WWM-ENTRY
088500       AT END
088600          MOVE 60                 TO PPS-RTC
088700          GO TO 0500-FIND-EXIT
088800       WHEN WWM-MSA (WWM-INDX) = P-GEO-MSA
088900          MOVE WWM-PTR (WWM-INDX) TO W-SUB1
089000          PERFORM 0550-N-GET-WAGE-RATE
089100             THRU 0550-N-EXIT
089200     END-SEARCH.
089300
089400 0500-FIND-EXIT.
089500      EXIT.
089600
089700 0550-N-GET-WAGE-RATE.
089800     IF WWW-DTCD (W-SUB1) NOT > WWD-DTCD (WWD-SUB)  THEN
089900        MOVE WWD-DATE (WWD-SUB)   TO W-NEW-EFF-DATE
090000        MOVE WWW-WART1 (W-SUB1)   TO W-NEW-RATE1-RECORD
090100        MOVE WWW-WART2 (W-SUB1)   TO W-NEW-RATE2-RECORD
090200     ELSE
090300        SUBTRACT 1 FROM W-SUB1
090400        IF W-SUB1 > WWM-PTR (WWM-INDX - 1)  THEN
090500           GO TO 0550-N-GET-WAGE-RATE
090600        ELSE
090700          MOVE 0                  TO W-NEW-RATE1-RECORD
090800                                     W-NEW-RATE2-RECORD
090900        END-IF
091000     END-IF.
091100
091200 0550-N-EXIT.
091300     EXIT.
091400/
091500 0700-FIND-COMPOSITE-CBSA-WI.
091600     IF P-SPEC-PYMT-IND = '1'  THEN
091700        MOVE P-SPEC-WAGE-INDX     TO COM-CBSA-W-INDEX
091800        GO TO 0700-FIND-EXIT
091900     END-IF.
092000
092100     MOVE COM-MAX-DATE            TO COM-SUB.
092200
092300     PERFORM UNTIL B-THRU-DATE NOT < COM-DATE (COM-SUB)
092400         SUBTRACT 1 FROM COM-SUB
092500     END-PERFORM.
092600
092700     SEARCH ALL COM-CBSA-ENTRY
092800       AT END
092900          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
093000             MOVE 60              TO PPS-RTC
093100             GO TO 0700-FIND-EXIT
093200          ELSE
093300             MOVE 61              TO PPS-RTC
093400             GO TO 0700-FIND-EXIT
093500          END-IF
093600       WHEN COM-CBSA-VALUE (COM-INDX) = P-GEO-CBSA
093700          MOVE COM-PTR (COM-INDX) TO W-SUB2
093800          PERFORM 0750-GET-COMP-CBSA-RATE
093900             THRU 0750-COMP-EXIT
094000     END-SEARCH.
094100
094200 0700-FIND-EXIT.
094300      EXIT.
094400
094500 0750-GET-COMP-CBSA-RATE.
094600     IF COM-WI-DATE-CODE (W-SUB2) NOT > COM-DATE-CODE (COM-SUB)
094700                                                   THEN
094800        MOVE COM-DATE (COM-SUB)   TO COM-CBSA-DATE
094900        MOVE COM-WAGE-INDEX (W-SUB2)
095000                                  TO COM-CBSA-W-INDEX
095100     ELSE
095200        SUBTRACT 1 FROM W-SUB2
095300        IF W-SUB2 > COM-PTR (COM-INDX - 1)  THEN
095400           GO TO 0750-GET-COMP-CBSA-RATE
095500        ELSE
095600           MOVE 0                 TO COM-CBSA-W-INDEX
095700        END-IF
095800     END-IF.
095900
096000 0750-COMP-EXIT.
096100     EXIT.
096200******************************************************************
096300/
096400 0800-FIND-BUNDLED-CBSA-WI.
096500     IF P-SPEC-PYMT-IND = '1'  THEN
096600        MOVE P-SPEC-WAGE-INDX     TO BUN-CBSA-W-INDEX
096700        GO TO 0800-FIND-EXIT
096800     END-IF.
096900
097000     IF B-THRU-DATE > 20141231  AND  B-THRU-DATE < 20160101
097100      MOVE "N" TO CHILD-HOSP-SWI-FOUND-SWITCH
097200      PERFORM 0820-SEARCH-CHILD-HOSP-TABLE
097300          WITH TEST AFTER
097400          VARYING CHILD-HOSP-TABLE-SUB FROM 1 BY 1
097500          UNTIL CHILD-HOSP-SWI-FOUND
097600             OR CHILD-HOSP-TABLE-SUB = TOTAL-NUM-OF-CHILD-HOSP
097700      IF CHILD-HOSP-SWI-FOUND
097800          MOVE CHILD-HOSP-SWI (CHILD-HOSP-TABLE-SUB) TO
097900             BUN-CBSA-W-INDEX
098000          GO TO 0800-FIND-EXIT.
098100
098200     MOVE BUN-MAX-DATE            TO BUN-SUB.
098300
098400* FOR CY 2015 VERSION 0 ADDED NEXT LINE TO HOLD THE YEAR CODE
098500* THAT WILL BE USED TO CHECK THAT THE YEAR OF THE WAGE INDEX
098600* THAT'S BEING USED TO PRICE THE CLAIM IS THE SAME AS THE YEAR
098700* OF THE CLAIM
098800     MOVE B-THRU-DATE (4:1)   TO B-THRU-YEAR-CODE.
098900
099000     PERFORM UNTIL B-THRU-DATE NOT < BUN-DATE (BUN-SUB)
099100         SUBTRACT 1 FROM BUN-SUB
099200     END-PERFORM.
099300
099400     SEARCH ALL BUN-CBSA-ENTRY
099500       AT END
099600          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
099700             MOVE 60              TO PPS-RTC
099800             GO TO 0800-FIND-EXIT
099900          ELSE
100000             MOVE 61              TO PPS-RTC
100100             GO TO 0800-FIND-EXIT
100200          END-IF
100300       WHEN BUN-CBSA-VALUE (BUN-INDX) = P-GEO-CBSA
100400          MOVE BUN-PTR (BUN-INDX) TO W-SUB3
100500          PERFORM 0850-GET-BUNDLED-CBSA-RATE
100600             THRU 0850-BUNDLED-EXIT
100700     END-SEARCH.
100800
100900 0800-FIND-EXIT.
101000      EXIT.
101100
101200 0820-SEARCH-CHILD-HOSP-TABLE.
101300     IF CHILD-HOSP-PROV (CHILD-HOSP-TABLE-SUB) = P-PROV-OSCAR
101400        SET CHILD-HOSP-SWI-FOUND TO TRUE.
101500****** Replaced the 850 paragraph from 2014
101600****** to fix a problem with the CBSA lookup that would
101700****** cause it to price with wage indexes from previous years if
101800****** it couldn't find a wage index to match the year of the clai
101900 0850-GET-BUNDLED-CBSA-RATE.
102000* CY 2015 ADD CHECK TO MAKE SURE THAT THE YEAR OF THE
102100* WAGE INDEX RECORD IS THE SAME AS THE YEAR OF THE BILL
102200     IF
102300        (BUN-WI-DATE-CODE (W-SUB3) =
102400         B-THRU-YEAR-CODE)
102500     THEN
102600        MOVE BUN-DATE (BUN-SUB)   TO BUN-CBSA-DATE
102700        MOVE BUN-WAGE-INDEX (W-SUB3)
102800                                  TO BUN-CBSA-W-INDEX
102900     ELSE
103000        SUBTRACT 1 FROM W-SUB3
103100        IF W-SUB3 > BUN-PTR (BUN-INDX - 1)
103200        THEN GO TO 0850-GET-BUNDLED-CBSA-RATE
103300        ELSE
103400          MOVE 0                 TO BUN-CBSA-W-INDEX
103500* FOR CY 2015 VERSION 0 ADDED ASSIGNMENT OF RETURN CODE
103600* WHEN THERE IS NO CBSA FOUND FOR THE YEAR OF THE CLAIM
103700           MOVE 60 TO PPS-RTC
103800        END-IF
103900     END-IF.
104000* the following code is the old way to search the Wage Index
104100* Table that was dropped because it would price claims using
104200* a CBSA with a previous year's Wage Index even though the
104300* CBSA had been dropped for the year of the claim
104400*0850-GET-BUNDLED-CBSA-RATE.
104500*    IF BUN-WI-DATE-CODE (W-SUB3) NOT > BUN-DATE-CODE (BUN-SUB)
104600*                                                  THEN
104700*       MOVE BUN-DATE (BUN-SUB)   TO BUN-CBSA-DATE
104800*       MOVE BUN-WAGE-INDEX (W-SUB3)
104900*                                 TO BUN-CBSA-W-INDEX
105000*    ELSE
105100*       SUBTRACT 1 FROM W-SUB3
105200*       IF W-SUB3 > BUN-PTR (BUN-INDX - 1)  THEN
105300*          GO TO 0850-GET-BUNDLED-CBSA-RATE
105400*       ELSE
105500*          MOVE 0                 TO BUN-CBSA-W-INDEX
105600*       END-IF
105700*    END-IF.
105800 0850-BUNDLED-EXIT.
105900     EXIT.
