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