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