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