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