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