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