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