000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. ESDRV160.
000300*AUTHOR.     CMS.                                                *
000400*       EFFECTIVE JANUARY 1, 2016
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.  (ESBUN160)*
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******************************************************************
016700
016800 ENVIRONMENT DIVISION.
016900 CONFIGURATION SECTION.
017000 SOURCE-COMPUTER.            IBM-Z990.
017100 OBJECT-COMPUTER.            IBM.
017200 INPUT-OUTPUT  SECTION.
017300 FILE-CONTROL.
017400
017500 DATA DIVISION.
017600 FILE SECTION.
017700/
017800 WORKING-STORAGE SECTION.
017900 01  W-STORAGE-REF                  PIC X(48)  VALUE
018000     'ESRD D16.0    -    W O R K I N G   S T O R A G E'.
018100
018200 01  DRIVER-VERSION                 PIC X(05) VALUE 'D16.0'.
018300
018400 01  ESCAL056                       PIC X(08) VALUE 'ESCAL056'.
018500 01  ESCAL062                       PIC X(08) VALUE 'ESCAL062'.
018600 01  ESCAL070                       PIC X(08) VALUE 'ESCAL070'.
018700 01  ESCAL071                       PIC X(08) VALUE 'ESCAL071'.
018800 01  ESCAL080                       PIC X(08) VALUE 'ESCAL080'.
018900*01  ESCAL090 does not exist        PIC X(08) VALUE 'ESCAL090'.
019000 01  ESCAL091                       PIC X(08) VALUE 'ESCAL091'.
019100 01  ESCAL100                       PIC X(08) VALUE 'ESCAL100'.
019200*01  ESCAL110 only for FISS testing PIC X(08) VALUE 'ESCAL110'.
019300*01  ESCAL111 only for FISS testing PIC X(08) VALUE 'ESCAL111'.
019400*01  ESCAL112 only for FISS testing PIC X(08) VALUE 'ESCAL112'.
019500*01  ESCAL113 only for FISS testing PIC X(08) VALUE 'ESCAL113'.
019600*01  ESCAL114 only for FISS testing PIC X(08) VALUE 'ESCAL114'.
019700*01  ESCAL115 still under CR7064... PIC X(08) VALUE 'ESCAL115'.
019800 01  ESCAL117                       PIC X(08) VALUE 'ESCAL117'.
019900*01  ESCAL120 does not exist        PIC X(08) VALUE 'ESCAL120'.
020000 01  ESCAL122                       PIC X(08) VALUE 'ESCAL122'.
020100 01  ESCAL130                       PIC X(08) VALUE 'ESCAL130'.
020200 01  ESCAL140                       PIC X(08) VALUE 'ESCAL140'.
020300 01  ESCAL151                       PIC X(08) VALUE 'ESCAL151'.
020400 01  ESCAL160                       PIC X(08) VALUE 'ESCAL160'.
020500
020600 01  DISPLAY-LINE-MEASUREMENT.
020700     05  FILLER                     PIC X(50) VALUE
020800         '....:...10....:...20....:...30....:...40....:...50'.
020900     05  FILLER                     PIC X(50) VALUE
021000         '....:...60....:...70....:...80....:...90....:..100'.
021100     05  FILLER                     PIC X(20) VALUE
021200         '....:..110....:..120'.
021300
021400 01  PRINT-LINE-MEASUREMENT.
021500     05  FILLER                     PIC X(51) VALUE
021600         'X....:...10....:...20....:...30....:...40....:...50'.
021700     05  FILLER                     PIC X(50) VALUE
021800         '....:...60....:...70....:...80....:...90....:..100'.
021900     05  FILLER                     PIC X(32) VALUE
022000         '....:..110....:..120....:..130..'.
022100
022200 01  WORK-AREA.
022300     05  W-SUB1                     PIC S9(07) COMP-3 VALUE ZERO.
022400     05  W-SUB2                     PIC S9(07) COMP-3 VALUE ZERO.
022500     05  W-SUB3                     PIC S9(07) COMP-3 VALUE ZERO.
022600
022700*ADDED B-THRU-YEAR-CODE TO COMPARE COMPARE BILL YEAR TO WI YEAR
022800 01  B-THRU-YEAR-CODE                 PIC  9(03) VALUE 0.
022900
023000/
023100 COPY DSCNTRL.
023200*COPY "DSCNTRL.CPY".
023300/
023400*The Pricer is required to handle claims for the current year and
023500*three prior years in order for claims to be processed in a timely
023600*manner.  However, because claims can be reopened due to requireme
023700*by the OIG or CWF, the pricer needs to be able to process claims
023800*for a total of TEN years running.  Therefore, a diagram is
023900*necessary to figure out which tables need to be kept and which re
024000*from the driver in order to save space and increase efficiency.
024100*An asterisk beside the word 'yes' (below) indicates that the tabl
024200*does not need to be updated (even though it is still needed for
024300*for prior year claims).  Example:  A claim dated Dec. 31, 2008 ne
024400*the MSA table to price the claim items using a blend of 25% MSA 7
024500*CBSA.  Therefore the 2018 pricer needs the MSA table to process a
024600*year old claim.  Beginning in 2019 the MSA table can then be remo
024700*
024800*
024900*                                                        Call
025000*                 Wage index tables needed            Calculate
025100*                                                     Subroutine
025200*
025300*                 Need    Need      Need             2222222222222
025400*20xx                   Composite  Bundled           0000000000000
025500*Year blend      MSA-tbl CBSA-tbl  CBSA-tbl Pricer   1111111111222
025600*                                           Version  0123456789012
025700*
025800*05 100%MSA       yes                        05.6    XXXXXX
025900*06  25%Composite yes*    yes                06.2    XXXXXXX
026000*07  50%  "       yes*    yes                07.0    XXXXXXXX
026100*07  50%  "       yes*    yes                07.1    XXXXXXXX
026200*08  75%  "       yes*    yes                08.0    XXXXXXXXX
026300*09 100%  "       yes*    yes                09.1    XXXXXXXXXX
026400*10 100%  "       yes*    yes                10.0    XXXXXXXXXXX
026500*11  25%Bundled   yes*    yes        yes     11.0    XXXXXXXXXXXX
026600*12  50%  "       yes*    yes        yes     12.0    XXXXXXXXXXXXX
026700*13  75%  "       yes*    yes        yes     13.0    XXXXXXXXXXXXX
026800*14 100%  "       yes*    yes*       yes     14.0    XXXXXXXXXXXXX
026900*15 100%  "       yes*    yes*       yes     15.0    XXXXXXXXXXXXX
027000*16 100%  "       yes*    yes*       yes     16.0     XXXXXXXXXXXX
027100*17 100%  "       yes*    yes*       yes     17.0      XXXXXXXXXXX
027200*18 100%  "       yes*    yes*       yes     18.0       XXXXXXXXXX
027300*19 100%  "        no     yes*       yes     19.0        XXXXXXXXX
027400*20 100%  "        no     yes*       yes     20.0         XXXXXXXX
027500*21 100%  "        no     yes*       yes     21.0          XXXXXXX
027600*22 100%  "        no     yes*       yes     22.0           XXXXXX
027700*23 100%  "        no     yes*       yes     23.0            XXXXX
027800*24 100%  "        no      no        yes     24.0             XXXX
027900*25 100%  "        no      no        yes     25.0              XXX
028000*26 100%  "        no      no        yes     26.0               XX
028100*27 100%  "        no      no        yes     27.0                X
028200*28 100%  "        no      no        yes     28.0
028300*29 100%  "        no      no        yes     29.0
028400/
028500*  The following COPYLIB will NOT change (it's for MSA in 2005). *
028600*  Any wage adjustments are made in the calculation sub-programs.*
028700*  This COPYLIB will be removed in 2019 since it will no longer  *
028800*  be used.                                                      *
028900 COPY ESWRT151.
029000*COPY "ESWRT121.CPY".
029100/
029200*  The following COPYLIB is for the Composite Rate payment       *
029300*  system.  It will cease to be updated beginning in 2014,       *
029400*  although it will still be used through calendar year 2024.    *
029500*  Unless policies change, this table will be limited to ten     *
029600*  calendar years worth of data in order to cut down on the      *
029700*  amount of memory space used by the program.                   *
029800*  This COPYLIB will be removed in 2024 since it will no longer  *
029900*  be used.                                                      *
030000 COPY ESCOM151.
030100*COPY "ESCOM121.CPY".
030200/
030300*  The following COPYLIB is for the new Bundled payment system.  *
030400*  It is effective January 1, 2011 and will be changed on a      *
030500*  yearly basis from then on.  Although it looks similiar to the *
030600*  CBSA COPYLIB below it and also uses CBSAs, the wage indices   *
030700*  are derived in a different manner and while in the blend      *
030800*  period, they have to remain distinct because of the need to   *
030900*  process prior year's bills which use the old single CBSA index*
031000*  This table will superceed the old CBSA table below starting in*
031100*  calendar year 2014.  Unless policies change, this table will  *
031200*  be limited to TEN calendar years worth of data in order to    *
031300*  cut down on the amount of memory space used by the program.   *
031400 COPY ESBUN160.
031500*COPY "ESBUN121.CPY".
031600/
031700 COPY ESCHI151.
031800/
031900 COPY WAGECPY.
032000*COPY "WAGECPY.CPY".
032100/
032200 COPY RTCCPY.
032300*COPY "RTCCPY.CPY".
032400/
032500 LINKAGE SECTION.
032600 COPY BILLCPY.
032700*COPY "BILLCPY.CPY".
032800/
032900 PROCEDURE DIVISION  USING BILL-NEW-DATA
033000                           PPS-DATA-ALL.
033100
033200******************************************************************
033300*    THIS SUBROUTINE WILL...                                     *
033400*        A. Validate BILL-THRU-DATE and P-ESRD-RATE.             *
033500*        B. When P-ESRD-RATE > ZERO, then Rate on the bill is put*
033600*           in the PPS-FINAL-PAY-AMT area and then the record is *
033700*           passed back to the calling program without calling   *
033800*           any Calculate subroutine.                            *
033900*        C. Get MSA WAGE-RATE and/or CBSA WAGE-INDEX from the    *
034000*           appropriate internal Indexed Tables.                 *
034100*        D. Call ONE of various calculate subroutines based on   *
034200*           the date shown on the bill record.  Will not call any*
034300*           calculate subroutines if BILL-THRU-DATE exceeds the  *
034400*           driver design date.  Return code will be "00" and the*
034500*           Driver Version number will be present after 2010.    *
034600*        E. Pass back the Driver Version if no MSA/CBSA and date *
034700*           comtination are found in the Indexed Tables.         *
034800*           Otherwise the calculate subroutine supplies the      *
034900*           Version Number since no further processing in this   *
035000*           program is done after the call to the calculate      *
035100*           subroutine.                                          *
035200******************************************************************
035300
035400 0100-ENTER-DRIVER.
035500     INITIALIZE PPS-DATA-ALL.
035600     MOVE ZEROS TO COM-CBSA-WAGE-RECORD.
035700     MOVE DRIVER-VERSION          TO PPS-CALC-VERS-CD.
035800     MOVE 00                      TO PPS-RTC.
035900*
036000* Propose moving 99 to PPS-RTC so that when claims with a date
036100* greater than the year that the DRIVER is designed for, will
036200* return a RTC=99 rather than RTC=00 which is does currently.
036300* i.e. B-THRU-DATE > 2011 for the current DRIVER will get RTC=99.
036400*
036500*    MOVE 99                      TO PPS-RTC.
036600* You may uncomment the above line to test it out it you wish.
036700*
036800*    DISPLAY '***Entering DRIVER, Bill-New-Data follows'.
036900*    DISPLAY BILL-NEW-DATA.
037000
037100     IF (B-THRU-DATE < 20050401) OR (B-THRU-DATE NOT NUMERIC)
037200        MOVE 98                   TO PPS-RTC
037300        GO TO 0100-EXIT-DRIVER
037400     END-IF.
037500
037600     IF P-ESRD-RATE NOT NUMERIC
037700        MOVE 50                   TO PPS-RTC
037800        GO TO 0100-EXIT-DRIVER
037900     END-IF.
038000
038100*P-ESRD-RATE, also called the Exception Rate, will not be granted*
038200*in full beginning in 2011 (the beginning of the Bundled method) *
038300*and will be eliminated entirely beginning in 2014 which is the  *
038400*end of the blending period.  For 2011, those providers who elect*
038500*to be in the blend, will get only 75% of the exception rate.    *
038600*The exception to this 'Exception Rate' is for those providers   *
038700*located within one of the Pacific Island Trust Territories.     *
038800*These providers are paid at cost and so a new variable is needed*
038900*to allow them to be paid the same way as before, but still allow*
039000*the pediatric providers who had the Exception Rate to be        *
039100*processed under the blended PPS if they chose to elect to be in *
039200*the blend.                                                      *
039300
039400     IF (B-THRU-DATE < 20110101)  AND  (P-ESRD-RATE > ZERO)
039500        MOVE P-ESRD-RATE          TO PPS-FINAL-PAY-AMT
039600        MOVE 01                   TO PPS-RTC
039700        GO TO 0100-EXIT-DRIVER
039800     END-IF.
039900
040000         IF (B-THRU-DATE > 20101231)        AND
040100            (B-THRU-DATE < 20140101) AND
040200            (P-PACIFIC-IS-TRUST-TERR = '2') AND
040300            (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******************************************************************
041000* Check for additions and deletions in CBSAs for each year.      *
041100*CY 2016 COMMENTED OUT
041200******************************************************************
041300
041400*    PERFORM 0400-CHECK-CBSA-ADDS-DELETES
041500*       THRU 0400-ADD-DELETE-EXIT.
041600
041700*    IF PPS-RTC > 00  THEN
041800*       GO TO 0100-EXIT-DRIVER
041900*    END-IF.
042000
042100/
042200******************************************************************
042300* Get the Wage Adjusted Rate as well as                          *
042400*     the COMposite and BUNdled budget neutralized Wage Indexes. *
042500******************************************************************
042600
042700* This driver will NOT CALL any calculate subroutine beyond the
042800* year for which the the driver is designed, and therefore a claim
042900* will not be paid correctly despite the RTC having a value of"00"
043000* A return code of "00" was only valid from 2005 thru 2010.
043100* Beginning in 2011 the return code
043200* should be greater than "01" for paid and unpaid claims.
043300*    FISS has the responsibility to insure that claims beyond the
043400* driver design date are not permitted.  Therefore for 2011, no
043500* claims should have a date beyond 2011.
043600*    FISS also has the responsibility of insuring that the claims
043700* do not have future dates beyond the "TODAYS-DATE"
043800* (which can be accepted from the IBM computer).
043900
044000     IF (B-THRU-DATE > 20131231) THEN
044100* Process 2014 and later claims.
044200        MOVE ZERO                TO W-NEW-RATE1-RECORD
044300                                    W-NEW-RATE2-RECORD
044400        PERFORM 0800-FIND-BUNDLED-CBSA-WI
044500           THRU 0800-FIND-EXIT
044600     ELSE
044700        IF (B-THRU-DATE > 20101231) THEN
044800* Process 2011 - 2013 claims.
044900            MOVE ZERO                TO W-NEW-RATE1-RECORD
045000                                        W-NEW-RATE2-RECORD
045100            PERFORM 0700-FIND-COMPOSITE-CBSA-WI
045200               THRU 0700-FIND-EXIT
045300            PERFORM 0800-FIND-BUNDLED-CBSA-WI
045400               THRU 0800-FIND-EXIT
045500        ELSE
045600           IF (B-THRU-DATE > 20081231)  THEN
045700* Process 2009 - 2010 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           ELSE
046300              IF (B-THRU-DATE > 20051231 AND
046400                  B-THRU-DATE < 20090101)  THEN
046500* Process 2006 - 08 claims.
046600                    PERFORM 0500-FIND-MSA-WAGE-ADJ-RATE
046700                       THRU 0500-FIND-EXIT
046800                    PERFORM 0700-FIND-COMPOSITE-CBSA-WI
046900                       THRU 0700-FIND-EXIT
047000              ELSE
047100                 IF (B-THRU-DATE > 20050331 AND
047200                     B-THRU-DATE < 20060101)  THEN
047300* Process 2005 claims.
047400                     PERFORM 0500-FIND-MSA-WAGE-ADJ-RATE
047500                        THRU 0500-FIND-EXIT
047600                 ELSE
047700                     MOVE 98         TO PPS-RTC
047800                 END-IF
047900              END-IF
048000           END-IF
048100        END-IF
048200     END-IF.
048300*RTC > 00  --  WAGE ADJUSTED RATE NOT FOUND.
048400     IF PPS-RTC > 00  THEN
048500        GO TO 0100-EXIT-DRIVER
048600     END-IF.
048700
048800******************************************************************
048900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
049000*           THRU DATE BETWEEN 20160101 AND 20161231              *
049100******************************************************************
049200
049300     IF (B-THRU-DATE > 20151231  AND
049400         B-THRU-DATE < 20170101)  THEN
049500        CALL ESCAL160 USING BILL-NEW-DATA
049600                            PPS-DATA-ALL
049700                            WAGE-NEW-RATE-RECORD
049800                            COM-CBSA-WAGE-RECORD
049900                            BUN-CBSA-WAGE-RECORD
050000        GO TO 0100-EXIT-DRIVER
050100     END-IF.
050200
050300******************************************************************
050400*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
050500*           THRU DATE BETWEEN 20150101 AND 20151231              *
050600******************************************************************
050700
050800     IF (B-THRU-DATE > 20141231  AND
050900         B-THRU-DATE < 20160101)  THEN
051000        CALL ESCAL151 USING BILL-NEW-DATA
051100                            PPS-DATA-ALL
051200                            WAGE-NEW-RATE-RECORD
051300                            COM-CBSA-WAGE-RECORD
051400                            BUN-CBSA-WAGE-RECORD
051500        GO TO 0100-EXIT-DRIVER
051600     END-IF.
051700
051800******************************************************************
051900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
052000*           THRU DATE BETWEEN 20140101 AND 20141231              *
052100******************************************************************
052200
052300     IF (B-THRU-DATE > 20131231  AND
052400         B-THRU-DATE < 20150101)  THEN
052500        CALL ESCAL140 USING BILL-NEW-DATA
052600                            PPS-DATA-ALL
052700                            WAGE-NEW-RATE-RECORD
052800                            COM-CBSA-WAGE-RECORD
052900                            BUN-CBSA-WAGE-RECORD
053000        GO TO 0100-EXIT-DRIVER
053100     END-IF.
053200
053300******************************************************************
053400*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
053500*           THRU DATE BETWEEN 20130101 AND 20131231              *
053600******************************************************************
053700
053800     IF (B-THRU-DATE > 20121231  AND
053900         B-THRU-DATE < 20140101)  THEN
054000        CALL ESCAL130 USING BILL-NEW-DATA
054100                            PPS-DATA-ALL
054200                            WAGE-NEW-RATE-RECORD
054300                            COM-CBSA-WAGE-RECORD
054400                            BUN-CBSA-WAGE-RECORD
054500        GO TO 0100-EXIT-DRIVER
054600     END-IF.
054700
054800******************************************************************
054900*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
055000*           THRU DATE BETWEEN 20120101 AND 20121231              *
055100*                  Remove this CALL in 2022.                     *
055200******************************************************************
055300
055400     IF (B-THRU-DATE > 20111231  AND
055500         B-THRU-DATE < 20130101)  THEN
055600        CALL ESCAL122 USING BILL-NEW-DATA
055700                            PPS-DATA-ALL
055800                            WAGE-NEW-RATE-RECORD
055900                            COM-CBSA-WAGE-RECORD
056000                            BUN-CBSA-WAGE-RECORD
056100        GO TO 0100-EXIT-DRIVER
056200     END-IF.
056300
056400******************************************************************
056500*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
056600*           THRU DATE BETWEEN 20110101 AND 20111231              *
056700*                  Remove this CALL in 2022.                     *
056800******************************************************************
056900
057000     IF (B-THRU-DATE > 20101231  AND
057100         B-THRU-DATE < 20120101)  THEN
057200        CALL ESCAL117 USING BILL-NEW-DATA
057300                            PPS-DATA-ALL
057400                            WAGE-NEW-RATE-RECORD
057500                            COM-CBSA-WAGE-RECORD
057600                            BUN-CBSA-WAGE-RECORD
057700        GO TO 0100-EXIT-DRIVER
057800     END-IF.
057900
058000******************************************************************
058100*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
058200*           THRU DATE BETWEEN 20100101 AND 20101231              *
058300*                  Remove this CALL in 2021.                     *
058400******************************************************************
058500
058600     IF (B-THRU-DATE > 20091231  AND
058700         B-THRU-DATE < 20110101)  THEN
058800        CALL ESCAL100 USING BILL-NEW-DATA
058900                            PPS-DATA-ALL
059000                            WAGE-NEW-RATE-RECORD
059100                            COM-CBSA-WAGE-RECORD
059200        GO TO 0100-EXIT-DRIVER
059300     END-IF.
059400
059500******************************************************************
059600*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
059700*           THRU DATE BETWEEN 20090101 AND 20091231              *
059800* NOTE:  THERE IS NO ESCAL090 DUE TO THIS VERSION BEING RELEASED *
059900*        BEFORE JANUARY 2009 (AND AFTER THE INITIAL 9.0 RELEASE) *
060000*                  Remove this CALL in 2020.                     *
060100******************************************************************
060200
060300     IF (B-THRU-DATE > 20081231  AND
060400         B-THRU-DATE < 20100101)  THEN
060500        CALL ESCAL091 USING BILL-NEW-DATA
060600                            PPS-DATA-ALL
060700                            WAGE-NEW-RATE-RECORD
060800                            COM-CBSA-WAGE-RECORD
060900        GO TO 0100-EXIT-DRIVER
061000     END-IF.
061100
061200******************************************************************
061300*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
061400*           THRU DATE BETWEEN 20080101 AND 20081231              *
061500*                  Remove this CALL in 2019.                     *
061600******************************************************************
061700
061800     IF (B-THRU-DATE > 20071231  AND
061900         B-THRU-DATE < 20090101)  THEN
062000        CALL ESCAL080 USING BILL-NEW-DATA
062100                            PPS-DATA-ALL
062200                            WAGE-NEW-RATE-RECORD
062300                            COM-CBSA-WAGE-RECORD
062400        GO TO 0100-EXIT-DRIVER
062500     END-IF.
062600
062700******************************************************************
062800*           THE NEXT CALL WILL PROCESS BILLS WITH  A             *
062900*           THRU DATE BETWEEN 20070401 AND 20071231              *
063000*                  Remove this CALL in 2018.                     *
063100******************************************************************
063200
063300     IF (B-THRU-DATE > 20070331  AND
063400         B-THRU-DATE < 20080101)  THEN
063500        CALL ESCAL071 USING BILL-NEW-DATA
063600                            PPS-DATA-ALL
063700                            WAGE-NEW-RATE-RECORD
063800                            COM-CBSA-WAGE-RECORD
063900        GO TO 0100-EXIT-DRIVER
064000     END-IF.
064100
064200******************************************************************
064300*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
064400*           THRU DATE BETWEEN 20070101 AND 20070331              *
064500*                  Remove this CALL in 2018.                     *
064600******************************************************************
064700
064800     IF (B-THRU-DATE > 20061231  AND
064900         B-THRU-DATE < 20070401)  THEN
065000        CALL ESCAL070 USING BILL-NEW-DATA
065100                            PPS-DATA-ALL
065200                            WAGE-NEW-RATE-RECORD
065300                            COM-CBSA-WAGE-RECORD
065400        GO TO 0100-EXIT-DRIVER
065500     END-IF.
065600
065700******************************************************************
065800*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
065900*           THRU DATE BETWEEN 20060101 AND 20061231              *
066000*                  Remove this CALL in 2017.                     *
066100******************************************************************
066200
066300     IF (B-THRU-DATE > 20051231  AND
066400         B-THRU-DATE < 20070101)  THEN
066500        CALL ESCAL062 USING BILL-NEW-DATA
066600                            PPS-DATA-ALL
066700                            WAGE-NEW-RATE-RECORD
066800                            COM-CBSA-WAGE-RECORD
066900        GO TO 0100-EXIT-DRIVER
067000     END-IF.
067100
067200******************************************************************
067300*           THE NEXT CALL WILL PROCESS BILLS WITH A              *
067400*           THRU DATE BETWEEN 20050401 AND 20051231              *
067500*                  Remove this CALL in 2016.                     *
067600******************************************************************
067700
067800     IF (B-THRU-DATE > 20050331  AND
067900         B-THRU-DATE < 20060101)  THEN
068000        CALL ESCAL056 USING BILL-NEW-DATA
068100                            PPS-DATA-ALL
068200                            WAGE-NEW-RATE-RECORD
068300        GO TO 0100-EXIT-DRIVER
068400     END-IF.
068500
068600
068700
068800 0100-EXIT-DRIVER.
068900*    DISPLAY 'GOING BACK'.
069000     GOBACK.
069100******************************************************************
069200/
069300*0400-CHECK-CBSA-ADDS-DELETES.
069400*
069500*    IF B-THRU-CCYY > 2010  THEN
069600** These CBSAs Deleted starting in 2011                          *
069700** Note that '14600' also appears when   < 2009                  *
069800** There is no CBSA that was deleted starting in 2010            *
069900*       IF P-GEO-CBSA = '14600' OR  '23020'  OR  '48260'  THEN
070000*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
070100*             MOVE 60             TO PPS-RTC
070200*             GO TO 0400-ADD-DELETE-EXIT
070300*          ELSE
070400*             MOVE 62             TO PPS-RTC
070500*             GO TO 0400-ADD-DELETE-EXIT
070600*          END-IF
070700*       END-IF
070800*    END-IF.
070900*
071000*    IF B-THRU-CCYY > 2008  THEN
071100** This CBSA Deleted starting in 2009                            *
071200*       IF P-GEO-CBSA = '42260'  THEN
071300*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
071400*             MOVE 60             TO PPS-RTC
071500*             GO TO 0400-ADD-DELETE-EXIT
071600*          ELSE
071700*             MOVE 62             TO PPS-RTC
071800*             GO TO 0400-ADD-DELETE-EXIT
071900*          END-IF
072000*       END-IF
072100*    END-IF.
072200*
072300*    IF B-THRU-CCYY > 2007  THEN
072400** This CBSA Deleted starting in 2008                            *
072500*       IF P-GEO-CBSA = '21604'  THEN
072600*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
072700*             MOVE 60             TO PPS-RTC
072800*             GO TO 0400-ADD-DELETE-EXIT
072900*          ELSE
073000*             MOVE 62             TO PPS-RTC
073100*             GO TO 0400-ADD-DELETE-EXIT
073200*          END-IF
073300*       END-IF
073400*    END-IF.
073500*
073600*    IF B-THRU-CCYY > 2006  THEN
073700** This CBSA Deleted starting in 2007                            *
073800*       IF P-GEO-CBSA = '46940'  THEN
073900*          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
074000*             MOVE 60             TO PPS-RTC
074100*             GO TO 0400-ADD-DELETE-EXIT
074200*          ELSE
074300*             MOVE 62             TO PPS-RTC
074400*             GO TO 0400-ADD-DELETE-EXIT
074500*          END-IF
074600*       END-IF
074700*    END-IF.
074800*
074900*    IF B-THRU-CCYY < 2011  THEN
075000** These CBSAs Added starting in 2011                            *
075100*      IF P-GEO-CBSA = '18880'  OR
075200*                      '35840'  OR
075300*                      '44600'  THEN
075400*        IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
075500*          MOVE 60                TO PPS-RTC
075600*          GO TO 0400-ADD-DELETE-EXIT
075700*        ELSE
075800*          MOVE 62                TO PPS-RTC
075900*          GO TO 0400-ADD-DELETE-EXIT
076000*        END-IF
076100*      ELSE
076200*        IF B-THRU-CCYY < 2010  THEN
076300** These CBSAs Added starting in 2010                            *
076400*          IF P-GEO-CBSA = '31740'  OR
076500*                          '31860'  THEN
076600*            IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
076700*              MOVE 60            TO PPS-RTC
076800*              GO TO 0400-ADD-DELETE-EXIT
076900*            ELSE
077000*              MOVE 62            TO PPS-RTC
077100*              GO TO 0400-ADD-DELETE-EXIT
077200*            END-IF
077300*          ELSE
077400*            IF B-THRU-CCYY < 2009  THEN
077500** This CBSA Added starting in 2009                            *
077600*              IF P-GEO-CBSA = '14600'  THEN
077700*                IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
077800*                  MOVE 60        TO PPS-RTC
077900*                  GO TO 0400-ADD-DELETE-EXIT
078000*                ELSE
078100*                  MOVE 62        TO PPS-RTC
078200*                  GO TO 0400-ADD-DELETE-EXIT
078300*                END-IF
078400*              ELSE
078500*                IF B-THRU-CCYY < 2008  THEN
078600** These CBSAs Added in 2008                                     *
078700*                  IF P-GEO-CBSA = '29420' OR
078800*                                  '37380' OR
078900*                                  '37764' THEN
079000*                    IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
079100*                      MOVE 60    TO PPS-RTC
079200*                      GO TO 0400-ADD-DELETE-EXIT
079300*                    ELSE
079400*                      MOVE 62    TO PPS-RTC
079500*                      GO TO 0400-ADD-DELETE-EXIT
079600*                    END-IF
079700*                  ELSE
079800*                    IF B-THRU-CCYY < 2007  THEN
079900** This CBSA Added in 2007                                       *
080000*                      IF P-GEO-CBSA = '42680'  THEN
080100*                      IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE THEN
080200*                          MOVE 60 TO PPS-RTC
080300*                          GO TO 0400-ADD-DELETE-EXIT
080400*                        ELSE
080500*                          MOVE 62 TO PPS-RTC
080600*                          GO TO 0400-ADD-DELETE-EXIT
080700*                        END-IF
080800*                      END-IF
080900*                    END-IF
081000*                  END-IF
081100*                END-IF
081200*              END-IF
081300*            END-IF
081400*          END-IF
081500*        END-IF
081600*      END-IF
081700*    END-IF.
081800*
081900*0400-ADD-DELETE-EXIT.
082000*    EXIT.
082100/
082200 0500-FIND-MSA-WAGE-ADJ-RATE.
082300     MOVE WWD-MAX                 TO WWD-SUB.
082400
082500     PERFORM UNTIL B-THRU-DATE NOT < WWD-DATE (WWD-SUB)
082600         SUBTRACT 1 FROM WWD-SUB
082700     END-PERFORM.
082800
082900     SEARCH ALL WWM-ENTRY
083000       AT END
083100          MOVE 60                 TO PPS-RTC
083200          GO TO 0500-FIND-EXIT
083300       WHEN WWM-MSA (WWM-INDX) = P-GEO-MSA
083400          MOVE WWM-PTR (WWM-INDX) TO W-SUB1
083500          PERFORM 0550-N-GET-WAGE-RATE
083600             THRU 0550-N-EXIT
083700     END-SEARCH.
083800
083900 0500-FIND-EXIT.
084000      EXIT.
084100
084200 0550-N-GET-WAGE-RATE.
084300     IF WWW-DTCD (W-SUB1) NOT > WWD-DTCD (WWD-SUB)  THEN
084400        MOVE WWD-DATE (WWD-SUB)   TO W-NEW-EFF-DATE
084500        MOVE WWW-WART1 (W-SUB1)   TO W-NEW-RATE1-RECORD
084600        MOVE WWW-WART2 (W-SUB1)   TO W-NEW-RATE2-RECORD
084700     ELSE
084800        SUBTRACT 1 FROM W-SUB1
084900        IF W-SUB1 > WWM-PTR (WWM-INDX - 1)  THEN
085000           GO TO 0550-N-GET-WAGE-RATE
085100        ELSE
085200          MOVE 0                  TO W-NEW-RATE1-RECORD
085300                                     W-NEW-RATE2-RECORD
085400        END-IF
085500     END-IF.
085600
085700 0550-N-EXIT.
085800     EXIT.
085900/
086000 0700-FIND-COMPOSITE-CBSA-WI.
086100     IF P-SPEC-PYMT-IND = '1'  THEN
086200        MOVE P-SPEC-WAGE-INDX     TO COM-CBSA-W-INDEX
086300        GO TO 0700-FIND-EXIT
086400     END-IF.
086500
086600     MOVE COM-MAX-DATE            TO COM-SUB.
086700
086800     PERFORM UNTIL B-THRU-DATE NOT < COM-DATE (COM-SUB)
086900         SUBTRACT 1 FROM COM-SUB
087000     END-PERFORM.
087100
087200     SEARCH ALL COM-CBSA-ENTRY
087300       AT END
087400          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
087500             MOVE 60              TO PPS-RTC
087600             GO TO 0700-FIND-EXIT
087700          ELSE
087800             MOVE 61              TO PPS-RTC
087900             GO TO 0700-FIND-EXIT
088000          END-IF
088100       WHEN COM-CBSA-VALUE (COM-INDX) = P-GEO-CBSA
088200          MOVE COM-PTR (COM-INDX) TO W-SUB2
088300          PERFORM 0750-GET-COMP-CBSA-RATE
088400             THRU 0750-COMP-EXIT
088500     END-SEARCH.
088600
088700 0700-FIND-EXIT.
088800      EXIT.
088900
089000 0750-GET-COMP-CBSA-RATE.
089100     IF COM-WI-DATE-CODE (W-SUB2) NOT > COM-DATE-CODE (COM-SUB)
089200                                                   THEN
089300        MOVE COM-DATE (COM-SUB)   TO COM-CBSA-DATE
089400        MOVE COM-WAGE-INDEX (W-SUB2)
089500                                  TO COM-CBSA-W-INDEX
089600     ELSE
089700        SUBTRACT 1 FROM W-SUB2
089800        IF W-SUB2 > COM-PTR (COM-INDX - 1)  THEN
089900           GO TO 0750-GET-COMP-CBSA-RATE
090000        ELSE
090100           MOVE 0                 TO COM-CBSA-W-INDEX
090200        END-IF
090300     END-IF.
090400
090500 0750-COMP-EXIT.
090600     EXIT.
090700******************************************************************
090800/
090900 0800-FIND-BUNDLED-CBSA-WI.
091000     IF P-SPEC-PYMT-IND = '1'  THEN
091100        MOVE P-SPEC-WAGE-INDX     TO BUN-CBSA-W-INDEX
091200        GO TO 0800-FIND-EXIT
091300     END-IF.
091400
091500     IF B-THRU-DATE > 20141231  AND  B-THRU-DATE < 20160101
091600      MOVE "N" TO CHILD-HOSP-SWI-FOUND-SWITCH
091700      PERFORM 0820-SEARCH-CHILD-HOSP-TABLE
091800          WITH TEST AFTER
091900          VARYING CHILD-HOSP-TABLE-SUB FROM 1 BY 1
092000          UNTIL CHILD-HOSP-SWI-FOUND
092100             OR CHILD-HOSP-TABLE-SUB = TOTAL-NUM-OF-CHILD-HOSP
092200      IF CHILD-HOSP-SWI-FOUND
092300          MOVE CHILD-HOSP-SWI (CHILD-HOSP-TABLE-SUB) TO
092400             BUN-CBSA-W-INDEX
092500          GO TO 0800-FIND-EXIT.
092600
092700     MOVE BUN-MAX-DATE            TO BUN-SUB.
092800
092900* FOR CY 2015 VERSION 0 ADDED NEXT LINE TO HOLD THE YEAR CODE
093000* THAT WILL BE USED TO CHECK THAT THE YEAR OF THE WAGE INDEX
093100* THAT'S BEING USED TO PRICE THE CLAIM IS THE SAME AS THE YEAR
093200* OF THE CLAIM
093300     MOVE B-THRU-DATE (4:1)   TO B-THRU-YEAR-CODE.
093400
093500     PERFORM UNTIL B-THRU-DATE NOT < BUN-DATE (BUN-SUB)
093600         SUBTRACT 1 FROM BUN-SUB
093700     END-PERFORM.
093800
093900     SEARCH ALL BUN-CBSA-ENTRY
094000       AT END
094100          IF MAINFRAME-PC-SWITCH = DS-ERROR-CODE  THEN
094200             MOVE 60              TO PPS-RTC
094300             GO TO 0800-FIND-EXIT
094400          ELSE
094500             MOVE 61              TO PPS-RTC
094600             GO TO 0800-FIND-EXIT
094700          END-IF
094800       WHEN BUN-CBSA-VALUE (BUN-INDX) = P-GEO-CBSA
094900          MOVE BUN-PTR (BUN-INDX) TO W-SUB3
095000          PERFORM 0850-GET-BUNDLED-CBSA-RATE
095100             THRU 0850-BUNDLED-EXIT
095200     END-SEARCH.
095300
095400 0800-FIND-EXIT.
095500      EXIT.
095600
095700 0820-SEARCH-CHILD-HOSP-TABLE.
095800     IF CHILD-HOSP-PROV (CHILD-HOSP-TABLE-SUB) = P-PROV-OSCAR
095900        SET CHILD-HOSP-SWI-FOUND TO TRUE.
096000****** Replaced the 850 paragraph from 2014
096100****** to fix a problem with the CBSA lookup that would
096200****** cause it to price with wage indexes from previous years if
096300****** it couldn't find a wage index to match the year of the clai
096400 0850-GET-BUNDLED-CBSA-RATE.
096500* CY 2015 ADD CHECK TO MAKE SURE THAT THE YEAR OF THE
096600* WAGE INDEX RECORD IS THE SAME AS THE YEAR OF THE BILL
096700     IF
096800        (BUN-WI-DATE-CODE (W-SUB3) =
096900         B-THRU-YEAR-CODE)
097000     THEN
097100        MOVE BUN-DATE (BUN-SUB)   TO BUN-CBSA-DATE
097200        MOVE BUN-WAGE-INDEX (W-SUB3)
097300                                  TO BUN-CBSA-W-INDEX
097400     ELSE
097500        SUBTRACT 1 FROM W-SUB3
097600        IF W-SUB3 > BUN-PTR (BUN-INDX - 1)
097700        THEN GO TO 0850-GET-BUNDLED-CBSA-RATE
097800        ELSE
097900          MOVE 0                 TO BUN-CBSA-W-INDEX
098000* FOR CY 2015 VERSION 0 ADDED ASSIGNMENT OF RETURN CODE
098100* WHEN THERE IS NO CBSA FOUND FOR THE YEAR OF THE CLAIM
098200           MOVE 60 TO PPS-RTC
098300        END-IF
098400     END-IF.
098500* the following code is the old way to search the Wage Index
098600* Table that was dropped because it would price claims using
098700* a CBSA with a previous year's Wage Index even though the
098800* CBSA had been dropped for the year of the claim
098900*0850-GET-BUNDLED-CBSA-RATE.
099000*    IF BUN-WI-DATE-CODE (W-SUB3) NOT > BUN-DATE-CODE (BUN-SUB)
099100*                                                  THEN
099200*       MOVE BUN-DATE (BUN-SUB)   TO BUN-CBSA-DATE
099300*       MOVE BUN-WAGE-INDEX (W-SUB3)
099400*                                 TO BUN-CBSA-W-INDEX
099500*    ELSE
099600*       SUBTRACT 1 FROM W-SUB3
099700*       IF W-SUB3 > BUN-PTR (BUN-INDX - 1)  THEN
099800*          GO TO 0850-GET-BUNDLED-CBSA-RATE
099900*       ELSE
100000*          MOVE 0                 TO BUN-CBSA-W-INDEX
100100*       END-IF
100200*    END-IF.
100300 0850-BUNDLED-EXIT.
100400     EXIT.
