000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.         ESMGR160.
000300*AUTHOR.             CMS.
000400*
000500*REMARKS.
000600* USED TO TEST THE ESRD PRICER VERSION 0 FOR CY 2016
000700* THIS ESMGR160 MODULE IS MADE AVAILABLE TO FISS
000800******************************************************************
000900* XX/XX/07 - NEED TO ADD COUNTERS FOR EACH CALC VERSION CALLED   *
001000*            AND THE NUMBERS FOR EACH RETURN CODE.  SAME FOR     *
001100*            THIS DRIVER.  HOPEFULLY BE DONE BY THE NEXT VERSION!*
001200*            THE TEST DRIVER WILL QUERY THIS PRODUCTION DRIVER   *
001300*            TO GET THE COUNTS.  OTHERWISE THE COUNTS WILL NOT BE*
001400*            RETURNED UNLESS OF COURSE IT IS A TEST SITUATION.   *
001500******************************************************************
001600
001700******************************************************************
001800*Essentially this program is nothing more than a front-end for the
001900*various subroutines.  These subroutines   MUST   be identical on*
002000*mainframe and PC, without exception!  Therefore there are three *
002100*parts to the working storage section:  (1) exclusive on the     *
002200*mainframe;  (2) exclusive on the PC;  (3) shared by both <passed*
002300*to the subroutines>.  The procedure division is divided into two*
002400*parts (mainframe code and PC code).  The Declarative Section may*
002500*be used by both, although it is for now really used by the PC.  *
002600******************************************************************
002700
002800******************************************************************
002900*This source code is used on both the IBM mainframe AND on the PC*
003000*<Micro Focus COBOL>.  The OFFICIAL source code always resides on*
003100*the mainframe and not on the PC.  Changes to the pricer is done *
003200*on an annual basis or as needed and made on the mainframe source*
003300*code  FIRST  and proofed.  Then the code (main program and      *
003400*copylibs - except for the ESRDGUI copylib) is transferred to the*
003500*PC and any additional changes necessary will be done on the PC  *
003600*portion (in general no changes need to be made).  Because some  *
003700*variables are only used on the PC (e.g. ESRDGUI.CPB), any changes
003800*made there must be transferred back to the mainframe in order to*
003900*maintain commonality of code.                                   *
004000******************************************************************
004100
004200******************************************************************
004300*The following should be the only error that you get when you    *
004400*compile on the mainframe.  This is only a warning and so does   *
004500*not affect the running of the program.  This warning can not    *
004600*be eliminated since the IBM compiler is truely marvelous and    *
004700*catches it since it examines the value of each element and      *
004800*notices the 'apparent error'.                                   *
004900*                                                                *
005000*IGYOP3091-W   CODE FROM "DISPLAY (LINE 2649.01)" TO "STOP (LINE *
005100*2650.01) CAN NEVER BE EXECUTED AND WAS THEREFORE DISCARDED.     *
005200******************************************************************
005300
005400 DATE-COMPILED.
005500 ENVIRONMENT DIVISION.
005600
005700 CONFIGURATION SECTION.
005800 SOURCE-COMPUTER.  IBM-Z990.
005900 OBJECT-COMPUTER.  ITTY-BITTY-MACHINE-CORPORATION.
006000
006100 INPUT-OUTPUT SECTION.
006200 FILE-CONTROL.
006300
006400*Mainframe files
006500     SELECT BILLFILE                  ASSIGN TO UT-S-SYSUT1
006600         FILE STATUS IS UT1-STAT.
006700
006800     SELECT IBM-PRINTER               ASSIGN TO UT-S-IBMPRINT
006900         FILE STATUS IS IBM-PRINTER-STAT.
007000
007100*PC files
007200     SELECT MSA-CBSA-XWALK-FILE       ASSIGN TO ESRD-XWALK-DAT
007300         ORGANIZATION IS SEQUENTIAL
007400         FILE STATUS IS MSA-CBSA-STATUS.
007500
007600     SELECT PC-PRINTER-FILE           ASSIGN TO JCL-PRINT-SPOOL
007700         FILE STATUS IS PC-SPOOLER-FILE-STATUS.
007800
007900 DATA DIVISION.
008000 FILE SECTION.
008100
008200*Mainframe files
008300 FD  BILLFILE
008400     LABEL RECORDS ARE STANDARD
008500     RECORDING MODE IS F
008600     BLOCK CONTAINS 0 RECORDS.
008700 01  BILL-REC                       PIC X(450).
008800
008900 FD  IBM-PRINTER
009000     RECORDING MODE IS F
009100     BLOCK CONTAINS 133 RECORDS
009200     LABEL RECORDS ARE STANDARD.
009300 01  IBM-PRINTER-LINE               PIC X(133).
009400
009500*PC files
009600 FD  MSA-CBSA-XWALK-FILE
009700     RECORDING MODE IS F
009800     LABEL RECORDS ARE STANDARD
009900     RECORD CONTAINS 107 CHARACTERS.
010000*    PRIMARY KEY OFFSET & LENGTH: 0, 3 (LTC-DRG)
010100 01  MSA-CBSA-XWALK-REC.
010200     05  MSA-PRIME-KEY              PIC X(04).
010300     05  FILLER                     PIC X(01).
010400     05  MSA-DESCRIPTION            PIC X(48).
010500     05  FILLER                     PIC X(08).
010600     05  CBSA-KEY                   PIC X(05).
010700     05  FILLER                     PIC X(03).
010800     05  CBSA-DESCRIPTION           PIC X(38).
010900
011000 FD  PC-PRINTER-FILE
011100     RECORDING MODE IS F
011200     LABEL RECORDS ARE STANDARD.
011300 01  PC-PRINTER-LINE                PIC X(100).
011400/
011500**
011600*      CENTERS FOR MEDICARE AND MEDICAID SERVICES
011700*REMARKS.  - CALLS THE ESCAL__ MODULES
011800*          - LOADS THE MSAX WAGE ADJUSTED RATE TABLES
011900*          - FINDS WAGE ADJUSTED RATE RECORD FOR THE
012000*            SUBMITTED BILL TO BE PASSED TO ESCAL__ MODULES.
012100******************************************************************
012200*   THIS ROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE     *
012300*   AND MEDICAID SERVICES.                                       *
012400*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE       *
012500*   PAYMENT FOR ESRD CLAIMS.                                     *
012600*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,       *
012700*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM      *
012800*   IS THAT OF THE USER.                                         *
012900*                  *  *  *  *  *  *  *  *                        *
013000*   THE PROGRAM WILL:                                            *
013100*       1. INCLUDE THE MSA WAGE ADJUSTED RATE TABLE. (ESWRT070)  *
013200*       2. INCLUDE THE CBSA WAGE INDEX TABLE.  (ESCBS070)        *
013300*       3. DO SOME EDITS ON THE BILL INFORMATION.                *
013400*       4. PASS BACK RETURN CODES.                               *
013500*       5. CREATE A FINAL PAYMENT WHEN THAT INFO IS ON THE CLAIM *
013600*       6. CALL A CALCULATE SUBROUTINE WHEN APPLICABLE BASED ON  *
013700*          CLAIM DATE                                            *
013800*                                                                *
013900*                  *  *  *  *  *  *  *  *                        *
014000*   CHANGE LOG.                                                  *
014100*                                                                *
014200*   THE FOLLOWING CHANGES MADE BY BRIAN BARANOSKI                *
014300* 10/20/06 - NEW CBSA TABLE FOR CY2007 (I.E.COPY EXCBS070)       *
014400*          - ADDED DATE CHECKS FOR CY2007 AND CALL ESCAL070      *
014500* 12/28/06 - ADDED DATE CHECKS FOR CY2007 APRIL AND CALL ESCAL071*
014600*          - CREATED ENTER AND EXIT PARAGRAPHS FOR CLARITY       *
014700*          - STREAMLINED THE PROCESSING SO THAT IT IS MORE       *
014800*            EFFICIENT                                           *
014900*          - PROVIDED A DRIVER VERSION NUMBER WHICH WILL BE      *
015000*            PASSED BACK (IN THE PPS-CALC-VERS-CD) INDICATING AN *
015100*            INTERNAL ERROR THAT IS FOUND AND THUS THE CALCULATE *
015200*            SUBROUTINE IS NOT CALLED                            *
015300* 01/30/07 - NEW MSA AND CBSA TABLES WHICH INCLUDE THE LATEST    *
015400*            ADDITIONS TO THE STATE CODES PER CR#5490 AND CMSO   *
015500*            DATA ON WEB SITE                                    *
015600* 08/20/08 - Major changes finally completed to enable the same  *
015700*            program to work on the mainframe as well as the     *
015800*            PC (under MicroFocus COBOL using the Dialog System  *
015900*            which is a Graphical User Interface system).  The   *
016000*            code in the Procedure Division is for the most part *
016100*            completely separate between the mainfram and the PC.*
016200*            However, a fair amount of the working storage       *
016300*            is common to both uses.  Essentially only the       *
016400*            version information and some dates are needed to    *
016500*            make changes for the next year's ESRD PPS Pricer.   *
016600*            No changes need to be done to the PC screen set when*
016700*            changing versions of the pricer.  This was one of   *
016800*            the reasons the PC Pricer took so long to complete. *
016900*            Portions of the code will be removed when the 2005  *
017000*            blend process is no longer needed for historical    *
017100*            price lookups in prior years.  This will occur in   *
017200*            2013 when the need for the 25% blend in 2008 will go*
017300*            away.  The pricer is effective for the current year *
017400*            and four prior years, which is the technical time   *
017500*            that providers are given to make corrections to an  *
017600*            old claim.  Beginning in 2010, new code must be     *
017700*            inserted to prevent users from trying to correct old*
017800*            claims in 2005.  This will be a rolling process     *
017900*            whereby subsequent years see the removal of the     *
018000*            oldest year's claim process.                        *
018100* 12/12/08 - Fixed problem with MSA where the MSA number was in  *
018200*            range of 0100 to 0999 and was not putting a leading *
018300*            zero when the user only entered a three digit number*
018400*          - Fixed a potential problem in TEST mode (the word    *
018500*            TEST being put in the MSA field) when getting prices*
018600*            for next year and the month was not in November or  *
018700*            December when the wage index table was not updated  *
018800*            in the driver program with the next year's data. The*
018900*            wage index table is never ready before those months *
019000*            when crossing a year boundry.                       *
019100* 11/01/09 - Renamed this main program ESMGR100 and changed the  *
019200*            appropriate version information, and called the     *
019300*            appropriate driver.  Although the pricer is now a   *
019400*            TEN year pricer, the PRICER-EFFECTIVE-BEGIN-DT      *
019500*            variable was set to January 1, 2006 as this date    *
019600*            appears on the PC pricer information which is a     *
019700*            FOUR year pricer used by the 'public'.              *
019800* 01/08/10 - Renamed this main program ESMGR101 and changed the  *
019900*            appropriate version information, and called the     *
020000*            appropriate driver.                                 *
020100* 01/21/10 - Renamed this main program ESMGR102 and changed the  *
020200*            appropriate version information, and called the     *
020300*            appropriate driver.                                 *
020400* 08/04/10 - Increased mainframe input from 123 to 214 characters*
020500*            to accomodate the new bundled record layout.        *
020600******************************************************************
020700
020800******************************************************************
020900/
021000 WORKING-STORAGE SECTION.
021100*..1....:....2....:....3....:....4....:....5....:....6....:....7..
021200******************************************************************
021300*************  CHANGE THESE VALUES FOR EACH RELEASE  *************
021400******************************************************************
021500*             For use by BOTH the mainframe and the PC           *
021600*----------------------------------------------------------------*
021700 01  MANAGER-VERSION                PIC X(05) VALUE 'M16.0'.
021800
021900 01  CURRENT-YR-DRIVER              PIC X(08) VALUE 'ESDRV160'.
022000
022100******************************************************************
022200*                  For use ONLY by the mainframe                 *
022300*----------------------------------------------------------------*
022400*no variables here
022500
022600******************************************************************
022700*                     For use ONLY by the PC                     *
022800*----------------------------------------------------------------*
022900 01  PC-SCREEN-PRICER-VERSION       PIC X(07) VALUE 'PC-01.5'.
023000
023100 01  PRICER-EFFECTIVE-BEGIN-DT      PIC X(18) VALUE
023200                                              'April 1, 2005    '.
023300 01  PRICER-EFFECTIVE-END-DT        PIC X(18) VALUE
023400                                              'December 31, 2012'.
023500
023600******************************************************************
023700*******************  EXTERNAL FILE INFORMATION  ******************
023800******************************************************************
023900*                  For use ONLY by the mainframe                 *
024000*----------------------------------------------------------------*
024100 01  UT1-STAT.
024200     05  UT1-STAT1                  PIC X(01).
024300     05  UT1-STAT2                  PIC X(01).
024400
024500 01  IBM-PRINTER-STAT.
024600     05  IBM-PRINTER-STAT1          PIC X(01).
024700     05  IBM-PRINTER-STAT2          PIC X(01).
024800
024900******************************************************************
025000*                     For use ONLY by the PC                     *
025100*----------------------------------------------------------------*
025200 01  JCL-PRINT-SPOOL                PIC X(26) VALUE SPACES.
025300
025400 01  DIRECTORY-NAME                 PIC X(10) VALUE
025500                                              '\ESMGRV151'.
025600 01  FILE-NAME                      PIC X(13) VALUE
025700                                              '\PRNTFILE.DAT'.
025800 01  PC-PRINT-FILE                  PIC X(13) VALUE
025900                                              'PC_PRINT_FILE'.
026000 01  CBL-DELETE-FILE                PIC X(15) VALUE
026100                                              'CBL_DELETE_FILE'.
026200 01  CBL-CREATE-DIR                 PIC X(14) VALUE
026300                                              'CBL_CREATE_DIR'.
026400 01  CBL-DELETE-DIR                 PIC X(14) VALUE
026500                                              'CBL_DELETE_DIR'.
026600
026700 01  PC-PRINTER-FILENAME.
026800*    05  PC-P-FILE-NAME-LENGTH      PIC X(02) COMP-5 VALUE 26.
026900     05  PC-P-FILE-NAME.
027000         10 PC-P-DRIVE              PIC X(02).
027100         10 PC-P-DIRECTORY          PIC X(10).
027200         10 PC-P-FILENAME           PIC X(13).
027300         10 PC-P-FILLER             PIC X(01) VALUE SPACE.
027400
027500 01  PC-CREATE-FILENAME.
027600*    05  PC-C-FILE-NAME-LENGTH      PIC X(02) COMP-5 VALUE 26.
027700     05  PC-C-FILE-NAME.
027800         10 PC-C-DRIVE              PIC X(02).
027900         10 PC-C-DIRECTORY          PIC X(10).
028000         10 PC-C-FILENAME           PIC X(13).
028100         10 PC-C-FILLER             PIC X(01) VALUE SPACE.
028200
028300 01  PC-DELETE-FILENAME.
028400*    05  PC-D-FILE-NAME-LENGTH      PIC X(02) COMP-5 VALUE 26.
028500     05  PC-D-FILE-NAME.
028600         10 PC-D-DRIVE              PIC X(02).
028700         10 PC-D-DIRECTORY          PIC X(10).
028800         10 PC-D-FILENAME           PIC X(13).
028900         10 PC-D-FILLER             PIC X(01) VALUE SPACE.
029000
029100 01  PPS-REPORT-TITLE.
029200*    05  PPS-TITLE-LENGTH           PIC X(02) COMP-5 VALUE 18.
029300     05  PPS-TITLE-TEXT             PIC X(18) VALUE
029400                                        'PPS PAYMENT REPORT'.
029500
029600
029700 01  PC-DIRECTORY-NAME.
029800     05  PC-DIR-DRIVE               PIC X(02).
029900     05  PC-DIR-NAME                PIC X(10).
030000     05  PC-DIR-FILLER              PIC X(01) VALUE SPACE.
030100
030200 01  INSTALLATION-FILE-NAMES.
030300**FILE NAMES (DEPENDENT ON INSTALLATION DRIVE SPECIFIED BY USER)
030400     05  MSA-CBSA-XWALKFILE.
030500         10 XWALK-DRIVE             PIC X(02).
030600         10 XWALK-DIRECTORY         PIC X(10).
030700         10 XWALK-ADDRESS           PIC X(15) VALUE
030800            '\ESRD-XWALK.DAT'.
030900
031000*----------------------------------------------------------------*
031100* PC PRINTER FLAGS:                                              *
031200* THE DECIMAL VALUES OF THE FLAGS ARE ADDITIVE WHEN MORE THAN ONE*
031300* PRINTER SETTING IS DESIRED                                     *
031400*----------------------------------------------------------------*
031500
031600 01  PC-PRINTER-FLAGS               PIC 9(04) COMP-5.
031700     88 PC-P-DIALOG                           VALUE 1.
031800     88 PC-P-FONT-SELECTION                   VALUE 2.
031900     88 PC-P-PORTRAIT-ORIENTATION             VALUE 4.
032000     88 PC-P-LANDSCAPE-ORIENTATION            VALUE 8.
032100     88 PC-P-PROGRESS-DIALOG                  VALUE 16.
032200     88 PC-P-AND-PROG-DIALOG                  VALUE 17.
032300
032400 01  WINDOW-HANDLE                  PIC 9(04) COMP-5 VALUE 0.
032500
032600******************************************************************
032700***************************  COUNTERS  ***************************
032800******************************************************************
032900*                  For use ONLY by the mainframe                 *
033000*----------------------------------------------------------------*
033100 01  BILL-RECS-CT                   PIC 9(08) COMP SYNC VALUE 0.
033200 01  CLAIM-PAID-CT                  PIC 9(08) COMP SYNC VALUE 0.
033300 01  RATE-ON-BILL-CT                PIC 9(08) COMP SYNC VALUE 0.
033400 01  FACILITY-RATE-PROB-CT          PIC 9(08) COMP SYNC VALUE 0.
033500 01  PROVIDER-TYPE-PROB-CT          PIC 9(08) COMP SYNC VALUE 0.
033600 01  SPECIAL-PMT-PROB-CT            PIC 9(08) COMP SYNC VALUE 0.
033700 01  BIRTH-PROB-CT                  PIC 9(08) COMP SYNC VALUE 0.
033800 01  WEIGHT-PROB-CT                 PIC 9(08) COMP SYNC VALUE 0.
033900 01  HEIGHT-PROB-CT                 PIC 9(08) COMP SYNC VALUE 0.
034000 01  REV-CENTER-PROB-CT             PIC 9(08) COMP SYNC VALUE 0.
034100 01  COND-CODE-PROB-CT              PIC 9(08) COMP SYNC VALUE 0.
034200 01  MSA-CBSA-PROB-CT               PIC 9(08) COMP SYNC VALUE 0.
034300 01  EXCEED-HEIGHT-PROB-CT          PIC 9(08) COMP SYNC VALUE 0.
034400 01  EXCEED-WEIGHT-PROB-CT          PIC 9(08) COMP SYNC VALUE 0.
034500 01  THRU-DATE-PROB-CT              PIC 9(08) COMP SYNC VALUE 0.
034600 01  NO-ADJUST-CT                   PIC 9(08) COMP SYNC VALUE 0.
034700 01  OUT-CT                         PIC 9(08) COMP SYNC VALUE 0.
034800 01  ACUTE-CT                       PIC 9(08) COMP SYNC VALUE 0.
034900 01  CHRONIC-CT                     PIC 9(08) COMP SYNC VALUE 0.
035000 01  ACUTE-OUT-CT                   PIC 9(08) COMP SYNC VALUE 0.
035100 01  CHRONIC-OUT-CT                 PIC 9(08) COMP SYNC VALUE 0.
035200 01  ONSET-CT                       PIC 9(08) COMP SYNC VALUE 0.
035300 01  ONSET-OUT-CT                   PIC 9(08) COMP SYNC VALUE 0.
035400 01  LOW-V-CT                       PIC 9(08) COMP SYNC VALUE 0.
035500 01  TRAIN-CT                       PIC 9(08) COMP SYNC VALUE 0.
035600 01  LOW-V-TRAIN-CT                 PIC 9(08) COMP SYNC VALUE 0.
035700 01  MULTI-ADJUST-CT                PIC 9(08) COMP SYNC VALUE 0.
035800 01  PEDIATRIC-CT                   PIC 9(08) COMP SYNC VALUE 0.
035900 01  PEDIATRIC-TRAIN-CT             PIC 9(08) COMP SYNC VALUE 0.
036000 01  PEDIATRIC-OUT-CT               PIC 9(08) COMP SYNC VALUE 0.
036100 01  PEDIATRIC-OUT-TRAIN-CT         PIC 9(08) COMP SYNC VALUE 0.
036200 01  ACUTE-OUT-LOW-V-CT             PIC 9(08) COMP SYNC VALUE 0.
036300 01  ACUTE-OUT-LOW-V-TRAIN-CT       PIC 9(08) COMP SYNC VALUE 0.
036400 01  ACUTE-LOW-V-CT                 PIC 9(08) COMP SYNC VALUE 0.
036500 01  ACUTE-LOW-V-TRAIN-CT           PIC 9(08) COMP SYNC VALUE 0.
036600 01  ACUTE-TRAIN-CT                 PIC 9(08) COMP SYNC VALUE 0.
036700 01  CHRONIC-OUT-LOW-V-CT           PIC 9(08) COMP SYNC VALUE 0.
036800 01  CHRONIC-OUT-LV-TRAIN-CT        PIC 9(08) COMP SYNC VALUE 0.
036900 01  CHRONIC-LOW-V-CT               PIC 9(08) COMP SYNC VALUE 0.
037000 01  CHRONIC-LOW-V-TRAIN-CT         PIC 9(08) COMP SYNC VALUE 0.
037100 01  CHRONIC-TRAIN-CT               PIC 9(08) COMP SYNC VALUE 0.
037200 01  OUT-LOW-V-CT                   PIC 9(08) COMP SYNC VALUE 0.
037300 01  OUT-LOW-V-TRAIN-CT             PIC 9(08) COMP SYNC VALUE 0.
037400 01  ONSET-OUT-LOW-V-CT             PIC 9(08) COMP SYNC VALUE 0.
037500 01  LOW-BMI-CT                     PIC 9(08) COMP SYNC VALUE 0.
037600 01  OUT-LOW-CT                     PIC 9(08) COMP SYNC VALUE 0.
037700 01  OUT-LOW-TRAIN-CT               PIC 9(08) COMP SYNC VALUE 0.
037800 01  ONSET-OUT-LOW-CT               PIC 9(08) COMP SYNC VALUE 0.
037900 01  LOW-VOLUME-CT                  PIC 9(08) COMP SYNC VALUE 0.
038000 01  LOW-VOL-ONSET-CT               PIC 9(08) COMP SYNC VALUE 0.
038100 01  OUT-TRAIN-CT                   PIC 9(08) COMP SYNC VALUE 0.
038200 01  OUT-TRAIN-CHRONIC-CT           PIC 9(08) COMP SYNC VALUE 0.
038300 01  OUT-TRAIN-ACUTE-CT             PIC 9(08) COMP SYNC VALUE 0.
038400 01  BAD-NUM-DIAL-SES-CT            PIC 9(08) COMP SYNC VALUE 0.
038500 01  BAD-SERVICE-DATE-CT            PIC 9(08) COMP SYNC VALUE 0.
038600 01  BAD-DIAL-START-DATE-CT         PIC 9(08) COMP SYNC VALUE 0.
038700 01  BAD-TOT-OUT-PAYMENT-CT         PIC 9(08) COMP SYNC VALUE 0.
038800 01  BAD-COMOR-CWF-RTN-CT           PIC 9(08) COMP SYNC VALUE 0.
038900
039000 01  LINE-CTR                       PIC 9(02)  VALUE ZERO.
039100 01  MAX-LINES                      PIC 9(02)  VALUE 53.
039200
039300******************************************************************
039400*                     For use ONLY by the PC                     *
039500*----------------------------------------------------------------*
039600*No variables                                                    *
039700
039800******************************************************************
039900*************************  SUBSCRIPTS  ***************************
040000******************************************************************
040100*                  For use ONLY by the mainframe                 *
040200*----------------------------------------------------------------*
040300*No variables                                                    *
040400******************************************************************
040500*                     For use ONLY by the PC                     *
040600*----------------------------------------------------------------*
040700/
040800******************************************************************
040900**************************  HOLD AREAS  **************************
041000******************************************************************
041100*             For use by BOTH the mainframe and the PC           *
041200*----------------------------------------------------------------*
041300*Nothing used by both
041400******************************************************************
041500*                  For use ONLY by the mainframe                 *
041600*----------------------------------------------------------------*
041700 01  MSA-PERCENT                    PIC Z9(02).
041800 01  CBSA-PERCENT                   PIC Z9(02).
041900 01  CR-BLEND-PERCENT               PIC Z9.
042000 01  PPS-BLEND-PERCENT              PIC Z9.
042100 01  OUT-LOSS-SHARE-PERCENT         PIC Z9.
042200 01  NON-LABOR-PCT                  PIC 9.9(05).
042300 01  H-COMORBID-DATA.
042400     05  H-COMORBID-1               PIC X(02).
042500     05  H-COMORBID-2               PIC X(02).
042600     05  H-COMORBID-3               PIC X(02).
042700     05  H-COMORBID-4               PIC X(02).
042800     05  H-COMORBID-5               PIC X(02).
042900     05  H-COMORBID-6               PIC X(02).
043000 01  PG-NUMBER                      PIC 9(02)  VALUE 0.
043100 01  HOLD-PRT-YR                    PIC 9(04)  VALUE 9999.
043200
043300******************************************************************
043400*                     For use ONLY by the PC                     *
043500*----------------------------------------------------------------*
043600 01  COMPILED-DATE                  PIC X(16) VALUE SPACES.
043700
043800 01  PC-RUNNING-DATE-INFO.
043900     05  TODAYS-DATE.
044000         10  THIS-YEAR              PIC 9(04).
044100         10  THIS-MONTH             PIC 9(02).
044200         10  THIS-DAY               PIC 9(02).
044300     05  TODAYS-DAY                 PIC 9(01).
044400     05  TODAYS-TIME.
044500         10  THIS-HOUR              PIC 9(02).
044600         10  THIS-MINUTE            PIC 9(02).
044700         10  THIS-SECOND            PIC 9(04).
044800
044900 01  TESTING-FOR-NEXT-YEAR          PIC X(01)  VALUE SPACE.
045000
045100 01  NEXT-YEAR                      PIC 9(04).
045200
045300 01  HOLD-MONTH                     PIC 9(02).
045400   88  31-DAY-MONTH                           VALUE 01, 03, 05,
045500                                                    07, 08, 10,
045600                                                    12.
045700
045800   88  30-DAY-MONTH                           VALUE 04, 06, 09,
045900                                                    11.
046000   88  FEBRUARY                               VALUE 02.
046100
046200 01  HOLD-DAY                       PIC 9(02).
046300
046400 01  HOLD-YEAR                      PIC 9(04).
046500
046600 01  DATE-WORK-AREA.
046700     05  GUI-DATE.
046800         10  GUI-MONTH              PIC 9(02).
046900         10  GUI-DAY                PIC 9(02).
047000         10  GUI-YEAR               PIC 9(04).
047100     05  MAINFRAME-DATE-FORMAT.
047200         10  MAINFRAME-YEAR         PIC 9(04).
047300         10  MAINFRAME-MONTH        PIC 9(02).
047400         10  MAINFRAME-DAY          PIC 9(02).
047500     05  READABLE-DATE.
047600         10  READABLE-MONTH         PIC 9(02).
047700         10  FILLER                 PIC X(01) VALUE "/".
047800         10  READABLE-DAY           PIC 9(02).
047900         10  FILLER                 PIC X(01) VALUE "/".
048000         10  READABLE-YEAR          PIC 9(04).
048100
048200 01  REV-CODE-NUMERIC               PIC 9(04) VALUE ZERO.
048300
048400 01  GOT-STATE-CODE                 PIC X(01).
048500 01  NUMBER-DIGITS                  PIC 9(01) VALUE ZERO.
048600 01  X                              PIC 9(01) VALUE ZERO.
048700 01  Y                              PIC 9(01) VALUE ZERO.
048800 01  CLAIM-YEAR                     PIC 9(04) VALUE 0.
048900 01  2006-MSA-WAGE-AMT              PIC 9(04)V9(02) VALUE 0.
049000 01  2007-MSA-WAGE-AMT              PIC 9(04)V9(02) VALUE 0.
049100 01  2008-MSA-WAGE-AMT              PIC 9(04)V9(02) VALUE 0.
049200
049300 01  HOLD-MSA.
049400     05  HOLD-G-P-MSA               PIC X(04).
049500     05  FILLER            REDEFINES  HOLD-G-P-MSA.
049600         10  HOLD-G-P-MSA-R
049700                    OCCURS 4 TIMES  PIC 9(01).
049800     05  MSA-STATE-CODE             PIC X(04).
049900     05  FILLER            REDEFINES MSA-STATE-CODE.
050000         10  MSA-STATE-CODE-R
050100                    OCCURS 4 TIMES  PIC X(01).
050200
050300 01  HOLD-CBSA.
050400     05  HOLD-G-P-CBSA              PIC X(05).
050500     05  FILLER            REDEFINES  HOLD-G-P-CBSA.
050600         10  HOLD-G-P-CBSA-R
050700                    OCCURS 5 TIMES  PIC 9(01).
050800     05  CBSA-STATE-CODE            PIC X(05).
050900     05  FILLER            REDEFINES CBSA-STATE-CODE.
051000         10  CBSA-STATE-CODE-R
051100                    OCCURS 5 TIMES  PIC X(01).
051200
051300 01  DIAL-MODE                      PIC X(04).
051400 01  FORMATTED-AGE                  PIC ZZ9.
051500 01  FORMATTED-BMI                  PIC ZZ9.9(04).
051600 01  FORMATTED-BSA                  PIC ZZ9.9(04).
051700 01  FORMATTED-AGE-FACTOR           PIC 9.9(03).
051800 01  FORMATTED-BMI-FACTOR           PIC 9.9(04).
051900 01  FORMATTED-BSA-FACTOR           PIC 9.9(04).
052000 01  FORMATTED-MULTIPLIER           PIC 9.9(03).
052100 01  FORMATTED-HGT                  PIC ZZ9.99.
052200 01  FORMATTED-WGT                  PIC ZZ9.99.
052300 01  FORMATTED-BUN-CBSA-W-INDEX     PIC Z9.9(04).
052400 01  COMP-RATE-MSG-LINE-1           PIC X(30) VALUE
052500                                 'ALL Composite Rate results are'.
052600 01  COMP-RATE-MSG-LINE-2           PIC X(30) VALUE
052700                                 'NOT APPLICABLE due to'.
052800 01  COMP-RATE-MSG-LINE-3           PIC X(30) VALUE
052900                                 'blend payment being waived.'.
053000 01  PPS-LABOR-PORTION              PIC 9(04)V9(02).
053100 01  PPS-NON-LABOR-PORTION          PIC 9(04)V9(02).
053200 01  CR-LABOR-PORTION               PIC 9(04)V9(02).
053300 01  CR-NON-LABOR-PORTION           PIC 9(04)V9(02).
053400 01  IMPUT-MINUS-PREDICT            PIC S9(04)V9(04).
053500 01  IMPUT-PRED-DIFFER              PIC 9(04)V9(04).
053600 01  PPS-FINAL-PAYMENT              PIC 9(05)V9(02).
053700 01  PPS-FINAL-PAYMENT-TO-APRIL     PIC 9(05)V9(02).
053800
053900
054000******************************************************************
054100***************************  SWITCHES  ***************************
054200******************************************************************
054300*             For use by BOTH the mainframe and the PC           *
054400*----------------------------------------------------------------*
054500*Nothing used by both
054600******************************************************************
054700*                  For use ONLY by the mainframe                 *
054800*----------------------------------------------------------------*
054900
055000 01  IS-BILLFILE-EOF                PIC X(01)  VALUE SPACE.
055100     88  EOF-BILLFILE                          VALUE 'Y'.
055200
055300******************************************************************
055400*                     For use ONLY by the PC                     *
055500*----------------------------------------------------------------*
055600*----------------------------------------------------------------*
055700 01  PROGRAM-SWITCHES.
055800*----------------------------------------------------------------*
055900     05  WELCOME-CODE               PIC X(01).
056000
056100*----------------------------------------------------------------*
056200 01  GUI-FUNCTION-INDICATORS.
056300*----------------------------------------------------------------*
056400     05  PROV-DIR-OPT               PIC X(01) VALUE SPACES.
056500         88 VIEW-PROVIDER                     VALUE 'V'.
056600         88 CHANGE-PROVIDER                   VALUE 'C'.
056700         88 ADD-PROVIDER                      VALUE 'A'.
056800     05  CHANGE-PROV-STEP           PIC X(01) VALUE SPACE.
056900     05  NEW-PROV-STEP              PIC X(01) VALUE SPACE.
057000
057100*----------------------------------------------------------------*
057200 01  GUI-SWITCHES-AND-FLAGS.
057300*----------------------------------------------------------------*
057400     05  PROV-FOUND-SW              PIC X(01) VALUE SPACE.
057500         88 PROV-NOT-FOUND                    VALUE 'N'.
057600         88 PROV-FOUND                        VALUE 'Y'.
057700     05  EFF-DT-FOUND-SW            PIC X(01) VALUE SPACE.
057800         88 EFF-DT-FOUND                      VALUE 'Y'.
057900         88 EFF-DT-NOT-FOUND                  VALUE 'N'.
058000     05  CBSA-FOUND-SW              PIC X(01) VALUE SPACE.
058100         88 CBSA-FOUND                        VALUE 'Y'.
058200         88 CBSA-NOT-FOUND                    VALUE 'N'.
058300     05  IPPS-CBSA-FOUND-SW         PIC X(01) VALUE SPACE.
058400         88 IPPS-CBSA-FOUND                   VALUE 'Y'.
058500         88 IPPS-CBSA-NOT-FOUND               VALUE 'N'.
058600     05  ADD-ALLOWED-SW             PIC X(01) VALUE SPACE.
058700         88 ADD-ALLOWED                       VALUE 'Y'.
058800         88 ADD-NOT-ALLOWED                   VALUE 'N'.
058900     05  CHANGE-FLAG                PIC X(01) VALUE SPACE.
059000         88 CHANGE                            VALUE 'Y'.
059100         88 NO-CHANGE                         VALUE 'N'.
059200     05  INVALID-DATA-FLAG          PIC X(01) VALUE SPACE.
059300         88 NO-INVALID-DATA                   VALUE 'N'.
059400         88 INVALID-DATA                      VALUE 'Y'.
059500     05  COMPARE-SW                 PIC X(01) VALUE SPACE.
059600         88 FOR-PROV-DIR                      VALUE 'D'.
059700         88 FOR-PPS-CALC                      VALUE 'C'.
059800     05  CURRENT-CBSA-SW            PIC X(01) VALUE 'N'.
059900         88 CURRENT-CBSA                      VALUE 'Y'.
060000         88 NOT-CURRENT-CBSA                  VALUE 'N'.
060100     05  CURRENT-IPPS-CBSA-SW       PIC X(01) VALUE 'N'.
060200         88 CURRENT-IPPS-CBSA                 VALUE 'Y'.
060300         88 NOT-CURRENT-IPPS-CBSA             VALUE 'N'.
060400     05  CURRENT-PROV-SW            PIC X(01) VALUE 'N'.
060500         88 CURRENT-PROV                      VALUE 'Y'.
060600         88 NOT-CURRENT-PROV                  VALUE 'N'.
060700/
060800******************************************************************
060900*This area is common for mainframe and PC versions which send to *
061000*and receive from the driver and then onto the calculate         *
061100*subroutines.                                                    *
061200******************************************************************
061300*----------------------------------------------------------------*
061400*----------------------------------------------------------------*
061500*       Data passed TO and FROM the ESRD Driver SUBROUTINE       *
061600*This area MUST have identical code on both the mainframe and PC *
061700*----------------------------------------------------------------*
061800*----------------------------------------------------------------*
061900 COPY WAGECPY.
062000*COPY "WAGECPY.CPY".
062100/
062200 COPY RTCCPY.
062300*COPY "RTCCPY.CPY".
062400
062500
062600*    ******** POSSIBLE RETURN CODES TO THIS PROGRAM ********     *
062700*                                                                *
062800*Return Code  - -Description of error- - - - - - ..(programs    )*
062900*               Window on 2-CLAIM form         <calc = calculate>*
063000*                                              <drv = driver    >*
063100*                                              <mgr = manager   >*
063200*                                                                *
063300*                                                                *
063400*    ****  PPS-RTC 00-49 = BILL PAYMENT INFORMATION CODES        *
063500*      **  Return codes effective 4/1/2005 - 12/31/2010          *
063600*                                                                *
063700*  00 = ESRD PPS PAYMENT CALCULATED              ..(calc drv mgr)*
063800*               Window:  when encountered go to:  3-PPS form     *
063900*  01 = ESRD FACILITY RATE > ZERO                ..(     drv    )*
064000*               Window:  not applicable on the PC                *
064100*      **  Return codes effective 1/1/2011                       *
064200*  02 = PPS no adjustments                                       *
064300*  03 = PPS w/outlier                                            *
064400*  04 = PPS w/acute comorbid                                     *
064500*  05 = PPS w/chronic comorbid                                   *
064600*  06 = PPS w/acute comorbid and outlier                         *
064700*  07 = PPS w/chronic comorbid and outlier                       *
064800*  08 = PPS w/onset adjustment                                   *
064900*  09 = PPS w/onset adjustment and outlier                       *
065000*  10 = PPS w/low volume adjustment                              *
065100*  11 = PPS w/training adjustment                                *
065200*  12 = PPS w/low volume and training                            *
065300*  13 = PPS w/multiple adjustments                               *
065400*  14 = PPS pediatric                                            *
065500*  15 = PPS pediatric w/training                                 *
065600*  16 = PPS pediatric w/outlier                                  *
065700*  17 = PPS pediatric w/outlier and training                     *
065800*                                                                *
065900*                                                                *
066000*    ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID             *
066100*                                                                *
066200*  50 = ESRD FACILITY RATE NOT NUMERIC           ..(     drv    )*
066300*               Window:  not applicable on the PC                *
066400*  52 = PROVIDER TYPE NOT = '40' OR '41' OR '05' ..(calc        )*
066500*               Window:  M-52-INVALID-PROVIDER-TYPE              *
066600*  53 = SPECIAL PAYMENT INDICATOR NOT = '1' OR BLANK.(calc      )*
066700*               Window:  not applicable on the PC                *
066800*  54 = DATE OF BIRTH  NOT NUMERIC OR = ZERO     ..(calc        )*
066900*               Window:  M-54-INVALID-BIRTHDATE                  *
067000*  55 = PATIENT WEIGHT NOT NUMERIC OR = ZERO     ..(calc        )*
067100*               Window:  M-55-INVALID-PATIENT-WEIGHT             *
067200*  56 = PATIENT HEIGHT NOT NUMERIC OR = ZERO     ..(calc        )*
067300*               Window:  M-56-INVALID-PATIENT-HEIGHT             *
067400*  57 = REVENUE CENTER CODE NOT IN RANGE         ..(calc        )*
067500*               Window:  M-57-INVALID-REVENUE-CODE               *
067600*  58 = CONDITION CODE NOT = '73','74',BLANK OR 'NA'.(calc   mgr)*
067700*               Window:  M-58-INVALID-CONDITION-CODE             *
067800*MAINFRAME   60 = MSA OR CBSA WAGE ADJUSTED RATE RECORD NOT FOUND*
067900*PC-ONLY  60 = MSA Wage adjusted rate record not found.(drv     )*
068000*               WINDOW:  M-60-MSA-NOT-FOUND                      *
068100*PC-ONLY  61 = CBSA Wage index rate record not found .( drv     )*
068200*               WINDOW:  M-61-CBSA-NOT-FOUND                     *
068300*PC-ONLY  62 = CBSA is not valid for this calendar year.(drv    )*
068400*               WINDOW:  M-62-CBSA-NOT-VALID-THIS-YEAR           *
068500*  71 = EXCEEDS MAXIMUM HEIGHT ALLOWANCE         ..(calc        )*
068600*               Window:  M-71-EXCEED-MAX-HEIGHT                  *
068700*  72 = EXCEEDS MAXIMUM WEIGHT ALLOWANCE         ..(calc        )*
068800*               Window:  M-72-EXCEED-MAX-WEIGHT                  *
068900*            73 = Claim-Num-Dial-Session NOT numeric OR = ZERO   *
069000*            74 = Line-Item-Svc-Date NOT numeric OR = ZERO       *
069100*            75 = Dial-Start-Date NOT numeric  OR = ZERO         *
069200*            76 = Tot-Outlier-Pmt NOT numeric                    *
069300*            81 = Comorbid-CWF-Return-code NOT valid             *
069400*PC-ONLY  73 = EXCEEDS MAXIMUM AGE               ..(         mgr)*
069500*               Window:  M-73-EXCEEDS-MAXIMUM-AGE                *
069600*PC-ONLY  74 = BIRTHDATE GREATER THAN CLAIM DATE ..(         mgr)*
069700*               Window:  M-74-BIRTHDATE-CLAIM-THRU-DATE          *
069800*PC-ONLY  75 = CLAIM THRU DATE HAS INVALID DATE  ..(         mgr)*
069900*               Window:  M-75-INVALID-CLAIM-THRU-DATE            *
070000*PC-ONLY  76 = BIRTHDATE HAS INVALID DATE                        *
070100*               Window:  M-76-INVALID-BIRTHDATE  ..(         mgr)*
070200*PC-ONLYPPS-2011-OVIDER TYPE IS BLANK before 10/01/08.(      mgr)*
070300*               Window:  M-90-INVALID-PROVIDER-TYPE              *
070400*PC-ONLY  91 = MSA IS BLANK in years before 2009 ..(         mgr)*
070500*               Window:  M-91-INVALID-MSA                        *
070600*PC-ONLY  92 = CBSA IS BLANK in years 2006 or later.(        mgr)*
070700*               Window:  M-92-INVALID-CBSA                       *
070800*  98 = CLAIM THROUGH DATE BEFORE 04/01/2005                     *
070900*       OR NOT NUMERIC                           ..(     drv    )*
071000*               Window:  M-98-CLAIM-THRU-DATE-TOO-EARLY          *
071100*PC-ONLY  99 = CLAIM THROUGH DATE GREATER THAN CURRENT           *
071200*       CALENDAR YEAR                            ..(         mgr)*
071300*               Window:  M-99-CLAIM-THRU-DATE-TOO-LATE           *
071400******************************************************************
071500/
071600 COPY BILLCPY.
071700*COPY "BILLCPY.CPY".
071800/
071900******************************************************************
072000*               PROSPECTIVE PAYMENT REPORT COMPONENTS            *
072100******************************************************************
072200******************************************************************
072300*                  For use ONLY by the mainframe                 *
072400*----------------------------------------------------------------*
072500 01  DISPLAY-LINE-MEASUREMENT.
072600     05  FILLER                     PIC X(50) VALUE
072700         '....:...10....:...20....:...30....:...40....:...50'.
072800     05  FILLER                     PIC X(50) VALUE
072900         '....:...60....:...70....:...80....:...90....:..100'.
073000     05  FILLER                     PIC X(20) VALUE
073100         '....:..110....:..120'.
073200
073300 01  PRINT-LINE-MEASUREMENT.
073400     05  FILLER                     PIC X(51) VALUE
073500         'X....:...10....:...20....:...30....:...40....:...50'.
073600     05  FILLER                     PIC X(50) VALUE
073700         '....:...60....:...70....:...80....:...90....:..100'.
073800     05  FILLER                     PIC X(32) VALUE
073900         '....:..110....:..120....:..130..'.
074000
074100 01  A-BLANK-LINE                   PIC X(132) VALUE SPACES.
074200
074300 01  PRT-DETAIL-LINE-1A.
074400     05  FILLER                     PIC X(01)  VALUE SPACES.
074500     05  PRT-PROV-TYPE              PIC X(02).
074600     05  FILLER                     PIC X(02)  VALUE SPACES.
074700     05  PRT-MSA                    PIC X(04).
074800     05  FILLER                     PIC X(02)  VALUE SPACES.
074900     05  PRT-CBSA                   PIC X(05).
075000     05  FILLER                     PIC X(02)  VALUE SPACES.
075100     05  PRT-PROV-WAIVE-BLEND-INDIC PIC X(01).
075200     05  FILLER                     PIC X(02)  VALUE SPACES.
075300     05  PRT-PROV-LOW-VOLUME-INDIC  PIC X(01).
075400     05  FILLER                     PIC X(02)  VALUE SPACES.
075500     05  PRT-CLAIM-DATE             PIC 9(08).
075600     05  FILLER                     PIC X(02)  VALUE SPACES.
075700     05  PRT-LINE-ITEM-DATE-SERVICE PIC 9(08).
075800     05  FILLER                     PIC X(02)  VALUE SPACES.
075900     05  PRT-DIALYSIS-START-DATE    PIC 9(08).
076000     05  FILLER                     PIC X(02)  VALUE SPACES.
076100     05  PRT-BIRTH-DATE             PIC 9(08).
076200     05  FILLER                     PIC X(02)  VALUE SPACES.
076300     05  PRT-HEIGHT                 PIC Z99.99.
076400     05  FILLER                     PIC X(02)  VALUE SPACES.
076500     05  PRT-WEIGHT                 PIC Z99.99.
076600     05  FILLER                     PIC X(02)  VALUE SPACES.
076700     05  PRT-COND-CODE              PIC X(02).
076800     05  FILLER                     PIC X(02)  VALUE SPACES.
076900     05  PRT-REVENUE-CODE           PIC Z999.
077000     05  FILLER                     PIC X(01)  VALUE SPACES.
077100     05  PRT-NUM-DIALYSIS-SESSIONS  PIC X(03).
077200     05  FILLER                     PIC X(02)  VALUE SPACES.
077300     05  PRT-TOT-SB-OUTLIER-AMT     PIC $$$$9.99.
077400     05  FILLER                     PIC X(02)  VALUE SPACES.
077500     05  PRT-COMORBID-DATA          PIC X(12).
077600     05  FILLER                     PIC X(02)  VALUE SPACES.
077700     05  PRT-CWF-RETURN-CODE        PIC X(03).
077800     05  FILLER                     PIC X(01)  VALUE SPACES.
077900     05  PRT-RECURRENCE-COND-CODE   PIC X(05).
078000     05  FILLER                     PIC X(06)  VALUE SPACES.
078100
078200 01  PRT-DETAIL-LINE-2A.
078300     05  FILLER                     PIC X(01)  VALUE SPACES.
078400     05  FILLER                     PIC X(09)  VALUE SPACES.
078500     05  FILLER                     PIC X(04)  VALUE SPACES.
078600     05  PRT-AGE                    PIC Z99.
078700     05  FILLER                     PIC X(04)  VALUE SPACES.
078800     05  PRT-CR-BSA                 PIC ZZ9.9(04).
078900     05  FILLER                     PIC X(02)  VALUE SPACES.
079000     05  PRT-PPS-BSA                PIC ZZ9.9(04)
079100                                        BLANK WHEN ZERO.
079200     05  FILLER                     PIC X(02)  VALUE SPACES.
079300     05  PRT-OUT-BSA                PIC ZZ9.9(04)
079400                                        BLANK WHEN ZERO.
079500     05  FILLER                     PIC X(04)  VALUE SPACES.
079600     05  PRT-CR-BMI                 PIC ZZ9.9(04).
079700     05  FILLER                     PIC X(02)  VALUE SPACES.
079800     05  PRT-PPS-BMI                PIC ZZ9.9(04)
079900                                        BLANK WHEN ZERO.
080000     05  FILLER                     PIC X(02)  VALUE SPACES.
080100     05  PRT-OUT-BMI                PIC ZZ9.9(04)
080200                                        BLANK WHEN ZERO.
080300     05  FILLER                     PIC X(37)  VALUE SPACES.
080400     05  PRT-RTC                    PIC 9(03).
080500     05  FILLER                     PIC X(05)  VALUE SPACES.
080600     05  PRT-DRIVER-CALC-VERS-CD    PIC X(07)  JUST RIGHT.
080700
080800
080900 01  PRT-DETAIL-LINE-1B.
081000     05  FILLER                     PIC X(01)  VALUE SPACES.
081100     05  FILLER                     PIC X(02)  VALUE SPACES.
081200     05  PRT-B-MSA                  PIC X(04).
081300     05  FILLER                     PIC X(08)  VALUE SPACES.
081400     05  PRT-B-CBSA                 PIC X(05).
081500     05  FILLER                     PIC X(07)  VALUE SPACES.
081600     05  PRT-B-PROV-TYPE            PIC X(02).
081700     05  FILLER                     PIC X(03)  VALUE SPACES.
081800     05  PRT-B-BUDGET-NEUTRAL       PIC X(06).
081900     05  FILLER                     PIC X(03)  VALUE SPACES.
082000     05  PRT-B-DRUG-ADD-ON          PIC X(06).
082100     05  FILLER                     PIC X(02)  VALUE SPACES.
082200     05  PRT-B-CBSA-PMT-RATE        PIC X(07).
082300     05  FILLER                     PIC X(03)  VALUE SPACES.
082400     05  PRT-B-CLAIM-DATE           PIC X(08).
082500     05  FILLER                     PIC X(02)  VALUE SPACES.
082600     05  PRT-B-BIRTH-DATE           PIC X(08).
082700     05  PRT-HGT-WGT.
082800         10  FILLER                 PIC X(03).
082900         10  PRT-B-HEIGHT           PIC 9(06).
083000         10  FILLER                 PIC X(03).
083100         10  PRT-B-WEIGHT           PIC 9(06).
083200         10  FILLER                 PIC X(03).
083300     05  PRT-HGT-WGT-ERRORS  REDEFINES PRT-HGT-WGT.
083400         10  PRT-B-ERR-HEIGHT       PIC 9(09).
083500         10  FILLER                 PIC X(02).
083600         10  PRT-B-ERR-WEIGHT       PIC 9(09).
083700         10  FILLER                 PIC X(01).
083800     05  PRT-B-COND-CODE            PIC X(02).
083900     05  FILLER                     PIC X(02)  VALUE SPACES.
084000     05  PRT-B-REVENUE-CODE         PIC X(04).
084100     05  FILLER                     PIC X(02)  VALUE SPACES.
084200     05  FILLER                     PIC X(10)  VALUE SPACES.
084300     05  FILLER                     PIC X(04)  VALUE SPACES.
084400     05  PRT-B-RTC                  PIC 9(02).
084500     05  FILLER                     PIC X(03)  VALUE SPACES.
084600     05  PRT-B-DRIVER-CALC-VERS-CD  PIC X(05).
084700     05  FILLER                     PIC X(02)  VALUE SPACES.
084800
084900 01  PRT-DETAIL-LINE-2B.
085000     05  FILLER                     PIC X(01)  VALUE SPACES.
085100     05  PRT-B-MSA-WAGE             PIC X(07).
085200     05  FILLER                     PIC X(01)  VALUE SPACES.
085300     05  PRT-B-MSA-PERCENT          PIC X(03).
085400     05  FILLER                     PIC X(02)  VALUE SPACES.
085500     05  PRT-B-CBSA-INDEX           PIC X(07).
085600     05  FILLER                     PIC X(01)  VALUE SPACES.
085700     05  PRT-B-CBSA-PERCENT         PIC X(03).
085800     05  FILLER                     PIC X(05)  VALUE SPACES.
085900     05  PRT-B-MSA-WAGE-ADJ         PIC X(08).
086000     05  FILLER                     PIC X(01)  VALUE SPACES.
086100     05  PRT-B-CBSA-WAGE-ADJ        PIC X(08).
086200     05  FILLER                     PIC X(01)  VALUE SPACES.
086300     05  PRT-B-MSA-CBSA-WAGE-ADJ-RT PIC X(08).
086400     05  FILLER                     PIC X(05)  VALUE SPACES.
086500     05  PRT-B-AGE                  PIC X(03).
086600     05  FILLER                     PIC X(06)  VALUE SPACES.
086700     05  PRT-B-AGE-FACTOR           PIC X(05).
086800     05  FILLER                     PIC X(05)  VALUE SPACES.
086900     05  PRT-B-BSA-FACTOR           PIC X(06).
087000     05  FILLER                     PIC X(03)  VALUE SPACES.
087100     05  PRT-B-BMI-FACTOR           PIC X(06).
087200     05  FILLER                     PIC X(03)  VALUE SPACES.
087300     05  PRT-B-HEMO-CCPD-CAPD-VALUE PIC X(08).
087400     05  FILLER                     PIC X(01)  VALUE SPACES.
087500     05  PRT-B-FINAL-PAY-AMT        PIC X(11).
087600     05  PRT-B-ESRD-RATE-GT-ZERO    PIC X(01).
087700     05  FILLER                     PIC X(14)  VALUE SPACES.
087800
087900 01  PRT-DETAIL-LINE-3A5-10.
088000     05  FILLER                     PIC X(01)  VALUE SPACES.
088100     05  PRT-MSA-WAGE               PIC $$$9.99
088200                                        BLANK WHEN ZERO.
088300     05  FILLER                     PIC X(02)  VALUE ' ('.
088400     05  PRT-MSA-ADJ-YEAR-AMT       PIC $$$$9.99
088500                                        BLANK WHEN ZERO.
088600     05  FILLER                     PIC X(02)  VALUE '  '.
088700     05  PRT-MSA-PERCENT            PIC ZZ99
088800                                        BLANK WHEN ZERO.
088900     05  FILLER                     PIC X(01)  VALUE '%'.
089000     05  FILLER                     PIC X(03)  VALUE ' = '.
089100     05  PRT-MSA-WAGE-ADJ           PIC $$$$9.99
089200                                        BLANK WHEN ZERO.
089300     05  FILLER                     PIC X(10)  VALUE
089400                                               ')  +  (((('.
089500     05  PRT-CBSA-PMT-RATE-A        PIC $$$$9.99
089600                                        BLANK WHEN ZERO.
089700     05  FILLER                     PIC X(03)  VALUE ' * '.
089800     05  PRT-LABOR-PCT              PIC 9.99999.
089900     05  FILLER                     PIC X(03)  VALUE ' * '.
090000     05  PRT-CBSA-INDEX             PIC 9.9999
090100                                        BLANK WHEN ZERO.
090200     05  FILLER                     PIC X(05)  VALUE ') + ('.
090300     05  PRT-CBSA-PMT-RATE-B        PIC $$$$9.99
090400                                        BLANK WHEN ZERO.
090500     05  FILLER                     PIC X(03)  VALUE ' * '.
090600     05  PRT-NON-LABOR-PCT          PIC 9.99999.
090700     05  FILLER                     PIC X(04)  VALUE ')) *'.
090800     05  PRT-CBSA-PERCENT           PIC ZZ99
090900                                        BLANK WHEN ZERO.
091000     05  FILLER                     PIC X(01)  VALUE '%'.
091100     05  FILLER                     PIC X(04)  VALUE ') = '.
091200     05  PRT-CBSA-WAGE-ADJ          PIC $$$$$9.99
091300                                        BLANK WHEN ZERO.
091400     05  FILLER                     PIC X(04)  VALUE ')  ='.
091500     05  PRT-MSA-CBSA-WAGE-ADJ-RT-A PIC $$$$$$9.99.
091600
091700 01  PRT-DETAIL-LINE-3B5-10.
091800     05  FILLER                     PIC X(01)  VALUE SPACES.
091900     05  FILLER                     PIC X(01)  VALUE '('.
092000     05  PRT-MSA-CBSA-WAGE-ADJ-RT-B PIC $$$$$$9.9(02).
092100     05  FILLER                     PIC X(05)  VALUE '  *  '.
092200     05  PRT-AGE-FACTOR             PIC 9.999.
092300     05  FILLER                     PIC X(05)  VALUE '  *  '.
092400     05  PRT-BSA-FACTOR             PIC 9.9999.
092500     05  FILLER                     PIC X(05)  VALUE '  *  '.
092600     05  PRT-BMI-FACTOR             PIC 9.9999.
092700     05  FILLER                     PIC X(05)  VALUE '  *  '.
092800     05  PRT-BUDGET-NEUTRAL         PIC 9.9999.
092900     05  FILLER                     PIC X(05)  VALUE '  *  '.
093000     05  PRT-DRUG-ADD-ON            PIC 9.9999.
093100     05  FILLER                     PIC X(01)  VALUE ')'.
093200     05  FILLER                     PIC X(04)  VALUE '  = '.
093300     05  PRT-CASE-MIX-FCTR-ADJ-RATE PIC $$$$$$$9.99
093400                                        BLANK WHEN ZERO.
093500     05  FILLER                     PIC X(05)  VALUE '  +  '.
093600     05  PRT-HEMO-CCPD-CAPD-AMT     PIC $$9.99
093700                                        BLANK WHEN ZERO.
093800     05  FILLER                     PIC X(05)  VALUE '  *  '.
093900     05  PRT-HEMO-CCPD-CAPD-VALUE   PIC 9.999999
094000                                        BLANK WHEN ZERO.
094100     05  FILLER                     PIC X(05)  VALUE '  =  '.
094200     05  PRT-FINAL-PAY-AMT          PIC $$$$$$$9.99.
094300     05  FILLER                     PIC X(11)  VALUE SPACES.
094400
094500 01  PRT-DETAIL-LINE-3B.
094600     05  FILLER                     PIC X(01)  VALUE SPACES.
094700     05  FILLER                     PIC X(02)  VALUE '  '.
094800     05  FILLER                     PIC X(08)  VALUE SPACES.
094900     05  FILLER                     PIC X(02)  VALUE ' ('.
095000     05  FILLER                     PIC X(06)  VALUE SPACES.
095100     05  FILLER                     PIC X(02)  VALUE SPACES.
095200     05  FILLER                     PIC X(07)  VALUE SPACES.
095300     05  FILLER                     PIC X(05)  VALUE ') + ('.
095400     05  FILLER                     PIC X(08)  VALUE SPACES.
095500     05  FILLER                     PIC X(02)  VALUE SPACES.
095600     05  FILLER                     PIC X(07)  VALUE SPACES.
095700     05  FILLER                     PIC X(05)  VALUE ')  = '.
095800     05  FILLER                     PIC X(10)  VALUE SPACES.
095900     05  FILLER                     PIC X(04)  VALUE '   ('.
096000     05  FILLER                     PIC X(08)  VALUE SPACES.
096100     05  FILLER                     PIC X(02)  VALUE SPACES.
096200     05  FILLER                     PIC X(06)  VALUE SPACES.
096300     05  FILLER                     PIC X(04)  VALUE SPACES.
096400     05  FILLER                     PIC X(07)  VALUE SPACES.
096500     05  FILLER                     PIC X(05)  VALUE ') + ('.
096600     05  FILLER                     PIC X(07)  VALUE SPACES.
096700     05  FILLER                     PIC X(02)  VALUE SPACES.
096800     05  FILLER                     PIC X(07)  VALUE SPACES.
096900     05  FILLER                     PIC X(06)  VALUE ')  =  '.
097000     05  FILLER                     PIC X(10)  VALUE SPACES.
097100
097200 01  PRT-DETAIL-LINE-3A11.
097300     05  FILLER                     PIC X(01)  VALUE SPACES.
097400     05  PRT-MSA-WAGE-ADJ-XXXX      PIC $$$9.9(02).
097500     05  FILLER                     PIC X(02)  VALUE ' ('.
097600     05  PRT-AA                     PIC X(08)  VALUE 'M-ADJ-WG'.
097700     05  FILLER                     PIC X(02)  VALUE '  '.
097800     05  PRT-MSA-PERCENTX           PIC X(05)  VALUE 'M-PCT'.
097900     05  FILLER                     PIC X(03)  VALUE ' = '.
098000     05  PRT-BB                     PIC X(08)  VALUE 'M-WG-AMT'.
098100     05  FILLER                     PIC X(11)  VALUE
098200                                               ')  +  ((((('.
098300     05  PRT-CC                     PIC X(08)  VALUE 'C-WG-AMT'.
098400     05  FILLER                     PIC X(02)  VALUE '  '.
098500     05  PRT-DD                     PIC X(07)  VALUE '  LABOR'.
098600     05  FILLER                     PIC X(03)  VALUE ')  '.
098700     05  PRT-EE                     PIC X(06)  VALUE 'C-WG-I'.
098800     05  FILLER                     PIC X(05)  VALUE ') + ('.
098900     05  PRT-FF                     PIC X(08)  VALUE 'C-WG-AMT'.
099000     05  FILLER                     PIC X(02)  VALUE '  '.
099100     05  PRT-GG                     PIC X(07)  VALUE 'N-LABOR'.
099200     05  FILLER                     PIC X(05)  VALUE ')) * '.
099300     05  PRT-CBSA-PERCENTX          PIC X(05)  VALUE 'C-PCT'.
099400     05  PRT-HH                     PIC X(04)  VALUE ') = '.
099500     05  FILLER                     PIC X(09)  VALUE 'C-ADJ-AMT'.
099600     05  PRT-II                     PIC X(05)  VALUE ')  = '.
099700     05  FILLER                     PIC X(10)  VALUE 'CR-ADJ-AMT'.
099800
099900 01  PRT-DETAIL-LINE-3B11.
100000     05  FILLER                     PIC X(01)  VALUE SPACES.
100100     05  PRT-MSA-WAGE-ADJYYYY       PIC $$$9.9(02).
100200     05  FILLER                     PIC X(02)  VALUE ' ('.
100300     05  PRT-JJ                     PIC X(08)  VALUE 'M-ADJ-WG'.
100400     05  FILLER                     PIC X(02)  VALUE '  '.
100500     05  PRT-MSA-PERCENTX           PIC X(05)  VALUE 'M-PCT'.
100600     05  FILLER                     PIC X(03)  VALUE ' = '.
100700     05  PRT-KK                     PIC X(08)  VALUE 'M-WG-AMT'.
100800     05  FILLER                     PIC X(11)  VALUE
100900                                               ')  +  ((((('.
101000     05  PRT-LL                     PIC X(08)  VALUE 'C-WG-AMT'.
101100     05  FILLER                     PIC X(02)  VALUE '  '.
101200     05  PRT-MM                     PIC X(07)  VALUE '  LABOR'.
101300     05  FILLER                     PIC X(03)  VALUE ')  '.
101400     05  PRT-NN                     PIC X(06)  VALUE 'C-WG-I'.
101500     05  FILLER                     PIC X(05)  VALUE ') + ('.
101600     05  PRT-OO                     PIC X(08)  VALUE 'C-WG-AMT'.
101700     05  FILLER                     PIC X(02)  VALUE '  '.
101800     05  PRT-PP                     PIC X(07)  VALUE 'N-LABOR'.
101900     05  FILLER                     PIC X(05)  VALUE ')) * '.
102000     05  PRT-CBSA-PERCENTX          PIC X(05)  VALUE 'C-PCT'.
102100     05  PRT-QQ                     PIC X(04)  VALUE ') = '.
102200     05  FILLER                     PIC X(09)  VALUE 'C-ADJ-AMT'.
102300     05  PRT-RR                     PIC X(05)  VALUE ')  = '.
102400     05  FILLER                     PIC X(10)  VALUE 'CR-ADJ-AMT'.
102500
102600 01  PRT-DETAIL-LINE-3B.
102700     05  FILLER                     PIC X(01)  VALUE SPACES.
102800     05  FILLER                     PIC X(02)  VALUE '  '.
102900     05  FILLER                     PIC X(08)  VALUE SPACES.
103000     05  FILLER                     PIC X(02)  VALUE ' ('.
103100     05  FILLER                     PIC X(06)  VALUE SPACES.
103200     05  FILLER                     PIC X(02)  VALUE SPACES.
103300     05  FILLER                     PIC X(07)  VALUE SPACES.
103400     05  FILLER                     PIC X(05)  VALUE ') + ('.
103500     05  FILLER                     PIC X(08)  VALUE SPACES.
103600     05  FILLER                     PIC X(02)  VALUE SPACES.
103700     05  FILLER                     PIC X(07)  VALUE SPACES.
103800     05  FILLER                     PIC X(05)  VALUE ')  = '.
103900     05  FILLER                     PIC X(10)  VALUE SPACES.
104000     05  FILLER                     PIC X(04)  VALUE '   ('.
104100     05  FILLER                     PIC X(08)  VALUE SPACES.
104200     05  FILLER                     PIC X(02)  VALUE SPACES.
104300     05  FILLER                     PIC X(06)  VALUE SPACES.
104400     05  FILLER                     PIC X(04)  VALUE SPACES.
104500     05  FILLER                     PIC X(07)  VALUE SPACES.
104600     05  FILLER                     PIC X(05)  VALUE ') + ('.
104700     05  FILLER                     PIC X(07)  VALUE SPACES.
104800     05  FILLER                     PIC X(02)  VALUE SPACES.
104900     05  FILLER                     PIC X(07)  VALUE SPACES.
105000     05  FILLER                     PIC X(06)  VALUE ')  =  '.
105100     05  FILLER                     PIC X(10)  VALUE SPACES.
105200
105300 01  PRT-DETAIL-LINE-4A.
105400     05  FILLER                     PIC X(01)  VALUE SPACES.
105500     05  FILLER                     PIC X(05)  VALUE SPACES.
105600     05  PRT-BUN-AGE-FACTOR         PIC 9(01).9(03).
105700     05  FILLER                     PIC X(01)  VALUE SPACES.
105800     05  PRT-BUN-BSA-FACTOR         PIC 9(01).9(04).
105900     05  FILLER                     PIC X(01)  VALUE SPACES.
106000     05  PRT-BUN-BMI-FACTOR         PIC 9(01).9(04).
106100     05  FILLER                     PIC X(02)  VALUE SPACES.
106200     05  FILLER                     PIC X(06)  VALUE SPACES.
106300     05  FILLER                     PIC X(02)  VALUE SPACES.
106400     05  PRT-BUN-COMORBID-MULTIPLIER
106500                                    PIC 9(01).9(03).
106600     05  FILLER                     PIC X(02)  VALUE SPACES.
106700     05  PRT-BUN-ONSET-FACTOR       PIC 9(01).9(04).
106800     05  FILLER                     PIC X(02)  VALUE SPACES.
106900     05  PRT-BUN-LOW-VOL-MULTIPLIER PIC 9(01).9(03).
107000     05  FILLER                     PIC X(02)  VALUE SPACES.
107100     05  PRT-BUN-CASE-MIX           PIC 99.9(04).
107200     05  FILLER                     PIC X(02)  VALUE SPACES.
107300     05  PRT-BUN-FIX-DOLLAR         PIC 999.9(03).
107400     05  FILLER                     PIC X(02)  VALUE SPACES.
107500     05  PRT-BUN-PREDICTED          PIC 99999.9(03).
107600     05  FILLER                     PIC X(02)  VALUE SPACES.
107700     05  PRT-BUN-IMPUTED-MAP        PIC $$$9.9(04).
107800     05  FILLER                     PIC X(02)  VALUE SPACES.
107900     05  PRT-BUN-LOSS-SHARING-PCT   PIC 9.99.
108000     05  FILLER                     PIC X(01)  VALUE SPACES.
108100     05  PRT-PPS-BLEND-PPS-RATE     PIC $$$$$9.99.
108200     05  FILLER                     PIC X(01)  VALUE SPACES.
108300     05  PRT-PPS-FULL-PPS-RATE      PIC $$$$$9.99.
108400
108500 01  PRT-DETAIL-LINE-5A.
108600     05  FILLER                     PIC X(01)  VALUE SPACES.
108700     05  FILLER                     PIC X(05)  VALUE SPACES.
108800     05  PRT-OUT-AGE-FACTOR         PIC 9(01).9(03).
108900     05  FILLER                     PIC X(01)  VALUE SPACES.
109000     05  FILLER                     PIC X(08)  VALUE SPACES.
109100*    05  PRT-OUT-BSA                PIC ZZ9.9(04).
109200     05  FILLER                     PIC X(02)  VALUE SPACES.
109300     05  PRT-OUT-BSA-FACTOR         PIC 9(01).9(04).
109400     05  FILLER                     PIC X(01)  VALUE SPACES.
109500     05  FILLER                     PIC X(08)  VALUE SPACES.
109600*    05  PRT-OUT-BMI                PIC ZZ9.9(04).
109700     05  FILLER                     PIC X(02)  VALUE SPACES.
109800     05  PRT-OUT-BMI-FACTOR         PIC 9(01).9(04).
109900     05  FILLER                     PIC X(02)  VALUE SPACES.
110000     05  PRT-OUT-ONSET-FACTOR       PIC 9(01).9(04).
110100     05  FILLER                     PIC X(02)  VALUE SPACES.
110200     05  PRT-OUT-COMORBID-MULTIPLIER
110300                                    PIC 9(01).9(03).
110400     05  FILLER                     PIC X(02)  VALUE SPACES.
110500     05  PRT-OUT-LOW-VOL-MULTIPLIER PIC 9(01).9(03).
110600     05  FILLER                     PIC X(02)  VALUE SPACES.
110700     05  PRT-OUT-ADJ-AVG-MAP-AMT    PIC $$$9.9(02).
110800     05  FILLER                     PIC X(02)  VALUE SPACES.
110900     05  PRT-OUT-FIX-DOLLAR-LOSS    PIC $$$9.9(02).
111000     05  FILLER                     PIC X(01)  VALUE SPACES.
111100     05  PRT-OUT-PREDICTED-MAP      PIC $$$$9.9(04).
111200     05  FILLER                     PIC X(02)  VALUE SPACES.
111300     05  PRT-OUT-IMPUTED-MAP        PIC $$$9.9(04).
111400     05  FILLER                     PIC X(02)  VALUE SPACES.
111500     05  PRT-OUT-LOSS-SHARING-PCT   PIC 9.99
111600                                        BLANK WHEN ZERO.
111700     05  FILLER                     PIC X(01)  VALUE SPACES.
111800     05  PRT-PPS-BLEND-OUTLIER-RATE PIC $$$$$9.99
111900                                        BLANK WHEN ZERO.
112000     05  FILLER                     PIC X(01)  VALUE SPACES.
112100     05  PRT-PPS-FULL-OUTLIER-RATE  PIC $$$$$9.99
112200                                        BLANK WHEN ZERO.
112300
112400 01  PRT-MAIN-TITLE.
112500     05  FILLER                     PIC X(01)  VALUE SPACES.
112600     05  FILLER                     PIC X(12)  VALUE
112700        'ESRD PRICER '.
112800     05  PRT-PPMGR-VERSION          PIC X(05).
112900     05  FILLER                     PIC X(51)  VALUE
113000        '                 PROSPECTIVE  PAYMENT  TEST  DATA  '.
113100     05  FILLER                     PIC X(14)  VALUE
113200        'REPORT   FOR  '.
113300     05  PRT-YR                     PIC 9(04).
113400     05  FILLER                     PIC X(17)  VALUE SPACES.
113500     05  FILLER                     PIC X(10)  VALUE
113600        'DATE-TIME:'.
113700     05  FILLER                     PIC X(01) VALUE SPACE.
113800     05  RUN-DATE-TIME              PIC 9(12).
113900     05  FILLER                     PIC X(03) VALUE '  P'.
114000     05  PAGE-NUM                   PIC ZZ9.
114100
114200 01  COL-HEADER-1.
114300     05  FILLER                     PIC X(01)  VALUE SPACES.
114400     05  FILLER                     PIC X(02)  VALUE 'PR'.
114500     05  FILLER                     PIC X(02)  VALUE SPACES.
114600     05  FILLER                     PIC X(03)  VALUE 'MSA'.
114700     05  FILLER                     PIC X(03)  VALUE SPACES.
114800     05  FILLER                     PIC X(04)  VALUE 'CBSA'.
114900     05  FILLER                     PIC X(01)  VALUE SPACES.
115000     05  FILLER                     PIC X(07)  VALUE 'WAIV-LV'.
115100     05  FILLER                     PIC X(01)  VALUE SPACES.
115200     05  FILLER                     PIC X(08)  VALUE 'CLAIM-DT'.
115300     05  FILLER                     PIC X(02)  VALUE SPACES.
115400     05  FILLER                     PIC X(08)  VALUE 'SERV--DT'.
115500     05  FILLER                     PIC X(02)  VALUE SPACES.
115600     05  FILLER                     PIC X(08)  VALUE 'START-DT'.
115700     05  FILLER                     PIC X(02)  VALUE SPACES.
115800     05  FILLER                     PIC X(08)  VALUE 'BIRTH-DT'.
115900     05  FILLER                     PIC X(02)  VALUE SPACES.
116000     05  FILLER                     PIC X(06)  VALUE 'HEIGHT'.
116100     05  FILLER                     PIC X(02)  VALUE SPACES.
116200     05  FILLER                     PIC X(06)  VALUE 'WEIGHT'.
116300     05  FILLER                     PIC X(02)  VALUE SPACES.
116400     05  FILLER                     PIC X(08)  VALUE 'CC  -RC-'.
116500     05  FILLER                     PIC X(01)  VALUE SPACES.
116600     05  FILLER                     PIC X(03)  VALUE 'NDS'.
116700     05  FILLER                     PIC X(02)  VALUE SPACES.
116800     05  FILLER                     PIC X(08)  VALUE '-SB-AMT-'.
116900     05  FILLER                     PIC X(02)  VALUE SPACES.
117000     05  FILLER                     PIC X(12)  VALUE
117100                                                   'COMORBIDITY-'.
117200     05  FILLER                     PIC X(02)  VALUE SPACES.
117300     05  FILLER                     PIC X(03)  VALUE 'CWF'.
117400     05  FILLER                     PIC X(01)  VALUE SPACES.
117500     05  FILLER                     PIC X(05)  VALUE 'RECUR'.
117600     05  FILLER                     PIC X(06)  VALUE SPACES.
117700
117800 01  COL-HEADER-2.
117900     05  FILLER                     PIC X(01)  VALUE SPACES.
118000     05  FILLER                     PIC X(09)  VALUE SPACES.
118100     05  FILLER                     PIC X(04)  VALUE SPACES.
118200     05  FILLER                     PIC X(03)  VALUE 'AGE'.
118300     05  FILLER                     PIC X(06)  VALUE SPACES.
118400     05  FILLER                     PIC X(08)  VALUE 'CR-BSA'.
118500     05  FILLER                     PIC X(02)  VALUE SPACES.
118600     05  FILLER                     PIC X(08)  VALUE 'PPS-BSA'.
118700     05  FILLER                     PIC X(02)  VALUE SPACES.
118800     05  FILLER                     PIC X(08)  VALUE 'OUT-BSA'.
118900     05  FILLER                     PIC X(04)  VALUE SPACES.
119000     05  FILLER                     PIC X(08)  VALUE 'CR--BMI'.
119100     05  FILLER                     PIC X(02)  VALUE SPACES.
119200     05  FILLER                     PIC X(08)  VALUE 'PPS-BMI'.
119300     05  FILLER                     PIC X(02)  VALUE SPACES.
119400     05  FILLER                     PIC X(08)  VALUE 'OUT-BMI'.
119500     05  FILLER                     PIC X(35)  VALUE SPACES.
119600     05  FILLER                     PIC X(03)  VALUE 'RTC'.
119700     05  FILLER                     PIC X(05)  VALUE SPACES.
119800     05  FILLER                     PIC X(07)  VALUE 'VERSION'.
119900
120000
120100 01  COL-HEADER-3A5-10.
120200     05  FILLER                     PIC X(01)  VALUE SPACES.
120300     05  FILLER                     PIC X(07)  VALUE 'MSA-WG-'.
120400     05  FILLER                     PIC X(02)  VALUE ' ('.
120500     05  FILLER                     PIC X(08)  VALUE 'M-ADJ-WG'.
120600     05  FILLER                     PIC X(02)  VALUE '  '.
120700     05  FILLER                     PIC X(05)  VALUE 'M-PCT'.
120800     05  FILLER                     PIC X(03)  VALUE ' = '.
120900     05  FILLER                     PIC X(08)  VALUE 'M-WG-AMT'.
121000     05  FILLER                     PIC X(10)  VALUE
121100                                               ')  +  (((('.
121200     05  FILLER                     PIC X(08)  VALUE 'C-WG-AMT'.
121300     05  FILLER                     PIC X(03)  VALUE ' * '.
121400     05  FILLER                     PIC X(07)  VALUE '  LABOR'.
121500     05  FILLER                     PIC X(03)  VALUE ' * '.
121600     05  FILLER                     PIC X(06)  VALUE 'C-WG-I'.
121700     05  FILLER                     PIC X(05)  VALUE ') + ('.
121800     05  FILLER                     PIC X(08)  VALUE 'C-WG-AMT'.
121900     05  FILLER                     PIC X(03)  VALUE ' * '.
122000     05  FILLER                     PIC X(07)  VALUE 'N-LABOR'.
122100     05  FILLER                     PIC X(04)  VALUE ')) *'.
122200     05  FILLER                     PIC X(05)  VALUE 'C-PCT'.
122300     05  FILLER                     PIC X(04)  VALUE ') = '.
122400     05  FILLER                     PIC X(09)  VALUE 'C-ADJ-AMT'.
122500     05  FILLER                     PIC X(04)  VALUE ')  ='.
122600     05  FILLER                     PIC X(10)  VALUE 'CR-ADJ-AMT'.
122700
122800
122900 01  COL-HEADER-3B5-10.
123000     05  FILLER                     PIC X(01)  VALUE SPACES.
123100     05  FILLER                     PIC X(01)  VALUE '('.
123200     05  FILLER                     PIC X(10)  VALUE 'CR-ADJ-AMT'.
123300     05  FILLER                     PIC X(05)  VALUE '  *  '.
123400     05  FILLER                     PIC X(05)  VALUE 'AGE F'.
123500     05  FILLER                     PIC X(05)  VALUE '  *  '.
123600     05  FILLER                     PIC X(06)  VALUE 'BSA F'.
123700     05  FILLER                     PIC X(05)  VALUE '  *  '.
123800     05  FILLER                     PIC X(06)  VALUE 'BMI F'.
123900     05  FILLER                     PIC X(05)  VALUE '  *  '.
124000     05  FILLER                     PIC X(06)  VALUE 'BG-NEU'.
124100     05  FILLER                     PIC X(05)  VALUE '  *  '.
124200     05  FILLER                     PIC X(06)  VALUE 'DRG-AD'.
124300     05  FILLER                     PIC X(01)  VALUE ')'.
124400     05  FILLER                     PIC X(04)  VALUE '  = '.
124500     05  FILLER                     PIC X(11)  VALUE
124600                                               'CR-FCTR-AMT'.
124700     05  FILLER                     PIC X(05)  VALUE '  +  '.
124800     05  FILLER                     PIC X(06)  VALUE ' TRAIN'.
124900     05  FILLER                     PIC X(05)  VALUE '  *  '.
125000     05  FILLER                     PIC X(08)  VALUE 'HOMEDIAL'.
125100     05  FILLER                     PIC X(05)  VALUE '  =  '.
125200     05  FILLER                     PIC X(11)  VALUE
125300                                               ' FINAL-PMNT'.
125400     05  FILLER                     PIC X(11)  VALUE SPACES.
125500
125600
125700 01  COL-HEADER-3A11.
125800     05  FILLER                     PIC X(01)  VALUE SPACES.
125900     05  FILLER                     PIC X(07)  VALUE 'MSA-WG-'.
126000     05  FILLER                     PIC X(02)  VALUE ' ('.
126100     05  FILLER                     PIC X(08)  VALUE 'M-ADJ-WG'.
126200     05  FILLER                     PIC X(02)  VALUE '  '.
126300     05  FILLER                     PIC X(05)  VALUE 'M-PCT'.
126400     05  FILLER                     PIC X(03)  VALUE ' = '.
126500     05  FILLER                     PIC X(08)  VALUE 'M-WG-AMT'.
126600     05  FILLER                     PIC X(11)  VALUE
126700                                               ')  +  ((((('.
126800     05  FILLER                     PIC X(08)  VALUE 'C-WG-AMT'.
126900     05  FILLER                     PIC X(02)  VALUE '  '.
127000     05  FILLER                     PIC X(07)  VALUE '  LABOR'.
127100     05  FILLER                     PIC X(03)  VALUE ')  '.
127200     05  FILLER                     PIC X(06)  VALUE 'C-WG-I'.
127300     05  FILLER                     PIC X(05)  VALUE ') + ('.
127400     05  FILLER                     PIC X(08)  VALUE 'C-WG-AMT'.
127500     05  FILLER                     PIC X(02)  VALUE '  '.
127600     05  FILLER                     PIC X(07)  VALUE 'N-LABOR'.
127700     05  FILLER                     PIC X(05)  VALUE ')) * '.
127800     05  FILLER                     PIC X(05)  VALUE 'C-PCT'.
127900     05  FILLER                     PIC X(04)  VALUE ') = '.
128000     05  FILLER                     PIC X(09)  VALUE 'C-ADJ-AMT'.
128100     05  FILLER                     PIC X(05)  VALUE ')  = '.
128200     05  FILLER                     PIC X(10)  VALUE 'CR-ADJ-AMT'.
128300
128400
128500 01  COL-HEADER-3B11.
128600     05  FILLER                     PIC X(01)  VALUE SPACES.
128700     05  FILLER                     PIC X(02)  VALUE '  '.
128800     05  FILLER                     PIC X(08)  VALUE ' CR-C-WG'.
128900     05  FILLER                     PIC X(02)  VALUE ' ('.
129000     05  FILLER                     PIC X(06)  VALUE 'CR-C-I'.
129100     05  FILLER                     PIC X(02)  VALUE SPACES.
129200     05  FILLER                     PIC X(07)  VALUE ' CR-LAB'.
129300     05  FILLER                     PIC X(05)  VALUE ') + ('.
129400     05  FILLER                     PIC X(08)  VALUE ' CR-C-WG'.
129500     05  FILLER                     PIC X(02)  VALUE SPACES.
129600     05  FILLER                     PIC X(07)  VALUE 'CR-NLAB'.
129700     05  FILLER                     PIC X(05)  VALUE ')  = '.
129800     05  FILLER                     PIC X(10)  VALUE 'CR-BAS-AMT'.
129900     05  FILLER                     PIC X(04)  VALUE '   ('.
130000     05  FILLER                     PIC X(08)  VALUE 'PPS-C-WG'.
130100     05  FILLER                     PIC X(02)  VALUE SPACES.
130200     05  FILLER                     PIC X(06)  VALUE 'PP-C-I'.
130300     05  FILLER                     PIC X(04)  VALUE SPACES.
130400     05  FILLER                     PIC X(07)  VALUE 'PPS-LAB'.
130500     05  FILLER                     PIC X(05)  VALUE ') + ('.
130600     05  FILLER                     PIC X(07)  VALUE 'PP-C-WG'.
130700     05  FILLER                     PIC X(02)  VALUE SPACES.
130800     05  FILLER                     PIC X(07)  VALUE 'PP-NLAB'.
130900     05  FILLER                     PIC X(06)  VALUE ')  =  '.
131000     05  FILLER                     PIC X(10)  VALUE 'PP-BAS-AMT'.
131100
131200
131300 01  COL-HEADER-4A.
131400     05  FILLER                     PIC X(01)  VALUE SPACES.
131500     05  FILLER                     PIC X(09)  VALUE 'PPS------'.
131600     05  FILLER                     PIC X(02)  VALUE SPACES.
131700     05  FILLER                     PIC X(05)  VALUE 'AGE-F'.
131800     05  FILLER                     PIC X(02)  VALUE SPACES.
131900     05  FILLER                     PIC X(06)  VALUE '-BSA-F'.
132000     05  FILLER                     PIC X(02)  VALUE SPACES.
132100     05  FILLER                     PIC X(06)  VALUE '-BMI-F'.
132200     05  FILLER                     PIC X(02)  VALUE SPACES.
132300     05  FILLER                     PIC X(06)  VALUE 'DRG-AD'.
132400     05  FILLER                     PIC X(02)  VALUE SPACES.
132500     05  FILLER                     PIC X(06)  VALUE 'BUD-NU'.
132600     05  FILLER                     PIC X(06)  VALUE 'COMORB'.
132700     05  FILLER                     PIC X(02)  VALUE SPACES.
132800     05  FILLER                     PIC X(05)  VALUE 'ONSET'.
132900     05  FILLER                     PIC X(02)  VALUE SPACES.
133000     05  FILLER                     PIC X(05)  VALUE 'L-VOL'.
133100     05  FILLER                     PIC X(02)  VALUE SPACES.
133200     05  FILLER                     PIC X(08)  VALUE 'ADJ-B-RT'.
133300     05  FILLER                     PIC X(01)  VALUE SPACES.
133400     05  FILLER                     PIC X(08)  VALUE 'TRAINING'.
133500     05  FILLER                     PIC X(02)  VALUE SPACES.
133600     05  FILLER                     PIC X(07)  VALUE 'PP-WG-I'.
133700     05  FILLER                     PIC X(02)  VALUE SPACES.
133800     05  FILLER                     PIC X(07)  VALUE 'OUTLIER'.
133900     05  FILLER                     PIC X(02)  VALUE SPACES.
134000     05  FILLER                     PIC X(03)  VALUE 'PCT'.
134100     05  FILLER                     PIC X(01)  VALUE SPACES.
134200     05  FILLER                     PIC X(10)  VALUE '-BLEND--CR'.
134300     05  FILLER                     PIC X(01)  VALUE SPACES.
134400     05  FILLER                     PIC X(10)  VALUE '-FULL---CR'.
134500
134600 01  COL-HEADER-4B.
134700     05  FILLER                     PIC X(01)  VALUE SPACES.
134800     05  FILLER                     PIC X(03)  VALUE 'PPS'.
134900     05  FILLER                     PIC X(02)  VALUE SPACES.
135000     05  FILLER                     PIC X(05)  VALUE 'AGE F'.
135100     05  FILLER                     PIC X(01)  VALUE SPACES.
135200     05  FILLER                     PIC X(08)  VALUE '--BSA---'.
135300     05  FILLER                     PIC X(02)  VALUE SPACES.
135400     05  FILLER                     PIC X(06)  VALUE 'BSA FA'.
135500     05  FILLER                     PIC X(01)  VALUE SPACES.
135600     05  FILLER                     PIC X(08)  VALUE '--BMI---'.
135700     05  FILLER                     PIC X(02)  VALUE SPACES.
135800     05  FILLER                     PIC X(06)  VALUE 'BMI FA'.
135900     05  FILLER                     PIC X(02)  VALUE SPACES.
136000     05  FILLER                     PIC X(06)  VALUE 'ONSET-'.
136100     05  FILLER                     PIC X(02)  VALUE SPACES.
136200     05  FILLER                     PIC X(05)  VALUE 'COMO-'.
136300     05  FILLER                     PIC X(02)  VALUE SPACES.
136400     05  FILLER                     PIC X(05)  VALUE 'LOW V'.
136500     05  FILLER                     PIC X(02)  VALUE SPACES.
136600     05  FILLER                     PIC X(07)  VALUE 'ADJ MAP'.
136700     05  FILLER                     PIC X(02)  VALUE SPACES.
136800     05  FILLER                     PIC X(09)  VALUE '-IMP MAP-'.
136900     05  FILLER                     PIC X(02)  VALUE SPACES.
137000     05  FILLER                     PIC X(07)  VALUE 'FIX LOS'.
137100     05  FILLER                     PIC X(02)  VALUE SPACES.
137200     05  FILLER                     PIC X(04)  VALUE 'L PC'.
137300     05  FILLER                     PIC X(02)  VALUE SPACES.
137400     05  FILLER                     PIC X(08)  VALUE 'C-ADJ-MP'.
137500     05  FILLER                     PIC X(01)  VALUE SPACES.
137600     05  FILLER                     PIC X(09)  VALUE 'BLEND PPS'.
137700     05  FILLER                     PIC X(01)  VALUE SPACES.
137800     05  FILLER                     PIC X(10)  VALUE '--FULL PPS'.
137900
138000
138100 01  COL-HEADER-5A.
138200     05  FILLER                     PIC X(01)  VALUE SPACES.
138300     05  FILLER                     PIC X(03)  VALUE 'BUN'.
138400     05  FILLER                     PIC X(02)  VALUE SPACES.
138500     05  FILLER                     PIC X(05)  VALUE 'AGE F'.
138600     05  FILLER                     PIC X(01)  VALUE SPACES.
138700     05  FILLER                     PIC X(08)  VALUE '--BSA---'.
138800     05  FILLER                     PIC X(02)  VALUE SPACES.
138900     05  FILLER                     PIC X(06)  VALUE 'BSA FA'.
139000     05  FILLER                     PIC X(01)  VALUE SPACES.
139100     05  FILLER                     PIC X(08)  VALUE '--BMI---'.
139200     05  FILLER                     PIC X(02)  VALUE SPACES.
139300     05  FILLER                     PIC X(06)  VALUE 'BMI FA'.
139400     05  FILLER                     PIC X(02)  VALUE SPACES.
139500     05  FILLER                     PIC X(06)  VALUE 'ONSET-'.
139600     05  FILLER                     PIC X(02)  VALUE SPACES.
139700     05  FILLER                     PIC X(05)  VALUE 'COMO-'.
139800     05  FILLER                     PIC X(02)  VALUE SPACES.
139900     05  FILLER                     PIC X(05)  VALUE 'LOW V'.
140000     05  FILLER                     PIC X(02)  VALUE SPACES.
140100     05  FILLER                     PIC X(07)  VALUE 'ADJ MAP'.
140200     05  FILLER                     PIC X(02)  VALUE SPACES.
140300     05  FILLER                     PIC X(09)  VALUE '-IMP MAP-'.
140400     05  FILLER                     PIC X(02)  VALUE SPACES.
140500     05  FILLER                     PIC X(07)  VALUE 'FIX LOS'.
140600     05  FILLER                     PIC X(02)  VALUE SPACES.
140700     05  FILLER                     PIC X(04)  VALUE 'L PC'.
140800     05  FILLER                     PIC X(02)  VALUE SPACES.
140900     05  FILLER                     PIC X(08)  VALUE 'C-ADJ-MP'.
141000     05  FILLER                     PIC X(01)  VALUE SPACES.
141100     05  FILLER                     PIC X(10)  VALUE '-BLEND PPS'.
141200     05  FILLER                     PIC X(01)  VALUE SPACES.
141300     05  FILLER                     PIC X(10)  VALUE '--FULL PPS'.
141400
141500 01  COL-HEADER-5B.
141600     05  FILLER                     PIC X(01)  VALUE SPACES.
141700     05  FILLER                     PIC X(03)  VALUE 'BUN'.
141800     05  FILLER                     PIC X(02)  VALUE SPACES.
141900     05  FILLER                     PIC X(05)  VALUE 'AGE F'.
142000     05  FILLER                     PIC X(01)  VALUE SPACES.
142100     05  FILLER                     PIC X(08)  VALUE '--BSA---'.
142200     05  FILLER                     PIC X(02)  VALUE SPACES.
142300     05  FILLER                     PIC X(06)  VALUE 'BSA FA'.
142400     05  FILLER                     PIC X(01)  VALUE SPACES.
142500     05  FILLER                     PIC X(08)  VALUE '--BMI---'.
142600     05  FILLER                     PIC X(02)  VALUE SPACES.
142700     05  FILLER                     PIC X(06)  VALUE 'BMI FA'.
142800     05  FILLER                     PIC X(02)  VALUE SPACES.
142900     05  FILLER                     PIC X(06)  VALUE 'ONSET-'.
143000     05  FILLER                     PIC X(02)  VALUE SPACES.
143100     05  FILLER                     PIC X(05)  VALUE 'COMO-'.
143200     05  FILLER                     PIC X(02)  VALUE SPACES.
143300     05  FILLER                     PIC X(05)  VALUE 'LOW V'.
143400     05  FILLER                     PIC X(02)  VALUE SPACES.
143500     05  FILLER                     PIC X(07)  VALUE 'ADJ MAP'.
143600     05  FILLER                     PIC X(02)  VALUE SPACES.
143700     05  FILLER                     PIC X(09)  VALUE '-IMP MAP-'.
143800     05  FILLER                     PIC X(02)  VALUE SPACES.
143900     05  FILLER                     PIC X(07)  VALUE 'FIX LOS'.
144000     05  FILLER                     PIC X(02)  VALUE SPACES.
144100     05  FILLER                     PIC X(04)  VALUE 'L PC'.
144200     05  FILLER                     PIC X(02)  VALUE SPACES.
144300     05  FILLER                     PIC X(08)  VALUE 'C-ADJ-MP'.
144400     05  FILLER                     PIC X(01)  VALUE SPACES.
144500     05  FILLER                     PIC X(10)  VALUE '-BLEND PPS'.
144600     05  FILLER                     PIC X(01)  VALUE SPACES.
144700     05  FILLER                     PIC X(10)  VALUE '--FULL PPS'.
144800
144900 01  COL-HEADER-6.
145000     05  FILLER                     PIC X(01)  VALUE SPACES.
145100     05  FILLER                     PIC X(03)  VALUE SPACES.
145200     05  FILLER                     PIC X(02)  VALUE SPACES.
145300     05  FILLER                     PIC X(05)  VALUE 'AGE F'.
145400     05  FILLER                     PIC X(01)  VALUE SPACES.
145500     05  FILLER                     PIC X(08)  VALUE '--BSA---'.
145600     05  FILLER                     PIC X(02)  VALUE SPACES.
145700     05  FILLER                     PIC X(06)  VALUE 'BSA FA'.
145800     05  FILLER                     PIC X(01)  VALUE SPACES.
145900     05  FILLER                     PIC X(08)  VALUE '--BMI---'.
146000     05  FILLER                     PIC X(02)  VALUE SPACES.
146100     05  FILLER                     PIC X(06)  VALUE 'BMI FA'.
146200     05  FILLER                     PIC X(02)  VALUE SPACES.
146300     05  FILLER                     PIC X(06)  VALUE 'ONSET-'.
146400     05  FILLER                     PIC X(02)  VALUE SPACES.
146500     05  FILLER                     PIC X(05)  VALUE 'COMO-'.
146600     05  FILLER                     PIC X(02)  VALUE SPACES.
146700     05  FILLER                     PIC X(05)  VALUE 'LOW V'.
146800     05  FILLER                     PIC X(02)  VALUE SPACES.
146900     05  FILLER                     PIC X(07)  VALUE 'AA  MAP'.
147000     05  FILLER                     PIC X(02)  VALUE SPACES.
147100     05  FILLER                     PIC X(07)  VALUE 'FIX LOS'.
147200     05  FILLER                     PIC X(01)  VALUE SPACES.
147300     05  FILLER                     PIC X(10)  VALUE 'PRED MAP-'.
147400     05  FILLER                     PIC X(02)  VALUE SPACES.
147500     05  FILLER                     PIC X(09)  VALUE 'IMPUT MAP'.
147600     05  FILLER                     PIC X(02)  VALUE SPACES.
147700     05  FILLER                     PIC X(04)  VALUE 'PCT-'.
147800     05  FILLER                     PIC X(01)  VALUE SPACES.
147900     05  FILLER                     PIC X(09)  VALUE 'BLEND OUT'.
148000     05  FILLER                     PIC X(01)  VALUE SPACES.
148100     05  FILLER                     PIC X(09)  VALUE '-FULL OUT'.
148200/
148300******************************************************************
148400*                     For use by the PC only                     *
148500*Areas are broken down by screen area for ease of understanding  *
148600*----------------------------------------------------------------*
148700*  Claim screen layout
148800 01  PC-PRINT-REC-LAYOUT.
148900     05  PC-P-DATE-TIME-VERS-LINE.
149000         10  FILLER                 PIC X(13) VALUE SPACES.
149100         10  FILLER                 PIC X(12) VALUE
149200             'PRINT DATE: '.
149300         10  PC-P-MM                PIC 9(02).
149400         10  FILLER                 PIC X(01) VALUE '/'.
149500         10  PC-P-DD                PIC 9(02).
149600         10  FILLER                 PIC X(01) VALUE '/'.
149700         10  PC-P-CCYY              PIC 9(04).
149800         10  FILLER                 PIC X(05) VALUE SPACES.
149900         10  FILLER                 PIC X(06) VALUE 'TIME: '.
150000         10  PC-P-HOUR              PIC Z9.
150100         10  FILLER                 PIC X(01) VALUE ':'.
150200         10  PC-P-MINUTE            PIC 9(02).
150300         10  FILLER                 PIC X(01) VALUE SPACES.
150400         10  PC-P-MERIDIAN          PIC X(01).
150500         10  FILLER                 PIC X(03) VALUE '.M.'.
150600         10  FILLER                 PIC X(05) VALUE SPACES.
150700         10  FILLER                 PIC X(09) VALUE 'VERSION: '.
150800         10  PC-P-VERSION.
150900             15  PC-P-SCREEN-VERS   PIC X(07).
151000             15  FILLER             PIC X(01) VALUE '_'.
151100             15  PC-P-MANAGER-VERS  PIC X(05).
151200         10  FILLER                 PIC X(13) VALUE SPACES.
151300     05  PC-P-CLAIM-HEADER-LINE1.
151400         10  FILLER                 PIC X(36) VALUE SPACES.
151500         10  FILLER                 PIC X(23) VALUE
151600             '** Claim Information **'.
151700         10  FILLER                 PIC X(37) VALUE SPACES.
151800
151900     05  PC-P-CLAIM-HEADER-LINE1U.
152000         10  FILLER                 PIC X(36) VALUE SPACES.
152100         10  FILLER                 PIC X(23) VALUE
152200             '** ----------------- **'.
152300         10  FILLER                 PIC X(37) VALUE SPACES.
152400
152500     05  PC-P-CLAIM-HEADER-LINE2.
152600         10  FILLER                 PIC X(01) VALUE SPACES.
152700         10  FILLER                 PIC X(20) VALUE
152800             'Provider Information'.
152900         10  FILLER                 PIC X(08) VALUE SPACES.
153000         10  FILLER                 PIC X(06) VALUE SPACES.
153100         10  FILLER                 PIC X(19) VALUE
153200             'Patient Information'.
153300         10  FILLER                 PIC X(09) VALUE SPACES.
153400         10  FILLER                 PIC X(06) VALUE SPACES.
153500         10  FILLER                 PIC X(17) VALUE
153600             'Claim Information'.
153700         10  FILLER                 PIC X(10) VALUE SPACES.
153800
153900     05  PC-P-CLAIM-HEADER-LINE2U.
154000         10  FILLER                 PIC X(01) VALUE SPACES.
154100         10  FILLER                 PIC X(20) VALUE
154200             '-------- -----------'.
154300         10  FILLER                 PIC X(08) VALUE SPACES.
154400         10  FILLER                 PIC X(06) VALUE SPACES.
154500         10  FILLER                 PIC X(19) VALUE
154600             '------- -----------'.
154700         10  FILLER                 PIC X(09) VALUE SPACES.
154800         10  FILLER                 PIC X(06) VALUE SPACES.
154900         10  FILLER                 PIC X(17) VALUE
155000             '----- -----------'.
155100         10  FILLER                 PIC X(10) VALUE SPACES.
155200
155300     05  PC-P-CLAIM-DETAIL-LINE1.
155400         10  FILLER                 PIC X(01) VALUE SPACES.
155500         10  FILLER                 PIC X(05) VALUE 'Type:'.
155600         10  FILLER                 PIC X(01) VALUE SPACES.
155700         10  PC-P-G-FACILITY-TYPE-DESC
155800                                    PIC X(14).
155900         10  FILLER                 PIC X(07) VALUE SPACES.
156000         10  FILLER                 PIC X(06) VALUE SPACES.
156100         10  FILLER                 PIC X(01) VALUE SPACES.
156200         10  FILLER                 PIC X(10) VALUE 'Birthdate:'.
156300         10  FILLER                 PIC X(01) VALUE SPACES.
156400         10  PC-P-G-B-DOB-DATE      PIC X(10).
156500         10  FILLER                 PIC X(06) VALUE SPACES.
156600         10  FILLER                 PIC X(06) VALUE SPACES.
156700         10  FILLER                 PIC X(01) VALUE SPACES.
156800         10  FILLER                 PIC X(13) VALUE
156900             'Through Date:'.
157000         10  FILLER                 PIC X(01) VALUE SPACES.
157100         10  PC-P-G-B-THRU-DATE     PIC X(10).
157200         10  FILLER                 PIC X(03) VALUE SPACES.
157300
157400     05  PC-P-CLAIM-DETAIL-LINE2.
157500         10  FILLER                 PIC X(01) VALUE SPACES.
157600         10  FILLER                 PIC X(05) VALUE 'CBSA:'.
157700         10  FILLER                 PIC X(01) VALUE SPACES.
157800         10  PC-P-G-P-CBSA          PIC X(05).
157900         10  FILLER                 PIC X(16) VALUE SPACES.
158000         10  FILLER                 PIC X(06) VALUE SPACES.
158100         10  FILLER                 PIC X(01) VALUE SPACES.
158200         10  FILLER                 PIC X(07) VALUE 'Weight:'.
158300         10  FILLER                 PIC X(01) VALUE SPACES.
158400         10  PC-P-G-B-PATIENT-WGT   PIC Z(03).Z(02).
158500         10  FILLER                 PIC X(04) VALUE ' kg.'.
158600         10  FILLER                 PIC X(09) VALUE SPACES.
158700         10  FILLER                 PIC X(06) VALUE SPACES.
158800         10  FILLER                 PIC X(01) VALUE SPACES.
158900         10  FILLER                 PIC X(15) VALUE
159000             'Condition Code:'.
159100         10  FILLER                 PIC X(01) VALUE SPACES.
159200         10  PC-P-G-B-COND-CODE     PIC X(02).
159300         10  FILLER                 PIC X(09) VALUE SPACES.
159400
159500     05  PC-P-CLAIM-DETAIL-LINE3.
159600         10  FILLER                 PIC X(01) VALUE SPACES.
159700         10  PC-P-G-P-CBSA-NAME     PIC X(27).
159800         10  FILLER                 PIC X(68) VALUE SPACES.
159900
160000     05  PC-P-CLAIM-DETAIL-LINE4.
160100         10  FILLER                 PIC X(01) VALUE SPACES.
160200         10  FILLER                 PIC X(04) VALUE 'MSA:'.
160300         10  FILLER                 PIC X(03) VALUE SPACES.
160400         10  PC-P-G-P-MSA           PIC X(04).
160500         10  FILLER                 PIC X(16) VALUE SPACES.
160600         10  FILLER                 PIC X(06) VALUE SPACES.
160700         10  FILLER                 PIC X(01) VALUE SPACES.
160800         10  FILLER                 PIC X(07) VALUE 'Height:'.
160900         10  FILLER                 PIC X(01) VALUE SPACES.
161000         10  PC-P-G-B-PATIENT-HGT   PIC Z(03).Z(02).
161100         10  FILLER                 PIC X(04) VALUE ' cm.'.
161200         10  FILLER                 PIC X(09) VALUE SPACES.
161300         10  FILLER                 PIC X(06) VALUE SPACES.
161400         10  FILLER                 PIC X(01) VALUE SPACES.
161500         10  FILLER                 PIC X(13) VALUE
161600             'Revenue Code:'.
161700         10  FILLER                 PIC X(01) VALUE SPACES.
161800         10  PC-P-G-REV-CODE        PIC X(04).
161900         10  FILLER                 PIC X(09) VALUE SPACES.
162000
162100     05  PC-P-CLAIM-DETAIL-LINE5.
162200         10  FILLER                 PIC X(01) VALUE SPACES.
162300         10  PC-P-G-P-MSA-NAME      PIC X(27).
162400         10  FILLER                 PIC X(68) VALUE SPACES.
162500
162600     05  PC-P-CLAIM-DETAIL-LINE6.
162700         10  FILLER                 PIC X(28) VALUE SPACES.
162800         10  FILLER                 PIC X(06) VALUE SPACES.
162900         10  FILLER                 PIC X(01) VALUE SPACES.
163000         10  FILLER                 PIC X(18) VALUE
163100             'Unique Patient ID:'.
163200         10  FILLER                 PIC X(01) VALUE SPACES.
163300         10  PC-P-G-HICAN           PIC X(13).
163400         10  FILLER                 PIC X(29) VALUE SPACES.
163500
163600* area separating claim and pps screens
163700     05  PC-P-BLANK-LINE            PIC X(96) VALUE SPACES.
163800
163900     05  PC-P-DASH-LINE             PIC X(96) VALUE
164000         '--------------------------------------------------------
164100-        '----------------------------------------'.
164200
164300     05  PC-P-PPS-HEADER-LINE1.
164400         10  FILLER                 PIC X(34) VALUE SPACES.
164500         10  FILLER                 PIC X(29) VALUE
164600             '** PPS Final Payment (tab) **'.
164700         10  FILLER                 PIC X(33) VALUE SPACES.
164800
164900     05  PC-P-PPS-HEADER-LINE1U.
165000         10  FILLER                 PIC X(34) VALUE SPACES.
165100         10  FILLER                 PIC X(29) VALUE
165200             '** ----------------------- **'.
165300         10  FILLER                 PIC X(33) VALUE SPACES.
165400
165500     05  PC-P-PPS-HEADER-LINE2.
165600         10  FILLER                 PIC X(01) VALUE SPACES.
165700         10  FILLER                 PIC X(34) VALUE
165800             'PPS Version Used for Calculations:'.
165900         10  FILLER                 PIC X(02) VALUE SPACES.
166000         10  PC-P-G-PPS-CALC-VERS-CD
166100                                    PIC X(05).
166200         10  FILLER                 PIC X(10) VALUE SPACES.
166300         10  FILLER                 PIC X(23) VALUE
166400             'For claim through date:'.
166500         10  FILLER                 PIC X(02) VALUE SPACES.
166600         10  PC-P-G-PPS-CLAIM-THRU-DATE
166700                                    PIC X(10) VALUE SPACES.
166800         10  FILLER                 PIC X(09) VALUE SPACES.
166900
167000     05  PC-P-PPS-HEADER-LINE3.
167100         10  FILLER                 PIC X(32) VALUE SPACES.
167200         10  FILLER                 PIC X(32) VALUE
167300             '** Payment Calculations (tab) **'.
167400         10  FILLER                 PIC X(32) VALUE SPACES.
167500
167600     05  PC-P-PPS-HEADER-LINE3U.
167700         10  FILLER                 PIC X(32) VALUE SPACES.
167800         10  FILLER                 PIC X(32) VALUE
167900             '** -------------------------- **'.
168000         10  FILLER                 PIC X(32) VALUE SPACES.
168100
168200*  PPS screen layout
168300*  - - final payment tab - -
168400     05  PC-P-PPS-DETAIL-LINE1.
168500         10  FILLER                 PIC X(01) VALUE SPACES.
168600         10  FILLER                 PIC X(10) VALUE 'Rate Data:'.
168700         10  FILLER                 PIC X(85) VALUE SPACES.
168800
168900     05  PC-P-PPS-DETAIL-LINE1U.
169000         10  FILLER                 PIC X(01) VALUE SPACES.
169100         10  FILLER                 PIC X(10) VALUE '---- ---- '.
169200         10  FILLER                 PIC X(85) VALUE SPACES.
169300
169400     05  PC-P-PPS-DETAIL-LINE2.
169500         10  FILLER                 PIC X(16) VALUE SPACES.
169600         10  PC-P-G-MSA-PERCENT     PIC ZZZ.
169700         10  FILLER                 PIC X(02) VALUE ' %'.
169800         10  FILLER                 PIC X(03) VALUE SPACES.
169900         10  FILLER                 PIC X(13) VALUE
170000             'MSA Wage Rate'.
170100         10  FILLER                 PIC X(20) VALUE SPACES.
170200         10  PC-P-G-MSA-WAGE-ADJ    PIC $$,$$9.99.
170300         10  FILLER                 PIC X(30).
170400
170500     05  PC-P-PPS-DETAIL-LINE3.
170600         10  FILLER                 PIC X(16) VALUE SPACES.
170700         10  PC-P-G-CBSA-PERCENT    PIC ZZZ.
170800         10  FILLER                 PIC X(02) VALUE ' %'.
170900         10  FILLER                 PIC X(03) VALUE SPACES.
171000         10  FILLER                 PIC X(14) VALUE
171100             'CBSA Wage Rate'.
171200         10  FILLER                 PIC X(19) VALUE SPACES.
171300         10  PC-P-G-CBSA-WAGE-ADJ-1 PIC $$,$$9.99.
171400         10  FILLER                 PIC X(30).
171500
171600     05  PC-P-PPS-DETAIL-LINE4.
171700         10  FILLER                 PIC X(24) VALUE SPACES.
171800         10  FILLER                 PIC X(22) VALUE
171900             'PPS Wage Adjusted Rate'.
172000         10  FILLER                 PIC X(11) VALUE SPACES.
172100         10  PC-P-G-PPS-WAGE-ADJ-RATE
172200                                    PIC $$,$$9.99.
172300         10  FILLER                 PIC X(30) VALUE SPACES.
172400
172500     05  PC-P-PPS-DETAIL-LINE5.
172600         10  FILLER                 PIC X(01) VALUE SPACES.
172700         10  FILLER                 PIC X(12) VALUE
172800             'Adjustments:'.
172900         10  FILLER                 PIC X(83) VALUE SPACES.
173000
173100     05  PC-P-PPS-DETAIL-LINE5U.
173200         10  FILLER                 PIC X(01) VALUE SPACES.
173300         10  FILLER                 PIC X(12) VALUE
173400             '----------- '.
173500         10  FILLER                 PIC X(83) VALUE SPACES.
173600
173700     05  PC-P-PPS-DETAIL-LINE6.
173800         10  FILLER                 PIC X(11) VALUE SPACES.
173900         10  FILLER                 PIC X(18) VALUE
174000             'Drug Add-on Factor'.
174100         10  FILLER                 PIC X(11) VALUE SPACES.
174200         10  PC-P-G-DRUG-ADD-ON-RETURN
174300                                    PIC 9.9999.
174400         10  FILLER                 PIC X(50) VALUE SPACES.
174500
174600     05  PC-P-PPS-DETAIL-LINE7.
174700         10  FILLER                 PIC X(11) VALUE SPACES.
174800         10  FILLER                 PIC X(24) VALUE
174900             'Budget Neutrality Factor'.
175000         10  FILLER                 PIC X(05) VALUE SPACES.
175100         10  PC-P-G-PPS-BDGT-NEUT-RATE
175200                                    PIC 9.9999.
175300         10  FILLER                 PIC X(50) VALUE SPACES.
175400
175500     05  PC-P-PPS-DETAIL-LINE8.
175600         10  FILLER                 PIC X(11) VALUE SPACES.
175700         10  FILLER                 PIC X(10) VALUE
175800             'Age Factor'.
175900         10  FILLER                 PIC X(19) VALUE SPACES.
176000         10  PC-P-G-PPS-AGE-FACTOR  PIC 9.999.
176100         10  FILLER                 PIC X(51) VALUE SPACES.
176200
176300     05  PC-P-PPS-DETAIL-LINE9.
176400         10  FILLER                 PIC X(11) VALUE SPACES.
176500         10  FILLER                 PIC X(10) VALUE
176600             'BSA Factor'.
176700         10  FILLER                 PIC X(19) VALUE SPACES.
176800         10  PC-P-G-PPS-BSA-FACTOR  PIC 9.9999.
176900         10  FILLER                 PIC X(50) VALUE SPACES.
177000
177100     05  PC-P-PPS-DETAIL-LINE10.
177200         10  FILLER                 PIC X(11) VALUE SPACES.
177300         10  FILLER                 PIC X(10) VALUE
177400             'BMI Factor'.
177500         10  FILLER                 PIC X(19) VALUE SPACES.
177600         10  PC-P-G-PPS-BMI-FACTOR  PIC 9.9999.
177700         10  FILLER                 PIC X(50) VALUE SPACES.
177800
177900     05  PC-P-PPS-DETAIL-LINE11.
178000         10  FILLER                 PIC X(24) VALUE SPACES.
178100         10  FILLER                 PIC X(29) VALUE
178200             'Case Mix Factor Adjusted Rate'.
178300         10  FILLER                 PIC X(04) VALUE SPACES.
178400         10  PC-P-G-CASE-MIX-FCTR-ADJ-RT
178500                                    PIC $$,$$9.99.
178600         10  FILLER                 PIC X(30) VALUE SPACES.
178700     05  PC-P-PPS-DETAIL-LINE12.
178800         10  FILLER                 PIC X(11) VALUE SPACES.
178900         10  PC-P-G-TRAINING-DAILY-RATE
179000                                    PIC X(25) VALUE SPACES.
179100         10  FILLER                 PIC X(60) VALUE SPACES.
179200
179300     05  PC-P-PPS-DETAIL-LINE13.
179400         10  FILLER                 PIC X(11) VALUE SPACES.
179500         10  PC-P-G-TRAINING-LINE-1 PIC X(45) VALUE SPACES.
179600         10  FILLER                 PIC X(04) VALUE SPACES.
179700         10  PC-P-G-TRAINING-AMT    PIC $$9.
179800         10  FILLER                 PIC X(33) VALUE SPACES.
179900
180000     05  PC-P-PPS-DETAIL-LINE14.
180100         10  FILLER                 PIC X(11) VALUE SPACES.
180200         10  PC-P-G-TRAINING-LINE-2 PIC X(45) VALUE SPACES.
180300         10  FILLER                 PIC X(40) VALUE SPACES.
180400
180500     05  PC-P-PPS-DETAIL-LINE15.
180600         10  FILLER                 PIC X(11) VALUE SPACES.
180700         10  PC-P-G-TRAINING-LINE-3 PIC X(45) VALUE SPACES.
180800         10  FILLER                 PIC X(40) VALUE SPACES.
180900
181000     05  PC-P-PPS-DETAIL-LINE16.
181100         10  FILLER                 PIC X(24) VALUE SPACES.
181200         10  FILLER                 PIC X(18) VALUE
181300             'PPS Composite Rate'.
181400         10  FILLER                 PIC X(15) VALUE SPACES.
181500         10  PC-P-G-PPS-FINAL-PAY-AMT
181600                                    PIC $$,$$9.99.
181700         10  FILLER                 PIC X(30) VALUE SPACES.
181800
181900*  - - payment calculations tab - -
182000     05  PC-P-PPS-DETAIL-LINE17.
182100         10  FILLER                 PIC X(01) VALUE SPACE.
182200         10  FILLER                 PIC X(13) VALUE
182300             'MSA Wage Rate'.
182400         10  FILLER                 PIC X(35) VALUE SPACES.
182500         10  FILLER                 PIC X(14) VALUE
182600             'CBSA Wage Rate'.
182700         10  FILLER                 PIC X(33) VALUE SPACES.
182800
182900     05  PC-P-PPS-DETAIL-LINE17U.
183000         10  FILLER                 PIC X(01) VALUE SPACE.
183100         10  FILLER                 PIC X(13) VALUE
183200             '--- ---- ----'.
183300         10  FILLER                 PIC X(35) VALUE SPACES.
183400         10  FILLER                 PIC X(14) VALUE
183500             '---- ---- ----'.
183600         10  FILLER                 PIC X(33) VALUE SPACES.
183700
183800     05  PC-P-PPS-DETAIL-LINE18.
183900         10  FILLER                 PIC X(04) VALUE SPACES.
184000         10  PC-P-G-MSA-LINE-1      PIC X(31) VALUE SPACES.
184100         10  FILLER                 PIC X(01) VALUE SPACE.
184200         10  PC-P-G-MSA-WAGE-AMT    PIC $$,$$9.99 BLANK WHEN ZERO.
184300         10  FILLER                 PIC X(06) VALUE SPACES.
184400         10  FILLER                 PIC X(02) VALUE SPACES.
184500         10  FILLER                 PIC X(05) VALUE 'Labor'.
184600         10  FILLER                 PIC X(38) VALUE SPACES.
184700
184800     05  PC-P-PPS-DETAIL-LINE19.
184900         10  FILLER                 PIC X(04) VALUE SPACES.
185000         10  PC-P-G-MSA-LINE-2      PIC X(31) VALUE SPACES.
185100         10  FILLER                 PIC X(01) VALUE SPACE.
185200         10  PC-P-G-2006-MSA-WAGE-AMT
185300                                    PIC $$,$$9.99 BLANK WHEN ZERO.
185400         10  FILLER                 PIC X(06) VALUE SPACES.
185500         10  PC-P-G-CBSA-LINE-1     PIC X(31) VALUE SPACES.
185600         10  FILLER                 PIC X(01) VALUE SPACES.
185700         10  PC-P-G-CBSA-WAGE-PMT-RATE-1
185800                                    PIC $$,$$9.99 BLANK WHEN ZERO.
185900         10  FILLER                 PIC X(04) VALUE SPACES.
186000
186100     05  PC-P-PPS-DETAIL-LINE20.
186200         10  FILLER                 PIC X(04) VALUE SPACES.
186300         10  PC-P-G-MSA-LINE-3      PIC X(31) VALUE SPACES.
186400         10  FILLER                 PIC X(01) VALUE SPACE.
186500         10  PC-P-G-2007-MSA-WAGE-AMT
186600                                    PIC $$,$$9.99 BLANK WHEN ZERO.
186700         10  FILLER                 PIC X(06) VALUE SPACES.
186800         10  PC-P-G-CBSA-LINE-2     PIC X(31) VALUE SPACES.
186900         10  FILLER                 PIC X(03) VALUE SPACES.
187000         10  PC-P-G-PPS-NAT-LABOR-PCT
187100                                    PIC 9(01).9(05).
187200         10  FILLER                 PIC X(04) VALUE SPACES.
187300
187400     05  PC-P-PPS-DETAIL-LINE21.
187500         10  FILLER                 PIC X(04) VALUE SPACES.
187600         10  PC-P-G-MSA-LINE-4      PIC X(31) VALUE SPACES.
187700         10  FILLER                 PIC X(01) VALUE SPACE.
187800         10  PC-P-G-2008-MSA-WAGE-AMT
187900                                    PIC $$,$$9.99 BLANK WHEN ZERO.
188000         10  FILLER                 PIC X(06) VALUE SPACES.
188100         10  PC-P-G-CBSA-LINE-3     PIC X(31) VALUE SPACES.
188200         10  FILLER                 PIC X(03) VALUE SPACES.
188300         10  PC-P-G-CBSA-WAGE-INDEX PIC Z(02).Z(04).
188400         10  FILLER                 PIC X(04) VALUE SPACES.
188500
188600     05  PC-P-PPS-DETAIL-LINE22.
188700         10  FILLER                 PIC X(04) VALUE SPACES.
188800         10  PC-P-G-MSA-LINE-5      PIC X(31) VALUE SPACES.
188900         10  FILLER                 PIC X(01) VALUE SPACE.
189000         10  PC-P-G-2008-MSA-WAGE-ADJ
189100                                    PIC $$,$$9.99 BLANK WHEN ZERO.
189200         10  FILLER                 PIC X(06) VALUE SPACES.
189300         10  FILLER                 PIC X(31) VALUE SPACES.
189400         10  FILLER                 PIC X(01) VALUE SPACES.
189500         10  FILLER                 PIC X(09) VALUE SPACES.
189600         10  FILLER                 PIC X(04) VALUE SPACES.
189700
189800     05  PC-P-PPS-DETAIL-LINE23.
189900         10  FILLER                 PIC X(04) VALUE SPACES.
190000         10  FILLER                 PIC X(31) VALUE SPACES.
190100         10  FILLER                 PIC X(01) VALUE SPACE.
190200         10  FILLER                 PIC X(09) VALUE SPACES.
190300         10  FILLER                 PIC X(06) VALUE SPACES.
190400         10  FILLER                 PIC X(02) VALUE SPACES.
190500         10  FILLER                 PIC X(04) VALUE 'PLUS'.
190600         10  FILLER                 PIC X(39) VALUE SPACES.
190700
190800     05  PC-P-PPS-DETAIL-LINE24.
190900         10  FILLER                 PIC X(04) VALUE SPACES.
191000         10  FILLER                 PIC X(31) VALUE SPACES.
191100         10  FILLER                 PIC X(01) VALUE SPACE.
191200         10  FILLER                 PIC X(09).
191300         10  FILLER                 PIC X(06) VALUE SPACES.
191400         10  FILLER                 PIC X(02) VALUE SPACES.
191500         10  FILLER                 PIC X(09) VALUE
191600             'Non Labor'.
191700         10  FILLER                 PIC X(34) VALUE SPACES.
191800
191900     05  PC-P-PPS-DETAIL-LINE25.
192000         10  FILLER                 PIC X(04) VALUE SPACES.
192100         10  FILLER                 PIC X(31) VALUE SPACES.
192200         10  FILLER                 PIC X(01) VALUE SPACE.
192300         10  FILLER                 PIC X(09).
192400         10  FILLER                 PIC X(06) VALUE SPACES.
192500         10  PC-P-G-CBSA-LINE-4     PIC X(31) VALUE SPACES.
192600         10  FILLER                 PIC X(01) VALUE SPACES.
192700         10  PC-P-G-CBSA-WAGE-PMT-RATE-2
192800                                    PIC $$,$$9.99 BLANK WHEN ZERO.
192900         10  FILLER                 PIC X(04) VALUE SPACES.
193000
193100     05  PC-P-PPS-DETAIL-LINE26.
193200         10  FILLER                 PIC X(04) VALUE SPACES.
193300         10  FILLER                 PIC X(31) VALUE SPACES.
193400         10  FILLER                 PIC X(01) VALUE SPACE.
193500         10  FILLER                 PIC X(09) VALUE SPACES.
193600         10  FILLER                 PIC X(06) VALUE SPACES.
193700         10  PC-P-G-CBSA-LINE-5     PIC X(31) VALUE SPACES.
193800         10  FILLER                 PIC X(03) VALUE SPACES.
193900         10  PC-P-G-PPS-NAT-NONLABOR-PCT
194000                                    PIC 9(01).9(05).
194100         10  FILLER                 PIC X(04) VALUE SPACES.
194200
194300     05  PC-P-PPS-DETAIL-LINE27.
194400         10  FILLER                 PIC X(04) VALUE SPACES.
194500         10  FILLER                 PIC X(31) VALUE SPACES.
194600         10  FILLER                 PIC X(01) VALUE SPACE.
194700         10  FILLER                 PIC X(09) VALUE SPACES.
194800         10  FILLER                 PIC X(06) VALUE SPACES.
194900         10  FILLER                 PIC X(02) VALUE SPACES.
195000         10  FILLER                 PIC X(05) VALUE 'TIMES'.
195100         10  FILLER                 PIC X(38) VALUE SPACES.
195200
195300     05  PC-P-PPS-DETAIL-LINE28.
195400         10  FILLER                 PIC X(04) VALUE SPACES.
195500         10  FILLER                 PIC X(31) VALUE SPACES.
195600         10  FILLER                 PIC X(01) VALUE SPACE.
195700         10  FILLER                 PIC X(09) VALUE SPACES.
195800         10  FILLER                 PIC X(06) VALUE SPACES.
195900         10  PC-P-G-CBSA-LINE-6     PIC X(31) VALUE SPACES.
196000         10  FILLER                 PIC X(01) VALUE SPACES.
196100         10  PC-P-G-CBSA-WAGE-ADJ-2 PIC $$,$$9.99 BLANK WHEN ZERO.
196200         10  FILLER                 PIC X(04) VALUE SPACES.
196300
196400*----------------------------------------------------------------*
196500*----------------------------------------------------------------*
196600*WS-6                   DATA FROM THE USER                       *
196700*----------------------------------------------------------------*
196800*----------------------------------------------------------------*
196900
197000*ERROR HANDLING MESSAGES
197100 01 Display-Error.
197200    03 Display-Error-No             PIC 9(4) comp-5.
197300    03 Display-Details-1            PIC 9(4) comp-5.
197400    03 Display-Details-2            PIC 9(4) comp-5.
197500/
197600******************************************************************
197700*----------------------------------------------------------------*
197800*----------------------------------------------------------------*
197900*WS-3                      PROGRAM TABLES                        *
198000*This code came from Tamara Howard and is used in her Long Term  *
198100*Care pricer.  Leave this code in for possible future use on the *
198200*PC                                                              *
198300*----------------------------------------------------------------*
198400*----------------------------------------------------------------*
198500*
198600*----------------------------------------------------------------*
198700*  PPS RETURN CODE TABLE
198800*----------------------------------------------------------------*
198900 01  PPS-RETURN-CODE-DESCS.
199000*    PPS RETURN CODES 00-49 = HOW THE BILL WAS PAID
199100     05                             PIC X(80) VALUE
199200         '00 DRG payment without outlier.'.
199300     05  PIC X(80) VALUE
199400         '01 DRG payment with outlier.'.
199500     05  PIC X(80) VALUE
199600         '02 Short stay payment without outlier.'.
199700     05  PIC X(80) VALUE
199800         '03 Short stay payment with outlier'.
199900     05  PIC X(80) VALUE
200000         '04 Blend year 1 - 80% facility rate plus 20% DRG payment
200100-        ' without outlier.'.
200200     05  PIC X(80) VALUE
200300         '05 Blend year 1 - 80% facility rate plus 20% DRG payment
200400-        ' with outlier.'.
200500     05  PIC X(80) VALUE
200600         '06 Blend year 1 - 80% facility rate plus 20% short stay
200700-        'payment without outlier.'.
200800     05  PIC X(80) VALUE
200900         '07 Blend year 1 - 80% facility rate plus 20% short stay
201000-        'payment with outlier.'.
201100     05  PIC X(80) VALUE
201200         '08 Blend year 2 - 60% facility rate plus 40% DRG payment
201300-        ' without outlier.'.
201400     05  PIC X(80) VALUE
201500         '09 Blend year 2 - 60% facility rate plus 40% DRG payment
201600-        ' with outlier.'.
201700     05  PIC X(80) VALUE
201800         '10 Blend year 2 - 60% facility rate plus 40% short stay
201900-        'payment without outlier.'.
202000     05  PIC X(80) VALUE
202100         '11 Blend year 2 - 60% facility rate plus 40% short stay
202200-        'payment with outlier.'.
202300     05  PIC X(80) VALUE
202400         '12 Blend year 3 - 40% facility rate plus 60% DRG payment
202500-        ' without outlier.'.
202600     05  PIC X(80) VALUE
202700         '13 Blend year 3 - 40% facility rate plus 60% DRG payment
202800-        ' with outlier.'.
202900     05  PIC X(80) VALUE
203000         '14 Blend year 3 - 40% facility rate plus 60% short stay
203100-        'payment without outlier.'.
203200     05  PIC X(80) VALUE
203300         '15 Blend year 3 - 40% facility rate plus 60% short stay
203400-        'payment with outlier.'.
203500     05  PIC X(80) VALUE
203600         '16 Blend year 4 - 20% facility rate plus 80% DRG payment
203700-        ' without outlier.'.
203800     05  PIC X(80) VALUE
203900         '17 Blend year 4 - 20% facility rate plus 80% DRG payment
204000-        ' with outlier.'.
204100     05  PIC X(80) VALUE
204200         '18 Blend year 4 - 20% facility rate plus 80% short stay
204300-        'payment without outlier.'.
204400     05  PIC X(80) VALUE
204500         '19 Blend year 4 - 20% facility rate plus 80% short stay
204600-        'payment with outlier.'.
204700
204800*    PPS RETURN CODES 50-99 = WHY THE BILL WAS NOT PAID
204900
205000 01  PPS-RTC-TABLE REDEFINES PPS-RETURN-CODE-DESCS.
205100     03  PPS-RTC-ENTRY OCCURS 38 TIMES
205200             ASCENDING KEY IS TBL-PPS-RTC
205300             INDEXED BY PPS-RTC-IDX.
205400         05  TBL-PPS-RTC            PIC 99.
205500         05  FILLER                 PIC X(01).
205600         05  PPS-RETURN-CODE-DESC   PIC X(77).
205700
205800*-----------------END OF PPS RETURN CODE TABLE-------------------*
205900/
206000*----------------------------------------------------------------*
206100*----------------------------------------------------------------*
206200*     Data passed TO and FROM the GUI Screenset SUBROUTINES      *
206300*This area is COMPLETELY dependent on screenset data names       *
206400*It will change whenever either the GUI names change, their data *
206500*size change, or their position number within screensets change  *
206600*----------------------------------------------------------------*
206700*----------------------------------------------------------------*
206800
206900*FOR CALL TO DIALOG SYSTEM ("DSGRUN" EXECUTES IT)
207000 01 DIALOG-SYSTEM                   PIC X(06)   VALUE "DSGRUN".
207100
207200*FOR CALL TO DIALOG SYSTEM ("DS" FOR DEBUGGING SCREENSET CODE)
207300 01 ANIMATE-SCREEN                  PIC X(02)   VALUE "DS".
207400
207500******************************************************************
207600*The commented out "versions"   MUST  be switched depending on   *
207700*whether compilation is done on the mainframe or on the PC       *
207800******************************************************************
207900
208000*INCLUDE FIXED COPYFILE FOR DIALOG SYSTEM
208100 COPY "DSCNTRL".
208200*COPY "DSCNTRL.CPY".
208300/
208400*INCLUDE COPYBOOK FOR DIALOG SYSTEM
208500 COPY ESRDGUI.
208600*COPY "ESRDGUI.CPB".
208700/
208800 COPY FILESTAT.
208900*COPY "FILESTAT.CPY".
209000/
209100*The next two copylibs for some reason are not used on the PC.
209200*They were in Tamara Howard's Long Term Care PC pricer.
209300*Therefore do not uncomment them.
209400
209500*INCLUDE COPYFILE FOR DIALOG SYSTEM PANEL LINKING
209600*COPY "PAN2LINK.CPY".
209700
209800*INCLUDE COPYFILE FOR DIALOG SYSTEM PANEL ERRORS
209900*COPY "PAN2ERR.CPY".
210000/
210100 PROCEDURE DIVISION.
210200
210300******************************************************************
210400*  MAIN PROCESSING:                                              *
210500*  ----------------                                              *
210600*    A. Open files and display GUI interface to user.            *
210700*    B. Based on user's request, perform appropriate function.   *
210800*       Available Functions Include:                             *
210900*       ----------------------------                             *
211000*       1. View provider record:                                 *
211100*          - Access provider file and display requested record.  *
211200*       2. Change provider record:                               *
211300*          - Access provider file and display requested record.  *
211400*          - Validate changes entered by user.                   *
211500*          - Implement changes to provider record.               *
211600*       3. Create new provider record.                           *
211700*          - Validate data entered by user for record.           *
211800*          - Add new provider record to file.                    *
211900*       4. Enter a LTCH claim and calculate prospective pymt:    *
212000*          - Validate claim data entered by user.                *
212100*          - Pass bill record, provider record, and wage index   *
212200*            record to calculation program (LTCAL___).           *
212300*       5. Print PPS Payment Details & Provider & Claim Info.    *
212400*       6. Close files and exit application:                     *
212500*          - stop run.                                           *
212600******************************************************************
212700
212800******************************************************************
212900 DECLARATIVES.
213000******************************************************************
213100*----------------------------------------------------------------*
213200 D100-MSA-CBSA-XWALK-FILE-ERROR SECTION.
213300*----------------------------------------------------------------*
213400     USE AFTER ERROR PROCEDURE
213500         ON MSA-CBSA-XWALK-FILE.
213600
213700 D100-SET-UP-CBSAX-FILE.
213800**IF NO ERROR ENCOUNTERED RETURN  TO GET-CBSA ROUTINE
213900     IF MSA-CBSA-STATUS = 00   OR
214000        MSA-CBSA-STATUS = 02   THEN
214100        GO TO D100-EXIT.
214200
214300**SPECIAL ERROR HANDLING IF CBSA IS NOT FOUND
214400     IF MSA-CBSA-STATUS = 23   THEN
214500        SET CBSA-NOT-FOUND        TO TRUE
214600        MOVE 'N'                  TO G-CBSA-FOUND-SW
214700        MOVE 60                   TO PPS-RTC
214800        GO TO D100-EXIT.
214900
215000**ERROR HANDLING FOR ALL OTHER FILE ERRORS ENCOUNTERED
215100     MOVE MSA-CBSA-STATUS         TO FILE-STAT.
215200     MOVE 'CBSA File'             TO G-FILE-NAME.
215300     PERFORM D400-OUTPUT-FILE-ERROR-MSG THRU D400-EXIT.
215400 D100-EXIT.
215500      EXIT.
215600
215700*----------------------------------------------------------------*
215800 D300-PRINT-SPOOL-ERROR   SECTION.
215900*----------------------------------------------------------------*
216000     USE AFTER ERROR PROCEDURE
216100         ON PC-PRINTER-FILE.
216200
216300 D300-PRINT-SPOOL-FILE.
216400**IF NO ERROR ENCOUNTERED RETURN  TO PRINT ROUTINE
216500     IF PC-SPOOLER-FILE-STATUS = '00'  THEN
216600*       DISPLAY 'File status is zero: should not be here'
216700        GO TO D300-EXIT
216800     ELSE
216900*       DISPLAY 'AT D300-PRINT-SPOOL-FILE ERROR: THE STATUS = '
217000*               PC-SPOOLER-FILE-STATUS
217100        MOVE PC-SPOOLER-FILE-STATUS TO FILE-STAT
217200        IF FILE-STAT1 = '9'  THEN
217300           MOVE FILE-STAT2        TO GENERIC-STAT2-DISPLAY
217400        ELSE
217500           MOVE FILE-9-STAT2      TO GENERIC-STAT2-DISPLAY
217600*          DISPLAY 'FILE STATUS = ' PC-GENERIC-STAT-DISPLAY
217700        END-IF
217800     END-IF.
217900
218000     MOVE PC-SPOOLER-FILE-STATUS  TO FILE-STAT.
218100     MOVE 'Print File'            TO G-FILE-NAME.
218200     PERFORM D400-OUTPUT-FILE-ERROR-MSG THRU D400-EXIT.
218300
218400 D300-EXIT.
218500      EXIT.
218600
218700 D400-OUTPUT-FILE-ERROR-MSG.
218800
218900**ERROR HANDLING FOR ALL FILE ERRORS ENCOUNTERED
219000     SET FILE-STATUS-IDX, FILE-STATUS-9-IDX TO 1.
219100
219200*SEARCH FOR AN EXTENDED FILE STATUS CODE (3 DIGITS)
219300     IF FILE-STAT1 = '9'
219400        SEARCH FILE-STATUS-9-ENTRY VARYING FILE-STATUS-9-IDX
219500           AT END
219600              MOVE FILE-STAT TO G-FILE-STATUS
219700              MOVE 'A run-time error has occured.'
219800                                  TO G-FILE-ERROR-DESC
219900*             DISPLAY 'A run-time error has occured.'
220000           WHEN TBL-FILE-STATUS-9(FILE-STATUS-9-IDX) =
220100              FILE-9-STAT2
220200              MOVE FILE-9-STAT2 TO G-FILE-STATUS
220300              MOVE TBL-FILE-STATUS-9-MSG(FILE-STATUS-9-IDX)
220400                                  TO G-FILE-ERROR-DESC
220500*             DISPLAY TBL-FILE-STATUS-9-MSG(FILE-STATUS-9-IDX)
220600        END-SEARCH
220700     ELSE
220800        IF FILE-STAT1 = '3'  AND  FILE-STAT2 = '4'  THEN
220900           NEXT SENTENCE
221000*          DISPLAY 'Disk space full'
221100        ELSE
221200*SEARCH FOR A GENERAL FILE STATUS CODE (2 DIGITS)
221300           SEARCH FILE-STATUS-ENTRY VARYING FILE-STATUS-IDX
221400              AT END
221500                 MOVE FILE-STAT TO G-FILE-STATUS
221600                 MOVE 'An error has occured in this file.'
221700                                  TO G-FILE-ERROR-DESC
221800              WHEN TBL-FILE-STATUS(FILE-STATUS-IDX) = FILE-STAT
221900                 MOVE FILE-STAT TO G-FILE-STATUS
222000                 MOVE TBL-FILE-STATUS-MSG(FILE-STATUS-IDX)
222100                                  TO G-FILE-ERROR-DESC
222200           END-SEARCH
222300        END-IF
222400     END-IF.
222500
222600     MOVE 'Y'                     TO G-MAJOR-FILE-ERR-SW.
222700
222800
222900 D400-EXIT.
223000      EXIT.
223100
223200 END DECLARATIVES.
223300/
223400******************************************************************
223500 1000-START-TO-FINISH SECTION.
223600******************************************************************
223700
223800******************************************************************
223900*  Since the DS-CNTRL copylib must be different between the
224000*mainframe and the PC due to Microfocus COBOL pecularities (the
224100*program will not compile correctly on the mainframe if they were
224200*the same, a trick is incorporated within this copylib to determin
224300*if the same code is running on the mainframe or on the PC.  The
224400*MAINFRAME-PC-SWITCH is different on the two versions of the
224500*copylib.  This copylib is highly unlikely to change on the PC.
224600******************************************************************
224700
224800*The following should be the only error that you get when you
224900*compile on the mainframe.  This is only a warning and so does
225000*not affect the running of the program.  This warning can not
225100*be eliminated since the IBM compiler is truely marvelous and
225200*catches it since it examines the value of each element and
225300*notices the 'apparent error'.
225400*
225500*IGYOP3011-W   CODE FROM "DISPLAY (LINE 2800.01)" TO "STOP (LINE
225600*2800) CAN NEVER BE EXECUTED AND WAS THEREFORE DISCARDED.
225700
225800     INITIALIZE DS-ERROR-CODE.
225900
226000     IF MAINFRAME-PC-SWITCH  =  DS-ERROR-CODE  THEN
226100        PERFORM  8000-MAINFRAME-CODE
226200     ELSE
226300        PERFORM 1001-PC-CODE
226400     END-IF.
226500
226600     STOP RUN.
226700/
226800******************************************************************
226900******************************************************************
227000*. . . THE CODE BELOW IS STRICTLY FOR USE ON MICRO FOCUS COBOL . .
227100******************************************************************
227200******************************************************************
227300
227400******************************************************************
227500 1000-PC-CODE-PART    SECTION.
227600******************************************************************
227700 1001-PC-CODE.
227800     MOVE WHEN-COMPILED           TO COMPILED-DATE.
227900*    DISPLAY 'PC VERSION COMPILED ON ' COMPILED-DATE.
228000     ACCEPT TODAYS-DATE FROM DATE YYYYMMDD.
228100     ACCEPT TODAYS-TIME FROM TIME.
228200*    DISPLAY 'Todays date is                       ' TODAYS-DATE.
228300*    DISPLAY 'Time that the program was started is ' TODAYS-TIME.
228400*    DISPLAY ' '.
228500     PERFORM 1100-INITIALIZATION.
228600     MOVE SPACES                  TO G-BUTTON-CODE.
228700     PERFORM 1200-GUI-COMMUNICATION
228800         UNTIL G-BUTTON-CODE = 'EXIT'.
228900
229000
229100******************************************************************
229200 1100-INITIALIZATION.
229300******************************************************************
229400**INITIALIZE HOLD AREAS USED IN PPS CALC
229500     INITIALIZE BILL-NEW-DATA,
229600                PPS-DATA-ALL,
229700                DATA-BLOCK
229800                PRT-DETAIL-LINE-1A
229900                PRT-DETAIL-LINE-2A
230000                PRT-DETAIL-LINE-1B
230100                PRT-DETAIL-LINE-2B
230200                DATE-WORK-AREA.
230300
230400
230500**LOAD SCREENSET NAMED BY DS-SET-NAME
230600     INITIALIZE DS-CONTROL-BLOCK, DATA-BLOCK.
230700     MOVE "N"                     TO DS-CONTROL.
230800
230900**VERIFY THAT PROGRAM IS CALLING CORRECT VERSION OF SCREENSET
231000     MOVE DATA-BLOCK-VERSION-NO   TO DS-DATA-BLOCK-VERSION-NO.
231100     MOVE VERSION-NO              TO DS-VERSION-NO.
231200     MOVE MANAGER-VERSION         TO PRT-PPMGR-VERSION.
231300     MOVE "ESRDGUI"               TO DS-SET-NAME.
231400     MOVE "Y"                     TO WELCOME-CODE.
231500     MOVE PRICER-EFFECTIVE-BEGIN-DT
231600                                  TO G-PRICER-BEGIN-DT.
231700     MOVE PRICER-EFFECTIVE-END-DT TO G-PRICER-END-DT.
231800     MOVE 'NA'                    TO G-B-COND-CODE.
231900     ADD 1 TO THIS-YEAR  GIVING  NEXT-YEAR.
232000     MOVE THIS-MONTH              TO PC-P-MM.
232100     MOVE THIS-DAY                TO PC-P-DD.
232200     MOVE THIS-YEAR               TO PC-P-CCYY.
232300*Whenever the MicroFocus screens change, the next variable
232400*should also change to reflect the new version number
232500     MOVE PC-SCREEN-PRICER-VERSION
232600                                  TO PC-P-SCREEN-VERS.
232700*Whenever the manager program changes, the next variable
232800*should also change to reflect the new version number.
232900     MOVE MANAGER-VERSION         TO PC-P-MANAGER-VERS.
233000*The above two variables are independent of one another and
233100*reflect the totality of changes that can occur on the PC version.
233200     MOVE PC-P-VERSION            TO G-PRICER-VERSION.
233300/
233400*----------------------------------------------------------------*
233500 1200-GUI-COMMUNICATION.
233600*----------------------------------------------------------------*
233700
233800**CALL DIALOG SYSTEM FOR DEBUGGING SCREENSET CODE                *
233900*    CALL ANIMATE-SCREEN USING DS-CONTROL-BLOCK, DATA-BLOCK.
234000
234100**PASS CONTROL BLOCK & DATA BLOCK TO DIALOG SYSTEM, PROCESS, AND *
234200* DISPLAY APPROPRIATE SCREEN TO USER                             *
234300     CALL DIALOG-SYSTEM USING DS-CONTROL-BLOCK, DATA-BLOCK.
234400
234500
234600**GUI ERROR HANDLING UPON RETURN FROM DIALOG SYSTEM--------------*
234700     IF NOT DS-NO-ERROR
234800        MOVE DS-SYSTEM-ERROR      TO Display-error
234900*       DISPLAY "DS ERROR NO:         "  Display-error-no
235000*       DISPLAY "Error Details(1) :   "  Display-Details-1
235100*       DISPLAY "Error Details(2) :   "  Display-Details-2
235200     ELSE
235300*PREPARE FILES UPON ENTRANCE INTO THE APPLICATION----------------*
235400        IF WELCOME-CODE = "Y"   AND
235500           G-BUTTON-CODE NOT = 'EXIT'   THEN
235600           PERFORM 1250-PREPARE-FILES
235700        END-IF
235800*PERFORM APPROPRIATE PROCEDURE ACCORDING TO BUTTON PRESSED-------*
235900        EVALUATE G-BUTTON-CODE
236000
236100           WHEN 'CLAIM'
236200                PERFORM 2100-PROCESS-CLAIM-SCREEN  THRU
236300                        2100-PROCESS-CLAIM-SCREEN-EXIT
236400
236500           WHEN 'PRINT'
236600                PERFORM 4100-PROCESS-PRINT-SCREEN  THRU
236700                        4100-PROCESS-PRINT-SCREEN-EXIT
236800
236900           WHEN 'HELP'
237000                PERFORM 5000-PROCESS-HELP-SCREEN  THRU
237100                        5000-PROCESS-HELP-SCREEN-EXIT
237200
237300           WHEN 'EXIT'
237400                PERFORM 6000-PROCESS-EXIT-SCREEN  THRU
237500                        6000-PROCESS-EXIT-SCREEN-EXIT
237600
237700        END-EVALUATE.
237800
237900
238000*----------------------------------------------------------------*
238100 1250-PREPARE-FILES.
238200*----------------------------------------------------------------*
238300**RECEIVE THE INSTALLATION DRIVE FROM THE USER
238400*    MOVE G-DRIVE                 TO XWALK-DRIVE, PC-P-DRIVE.
238500**SET THE CURRENT DIRECTORY NAME FOR ALL FILES USED IN PROGRAM   *
238600     MOVE "C:"                    TO PC-DIR-DRIVE
238700                                     PC-P-DRIVE
238800                                     PC-D-DRIVE.
238900     MOVE DIRECTORY-NAME          TO PC-DIR-NAME
239000                                     PC-P-DIRECTORY
239100                                     PC-D-DIRECTORY.
239200     MOVE FILE-NAME               TO PC-P-FILENAME
239300                                     PC-C-FILENAME.
239400*    DISPLAY 'PC-DIRECTORY-NAME = ' PC-DIRECTORY-NAME.
239500     MOVE ZERO                    TO CREATE-STATUS-CD.
239600*    DISPLAY 'BEFORE DIR CREATE STATUS CODE' CREATE-STATUS-CD.
239700
239800     CALL CBL-CREATE-DIR   USING  PC-DIRECTORY-NAME
239900                       RETURNING  CREATE-STATUS-CD
240000     END-CALL.
240100
240200*    DISPLAY 'AFTER DIR CREATE STATUS CODE = ' CREATE-STATUS-CD.
240300
240400*    IF CREATE-STATUS-CD = ZERO THEN
240500*       DISPLAY 'Directory CREATED for use in printing'
240600*    ELSE
240700*       IF CREATE-STATUS-CD = 14605  THEN
240800*          DISPLAY 'Directory already exists' CREATE-STATUS-CD
240900*       ELSE
241000*          DISPLAY 'Directory creation problem ' CREATE-STATUS-CD
241100*       END-IF
241200*    END-IF.
241300
241400
241500**OPEN MAIN FILES
241600**RECEIVE THE INSTALLATION DRIVE FROM THE USER
241700*    MOVE G-DRIVE                 TO XWALK-DRIVE, PC-P-DRIVE.
241800
241900**SET THE CURRENT DIRECTORY NAME FOR ALL FILES
242000*    MOVE DIRECTORY-NAME          TO XWALK-DRIVE, PC-P-DIRECTORY.
242100
242200**OPEN MAIN FILES
242300*    OPEN MSA-CBSA-XWALK-FILE.
242400
242500
242600**SET "WELCOME" (FIRST TIME THROUGH) FLAG OFF
242700     MOVE "N"                     TO WELCOME-CODE.
242800/
242900******************************************************************
243000 2000-PPS-PROCESSING SECTION.
243100******************************************************************
243200*----------------------------------------------------------------*
243300 2100-PROCESS-CLAIM-SCREEN.
243400     INITIALIZE BILL-NEW-DATA,
243500                PPS-DATA-ALL.
243600     MOVE 00                      TO PPS-RTC.
243700
243800*TRANSFER INPUT GUI DATA  TO  PPS-DATA-AREA----------------------*
243900*VALIDATE BIRTH DATE                                             *
244000     MOVE G-B-DOB-DATE            TO GUI-DATE.
244100     MOVE GUI-YEAR                TO MAINFRAME-YEAR.
244200     MOVE GUI-MONTH               TO MAINFRAME-MONTH.
244300     MOVE GUI-DAY                 TO MAINFRAME-DAY.
244400     MOVE MAINFRAME-DATE-FORMAT   TO B-DOB-DATE.
244500
244600*VALIDATE BIRTH MONTH                                            *
244700     IF (GUI-MONTH > 0) AND (GUI-MONTH < 13)  THEN
244800        NEXT SENTENCE
244900     ELSE
245000        MOVE 76 TO PPS-RTC
245100     END-IF.
245200
245300*VALIDATE BIRTH YEAR                                             *
245400     IF GUI-YEAR > 1890  THEN
245500        NEXT SENTENCE
245600     ELSE
245700        MOVE 76 TO PPS-RTC
245800     END-IF.
245900
246000     MOVE GUI-MONTH               TO HOLD-MONTH.
246100     MOVE GUI-YEAR                TO HOLD-YEAR.
246200
246300*VALIDATE BIRTH DAY                                              *
246400     IF (GUI-DAY > 0)  AND  (GUI-DAY < 32)  THEN
246500        IF 31-DAY-MONTH  THEN
246600           NEXT SENTENCE
246700        ELSE
246800           IF GUI-DAY < 31  THEN
246900              IF 30-DAY-MONTH  THEN
247000                 NEXT SENTENCE
247100              ELSE
247200                 IF (GUI-DAY < 29)  AND  FEBRUARY  THEN
247300                    NEXT SENTENCE
247400                 ELSE
247500                    IF (GUI-DAY < 30) AND  FEBRUARY  THEN
247600                       IF FUNCTION MOD (HOLD-YEAR 400) = 0  THEN
247700                          NEXT SENTENCE
247800                       ELSE
247900                          IF FUNCTION MOD(HOLD-YEAR 100) = 0 THEN
248000                             MOVE 76 TO PPS-RTC
248100                          ELSE
248200                             IF FUNCTION MOD(HOLD-YEAR 4)= 0 THEN
248300                                NEXT SENTENCE
248400                             ELSE
248500                                MOVE 76 TO PPS-RTC
248600                             END-IF
248700                          END-IF
248800                       END-IF
248900                    ELSE
249000                       MOVE 76    TO PPS-RTC
249100                    END-IF
249200                 END-IF
249300              END-IF
249400           ELSE
249500              MOVE 76             TO PPS-RTC
249600           END-IF
249700        END-IF
249800     ELSE
249900        MOVE 76                   TO PPS-RTC
250000     END-IF.
250100
250200     IF PPS-RTC = 00  THEN
250300        NEXT SENTENCE
250400     ELSE
250500        GO TO 2100-PROCESS-CLAIM-SCREEN-EXIT
250600     END-IF.
250700
250800*VALIDATE CLAIM DATE                                             *
250900     MOVE G-B-THRU-DATE           TO GUI-DATE.
251000     MOVE GUI-YEAR                TO CLAIM-YEAR.
251100     MOVE GUI-YEAR                TO MAINFRAME-YEAR.
251200     MOVE GUI-MONTH               TO MAINFRAME-MONTH.
251300     MOVE GUI-DAY                 TO MAINFRAME-DAY.
251400     MOVE MAINFRAME-DATE-FORMAT   TO B-THRU-DATE.
251500
251600*Need to VALIDATE G-B-NUM-DIALYSIS-SESSIONS                      *
251700     MOVE G-B-NUM-DIALYSIS-SESSIONS    TO
251800                               B-CLAIM-NUM-DIALYSIS-SESSIONS.
251900
252000*Need to VALIDATE G-B-SEPARATELY-BILLABLE-AMT                    *
252100     MOVE G-B-SEPARATELY-BILLABLE-AMT
252200                                  TO B-TOT-PRICE-SB-OUTLIER.
252300
252400     IF G-B-ACUTE-MA = 'Y'  THEN
252500        MOVE 'MA'                 TO COMORBID-DATA (1)
252600     ELSE
252700        MOVE SPACES               TO COMORBID-DATA (1)
252800     END-IF.
252900
253000     IF G-B-ACUTE-MB = 'Y'  THEN
253100        MOVE 'MB'                 TO COMORBID-DATA (2)
253200     ELSE
253300        MOVE SPACES               TO COMORBID-DATA (2)
253400     END-IF.
253500
253600     IF G-B-ACUTE-MC = 'Y'  THEN
253700        MOVE 'MC'                 TO COMORBID-DATA (3)
253800     ELSE
253900        MOVE SPACES               TO COMORBID-DATA (3)
254000     END-IF.
254100
254200     IF G-B-CHRONIC-MD = 'Y'  THEN
254300        MOVE 'MD'                 TO COMORBID-DATA (4)
254400     ELSE
254500        MOVE SPACES               TO COMORBID-DATA (4)
254600     END-IF.
254700
254800     IF G-B-CHRONIC-ME = 'Y'  THEN
254900        MOVE 'ME'                 TO COMORBID-DATA (5)
255000     ELSE
255100        MOVE SPACES               TO COMORBID-DATA (5)
255200     END-IF.
255300
255400     IF G-B-CHRONIC-MF = 'Y'  THEN
255500        MOVE 'MF'                 TO COMORBID-DATA (6)
255600     ELSE
255700        MOVE SPACES               TO COMORBID-DATA (6)
255800     END-IF.
255900
256000     MOVE SPACES                  TO COMORBID-CWF-RETURN-CODE.
256100
256200     IF G-B-DIALYSIS-START-DATE = 'Y'  THEN
256300        MOVE B-THRU-DATE          TO B-DIALYSIS-START-DATE
256400        MOVE B-THRU-DATE          TO B-LINE-ITEM-DATE-SERVICE
256500     ELSE
256600        MOVE ZERO                 TO B-DIALYSIS-START-DATE
256700        MOVE B-THRU-DATE          TO B-LINE-ITEM-DATE-SERVICE
256800     END-IF.
256900
257000*VALIDATE CLAIM MONTH                                            *
257100     IF (GUI-MONTH > 0) AND (GUI-MONTH < 13)  THEN
257200        NEXT SENTENCE
257300     ELSE
257400        MOVE 75 TO PPS-RTC
257500     END-IF.
257600
257700*VALIDATE CLAIM YEAR                                             *
257800     IF GUI-YEAR > 2004  THEN
257900        NEXT SENTENCE
258000     ELSE
258100        MOVE 75 TO PPS-RTC
258200     END-IF.
258300
258400     MOVE GUI-MONTH               TO HOLD-MONTH.
258500     MOVE GUI-YEAR                TO HOLD-YEAR.
258600
258700*VALIDATE CLAIM DAY                                              *
258800     IF (GUI-DAY > 0)  AND  (GUI-DAY < 32)  THEN
258900        IF 31-DAY-MONTH  THEN
259000           NEXT SENTENCE
259100        ELSE
259200           IF GUI-DAY < 31  THEN
259300              IF 30-DAY-MONTH  THEN
259400                 NEXT SENTENCE
259500              ELSE
259600                 IF (GUI-DAY < 29)  AND  FEBRUARY  THEN
259700                    NEXT SENTENCE
259800                 ELSE
259900                    IF (GUI-DAY < 30) AND  FEBRUARY  THEN
260000                       IF FUNCTION MOD (HOLD-YEAR 400) = 0  THEN
260100                          NEXT SENTENCE
260200                       ELSE
260300                          IF FUNCTION MOD(HOLD-YEAR 100) = 0 THEN
260400                             MOVE 75 TO PPS-RTC
260500                          ELSE
260600                             IF FUNCTION MOD(HOLD-YEAR 4)= 0 THEN
260700                                NEXT SENTENCE
260800                             ELSE
260900                                MOVE 75 TO PPS-RTC
261000                             END-IF
261100                          END-IF
261200                       END-IF
261300                    ELSE
261400                       MOVE 75    TO PPS-RTC
261500                    END-IF
261600                 END-IF
261700              END-IF
261800           ELSE
261900              MOVE 75             TO PPS-RTC
262000           END-IF
262100        END-IF
262200     ELSE
262300        MOVE 75                   TO PPS-RTC
262400     END-IF.
262500
262600     IF PPS-RTC = 00  THEN
262700        NEXT SENTENCE
262800     ELSE
262900        GO TO 2100-PROCESS-CLAIM-SCREEN-EXIT
263000     END-IF.
263100
263200*VALIDATE CONNECTION BETWEEN BIRTH DATE AND CLAIM DATE           *
263300     IF B-DOB-DATE < B-THRU-DATE  THEN
263400        NEXT SENTENCE
263500     ELSE
263600        MOVE 74                   TO PPS-RTC
263700     END-IF.
263800
263900*Testing for next years PC-Pricer can only occur during the      *
264000*months of November and December of the current year (i.e. when  *
264100*the wage index table for next year is available - and loaded    *
264200*into the driver).                                               *
264300     IF GUI-YEAR > THIS-YEAR  THEN
264400        IF G-P-MSA = 'TEST'  THEN
264500           IF GUI-YEAR > NEXT-YEAR  THEN
264600              MOVE 99             TO PPS-RTC
264700           ELSE
264800              IF THIS-MONTH < 11  THEN
264900                 MOVE 99          TO PPS-RTC
265000              ELSE
265100                 NEXT SENTENCE
265200              END-IF
265300           END-IF
265400        ELSE
265500           MOVE 99                TO PPS-RTC
265600        END-IF
265700     END-IF.
265800
265900     IF PPS-RTC = 00  THEN
266000        NEXT SENTENCE
266100     ELSE
266200        GO TO 2100-PROCESS-CLAIM-SCREEN-EXIT
266300     END-IF.
266400
266500*FORMAT MSA IF IN APPROPRIATE DATA PRESENT                       *
266600     IF G-P-MSA = '    ' THEN
266700        MOVE G-P-MSA                      TO P-GEO-MSA
266800        IF CLAIM-YEAR > 2008  THEN
266900           NEXT SENTENCE
267000        ELSE
267100           MOVE 91                        TO PPS-RTC
267200        END-IF
267300     ELSE
267400        IF CLAIM-YEAR > 2008  AND  G-P-MSA = 'TEST'  THEN
267500           MOVE G-P-MSA                   TO P-GEO-MSA
267600        ELSE
267700           IF CLAIM-YEAR > 2008  THEN
267800              MOVE SPACES                 TO G-P-MSA
267900                                             P-GEO-MSA
268000           ELSE
268100              PERFORM 2110-FORMAT-MSA
268200           END-IF
268300        END-IF
268400     END-IF.
268500
268600
268700*FORMAT CBSA IF IN APPROPRIATE DATA PRESENT                      *
268800     IF G-P-CBSA = '     ' THEN
268900        MOVE G-P-CBSA                     TO P-GEO-CBSA
269000        IF CLAIM-YEAR < 2006  THEN
269100           NEXT SENTENCE
269200        ELSE
269300           MOVE 92                        TO PPS-RTC
269400        END-IF
269500     ELSE
269600        IF CLAIM-YEAR < 2006  THEN
269700           MOVE SPACES                    TO G-P-CBSA
269800                                             P-GEO-CBSA
269900        ELSE
270000           PERFORM 2120-FORMAT-CBSA
270100        END-IF
270200     END-IF.
270300
270400
270500*PROVIDER INFORMATION                                            *
270600     IF G-FACILITY-TYPE-DESC = 'Hospital Based' THEN
270700        MOVE '40'                 TO P-PROV-TYPE
270800     ELSE
270900        IF G-FACILITY-TYPE-DESC = 'Independent' THEN
271000           MOVE '41'              TO P-PROV-TYPE
271100        ELSE
271200           MOVE 90                TO PPS-RTC
271300        END-IF
271400     END-IF.
271500
271600*Need to VALIDATE G-P-WAIVE-BLEND WITH YEARS 2011 - 2013         *
271700     IF G-P-WAIVE-BLEND = 'Y'  THEN
271800        MOVE 'Y'                  TO P-PROV-WAIVE-BLEND-PAY-INDIC
271900     ELSE
272000        MOVE 'N'                  TO P-PROV-WAIVE-BLEND-PAY-INDIC
272100     END-IF.
272200
272300     IF CLAIM-YEAR > 2013  THEN
272400        MOVE 'Y'                  TO P-PROV-WAIVE-BLEND-PAY-INDIC
272500     END-IF.
272600
272700     IF G-P-LOW-VOLUME = 'Y'  THEN
272800        MOVE 'Y'                  TO P-PROV-LOW-VOLUME-INDIC
272900     ELSE
273000        MOVE 'N'                  TO P-PROV-LOW-VOLUME-INDIC
273100     END-IF.
273200
273300     MOVE G-B-PATIENT-WGT         TO B-PATIENT-WGT.
273400     MOVE G-B-PATIENT-HGT         TO B-PATIENT-HGT.
273500*    HICAN is for information only and used only on screens      *
273600
273700     IF G-B-COND-CODE = 'NA'  THEN
273800        MOVE SPACES               TO B-COND-CODE
273900     ELSE
274000        MOVE G-B-COND-CODE        TO B-COND-CODE
274100     END-IF.
274200
274300     MOVE G-B-REV-CODE3           TO REV-CODE-NUMERIC.
274400     MOVE REV-CODE-NUMERIC        TO B-REV-CODE.
274500     MOVE "T"                     TO OLD-TEST-INDICATOR
274600                                     BUNDLED-TEST-INDIC.
274700
274800     IF PPS-RTC = 00  THEN
274900        NEXT SENTENCE
275000     ELSE
275100        MOVE PPS-RTC              TO G-PPS-RTC
275200        GO TO 2100-PROCESS-CLAIM-SCREEN-EXIT
275300     END-IF.
275400
275500*CALL the current year driver                                    *
275600     CALL  CURRENT-YR-DRIVER   USING BILL-NEW-DATA
275700                               PPS-DATA-ALL.
275800
275900     MOVE PPS-RTC                 TO G-PPS-RTC.
276000
276100     IF PPS-RTC < 36 THEN
276200        NEXT SENTENCE
276300     ELSE
276400        GO TO 2100-PROCESS-CLAIM-SCREEN-EXIT
276500     END-IF.
276600
276700*Prepare to populate both sets of PPS Screens with common data   *
276800*TRANSFER PPS-DATA-AREA AND OTHER FIELDS  TO  GUI PPS AREA-------*
276900*Final payment tab of the PPS-screen                             *
277000*  outside of boxes                                              *
277100     MOVE PPS-CALC-VERS-CD        TO G-PPS-CALC-VERS-CD.
277200     MOVE B-THRU-DATE             TO MAINFRAME-DATE-FORMAT.
277300     MOVE MAINFRAME-YEAR          TO READABLE-YEAR.
277400     MOVE MAINFRAME-YEAR          TO G-B-THRU-YYYY.
277500     MOVE MAINFRAME-MONTH         TO READABLE-MONTH.
277600     MOVE MAINFRAME-DAY           TO READABLE-DAY.
277700     MOVE READABLE-DATE           TO G-PPS-CLAIM-THRU-DATE.
277800* HICAN is already available as it is only for info only         *
277900
278000     IF MAINFRAME-YEAR < 2011  THEN
278100        PERFORM 2205-DISPLAY-COMP-RATE-SCREEN
278200     ELSE
278300        PERFORM 2211-DISPLAY-NEW-PPS-SCREEN
278400     END-IF.
278500
278600 2100-PROCESS-CLAIM-SCREEN-EXIT.
278700     MOVE PPS-RTC                 TO G-PPS-RTC.
278800/
278900 2110-FORMAT-MSA.
279000     MOVE G-P-MSA                 TO HOLD-G-P-MSA.
279100     IF HOLD-G-P-MSA   NUMERIC  THEN
279200*All characters are digits                                       *
279300        IF HOLD-G-P-MSA-R (1) = ZERO  AND
279400           HOLD-G-P-MSA-R (2) = ZERO  THEN
279500           IF HOLD-G-P-MSA-R (3) = 4 OR 6 OR 8  THEN
279600              MOVE HOLD-G-P-MSA        TO P-GEO-MSA
279700           ELSE
279800              MOVE SPACES              TO MSA-STATE-CODE-R (1)
279900              MOVE SPACES              TO MSA-STATE-CODE-R (2)
280000              MOVE HOLD-G-P-MSA-R (3)  TO MSA-STATE-CODE-R (3)
280100              MOVE HOLD-G-P-MSA-R (4)  TO MSA-STATE-CODE-R (4)
280200              MOVE MSA-STATE-CODE      TO P-GEO-MSA
280300           END-IF
280400        ELSE
280500           MOVE HOLD-G-P-MSA           TO P-GEO-MSA
280600        END-IF
280700     ELSE
280800*At least one character is not a digit                           *
280900        COMPUTE X = 4
281000        COMPUTE Y = 4
281100        COMPUTE NUMBER-DIGITS = ZERO
281200        MOVE 'N'                       TO GOT-STATE-CODE
281300        PERFORM UNTIL GOT-STATE-CODE = 'Y'
281400*Start examining characters in reverse order looking only for digi
281500           IF HOLD-G-P-MSA-R (X) NUMERIC  THEN
281600              MOVE HOLD-G-P-MSA-R (X)  TO MSA-STATE-CODE-R (Y)
281700              COMPUTE X = X - 1
281800              COMPUTE Y = Y - 1
281900              COMPUTE NUMBER-DIGITS = NUMBER-DIGITS + 1
282000              IF X = ZERO  THEN
282100*Last examined character is a digit                              *
282200                 IF NUMBER-DIGITS = 2  THEN
282300                    MOVE SPACE         TO MSA-STATE-CODE-R (2)
282400                    MOVE SPACE         TO MSA-STATE-CODE-R (1)
282500                 ELSE
282600                    IF NUMBER-DIGITS = 1  THEN
282700                       MOVE ZERO       TO MSA-STATE-CODE-R (3)
282800                       MOVE SPACE      TO MSA-STATE-CODE-R (2)
282900                       MOVE SPACE      TO MSA-STATE-CODE-R (1)
283000                    ELSE
283100                       MOVE ZERO       TO MSA-STATE-CODE-R (1)
283200                    END-IF
283300                 END-IF
283400                 MOVE 'Y'              TO GOT-STATE-CODE
283500              END-IF
283600           ELSE
283700              COMPUTE X = X - 1
283800              IF X = ZERO  THEN
283900*Last examined character is NOT a digit                          *
284000                 IF NUMBER-DIGITS = 2  THEN
284100                    MOVE SPACE         TO MSA-STATE-CODE-R (2)
284200                    MOVE SPACE         TO MSA-STATE-CODE-R (1)
284300                 ELSE
284400                    IF NUMBER-DIGITS = 1  THEN
284500                       MOVE ZERO       TO MSA-STATE-CODE-R (3)
284600                       MOVE SPACE      TO MSA-STATE-CODE-R (2)
284700                       MOVE SPACE      TO MSA-STATE-CODE-R (1)
284800                    ELSE
284900                       IF NUMBER-DIGITS = 3  THEN
285000                          MOVE SPACE   TO MSA-STATE-CODE-R (1)
285100                       ELSE
285200*There were no digits in the MSA                                 *
285300                          MOVE SPACES  TO MSA-STATE-CODE
285400                          MOVE 91      TO PPS-RTC
285500                       END-IF
285600                    END-IF
285700                 END-IF
285800                 MOVE 'Y'              TO GOT-STATE-CODE
285900              END-IF
286000           END-IF
286100        END-PERFORM
286200        MOVE MSA-STATE-CODE            TO P-GEO-MSA
286300     END-IF.
286400
286500     MOVE P-GEO-MSA               TO G-P-MSA.
286600/
286700 2120-FORMAT-CBSA.
286800      MOVE G-P-CBSA               TO HOLD-G-P-CBSA.
286900      IF HOLD-G-P-CBSA NUMERIC  THEN
287000*All characters are digits                                       *
287100         IF HOLD-G-P-CBSA-R (1) = ZERO  AND
287200            HOLD-G-P-CBSA-R (2) = ZERO  AND
287300            HOLD-G-P-CBSA-R (3) = ZERO  THEN
287400            MOVE SPACES                 TO CBSA-STATE-CODE-R (1)
287500            MOVE SPACES                 TO CBSA-STATE-CODE-R (2)
287600            MOVE SPACES                 TO CBSA-STATE-CODE-R (3)
287700            MOVE HOLD-G-P-CBSA-R (4)    TO CBSA-STATE-CODE-R (4)
287800            MOVE HOLD-G-P-CBSA-R (5)    TO CBSA-STATE-CODE-R (5)
287900            MOVE CBSA-STATE-CODE        TO P-GEO-CBSA
288000         ELSE
288100            MOVE HOLD-G-P-CBSA          TO P-GEO-CBSA
288200         END-IF
288300      ELSE
288400*At least one character is not a digit                           *
288500         COMPUTE X = 5
288600         COMPUTE Y = 5
288700         COMPUTE NUMBER-DIGITS = ZERO
288800         MOVE 'N'                       TO GOT-STATE-CODE
288900         PERFORM UNTIL GOT-STATE-CODE = 'Y'
289000*Start examining characters in reverse order looking only for digi
289100            IF HOLD-G-P-CBSA-R (X) NUMERIC  THEN
289200               MOVE HOLD-G-P-CBSA-R (X) TO CBSA-STATE-CODE-R (Y)
289300               COMPUTE X = X - 1
289400               COMPUTE Y = Y - 1
289500               COMPUTE NUMBER-DIGITS = NUMBER-DIGITS + 1
289600               IF X = ZERO  THEN
289700*Last examined character is a digit                              *
289800                  IF NUMBER-DIGITS = 2  THEN
289900                     MOVE SPACE         TO CBSA-STATE-CODE-R (3)
290000                     MOVE SPACE         TO CBSA-STATE-CODE-R (2)
290100                     MOVE SPACE         TO CBSA-STATE-CODE-R (1)
290200                  ELSE
290300                     IF NUMBER-DIGITS = 1  THEN
290400                        MOVE ZERO       TO CBSA-STATE-CODE-R (4)
290500                        MOVE SPACE      TO CBSA-STATE-CODE-R (3)
290600                        MOVE SPACE      TO CBSA-STATE-CODE-R (2)
290700                        MOVE SPACE      TO CBSA-STATE-CODE-R (1)
290800                     ELSE
290900                        IF NUMBER-DIGITS = 3  THEN
291000                           MOVE SPACE   TO CBSA-STATE-CODE-R (2)
291100                           MOVE SPACE   TO CBSA-STATE-CODE-R (1)
291200                        ELSE
291300                           MOVE SPACE   TO CBSA-STATE-CODE-R (1)
291400                        END-IF
291500                     END-IF
291600                  END-IF
291700                  MOVE 'Y'              TO GOT-STATE-CODE
291800               END-IF
291900            ELSE
292000               COMPUTE X = X - 1
292100               IF X = ZERO  THEN
292200*Last examined character is NOT a digit                          *
292300                  IF NUMBER-DIGITS = 2  THEN
292400                    MOVE SPACE          TO CBSA-STATE-CODE-R (3)
292500                    MOVE SPACE          TO CBSA-STATE-CODE-R (2)
292600                    MOVE SPACE          TO CBSA-STATE-CODE-R (1)
292700                 ELSE
292800                    IF NUMBER-DIGITS = 1  THEN
292900                       MOVE ZERO        TO CBSA-STATE-CODE-R (4)
293000                       MOVE SPACE       TO CBSA-STATE-CODE-R (3)
293100                       MOVE SPACE       TO CBSA-STATE-CODE-R (2)
293200                       MOVE SPACE       TO CBSA-STATE-CODE-R (1)
293300                    ELSE
293400                       IF NUMBER-DIGITS = 3  THEN
293500                          MOVE SPACE    TO CBSA-STATE-CODE-R (2)
293600                          MOVE SPACE    TO CBSA-STATE-CODE-R (1)
293700                       ELSE
293800*There were no digits in the CBSA                                *
293900                           MOVE SPACES  TO CBSA-STATE-CODE
294000                           MOVE 92      TO PPS-RTC
294100                       END-IF
294200                    END-IF
294300                 END-IF
294400                 MOVE 'Y'               TO GOT-STATE-CODE
294500              END-IF
294600           END-IF
294700        END-PERFORM
294800        MOVE CBSA-STATE-CODE            TO P-GEO-CBSA
294900     END-IF.
295000
295100     MOVE P-GEO-CBSA              TO G-P-CBSA.
295200/
295300 2205-DISPLAY-COMP-RATE-SCREEN.
295400*Prepare to populate the Composite Rate PPS Screen (two tabs)    *
295500*Final payment tab of the PPS-screen                             *
295600*  Rate Data box                                                 *
295700     COMPUTE CBSA-PERCENT = 100 * CBSA-PCT.
295800     COMPUTE MSA-PERCENT  = 100 * MSA-PCT.
295900     MOVE MSA-PERCENT             TO G-MSA-PERCENT.
296000     MOVE CBSA-PERCENT            TO G-CBSA-PERCENT.
296100     MOVE MSA-PERCENT             TO G-MSA-PCT.
296200     MOVE CBSA-PERCENT            TO G-CBSA-PCT.
296300     MOVE MSA-WAGE-ADJ            TO G-MSA-WAGE-ADJ.
296400     MOVE CBSA-WAGE-ADJ           TO G-CBSA-WAGE-ADJ.
296500     MOVE PPS-WAGE-ADJ-RATE       TO G-PPS-WAGE-ADJ-RATE
296600
296700*  Adjustments box                                               *
296800     MOVE DRUG-ADD-ON-RETURN      TO G-DRUG-ADD-ON-RETURN.
296900     MOVE PPS-BDGT-NEUT-RATE      TO G-PPS-BDGT-NEUT-RATE.
297000     MOVE PPS-AGE-FACTOR          TO G-PPS-AGE-FACTOR.
297100     MOVE PPS-BSA-FACTOR          TO G-PPS-BSA-FACTOR.
297200     MOVE PPS-BMI-FACTOR          TO G-PPS-BMI-FACTOR.
297300     MOVE CASE-MIX-FCTR-ADJ-RATE  TO G-CASE-MIX-FCTR-ADJ-RT.
297400
297500*  Training box                                                  *
297600     MOVE 'Training'              TO G-TRAINING-DAILY-RATE.
297700     MOVE SPACES                  TO G-TRAINING-LINE-1
297800                                     G-TRAINING-LINE-2
297900                                     G-TRAINING-LINE-3.
298000
298100     IF (B-COND-CODE = '73') AND (B-REV-CODE = '0821' OR '0831'
298200                                                      OR '0851')
298300        STRING 'For HEMO, Peritoneal, or CCPD'
298400                                DELIMITED BY SIZE
298500                                INTO G-TRAINING-LINE-1
298600        MOVE BLOOD-DOLLAR         TO G-TRAINING-AMT
298700     ELSE
298800        IF (B-COND-CODE = '73')  AND  (B-REV-CODE = '0841')  THEN
298900           STRING 'For CAPD'    DELIMITED BY SIZE
299000                                INTO G-TRAINING-LINE-1
299100           MOVE BLOOD-DOLLAR      TO G-TRAINING-AMT
299200        ELSE
299300           IF (B-COND-CODE = '74')  AND
299400              (B-REV-CODE = '0841' OR '0851')  THEN
299500              IF B-REV-CODE = '0841' THEN
299600                 MOVE 'CAPD Daily Rate'
299700                                  TO G-TRAINING-DAILY-RATE
299800              ELSE
299900                 MOVE 'CCPD Daily Rate'
300000                                  TO G-TRAINING-DAILY-RATE
300100              END-IF
300200              STRING 'With home dialysis of CAPD or CCPD'
300300                                DELIMITED BY SIZE
300400                                INTO G-TRAINING-LINE-1
300500              STRING 'PPS composite rate is computed by'
300600                     ' multiplying'
300700                                DELIMITED BY SIZE
300800                                INTO G-TRAINING-LINE-2
300900              STRING 'case mix factor adjusted rate by 3/7'
301000                                DELIMITED BY SIZE
301100                                INTO G-TRAINING-LINE-3
301200              MOVE ZERO           TO G-TRAINING-AMT
301300           ELSE
301400              STRING 'Training does not apply'
301500                                DELIMITED BY SIZE
301600                                INTO G-TRAINING-DAILY-RATE
301700              MOVE ZERO           TO G-TRAINING-AMT
301800           END-IF
301900        END-IF
302000     END-IF.
302100
302200     MOVE PPS-FINAL-PAY-AMT       TO G-PPS-FINAL-PAY-AMT.
302300
302400*  Rate Data box                                                 *
302500     COMPUTE CBSA-PERCENT = 100 * CBSA-PCT.
302600     COMPUTE MSA-PERCENT  = 100 * MSA-PCT.
302700     MOVE MSA-PERCENT             TO G-MSA-PERCENT.
302800     MOVE CBSA-PERCENT            TO G-CBSA-PERCENT.
302900     MOVE MSA-PERCENT             TO G-MSA-PCT.
303000     MOVE CBSA-PERCENT            TO G-CBSA-PCT.
303100     MOVE MSA-WAGE-ADJ            TO G-MSA-WAGE-ADJ.
303200     MOVE CBSA-WAGE-ADJ           TO G-CBSA-WAGE-ADJ.
303300     MOVE PPS-WAGE-ADJ-RATE       TO G-PPS-WAGE-ADJ-RATE
303400
303500*  Adjustments box                                               *
303600     MOVE DRUG-ADD-ON-RETURN      TO G-DRUG-ADD-ON-RETURN.
303700     MOVE PPS-BDGT-NEUT-RATE      TO G-PPS-BDGT-NEUT-RATE.
303800     MOVE PPS-AGE-FACTOR          TO G-PPS-AGE-FACTOR.
303900     MOVE PPS-BSA-FACTOR          TO G-PPS-BSA-FACTOR.
304000     MOVE PPS-BMI-FACTOR          TO G-PPS-BMI-FACTOR.
304100     MOVE CASE-MIX-FCTR-ADJ-RATE  TO G-CASE-MIX-FCTR-ADJ-RT.
304200
304300*Payment calculations tab of the PPS-screen                      *
304400*  MSA Wage Rate box                                             *
304500     MOVE SPACES                  TO G-MSA-LINE-1
304600                                     G-MSA-LINE-2
304700                                     G-MSA-LINE-3
304800                                     G-MSA-LINE-4
304900                                     G-MSA-LINE-5.
305000     MOVE ZERO                    TO G-MSA-WAGE-AMT
305100                                     G-2006-MSA-WAGE-AMT
305200                                     G-2007-MSA-WAGE-AMT
305300                                     G-2008-MSA-WAGE-AMT
305400                                     G-2008-MSA-WAGE-ADJ.
305500
305600     IF CLAIM-YEAR > 2008  THEN
305700        STRING 'MSA information is not relevant'
305800                                DELIMITED BY SIZE
305900                                INTO G-MSA-LINE-1
306000     ELSE
306100        IF P-PROV-TYPE = '40' THEN
306200           STRING '2005 (Hospital based wage)'
306300                                DELIMITED BY SIZE
306400                                INTO G-MSA-LINE-1
306500        ELSE
306600           STRING '2005 (Independent based wage)'
306700                                DELIMITED BY SIZE
306800                                INTO G-MSA-LINE-1
306900        END-IF
307000
307100        MOVE MSA-WAGE-AMT         TO G-MSA-WAGE-AMT
307200        STRING MSA-PERCENT ' % blend for ' CLAIM-YEAR
307300                                DELIMITED BY SIZE
307400                                INTO G-MSA-LINE-2
307500        MOVE MSA-WAGE-ADJ            TO G-2006-MSA-WAGE-AMT
307600        COMPUTE 2006-MSA-WAGE-AMT ROUNDED =
307700                   MSA-WAGE-AMT * 1.016
307800        COMPUTE 2007-MSA-WAGE-AMT ROUNDED =
307900                   2006-MSA-WAGE-AMT * 1.016
308000        IF CLAIM-YEAR = 2006  THEN
308100           STRING '2006  . . . . . . . . . . . . .'
308200                                DELIMITED BY SIZE
308300                                INTO G-MSA-LINE-1
308400           MOVE 2006-MSA-WAGE-AMT TO G-MSA-WAGE-AMT
308500           STRING MSA-PERCENT ' % blend for ' CLAIM-YEAR
308600                                DELIMITED BY SIZE
308700                                INTO G-MSA-LINE-2
308800           MOVE MSA-WAGE-ADJ      TO G-2006-MSA-WAGE-AMT
308900        ELSE
309000           IF CLAIM-YEAR = 2007  THEN
309100              MOVE 2006-MSA-WAGE-AMT TO G-MSA-WAGE-AMT
309200              IF PPS-CALC-VERS-CD = 'C07.0'  THEN
309300                 STRING '2007  . . . . . . . . . . . . .'
309400                                DELIMITED BY SIZE
309500                                INTO G-MSA-LINE-1
309600                 MOVE 2006-MSA-WAGE-AMT TO G-MSA-WAGE-AMT
309700              ELSE
309800                 STRING '2007  . . . . . . . . . . . . .'
309900                                DELIMITED BY SIZE
310000                                INTO G-MSA-LINE-1
310100                 MOVE 2007-MSA-WAGE-AMT TO G-MSA-WAGE-AMT
310200              END-IF
310300              STRING MSA-PERCENT ' % blend for ' CLAIM-YEAR
310400                                DELIMITED BY SIZE
310500                                INTO G-MSA-LINE-2
310600              MOVE MSA-WAGE-ADJ   TO G-2006-MSA-WAGE-AMT
310700           ELSE
310800              IF CLAIM-YEAR = 2008  THEN
310900                 STRING '2008  . . . . . . . . . . . . .'
311000                                DELIMITED BY SIZE
311100                                INTO G-MSA-LINE-1
311200                 MOVE 2007-MSA-WAGE-AMT
311300                                  TO G-MSA-WAGE-AMT
311400                 STRING MSA-PERCENT ' % blend for ' CLAIM-YEAR
311500                                DELIMITED BY SIZE
311600                                INTO G-MSA-LINE-2
311700                 MOVE MSA-WAGE-ADJ TO G-2006-MSA-WAGE-AMT
311800              END-IF
311900           END-IF
312000        END-IF
312100     END-IF.
312200
312300*  CBSA Wage Rate box                                            *
312400     MOVE SPACES                  TO G-CBSA-LINE-1
312500                                     G-CBSA-LINE-2
312600                                     G-CBSA-LINE-3
312700                                     G-CBSA-LINE-4
312800                                     G-CBSA-LINE-5
312900                                     G-CBSA-LINE-6.
313000     MOVE ZERO                    TO G-CBSA-WAGE-PMT-RATE
313100                                     G-PPS-NAT-LABOR-PCT
313200                                     G-CBSA-WAGE-INDEX
313300                                     G-CBSA-WAGE-PMT-RATE
313400                                     G-PPS-NAT-NONLABOR-PCT
313500                                     G-CBSA-WAGE-ADJ.
313600
313700     IF CLAIM-YEAR = 2005  THEN
313800        STRING 'CBSA information not relevant'
313900                                DELIMITED BY SIZE
314000                                INTO G-CBSA-LINE-1
314100     ELSE
314200        IF P-PROV-TYPE = '40' THEN
314300           STRING 'Hospital based payment rate'
314400                                DELIMITED BY SIZE
314500                                INTO G-CBSA-LINE-1
314600           STRING 'Hospital based payment rate'
314700                                DELIMITED BY SIZE
314800                                INTO G-CBSA-LINE-4
314900        ELSE
315000           STRING 'Independent based payment rate'
315100                                DELIMITED BY SIZE
315200                                INTO G-CBSA-LINE-1
315300           STRING 'Independent based payment rate'
315400                                DELIMITED BY SIZE
315500                                INTO G-CBSA-LINE-4
315600        END-IF
315700
315800        MOVE CBSA-WAGE-PMT-RATE   TO G-CBSA-WAGE-PMT-RATE
315900        STRING 'National labor percentage'
316000                                DELIMITED BY SIZE
316100                                INTO G-CBSA-LINE-2
316200        MOVE PPS-NAT-LABOR-PCT    TO G-PPS-NAT-LABOR-PCT
316300        STRING 'CBSA wage index'
316400                                DELIMITED BY SIZE
316500                                INTO G-CBSA-LINE-3
316600        MOVE CBSA-WAGE-INDEX      TO G-CBSA-WAGE-INDEX
316700        MOVE CBSA-WAGE-PMT-RATE   TO G-CBSA-WAGE-PMT-RATE
316800        STRING 'Non labor percentage'
316900                                DELIMITED BY SIZE
317000                                INTO G-CBSA-LINE-5
317100        MOVE PPS-NAT-NONLABOR-PCT TO G-PPS-NAT-NONLABOR-PCT
317200        STRING CBSA-PERCENT ' % blend FOR ' CLAIM-YEAR
317300                            '. . . . . .'
317400                                DELIMITED BY SIZE
317500                                INTO G-CBSA-LINE-6
317600        MOVE CBSA-WAGE-ADJ        TO G-CBSA-WAGE-ADJ
317700     END-IF.
317800/
317900 2211-DISPLAY-NEW-PPS-SCREEN.
318000*Prepare to populate the New PPS Screen (four tabs)              *
318100*Final payment tab of the PPS-screen (first tab)                 *
318200*----------------------------------------------------------------*
318300* These variables to display on NEW PPS Screen   TAB-1           *
318400*----------------------------------------------------------------*
318500*Max variable characters is 23
318600*LN   = LINE  CR = COMPOSITE RATE  CM = CASE-MIX
318700*NEUT = NEUTRALITY  ADJ = ADJUST  PMT = PAYMENT OR PMT
318800*----PPS column
318900
319000     INITIALIZE
319100               G-BUN-CALC-VERS-CD
319200               G-PPS-DATE-OF-SERVICE
319300               G-HICAN2
319400               G-PPS-11-WAGE-ADJ-RATE
319500               G-PPS-11-AGE-FACTOR
319600               G-PPS-11-BSA-FACTOR
319700               G-PPS-11-BMI-FACTOR
319800               G-PPS-ONSET-FACTOR
319900               G-PPS-COMORBID-FACTOR
320000               G-PPS-LOW-VOL-FACTOR
320100               G-PPS-ADJUSTED-RATE
320200               G-PPS-COND-CD-1-LN-9
320300               G-PPS-COND-CD-2-LN-10
320400               G-PPS-COND-CD-AMT-LN-10
320500               G-PPS-COND-CD-3-LN-11
320600               G-PPS-COND-CD-4-LN-12
320700               G-PPS-UNBLND-PPS-PMT
320800               G-PPS-UNBLNDPPS-PMT-AMT
320900               G-PPS-BLEND-RATE-LN-14
321000               G-PPS-BLEND-RATE-PCT
321100               G-PPS-BLENDED-PPS-PMT
321200               G-PPS-BLEND-RATE-2
321300               G-PPS-BLEND-PPS-PMT-AMT
321400               G-PPS-UN-BLEND-OUT-PMT
321500               G-PPS-OUT-PMT-AMT-2
321600               G-PPS-OUT-PMT-AMT
321700               G-PPS-BLNDED-CR-PMT
321800               G-PPS-BUDGET-NEUT-RATE3
321900               G-PPS-BUDGET-NEUT-RATE2
322000               G-PPS-BLNDED-CR-PMT-AMT
322100               G-PPS-BUDGET-NEUT
322200               G-PPS-BUDGET-NEUT-RATE
322300               G-PPS-DEDUCTABLE
322400               G-PPS-PCT-DEDUCTABLE
322500               G-PPS-FINAL-PMT-AMT
322600               G-PPS-BLEND-MSG-LN-21
322700               G-PPS-BLEND-MSG-LN-22
322800*Outlier column
322900               G-OUT-11-AGE-FACTOR
323000               G-OUT-11-BSA-FACTOR
323100               G-OUT-11-BMI-FACTOR
323200               G-OUT-ONSET-FACTOR
323300               G-OUT-COMORBID-FACTOR
323400               G-OUT-LOW-VOL-FACTOR
323500               G-OUT-PREDICTED-MAP
323600               G-OUT-CM-PREDICT-MAPAMT
323700               G-OUT-IMPUTED-MAP-AMT
323800               G-OUT-PRE-IMP-LEFTPAREN
323900               G-OUT-PRED-IMPUT-DIFFER
324000               G-OUT-PRE-IMP-RGHTPAREN
324100               G-OUT-COND-CD-1-LN-11
324200               G-OUT-COND-CD-1-LN11AMT
324300               G-OUT-UNBLEND-PMT
324400               G-OUT-UNBLEND-PMT-AMT
324500               G-OUT-BLEND-RATE-LN-13
324600               G-OUT-BLEND-RATE-PCT
324700               G-OUT-BLEND-PMT
324800               G-OUT-BLEND-PMT-AMT
324900*Composite Rate column
325000               G-CR-WAGE-RATE-LN-1
325100               G-CR-PPS-11-WG-ADJ-RATE
325200               G-CR-AGE-FACTOR-LN-2
325300               G-CR-AGE-FACTOR
325400               G-CR-BSA-FACTOR-LN-3
325500               G-CR-BSA-FACTOR
325600               G-CR-BMI-FACTOR-LN-4
325700               G-CR-BMI-FACTOR
325800               G-CR-DRUG-ADD-ON-LN-5
325900               G-CR-DRUG-ADD-ON-FACTOR
326000               G-CR-CM-BDGT-LN-6
326100               G-CR-CM-BDGT-NEUT-FCTR
326200               G-CR-PART-D-DRUG-LN-7
326300               G-CR-PART-D-DRUG-ADJUST
326400               G-CR-CM-FCTR-LN-8
326500               G-CR-CM-FCTR-ADJ-AMT
326600               G-CR-COND-CD-1-LN-9
326700               G-CR-COND-CD-2-LN-10
326800               G-CR-COND-CD-AMT-LN-10
326900               G-CR-COND-CD-3-LN-11
327000               G-CR-COND-CD-4-LN-12
327100               G-CR-UNBLEND-PMT-LN-13
327200               G-CR-UNBLENDED-PMT-AMT
327300               G-CR-BLEND-RATE-LN-14
327400               G-CR-BLEND-RATE-PCT
327500               G-CR-BLEND-CR-PMT-LN-15
327600               G-CR-BLENDED-CR-AMT
327700*----------------------------------------------------------------*
327800* These variables to display on NEW PPS Screen   TAB-2           *
327900*----------------------------------------------------------------*
328000*PPS column
328100               G-PPS-CBSA-BASE-RT-AMT
328200               G-PPS-LABOR-PCT
328300               G-PPS-WAGE-INDEX
328400               G-PPS-LABOR-PORTION
328500               G-PPS-NON-LABOR-PCT
328600               G-PPS-NON-LABOR-PORTION
328700*Outlier column
328800               G-OUT-ADJ-SERVICEMAP
328900               G-OUT-ADJ-SERVICEMAPAMT
329000               G-OUT-COST-OUT-SERVICES
329100               G-OUT-FIX-DOLR-LOSS
329200               G-OUT-FIX-DOLR-LOSS-AMT
329300               G-OUT-PRED-SERVICES-MAP
329400               G-OUT-IMPUT-MINUS-PRED
329500               G-OUT-LOSS-SHARE-PCT
329600*----------------------------------------------------------------*
329700* These variables to display on NEW PPS Screen   TAB-3           *
329800*----------------------------------------------------------------*
329900               G-CR-CBSA-BASE-RATE
330000               G-CR-CBSA-BASE-RATE-AMT
330100               G-CR-LABOR-PCT
330200               G-CR-LABOR-PERCENT
330300               G-CR-WAGE-INDX
330400               G-CR-WAGE-INDEX
330500               G-CR-LABOR-PORTION
330600               G-CR-LABOR-PORTION-AMT
330700               G-CR-ESRD-BASE-RATE-2
330800               G-CR-NON-LABOR-PCT
330900               G-CR-NON-LABOR-PERCENT
331000               G-CR-NON-LABOR-PORTION
331100               G-CR-NON-LABOR-PORT-AMT
331200               G-CR-WAGE-ADJ-BASE-RATE
331300*----------------------------------------------------------------*
331400* These variables to display on NEW PPS Screen   TAB-4           *
331500*----------------------------------------------------------------*
331600               G-PPS-AGE-LINE-1
331700               G-PPS-AGE-LINE-2
331800               G-PPS-AGE-LINE-3
331900               G-PPS-AGE-LINE-4
332000               G-OUT-AGE-LINE-1
332100               G-OUT-AGE-LINE-2
332200               G-OUT-AGE-LINE-3
332300               G-OUT-AGE-LINE-4
332400               G-CR-AGE-LINE-1
332500               G-CR-AGE-LINE-2
332600               G-CR-AGE-LINE-2
332700               G-CR-AGE-LINE-3
332800               G-CR-AGE-LINE-4
332900               G-PPS-BSA-LINE-1
333000               G-PPS-BSA-LINE-2
333100               G-PPS-BSA-LINE-3
333200               G-PPS-BSA-LINE-4
333300               G-PPS-BSA-LINE-5
333400               G-PPS-BSA-LINE-6
333500               G-PPS-BSA-LINE-7
333600               G-PPS-BSA-LINE-8
333700               G-OUT-BSA-LINE-1
333800               G-OUT-BSA-LINE-2
333900               G-OUT-BSA-LINE-3
334000               G-OUT-BSA-LINE-4
334100               G-OUT-BSA-LINE-5
334200               G-OUT-BSA-LINE-6
334300               G-OUT-BSA-LINE-7
334400               G-OUT-BSA-LINE-8
334500               G-CR-BSA-LINE-1
334600               G-CR-BSA-LINE-2
334700               G-CR-BSA-LINE-3
334800               G-CR-BSA-LINE-4
334900               G-CR-BSA-LINE-5
335000               G-CR-BSA-LINE-6
335100               G-CR-BSA-LINE-7
335200               G-CR-BSA-LINE-8
335300               G-PPS-BMI-LINE-1
335400               G-PPS-BMI-LINE-2
335500               G-PPS-BMI-LINE-3
335600               G-PPS-BMI-LINE-4
335700               G-PPS-BMI-LINE-5
335800               G-PPS-BMI-LINE-6
335900               G-PPS-BMI-LINE-7
336000               G-PPS-BMI-LINE-8
336100               G-OUT-BMI-LINE-1
336200               G-OUT-BMI-LINE-2
336300               G-OUT-BMI-LINE-3
336400               G-OUT-BMI-LINE-4
336500               G-OUT-BMI-LINE-5
336600               G-OUT-BMI-LINE-6
336700               G-OUT-BMI-LINE-7
336800               G-OUT-BMI-LINE-8
336900               G-CR-BMI-LINE-1
337000               G-CR-BMI-LINE-2
337100               G-CR-BMI-LINE-3
337200               G-CR-BMI-LINE-4
337300               G-CR-BMI-LINE-5
337400               G-CR-BMI-LINE-6
337500               G-CR-BMI-LINE-7
337600               G-CR-BMI-LINE-8.
337700
337800     MOVE PPS-CALC-VERS-CD        TO G-BUN-CALC-VERS-CD.
337900     MOVE READABLE-DATE           TO G-PPS-DATE-OF-SERVICE.
338000     MOVE G-HICAN                 TO G-HICAN2.
338100
338200*----------------------------------------------------------------*
338300* Display of variables on NEW PPS Screen   TAB-1                 *
338400*----------------------------------------------------------------*
338500*PPS column
338600     MOVE PPS-2011-WAGE-ADJ-RATE  TO G-PPS-11-WAGE-ADJ-RATE.
338700     MOVE PPS-2011-AGE-FACTOR     TO G-PPS-11-AGE-FACTOR.
338800     MOVE PPS-2011-BSA-FACTOR     TO G-PPS-11-BSA-FACTOR.
338900     MOVE PPS-2011-BMI-FACTOR     TO G-PPS-11-BMI-FACTOR.
339000     MOVE BUN-ONSET-FACTOR        TO G-PPS-ONSET-FACTOR.
339100     MOVE BUN-COMORBID-MULTIPLIER TO G-PPS-COMORBID-FACTOR.
339200     MOVE BUN-LOW-VOL-MULTIPLIER  TO G-PPS-LOW-VOL-FACTOR.
339300     MOVE BUN-ADJUSTED-BASE-WAGE-AMT
339400                                  TO G-PPS-ADJUSTED-RATE.
339500     IF B-COND-CODE = '73'  THEN
339600        IF BUN-ONSET-FACTOR  >  1.000  THEN
339700           STRING 'No training add on when onset is present'
339800                  DELIMITED BY SIZE
339900                  INTO G-PPS-COND-CD-1-LN-9
340000           MOVE SPACES            TO G-PPS-COND-CD-2-LN-10
340100           MOVE SPACES            TO G-PPS-COND-CD-3-LN-11
340200           MOVE SPACES            TO G-PPS-COND-CD-4-LN-12
340300           MOVE ZERO              TO G-PPS-COND-CD-AMT-LN-10
340400        ELSE
340500           STRING 'Training add on is'
340600                  DELIMITED BY SIZE
340700                  INTO G-PPS-COND-CD-1-LN-9
340800           MOVE PPS-BUN-CBSA-W-INDEX
340900                                  TO FORMATTED-BUN-CBSA-W-INDEX
341000           STRING '+  ( $33.44        *      '
341100                  FORMATTED-BUN-CBSA-W-INDEX
341200                  '  )'
341300                  DELIMITED BY SIZE
341400                  INTO G-PPS-COND-CD-2-LN-10
341500           MOVE PPS-BUN-WAGE-ADJ-TRAIN-AMT
341600                                  TO G-PPS-COND-CD-AMT-LN-10
341700           STRING '(base payment  *  wage index)'
341800                  DELIMITED BY SIZE
341900                  INTO G-PPS-COND-CD-3-LN-11
342000           MOVE SPACES            TO G-PPS-COND-CD-4-LN-12
342100        END-IF
342200     ELSE
342300        IF (B-COND-CODE = '74')  AND
342400           (B-REV-CODE  = '0841'  OR  '0851')  THEN
342500           IF B-REV-CODE = '0841' THEN
342600              MOVE 'CAPD Daily Rate'
342700                                  TO G-PPS-COND-CD-1-LN-9
342800           ELSE
342900              MOVE 'CCPD Daily Rate'
343000                                   TO G-PPS-COND-CD-1-LN-9
343100           END-IF
343200           STRING 'With home dialysis of CAPD or CCPD'
343300                   DELIMITED BY SIZE
343400                   INTO G-PPS-COND-CD-2-LN-10
343500           STRING 'PPS dolar amount is computed by'
343600                  ' multiplying'
343700                  DELIMITED BY SIZE
343800                  INTO G-PPS-COND-CD-3-LN-11
343900           STRING 'adjusted rate by 3/7'
344000                   DELIMITED BY SIZE
344100                   INTO G-PPS-COND-CD-4-LN-12
344200           MOVE ZERO              TO G-TRAINING-AMT
344300        ELSE
344400           STRING 'Training does not apply'
344500                  DELIMITED BY SIZE
344600                  INTO G-PPS-COND-CD-1-LN-9
344700           MOVE SPACES            TO G-PPS-COND-CD-2-LN-10
344800           MOVE SPACES            TO G-PPS-COND-CD-3-LN-11
344900           MOVE SPACES            TO G-PPS-COND-CD-4-LN-12
345000           MOVE ZERO              TO G-PPS-COND-CD-AMT-LN-10
345100        END-IF
345200     END-IF.
345300
345400     IF P-PROV-WAIVE-BLEND-PAY-INDIC = 'N'   THEN
345500*Blended payment WITH outlier
345600        STRING 'UNblended PPS payment. . . . .'
345700                DELIMITED BY SIZE
345800                INTO G-PPS-UNBLND-PPS-PMT
345900        MOVE PPS-2011-FULL-PPS-RATE
346000                                  TO G-PPS-UNBLNDPPS-PMT-AMT
346100
346200        STRING '*  Blend rate. .'
346300                DELIMITED BY SIZE
346400                INTO G-PPS-BLEND-RATE-LN-14
346500        COMPUTE PPS-BLEND-PERCENT = 100 * BUN-CBSA-PCT-BLEND
346600        STRING PPS-BLEND-PERCENT   ' %'
346700               DELIMITED BY SIZE
346800               INTO G-PPS-BLEND-RATE-PCT
346900
347000        STRING '=  Blended PPS payment. . . .'
347100                DELIMITED BY SIZE
347200                INTO G-PPS-BLENDED-PPS-PMT
347300        MOVE PPS-2011-BLEND-PPS-RATE
347400                                  TO G-PPS-BLEND-PPS-PMT-AMT
347500
347600        IF PPS-2011-BLEND-OUTLIER-RATE  >  ZERO  THEN
347700           STRING '+  Blended Outlier payment  . . .'
347800                   DELIMITED BY SIZE
347900                   INTO G-PPS-UN-BLEND-OUT-PMT
348000           MOVE PPS-2011-BLEND-OUTLIER-RATE
348100                                  TO G-PPS-OUT-PMT-AMT
348200
348300           STRING '+  Blended CR Payment. . . .'
348400                   DELIMITED BY SIZE
348500                   INTO G-PPS-BLNDED-CR-PMT
348600           MOVE PPS-2011-BLEND-COMP-RATE
348700                                  TO G-PPS-BLNDED-CR-PMT-AMT
348800
348900           COMPUTE PPS-FINAL-PAYMENT   ROUNDED  =
349000                     PPS-2011-BLEND-PPS-RATE
349100                   + PPS-2011-BLEND-OUTLIER-RATE
349200                   + PPS-2011-BLEND-COMP-RATE
349300           END-COMPUTE
349400
349500           IF MAINFRAME-YEAR = 2011  THEN
349600              IF MAINFRAME-MONTH  <  4  THEN
349700                 STRING '*  Bud neutral '
349800                        '1/1 - 3/31 '
349900                        DELIMITED BY SIZE
350000                        INTO G-PPS-BUDGET-NEUT
350100                 STRING '96.9%'
350200                        DELIMITED BY SIZE
350300                        INTO G-PPS-BUDGET-NEUT-RATE
350400                 COMPUTE PPS-FINAL-PAYMENT-TO-APRIL  ROUNDED =
350500                         PPS-FINAL-PAYMENT  *  0.969
350600                 MOVE PPS-FINAL-PAYMENT-TO-APRIL
350700                                  TO G-PPS-FINAL-PMT-AMT
350800              ELSE
350900                 STRING '*  Bud neutral '
351000                        'after 3/31 '
351100                        DELIMITED BY SIZE
351200                        INTO G-PPS-BUDGET-NEUT
351300                 STRING '100%'
351400                        DELIMITED BY SIZE
351500                        INTO G-PPS-BUDGET-NEUT-RATE
351600                 MOVE PPS-FINAL-PAYMENT
351700                                  TO G-PPS-FINAL-PMT-AMT
351800              END-IF
351900           ELSE
352000              STRING '*  PPS bud neutral for '
352100                     MAINFRAME-YEAR
352200                     DELIMITED BY SIZE
352300                     INTO G-PPS-BUDGET-NEUT
352400              STRING ' 100%'
352500                     DELIMITED BY SIZE
352600                     INTO G-PPS-BUDGET-NEUT-RATE
352700              MOVE PPS-FINAL-PAYMENT TO G-PPS-FINAL-PMT-AMT
352800           END-IF
352900        ELSE
353000*Blended payment WITHOUT outlier
353100           STRING '+  Blended CR Payment. . . .'
353200                   DELIMITED BY SIZE
353300                   INTO G-PPS-UN-BLEND-OUT-PMT
353400           MOVE PPS-2011-BLEND-COMP-RATE
353500                                  TO G-PPS-OUT-PMT-AMT
353600
353700           COMPUTE PPS-FINAL-PAYMENT   ROUNDED  =
353800                     PPS-2011-BLEND-PPS-RATE
353900                   + PPS-2011-BLEND-COMP-RATE
354000           END-COMPUTE
354100
354200           IF MAINFRAME-YEAR = 2011  THEN
354300              IF MAINFRAME-MONTH  <  4  THEN
354400                 STRING '*  Bud neutral '
354500                        '1/1 - 3/31 '
354600                        DELIMITED BY SIZE
354700                        INTO G-PPS-BLNDED-CR-PMT
354800                 STRING '96.9%'
354900                        DELIMITED BY SIZE
355000                        INTO G-PPS-BUDGET-NEUT-RATE2
355100                 COMPUTE PPS-FINAL-PAYMENT-TO-APRIL  ROUNDED =
355200                         PPS-FINAL-PAYMENT  *  0.969
355300                 MOVE PPS-FINAL-PAYMENT-TO-APRIL
355400                                  TO G-PPS-FINAL-PMT-AMT
355500              ELSE
355600                 STRING '*  Bud neutral '
355700                        'after 3/31 '
355800                        DELIMITED BY SIZE
355900                        INTO G-PPS-BLNDED-CR-PMT
356000                 STRING '100%'
356100                        DELIMITED BY SIZE
356200                        INTO G-PPS-BUDGET-NEUT-RATE2
356300                 MOVE PPS-FINAL-PAYMENT
356400                                  TO G-PPS-FINAL-PMT-AMT
356500              END-IF
356600           ELSE
356700              STRING '*  PPS bud neutral for '
356800                     MAINFRAME-YEAR
356900                     DELIMITED BY SIZE
357000                     INTO G-PPS-BLNDED-CR-PMT
357100              STRING ' 100%'
357200                     DELIMITED BY SIZE
357300                     INTO G-PPS-BUDGET-NEUT-RATE2
357400              MOVE PPS-FINAL-PAYMENT TO G-PPS-FINAL-PMT-AMT
357500           END-IF
357600        END-IF
357700        STRING 'does not include separately billable payment'
357800               DELIMITED BY SIZE
357900               INTO G-PPS-BLEND-MSG-LN-21
358000        STRING 'for transitioning providers'
358100               DELIMITED BY SIZE
358200               INTO G-PPS-BLEND-MSG-LN-22
358300     ELSE
358400*NO Blended payment WITH outlier
358500        STRING 'PPS payment. . . . . . . .'
358600                DELIMITED BY SIZE
358700                INTO G-PPS-UNBLND-PPS-PMT
358800        MOVE PPS-2011-FULL-PPS-RATE
358900                                  TO G-PPS-UNBLNDPPS-PMT-AMT
359000
359100        IF PPS-2011-FULL-OUTLIER-RATE  >  ZERO  THEN
359200           STRING '+  Outlier payment  . . .'
359300                   DELIMITED BY SIZE
359400                   INTO G-PPS-BLEND-RATE-LN-14
359500           MOVE PPS-2011-FULL-OUTLIER-RATE
359600                                  TO G-PPS-OUT-PMT-AMT-2
359700
359800           COMPUTE PPS-FINAL-PAYMENT   ROUNDED  =
359900                     PPS-2011-FULL-PPS-RATE
360000                   + PPS-2011-FULL-OUTLIER-RATE
360100           END-COMPUTE
360200
360300           IF MAINFRAME-YEAR = 2011  THEN
360400              IF MAINFRAME-MONTH  <  4  THEN
360500                 STRING '*  Bud neutral '
360600                        '1/1 - 3/31 '
360700                        DELIMITED BY SIZE
360800                        INTO G-PPS-BLENDED-PPS-PMT
360900                 STRING '96.9%'
361000                        DELIMITED BY SIZE
361100                        INTO G-PPS-BUDGET-NEUT-RATE3
361200                 COMPUTE PPS-FINAL-PAYMENT-TO-APRIL  ROUNDED =
361300                         PPS-FINAL-PAYMENT  *  0.969
361400                 MOVE PPS-FINAL-PAYMENT-TO-APRIL
361500                                  TO G-PPS-FINAL-PMT-AMT
361600              ELSE
361700                 STRING '*  Bud neutral '
361800                        'after 3/31 '
361900                        DELIMITED BY SIZE
362000                        INTO G-PPS-BLENDED-PPS-PMT
362100                 STRING '100%'
362200                        DELIMITED BY SIZE
362300                        INTO G-PPS-BUDGET-NEUT-RATE3
362400                 MOVE PPS-FINAL-PAYMENT
362500                                  TO G-PPS-FINAL-PMT-AMT
362600              END-IF
362700           ELSE
362800              STRING '*  PPS bud neutral for '
362900                     MAINFRAME-YEAR
363000                     DELIMITED BY SIZE
363100                     INTO G-PPS-BLENDED-PPS-PMT
363200              STRING ' 100%'
363300                     DELIMITED BY SIZE
363400                     INTO G-PPS-BUDGET-NEUT-RATE3
363500              MOVE PPS-FINAL-PAYMENT TO G-PPS-FINAL-PMT-AMT
363600           END-IF
363700        ELSE
363800*NO Blended payment WITHOUT outlier
363900           STRING 'PPS payment. . . . . . . .'
364000                   DELIMITED BY SIZE
364100                   INTO G-PPS-UNBLND-PPS-PMT
364200           MOVE PPS-2011-FULL-PPS-RATE
364300                                  TO G-PPS-UNBLNDPPS-PMT-AMT
364400
364500           COMPUTE PPS-FINAL-PAYMENT   ROUNDED  =
364600                     PPS-2011-FULL-PPS-RATE  * 1.0
364700           END-COMPUTE
364800
364900           IF MAINFRAME-YEAR = 2011  THEN
365000              IF MAINFRAME-MONTH  <  4  THEN
365100                 STRING '*  Bud neutral '
365200                        '1/1 - 3/31 '
365300                        DELIMITED BY SIZE
365400                        INTO G-PPS-BLEND-RATE-LN-14
365500                 STRING '96.9%'
365600                        DELIMITED BY SIZE
365700                        INTO G-PPS-BLEND-RATE-PCT
365800                 COMPUTE PPS-FINAL-PAYMENT-TO-APRIL  ROUNDED =
365900                         PPS-FINAL-PAYMENT  *  0.969
366000                 MOVE PPS-FINAL-PAYMENT-TO-APRIL
366100                                  TO G-PPS-FINAL-PMT-AMT
366200              ELSE
366300                 STRING '*  Bud neutral '
366400                        'after 3/31 '
366500                        DELIMITED BY SIZE
366600                        INTO G-PPS-BLEND-RATE-LN-14
366700                 STRING '100%'
366800                        DELIMITED BY SIZE
366900                        INTO G-PPS-BLEND-RATE-PCT
367000                 MOVE PPS-FINAL-PAYMENT
367100                                  TO G-PPS-FINAL-PMT-AMT
367200              END-IF
367300           ELSE
367400              STRING '*  PPS bud neutral for '
367500                     MAINFRAME-YEAR
367600                     DELIMITED BY SIZE
367700                     INTO G-PPS-BLNDED-CR-PMT
367800              STRING ' 100%'
367900                     DELIMITED BY SIZE
368000                     INTO G-PPS-BUDGET-NEUT-RATE2
368100              MOVE PPS-FINAL-PAYMENT TO G-PPS-FINAL-PMT-AMT
368200        END-IF
368300     END-IF.
368400
368500*Outlier column
368600     MOVE OUT-AGE-FACTOR          TO G-OUT-11-AGE-FACTOR.
368700     MOVE OUT-BSA-FACTOR          TO G-OUT-11-BSA-FACTOR.
368800     MOVE OUT-BMI-FACTOR          TO G-OUT-11-BMI-FACTOR.
368900     MOVE OUT-ONSET-FACTOR        TO G-OUT-ONSET-FACTOR.
369000     MOVE OUT-COMORBID-MULTIPLIER TO G-OUT-COMORBID-FACTOR.
369100     MOVE OUT-LOW-VOL-MULTIPLIER  TO G-OUT-LOW-VOL-FACTOR.
369200     MOVE OUT-PREDICTED-SERVICES-MAP
369300                                  TO G-OUT-PREDICTED-MAP.
369400     MOVE OUT-CASE-MIX-PREDICTED-MAP
369500                                  TO G-OUT-CM-PREDICT-MAPAMT.
369600     IF PPS-2011-FULL-OUTLIER-RATE = ZERO  THEN
369700        MOVE 'NO OUTLIER payment made because'
369800                                  TO G-OUT-COND-CD-1-LN-11
369900        MOVE 'predicted MAP exceeds imputed MAP'
370000                                  TO G-OUT-UNBLEND-PMT
370100        MOVE 'see calculations for more information'
370200                                  TO G-OUT-BLEND-PMT
370300        MOVE SPACES               TO G-OUT-BLEND-RATE-LN-13
370400        MOVE SPACES               TO G-OUT-BLEND-RATE-PCT
370500        MOVE ZERO                 TO G-OUT-COND-CD-1-LN11AMT
370600        MOVE ZERO                 TO G-OUT-UNBLEND-PMT-AMT
370700        MOVE ZERO                 TO G-OUT-BLEND-PMT-AMT
370800     ELSE
370900        IF (B-COND-CODE = '74')  AND
371000           (B-REV-CODE  = '0841'  OR  '0851')  THEN
371100           MOVE '*  3/7  (home dialysis adjustment)'
371200                                  TO G-OUT-COND-CD-1-LN-11
371300           MOVE ZERO              TO G-OUT-COND-CD-1-LN11AMT
371400        ELSE
371500           MOVE SPACES            TO G-OUT-COND-CD-1-LN-11
371600           MOVE ZERO              TO G-OUT-COND-CD-1-LN11AMT
371700        END-IF
371800        IF P-PROV-WAIVE-BLEND-PAY-INDIC  =  'N'  THEN
371900           MOVE 'UNblended outlier amount'
372000                                  TO G-OUT-UNBLEND-PMT
372100           MOVE PPS-2011-FULL-OUTLIER-RATE
372200                                  TO G-OUT-UNBLEND-PMT-AMT
372300           MOVE '*  Blend rate.'  TO G-OUT-BLEND-RATE-LN-13
372400           MOVE G-PPS-BLEND-RATE-PCT
372500                                  TO G-OUT-BLEND-RATE-PCT
372600           MOVE 'Blended outlier payment'
372700                                  TO G-OUT-BLEND-PMT
372800           MOVE PPS-2011-BLEND-OUTLIER-RATE
372900                                  TO G-OUT-BLEND-PMT-AMT
373000        ELSE
373100           MOVE 'Outlier payment. . .'
373200                                  TO G-OUT-UNBLEND-PMT
373300           MOVE PPS-2011-FULL-OUTLIER-RATE
373400                                  TO G-OUT-UNBLEND-PMT-AMT
373500           MOVE SPACES            TO G-OUT-BLEND-RATE-LN-13
373600           MOVE SPACES            TO G-OUT-BLEND-RATE-PCT
373700           MOVE SPACES            TO G-OUT-BLEND-PMT
373800           MOVE ZERO              TO G-OUT-BLEND-PMT-AMT
373900        END-IF
374000     END-IF.
374100
374200*Composite Rate column
374300     IF P-PROV-WAIVE-BLEND-PAY-INDIC = 'N' THEN
374400        STRING 'CR Wage Adjusted Base Rate.'
374500               DELIMITED BY SIZE
374600               INTO G-CR-WAGE-RATE-LN-1
374700        MOVE PPS-2011-WAGE-ADJ-RATE
374800                                  TO G-CR-PPS-11-WG-ADJ-RATE
374900
375000        STRING '*  Age factor . . . . . . . . . .'
375100               DELIMITED BY SIZE
375200               INTO G-CR-AGE-FACTOR-LN-2
375300        MOVE PPS-AGE-FACTOR       TO FORMATTED-AGE-FACTOR
375400        MOVE FORMATTED-AGE-FACTOR TO G-CR-AGE-FACTOR
375500
375600        STRING '*  BSA factor . . . . . . . . . .'
375700                DELIMITED BY SIZE
375800                INTO G-CR-BSA-FACTOR-LN-3
375900        MOVE PPS-BSA-FACTOR       TO FORMATTED-BSA-FACTOR
376000        MOVE FORMATTED-BSA-FACTOR TO G-CR-BSA-FACTOR
376100
376200        STRING '*  BMI factor . . . . . . . . . .'
376300                DELIMITED BY SIZE
376400                INTO G-CR-BMI-FACTOR-LN-4
376500        MOVE PPS-BMI-FACTOR       TO FORMATTED-BMI-FACTOR
376600        MOVE FORMATTED-BMI-FACTOR TO G-CR-BMI-FACTOR
376700
376800        STRING '*  Drug Add on factor . .'
376900               DELIMITED BY SIZE
377000               INTO G-CR-DRUG-ADD-ON-LN-5
377100        MOVE DRUG-ADD-ON-RETURN   TO G-CR-DRUG-ADD-ON-FACTOR
377200
377300        STRING '*  Case-Mix neutral fctr'
377400                DELIMITED BY SIZE
377500                INTO G-CR-CM-BDGT-LN-6
377600        MOVE PPS-BDGT-NEUT-RATE   TO G-CR-CM-BDGT-NEUT-FCTR
377700
377800        STRING '+  Part-D drug adjustment . . . . .'
377900                DELIMITED BY SIZE
378000                INTO G-CR-PART-D-DRUG-LN-7
378100        MOVE A-49-CENT-DRUG-ADJ   TO G-CR-PART-D-DRUG-ADJUST
378200
378300        STRING '=  Case-Mix factor adjust rate. . .'
378400               DELIMITED BY SIZE
378500               INTO G-CR-CM-FCTR-LN-8
378600        MOVE CASE-MIX-FCTR-ADJ-RATE
378700                                  TO G-CR-CM-FCTR-ADJ-AMT
378800
378900        STRING 'UNblended CR payment. . . .'
379000                DELIMITED BY SIZE
379100                INTO G-CR-UNBLEND-PMT-LN-13
379200        MOVE PPS-2011-FULL-COMP-RATE
379300                                  TO G-CR-UNBLENDED-PMT-AMT
379400
379500        STRING '*  Blend rate. . . . .'
379600                DELIMITED BY SIZE
379700                INTO G-CR-BLEND-RATE-LN-14
379800        COMPUTE CR-BLEND-PERCENT  = 100 * COM-CBSA-PCT-BLEND
379900        STRING CR-BLEND-PERCENT   ' %'
380000               DELIMITED BY SIZE
380100               INTO G-CR-BLEND-RATE-PCT
380200
380300        STRING 'Blended CR payment. . . . .'
380400               DELIMITED BY SIZE
380500               INTO G-CR-BLEND-CR-PMT-LN-15
380600        MOVE PPS-2011-BLEND-COMP-RATE
380700                                  TO G-CR-BLENDED-CR-AMT
380800*  Training box                                                  *
380900        MOVE 'Training add on is' TO G-CR-COND-CD-1-LN-9
381000        MOVE SPACES               TO G-CR-COND-CD-2-LN-10
381100                                     G-CR-COND-CD-3-LN-11
381200                                     G-CR-COND-CD-4-LN-12
381300
381400        IF (B-COND-CODE = '73') AND (B-REV-CODE = '0821' OR '0831'
381500                                               OR '0851')
381600           STRING '+  For HEMO, Peritoneal, or CCPD'
381700                  DELIMITED BY SIZE
381800                  INTO G-CR-COND-CD-2-LN-10
381900           MOVE BLOOD-DOLLAR      TO G-CR-COND-CD-AMT-LN-10
382000        ELSE
382100           IF (B-COND-CODE = '73')  AND  (B-REV-CODE = '0841')
382200                                                            THEN
382300              STRING '+  For CAPD'
382400                      DELIMITED BY SIZE
382500                      INTO G-CR-COND-CD-2-LN-10
382600              MOVE BLOOD-DOLLAR   TO G-CR-COND-CD-AMT-LN-10
382700           ELSE
382800              IF (B-COND-CODE = '74')  AND
382900                 (B-REV-CODE = '0841' OR '0851')  THEN
383000                 IF B-REV-CODE = '0841' THEN
383100                    MOVE 'CAPD Daily Rate'
383200                                  TO G-CR-COND-CD-1-LN-9
383300                 ELSE
383400                    MOVE 'CCPD Daily Rate'
383500                                     TO G-CR-COND-CD-1-LN-9
383600                 END-IF
383700                 STRING 'With home dialysis of CAPD or CCPD'
383800                        DELIMITED BY SIZE
383900                        INTO G-CR-COND-CD-2-LN-10
384000                 STRING 'composite rate is computed by'
384100                     ' multiplying'
384200                     DELIMITED BY SIZE
384300                     INTO G-CR-COND-CD-3-LN-11
384400                 STRING 'case mix factor adjusted rate by 3/7'
384500                         DELIMITED BY SIZE
384600                         INTO G-CR-COND-CD-4-LN-12
384700                 MOVE ZERO           TO G-TRAINING-AMT
384800              ELSE
384900                 STRING 'Training does not apply'
385000                        DELIMITED BY SIZE
385100                        INTO G-CR-COND-CD-1-LN-9
385200                 MOVE ZERO           TO G-CR-COND-CD-AMT-LN-10
385300              END-IF
385400           END-IF
385500        END-IF
385600     ELSE
385700        STRING 'ALL Composite Rate results are'
385800               DELIMITED BY SIZE
385900               INTO G-CR-UNBLEND-PMT-LN-13
386000        STRING 'NOT APPLICABLE due'
386100               DELIMITED BY SIZE
386200               INTO G-CR-BLEND-RATE-LN-14
386300        STRING 'to blend payment being waived.'
386400               DELIMITED BY SIZE
386500               INTO G-CR-BLEND-CR-PMT-LN-15
386600     END-IF.
386700
386800*----------------------------------------------------------------*
386900*PPS & Outlier Pay calculation tab of the PPS-screen TAB-2       *
387000*----------------------------------------------------------------*
387100*PPS column
387200     MOVE PPS-BUN-BASE-PMT-RATE TO G-PPS-CBSA-BASE-RT-AMT.
387300     MOVE PPS-2011-NAT-LABOR-PCT  TO G-PPS-LABOR-PCT.
387400     MOVE PPS-BUN-CBSA-W-INDEX    TO G-PPS-WAGE-INDEX.
387500     COMPUTE PPS-LABOR-PORTION ROUNDED  =
387600          (PPS-BUN-BASE-PMT-RATE  *  PPS-2011-NAT-LABOR-PCT
387700                                  *  PPS-BUN-CBSA-W-INDEX).
387800     MOVE PPS-LABOR-PORTION       TO G-PPS-LABOR-PORTION.
387900     MOVE PPS-2011-NAT-NONLABOR-PCT
388000                                  TO G-PPS-NON-LABOR-PCT.
388100     COMPUTE PPS-NON-LABOR-PORTION ROUNDED  =
388200          (PPS-BUN-BASE-PMT-RATE  *  PPS-2011-NAT-NONLABOR-PCT)
388300     MOVE PPS-NON-LABOR-PORTION   TO G-PPS-NON-LABOR-PORTION.
388400*Outlier column
388500     IF AGE-RETURN  <  18  THEN
388600        STRING 'Adj. avg. outlier services MAP '
388700               'amt. age less than 18'
388800               DELIMITED BY SIZE
388900               INTO G-OUT-ADJ-SERVICEMAP
389000        MOVE OUT-ADJ-AVG-MAP-AMT  TO G-OUT-ADJ-SERVICEMAPAMT
389100     ELSE
389200        STRING 'Adj. avg. outlier services MAP '
389300               'amt. age greater than 17'
389400               DELIMITED BY SIZE
389500               INTO G-OUT-ADJ-SERVICEMAP
389600        MOVE OUT-ADJ-AVG-MAP-AMT  TO G-OUT-ADJ-SERVICEMAPAMT
389700     END-IF.
389800
389900     MOVE OUT-IMPUTED-MAP         TO G-OUT-IMPUTED-MAP-AMT.
390000
390100     IF AGE-RETURN  <  18  THEN
390200        STRING '+  Fixed dollar loss for age less than 18 yrs.'
390300               DELIMITED BY SIZE
390400               INTO G-OUT-FIX-DOLR-LOSS
390500        MOVE OUT-FIX-DOLLAR-LOSS  TO G-OUT-FIX-DOLR-LOSS-AMT
390600     ELSE
390700        STRING '+  Fixed dollar loss for age greater than '
390800               '17 yrs.'
390900               DELIMITED BY SIZE
391000               INTO G-OUT-FIX-DOLR-LOSS
391100        MOVE OUT-FIX-DOLLAR-LOSS  TO G-OUT-FIX-DOLR-LOSS-AMT
391200     END-IF.
391300
391400     MOVE OUT-PREDICTED-MAP       TO G-OUT-PRED-SERVICES-MAP.
391500     COMPUTE IMPUT-MINUS-PREDICT ROUNDED =
391600        OUT-IMPUTED-MAP  -  OUT-PREDICTED-MAP.
391700
391800     IF PPS-2011-FULL-OUTLIER-RATE = ZERO  THEN
391900        MOVE '('                  TO G-OUT-PRE-IMP-LEFTPAREN
392000        MOVE ')'                  TO G-OUT-PRE-IMP-RGHTPAREN
392100        MOVE IMPUT-MINUS-PREDICT  TO G-OUT-IMPUT-MINUS-PRED
392200        MOVE IMPUT-MINUS-PREDICT  TO G-OUT-PRED-IMPUT-DIFFER
392300        MOVE SPACES               TO G-OUT-LOSS-SHARE-PCT
392400     ELSE
392500        MOVE IMPUT-MINUS-PREDICT  TO G-OUT-IMPUT-MINUS-PRED
392600        COMPUTE OUT-LOSS-SHARE-PERCENT  ROUNDED  =
392700            100 * OUT-LOSS-SHARING-PCT
392800        STRING OUT-LOSS-SHARE-PERCENT  ' %'
392900               DELIMITED BY SIZE
393000               INTO G-OUT-LOSS-SHARE-PCT
393100        COMPUTE IMPUT-PRED-DIFFER  ROUNDED  =
393200           IMPUT-MINUS-PREDICT  *  OUT-LOSS-SHARING-PCT
393300        MOVE IMPUT-PRED-DIFFER    TO G-OUT-PRED-IMPUT-DIFFER
393400     END-IF.
393500
393600*----------------------------------------------------------------*
393700*Composite Rate Pay calculation tab of the PPS-screen  TAB-3     *
393800*----------------------------------------------------------------*
393900     IF P-PROV-WAIVE-BLEND-PAY-INDIC = 'N' THEN
394000        STRING 'CR Base Rate. . . . . . . . . .'
394100               DELIMITED BY SIZE
394200               INTO G-CR-CBSA-BASE-RATE
394300        MOVE COM-PAYMENT-RATE     TO G-CR-CBSA-BASE-RATE-AMT
394400
394500        STRING 'CR Labor pct. . . .'
394600               DELIMITED BY SIZE
394700               INTO G-CR-LABOR-PCT
394800        MOVE PPS-NAT-LABOR-PCT    TO G-CR-LABOR-PERCENT
394900
395000        STRING 'CR Wage Index . . . . . . . . .'
395100                DELIMITED BY SIZE
395200                INTO G-CR-WAGE-INDX
395300        MOVE CBSA-WAGE-INDEX      TO G-CR-WAGE-INDEX
395400
395500        STRING 'Composite Rate labor portion. .'
395600                DELIMITED BY SIZE
395700                INTO G-CR-LABOR-PORTION
395800        COMPUTE CR-LABOR-PORTION  ROUNDED  =
395900                (COM-PAYMENT-RATE  *  PPS-NAT-LABOR-PCT
396000                                   *  CBSA-WAGE-INDEX)
396100        MOVE CR-LABOR-PORTION     TO G-CR-LABOR-PORTION-AMT
396200
396300        STRING 'CR Base Rate. . . . . . . . . .'
396400               DELIMITED BY SIZE
396500               INTO G-CR-ESRD-BASE-RATE-2
396600
396700        STRING 'CR non labor pct .'
396800                DELIMITED BY SIZE
396900                INTO G-CR-NON-LABOR-PCT
397000        MOVE PPS-NAT-NONLABOR-PCT TO G-CR-NON-LABOR-PERCENT
397100
397200        STRING 'Composite Rate NON labor portion .'
397300                DELIMITED BY SIZE
397400                INTO G-CR-NON-LABOR-PORTION
397500        COMPUTE CR-NON-LABOR-PORTION  ROUNDED  =
397600                (COM-PAYMENT-RATE  *  PPS-NAT-NONLABOR-PCT)
397700        MOVE CR-NON-LABOR-PORTION TO G-CR-NON-LABOR-PORT-AMT
397800
397900        STRING 'CR Wage Adjusted Base Rate'
398000               DELIMITED BY SIZE
398100               INTO G-CR-WAGE-ADJ-BASE-RATE
398200        MOVE PPS-WAGE-ADJ-RATE    TO G-CR-PPS-11-WG-ADJ-RATE
398300     ELSE
398400        STRING 'ALL Composite Rate results are'
398500               DELIMITED BY SIZE
398600               INTO G-CR-LABOR-PORTION
398700        STRING 'NOT APPLICABLE due'
398800               DELIMITED BY SIZE
398900               INTO G-CR-ESRD-BASE-RATE-2
399000        STRING 'to blend payment being waived.'
399100               DELIMITED BY SIZE
399200               INTO G-CR-NON-LABOR-PORTION
399300     END-IF.
399400
399500
399600*----------------------------------------------------------------*
399700*Age, BSA, BMI calculation tab of the PPS-screen   TAB-4         *
399800*----------------------------------------------------------------*
399900*************
400000*  Age boxes*
400100*************
400200*  PPS COLUMN                                                    *
400300     IF B-REV-CODE = '0821' THEN
400400        MOVE 'HEMO'               TO DIAL-MODE
400500     ELSE
400600        MOVE 'PD  '               TO DIAL-MODE
400700     END-IF.
400800
400900     MOVE AGE-RETURN              TO FORMATTED-AGE.
401000     STRING 'Age  =  '  FORMATTED-AGE
401100            '        Dialysis Mode = ' DIAL-MODE
401200            DELIMITED BY SIZE
401300            INTO G-PPS-AGE-LINE-1.
401400
401500     IF AGE-RETURN < 13  THEN
401600        STRING 'for younger pediatric patient'
401700               DELIMITED BY SIZE
401800               INTO G-PPS-AGE-LINE-2
401900        STRING 'with   ' DIAL-MODE '   dialysis mode'
402000               DELIMITED BY SIZE
402100               INTO G-PPS-AGE-LINE-3
402200     ELSE
402300        IF AGE-RETURN < 18  THEN
402400           STRING 'for older pediatric patient'
402500                  DELIMITED BY SIZE
402600                  INTO G-PPS-AGE-LINE-2
402700           STRING 'with   ' DIAL-MODE '   dialysis mode'
402800                  DELIMITED BY SIZE
402900                  INTO G-PPS-AGE-LINE-3
403000        ELSE
403100           IF AGE-RETURN < 45  THEN
403200              STRING 'for patients 18-44 years old'
403300                     DELIMITED BY SIZE
403400                     INTO G-PPS-AGE-LINE-2
403500           ELSE
403600              IF AGE-RETURN < 60  THEN
403700                 STRING 'for patients 45-59 years old'
403800                        DELIMITED BY SIZE
403900                        INTO G-PPS-AGE-LINE-2
404000              ELSE
404100                 IF AGE-RETURN < 70  THEN
404200                    STRING 'for patients 60-69 years old'
404300                           DELIMITED BY SIZE
404400                           INTO G-PPS-AGE-LINE-2
404500                 ELSE
404600                    IF AGE-RETURN < 80  THEN
404700                       STRING 'for patients 70-79 years old'
404800                              DELIMITED BY SIZE
404900                              INTO G-PPS-AGE-LINE-2
405000                    ELSE
405100                       STRING 'for patients 80-plus years old'
405200                              DELIMITED BY SIZE
405300                              INTO G-PPS-AGE-LINE-2
405400                    END-IF
405500                 END-IF
405600              END-IF
405700           END-IF
405800        END-IF
405900     END-IF.
406000
406100*  OUTLIER COLUMN                                                *
406200     MOVE PPS-2011-AGE-FACTOR     TO FORMATTED-AGE-FACTOR.
406300     STRING 'Age factor  =  '
406400            FORMATTED-AGE-FACTOR
406500            DELIMITED BY SIZE
406600            INTO G-PPS-AGE-LINE-4.
406700
406800     MOVE G-PPS-AGE-LINE-1        TO G-OUT-AGE-LINE-1.
406900     MOVE G-PPS-AGE-LINE-2        TO G-OUT-AGE-LINE-2.
407000     MOVE G-PPS-AGE-LINE-3        TO G-OUT-AGE-LINE-3.
407100     MOVE OUT-AGE-FACTOR          TO FORMATTED-AGE-FACTOR.
407200     STRING 'Age factor  =  '
407300            FORMATTED-AGE-FACTOR
407400            DELIMITED BY SIZE
407500            INTO G-OUT-AGE-LINE-4.
407600
407700*  COMPOSITE RATE COLUMN                                         *
407800     IF P-PROV-WAIVE-BLEND-PAY-INDIC = 'N' THEN
407900        STRING 'Age  =  '
408000               FORMATTED-AGE
408100               '         Dialysis Mode = '
408200               DIAL-MODE
408300               DELIMITED BY SIZE
408400               INTO G-CR-AGE-LINE-1
408500        MOVE PPS-AGE-FACTOR       TO FORMATTED-AGE-FACTOR
408600        STRING 'Age factor  =  '
408700               FORMATTED-AGE-FACTOR
408800               DELIMITED BY SIZE
408900               INTO G-CR-AGE-LINE-4
409000
409100        IF AGE-RETURN < 18  THEN
409200           STRING 'for patients 0-17 years old'
409300                  DELIMITED BY SIZE
409400                  INTO G-CR-AGE-LINE-2
409500        ELSE
409600           IF AGE-RETURN < 45  THEN
409700              STRING 'for patients 18-44 years old'
409800                     DELIMITED BY SIZE
409900                     INTO G-CR-AGE-LINE-2
410000           ELSE
410100              IF AGE-RETURN < 60  THEN
410200                 STRING 'for patients 45-59 years old'
410300                        DELIMITED BY SIZE
410400                        INTO G-CR-AGE-LINE-2
410500              ELSE
410600                 IF AGE-RETURN < 70  THEN
410700                    STRING 'for patients 60-69 years old'
410800                           DELIMITED BY SIZE
410900                           INTO G-CR-AGE-LINE-2
411000                 ELSE
411100                    IF AGE-RETURN < 80  THEN
411200                       STRING 'for patients 70-79 years old'
411300                              DELIMITED BY SIZE
411400                              INTO G-CR-AGE-LINE-2
411500                    ELSE
411600                       STRING 'for patients 80-plus years old'
411700                              DELIMITED BY SIZE
411800                              INTO G-CR-AGE-LINE-2
411900                    END-IF
412000                 END-IF
412100              END-IF
412200           END-IF
412300        END-IF
412400     ELSE
412500        STRING 'ALL Composite Rate results are'
412600               DELIMITED BY SIZE
412700               INTO G-CR-AGE-LINE-1
412800        STRING 'NOT APPLICABLE due'
412900               DELIMITED BY SIZE
413000               INTO G-CR-AGE-LINE-2
413100        STRING 'to blend payment being waived.'
413200               DELIMITED BY SIZE
413300               INTO G-CR-AGE-LINE-3
413400     END-IF.
413500
413600*************
413700*  BSA boxes*
413800*************
413900*  BOTH PPS and Outlier BSA                                      *
414000     MOVE '                .725                .425'
414100                                  TO G-PPS-BSA-LINE-1.
414200     MOVE B-PATIENT-HGT           TO FORMATTED-HGT.
414300     MOVE B-PATIENT-WGT           TO FORMATTED-WGT.
414400     STRING '( ( '
414500            FORMATTED-HGT
414600            '        *    '
414700            FORMATTED-WGT
414800            '         )  *  .007184 )'
414900            DELIMITED BY SIZE
415000            INTO G-PPS-BSA-LINE-2.
415100
415200     MOVE BUN-BSA                 TO FORMATTED-BSA.
415300     STRING 'BSA  =  '   FORMATTED-BSA
415400            DELIMITED BY SIZE
415500            INTO G-PPS-BSA-LINE-3.
415600     MOVE G-PPS-BSA-LINE-1        TO G-OUT-BSA-LINE-1.
415700     MOVE G-PPS-BSA-LINE-2        TO G-OUT-BSA-LINE-2.
415800     MOVE G-PPS-BSA-LINE-3        TO G-OUT-BSA-LINE-3.
415900     MOVE G-PPS-BSA-LINE-4        TO G-OUT-BSA-LINE-4.
416000
416100     IF AGE-RETURN > 17  THEN
416200*  PPS adult BSA factor                                          *
416300        MOVE BUN-BSA              TO FORMATTED-BSA
416400        STRING '          ( ( '
416500               FORMATTED-BSA
416600               ' - 1.87)  / .1)'
416700               DELIMITED BY SIZE
416800               INTO G-PPS-BSA-LINE-5
416900        MOVE PPS-CM-BSA           TO FORMATTED-MULTIPLIER
417000        STRING FORMATTED-MULTIPLIER
417100               DELIMITED BY SIZE
417200               INTO G-PPS-BSA-LINE-6
417300        MOVE PPS-2011-BSA-FACTOR  TO FORMATTED-BSA-FACTOR
417400        STRING 'BSA factor  =  '
417500               FORMATTED-BSA-FACTOR
417600               DELIMITED BY SIZE
417700               INTO G-PPS-BSA-LINE-7
417800        STRING 'for adult patient'
417900               DELIMITED BY SIZE
418000               INTO G-PPS-BSA-LINE-8
418100*  Outlier adult BSA factor                                      *
418200        MOVE G-PPS-BSA-LINE-5     TO G-OUT-BSA-LINE-5
418300        MOVE OUT-SB-BSA           TO FORMATTED-MULTIPLIER
418400        STRING FORMATTED-MULTIPLIER
418500               DELIMITED BY SIZE
418600               INTO G-OUT-BSA-LINE-6
418700        MOVE OUT-BSA-FACTOR       TO FORMATTED-BSA-FACTOR
418800        STRING 'BSA factor  =  '
418900               FORMATTED-BSA-FACTOR
419000               DELIMITED BY SIZE
419100               INTO G-OUT-BSA-LINE-7
419200        MOVE G-PPS-BSA-LINE-8     TO G-OUT-BSA-LINE-8
419300     ELSE
419400*  PPS and Outlier Pediatric BSA factor                          *
419500        MOVE PPS-2011-BSA-FACTOR  TO FORMATTED-BSA-FACTOR
419600        STRING 'BSA factor  =  '
419700               FORMATTED-BSA-FACTOR
419800               DELIMITED BY SIZE
419900               INTO G-PPS-BSA-LINE-7
420000        STRING 'for pediatric patient'
420100               DELIMITED BY SIZE
420200               INTO G-PPS-BSA-LINE-8
420300        MOVE OUT-BSA-FACTOR       TO FORMATTED-BSA-FACTOR
420400        STRING 'BSA FACTOR = '
420500               FORMATTED-BSA-FACTOR
420600               DELIMITED BY SIZE
420700               INTO G-OUT-BSA-LINE-7
420800        MOVE G-PPS-BSA-LINE-8     TO G-OUT-BSA-LINE-8
420900     END-IF.
421000
421100     IF P-PROV-WAIVE-BLEND-PAY-INDIC = 'N'  THEN
421200*  Composite Rate BSA factor                                     *
421300        MOVE '                .725                .425'
421400                                  TO G-CR-BSA-LINE-1
421500        STRING '( ( '
421600               FORMATTED-HGT
421700               '        *    '
421800               FORMATTED-WGT
421900               '         )  *  .007184 )'
422000               DELIMITED BY SIZE
422100               INTO G-CR-BSA-LINE-2
422200        MOVE PPS-BSA              TO FORMATTED-BSA
422300        STRING 'BSA  =  '
422400               FORMATTED-BSA
422500               DELIMITED BY SIZE
422600               INTO G-CR-BSA-LINE-3
422700        IF AGE-RETURN > 17  THEN
422800           MOVE PPS-BSA           TO FORMATTED-BSA
422900           STRING '           ( ( '
423000                  FORMATTED-BSA
423100                  ' - 1.84)  / .1)'
423200                  DELIMITED BY SIZE
423300                  INTO G-CR-BSA-LINE-5
423400           MOVE CR-BSA-MULTIPLIER TO FORMATTED-MULTIPLIER
423500           STRING FORMATTED-MULTIPLIER
423600                  DELIMITED BY SIZE
423700                  INTO G-CR-BSA-LINE-6
423800           MOVE PPS-BSA-FACTOR    TO FORMATTED-BSA-FACTOR
423900           STRING 'BSA factor  =  '
424000                  FORMATTED-BSA-FACTOR
424100                  DELIMITED BY SIZE
424200                  INTO G-CR-BSA-LINE-7
424300           STRING 'for adult patient'
424400                  DELIMITED BY SIZE
424500                  INTO G-CR-BSA-LINE-8
424600        ELSE
424700           MOVE PPS-BSA-FACTOR       TO FORMATTED-BSA-FACTOR
424800           STRING 'BSA factor  =  '
424900                  FORMATTED-BSA-FACTOR
425000                  DELIMITED BY SIZE
425100                  INTO G-CR-BSA-LINE-7
425200           STRING 'for pediatric patient'
425300                  DELIMITED BY SIZE
425400                  INTO G-CR-BSA-LINE-8
425500        END-IF
425600     END-IF.
425700
425800*************
425900*  BMI boxes*                                                  *
426000*************
426100*  PPS and Outlier BMI                                           *
426200     MOVE '                                  2'
426300                                  TO G-PPS-BMI-LINE-1
426400     MOVE B-PATIENT-HGT           TO FORMATTED-HGT.
426500     MOVE B-PATIENT-WGT           TO FORMATTED-WGT.
426600     STRING '( '
426700            FORMATTED-WGT
426800            '   /   ( '
426900            FORMATTED-HGT
427000            '    ) )  *  10000'
427100            DELIMITED BY SIZE
427200            INTO G-PPS-BMI-LINE-2
427300     MOVE BUN-BMI                 TO FORMATTED-BMI.
427400     STRING 'BMI  =  '
427500            FORMATTED-BMI
427600            DELIMITED BY SIZE
427700            INTO G-PPS-BMI-LINE-3.
427800
427900     MOVE G-PPS-BMI-LINE-1        TO G-OUT-BMI-LINE-1.
428000     MOVE G-PPS-BMI-LINE-2        TO G-OUT-BMI-LINE-2.
428100     MOVE G-PPS-BMI-LINE-3        TO G-OUT-BMI-LINE-3.
428200     MOVE G-PPS-BMI-LINE-4        TO G-OUT-BMI-LINE-4.
428300
428400     MOVE PPS-2011-BMI-FACTOR       TO FORMATTED-BMI-FACTOR
428500     STRING 'BMI factor  =  '
428600            FORMATTED-BMI-FACTOR
428700            DELIMITED BY SIZE
428800            INTO G-PPS-BMI-LINE-7
428900     MOVE OUT-BMI-FACTOR       TO FORMATTED-BMI-FACTOR
429000     STRING 'BMI factor  =  '
429100            FORMATTED-BMI-FACTOR
429200            DELIMITED BY SIZE
429300            INTO G-OUT-BMI-LINE-7
429400     IF (AGE-RETURN > 17)  AND  (BUN-BMI < 18.5)   THEN
429500*  PPS adult BMI factor < 18.5                                   *
429600        STRING 'for adult patient with BMI < 18.5'
429700               DELIMITED BY SIZE
429800               INTO G-PPS-BMI-LINE-8
429900        MOVE G-PPS-BMI-LINE-8     TO G-OUT-BMI-LINE-8
430000     ELSE
430100        IF AGE-RETURN > 17  AND  (BUN-BMI > 18.5)   THEN
430200*  PPS adult BMI factor > 18.5                                   *
430300           STRING 'for adult patient with BMI > 18.5'
430400                  DELIMITED BY SIZE
430500                  INTO G-PPS-BMI-LINE-8
430600           MOVE G-PPS-BMI-LINE-8  TO G-OUT-BMI-LINE-8
430700        ELSE
430800           IF AGE-RETURN < 17  AND  (BUN-BMI < 18.5)   THEN
430900*  PPS pediatric BMI factor < 18.5                               *
431000              STRING 'for pediatric patient with BMI < 18.5'
431100                     DELIMITED BY SIZE
431200                     INTO G-PPS-BMI-LINE-8
431300              MOVE G-PPS-BMI-LINE-8     TO G-OUT-BMI-LINE-8
431400           ELSE
431500*  PPS pediatric BMI factor > 18.5                               *
431600              STRING 'for pediatric patient with BMI > 18.5'
431700                     DELIMITED BY SIZE
431800                     INTO G-PPS-BMI-LINE-8
431900              MOVE G-PPS-BMI-LINE-8     TO G-OUT-BMI-LINE-8
432000           END-IF
432100        END-IF
432200     END-IF.
432300
432400     IF P-PROV-WAIVE-BLEND-PAY-INDIC = 'N'  THEN
432500*  Composite Rate BMI                                            *
432600        MOVE '                                  2'
432700                                  TO G-CR-BMI-LINE-1
432800        MOVE B-PATIENT-HGT        TO FORMATTED-HGT
432900        MOVE B-PATIENT-WGT        TO FORMATTED-WGT
433000        STRING '( '
433100               FORMATTED-WGT
433200               '   /   ( '
433300               FORMATTED-HGT
433400               '    ) )  *  10000'
433500               DELIMITED BY SIZE
433600               INTO G-CR-BMI-LINE-2
433700        MOVE PPS-BMI              TO FORMATTED-BMI
433800        STRING 'BMI  =  '
433900               FORMATTED-BMI
434000               DELIMITED BY SIZE
434100               INTO G-CR-BMI-LINE-3
434200        MOVE PPS-BMI-FACTOR       TO FORMATTED-BMI-FACTOR
434300        STRING 'BMI factor  =  '
434400               FORMATTED-BMI-FACTOR
434500               DELIMITED BY SIZE
434600               INTO G-CR-BMI-LINE-7
434700
434800        IF (AGE-RETURN > 17)  AND  (PPS-BMI < 18.5)   THEN
434900*  Composite Rate adult BMI factor < 18.5                        *
435000           STRING 'for adult patient with BMI < 18.5'
435100                  DELIMITED BY SIZE
435200                  INTO G-CR-BMI-LINE-8
435300        ELSE
435400           IF AGE-RETURN > 17  AND  (PPS-BMI > 18.5)   THEN
435500*  Composite Rate adult BMI factor > 18.5                        *
435600              STRING 'for adult patient with BMI > 18.5'
435700                     DELIMITED BY SIZE
435800                     INTO G-CR-BMI-LINE-8
435900           ELSE
436000              IF AGE-RETURN < 17  AND  (PPS-BMI < 18.5)   THEN
436100*  Composite Rate pediatric BMI factor < 18.5                    *
436200                 STRING 'for pediatric patient with BMI < 18.5'
436300                        DELIMITED BY SIZE
436400                        INTO G-CR-BMI-LINE-8
436500              ELSE
436600*  Composite Rate pediatric BMI factor > 18.5                    *
436700                 STRING 'for pediatric patient with BMI > 18.5'
436800                        DELIMITED BY SIZE
436900                        INTO G-CR-BMI-LINE-8
437000              END-IF
437100           END-IF
437200        END-IF
437300     END-IF.
437400/
437500******************************************************************
437600 4000-PRINT SECTION.
437700******************************************************************
437800*----------------------------------------------------------------*
437900 4100-PROCESS-PRINT-SCREEN.
438000*----------------------------------------------------------------*
438100**SPECIFY THE FILE TO BE PRINTED
438200     MOVE PC-P-FILE-NAME TO JCL-PRINT-SPOOL.
438300
438400     OPEN OUTPUT PC-PRINTER-FILE.
438500
438600*    DISPLAY 'PC-PRINTER-NAME = ' PC-PRINTER-FILENAME 'x'.
438700
438800     IF PC-SPOOLER-FILE-STATUS  = '00' THEN
438900        NEXT SENTENCE
439000     ELSE
439100*       DISPLAY 'OPEN-SPOOLER-FILE-STATUS = '
439200*                  PC-SPOOLER-FILE-STATUS
439300        GO TO 4100-PROCESS-PRINT-SCREEN-EXIT
439400     END-IF.
439500
439600**CREATE AND PRINT THE OUTPUT FILE CONTAINING THE REPORT
439700
439800     PERFORM 4150-CREATE-PPS-REPORT.
439900     PERFORM 4200-WRITE-REPORT-TO-FILE.
440000
440100     CLOSE PC-PRINTER-FILE.
440200
440300     IF PC-SPOOLER-FILE-STATUS  = '00' THEN
440400        NEXT SENTENCE
440500     ELSE
440600*       DISPLAY 'CLOSE-SPOOLER-FILE-STATUS = '
440700*                   PC-SPOOLER-FILE-STATUS
440800        GO TO 4100-PROCESS-PRINT-SCREEN-EXIT
440900     END-IF.
441000
441100*    DISPLAY ' '.
441200
441300*    DISPLAY 'GOOD-SPOOLER-FILE-STATUS = ' PC-SPOOLER-FILE-STATUS.
441400
441500**PRINTER DIALOG AND PROGRESS DIALOG PRINTER SETTINGS ENABLED
441600     SET PC-P-PORTRAIT-ORIENTATION TO TRUE.
441700*    DISPLAY 'PC-P-PORTRAIT-ORIENTATION = ' PC-PRINTER-FLAGS.
441800
441900     MOVE ZEROES TO PC-PRINT-STATUS-CODE.
442000
442100**PRINT THE FILE WHERE THE PRINTOUT IS LOCATED
442200     CALL PC-PRINT-FILE   USING      PC-PRINTER-FILENAME
442300                                     PPS-REPORT-TITLE
442400                          BY VALUE   PC-PRINTER-FLAGS
442500                          BY VALUE   WINDOW-HANDLE
442600                          RETURNING  PC-PRINT-STATUS-CODE
442700     END-CALL.
442800
442900**CHECK THE PRINT STATUS & IF AN ERROR OCCURED, THEN DISPLAY IT
443000
443100     IF PC-PRINT-STATUS-CODE  = ZERO  THEN
443200        NEXT SENTENCE
443300     ELSE
443400*       DISPLAY 'Printer FILE has some kind of error. '
443500*               'FILE not created.' PC-PRINT-STATUS-CODE
443600        GO TO 4100-PROCESS-PRINT-SCREEN-EXIT
443700     END-IF.
443800
443900     IF PC-PRINT-STATUS-CODE = ZERO  THEN
444000        NEXT SENTENCE
444100     ELSE
444200        IF PC-PRINT-STATUS-CODE > 24  THEN
444300           NEXT SENTENCE
444400*          DISPLAY
444500*       'Major error... the returned PC-P-STATUS-CODE exceeds 24'
444600*       'PC-P-STATUS-CODE = ' PC-PRINT-STATUS-CODE
444700        ELSE
444800           PERFORM 4300-GET-PRINT-ERROR-MSG THRU 4300-EXIT
444900*          DISPLAY 'GOT ERROR MESSAGE'
445000        END-IF
445100     END-IF.
445200
445300 4100-PROCESS-PRINT-SCREEN-EXIT.
445400      EXIT.
445500
445600
445700*----------------------------------------------------------------*
445800 4150-CREATE-PPS-REPORT.
445900*----------------------------------------------------------------*
446000* Prepare printed date, time, version of printout                *
446100     ACCEPT TODAYS-TIME FROM TIME.
446200
446300     IF THIS-HOUR > 12  THEN
446400        SUBTRACT 12 FROM THIS-HOUR GIVING THIS-HOUR
446500        MOVE 'P'                  TO PC-P-MERIDIAN
446600     ELSE
446700        IF THIS-HOUR = 12  THEN
446800           MOVE 'P'               TO PC-P-MERIDIAN
446900        ELSE
447000           MOVE 'A'               TO PC-P-MERIDIAN
447100        END-IF
447200     END-IF.
447300
447400     MOVE THIS-HOUR               TO PC-P-HOUR.
447500     MOVE THIS-MINUTE             TO PC-P-MINUTE.
447600
447700* Prepare printed report of claim screen                         *
447800     MOVE G-FACILITY-TYPE-DESC    TO PC-P-G-FACILITY-TYPE-DESC.
447900     MOVE G-P-MSA                 TO PC-P-G-P-MSA.
448000     MOVE G-P-CBSA                TO PC-P-G-P-CBSA.
448100     MOVE B-DOB-DATE              TO MAINFRAME-DATE-FORMAT.
448200     MOVE MAINFRAME-YEAR          TO READABLE-YEAR.
448300     MOVE MAINFRAME-MONTH         TO READABLE-MONTH.
448400     MOVE MAINFRAME-DAY           TO READABLE-DAY.
448500     MOVE READABLE-DATE           TO PC-P-G-B-DOB-DATE.
448600     MOVE G-B-PATIENT-WGT         TO PC-P-G-B-PATIENT-WGT.
448700     MOVE G-B-PATIENT-HGT         TO PC-P-G-B-PATIENT-HGT.
448800     MOVE G-HICAN                 TO PC-P-G-HICAN.
448900     MOVE B-THRU-DATE             TO MAINFRAME-DATE-FORMAT.
449000     MOVE MAINFRAME-YEAR          TO READABLE-YEAR.
449100     MOVE MAINFRAME-MONTH         TO READABLE-MONTH.
449200     MOVE MAINFRAME-DAY           TO READABLE-DAY.
449300     MOVE READABLE-DATE           TO PC-P-G-B-THRU-DATE.
449400     MOVE G-B-COND-CODE           TO PC-P-G-B-COND-CODE.
449500     MOVE B-REV-CODE              TO PC-P-G-REV-CODE.
449600
449700* Prepare printed report of PPS screen Final Payment TAB
449800     MOVE G-PPS-CALC-VERS-CD      TO PC-P-G-PPS-CALC-VERS-CD.
449900     MOVE G-PPS-CLAIM-THRU-DATE   TO PC-P-G-PPS-CLAIM-THRU-DATE.
450000     MOVE G-MSA-PERCENT           TO PC-P-G-MSA-PERCENT.
450100     MOVE G-CBSA-PERCENT          TO PC-P-G-CBSA-PERCENT.
450200     MOVE G-MSA-WAGE-ADJ          TO PC-P-G-MSA-WAGE-ADJ.
450300     MOVE G-CBSA-WAGE-ADJ         TO PC-P-G-CBSA-WAGE-ADJ-1.
450400     MOVE G-PPS-WAGE-ADJ-RATE     TO PC-P-G-PPS-WAGE-ADJ-RATE.
450500     MOVE G-DRUG-ADD-ON-RETURN    TO PC-P-G-DRUG-ADD-ON-RETURN.
450600     MOVE G-PPS-BDGT-NEUT-RATE    TO PC-P-G-PPS-BDGT-NEUT-RATE.
450700     MOVE G-PPS-AGE-FACTOR        TO PC-P-G-PPS-AGE-FACTOR.
450800     MOVE G-PPS-BSA-FACTOR        TO PC-P-G-PPS-BSA-FACTOR.
450900     MOVE G-PPS-BMI-FACTOR        TO PC-P-G-PPS-BMI-FACTOR.
451000     MOVE G-CASE-MIX-FCTR-ADJ-RT  TO PC-P-G-CASE-MIX-FCTR-ADJ-RT.
451100     MOVE G-TRAINING-DAILY-RATE   TO PC-P-G-TRAINING-DAILY-RATE.
451200     MOVE G-TRAINING-LINE-1       TO PC-P-G-TRAINING-LINE-1.
451300     MOVE G-TRAINING-LINE-2       TO PC-P-G-TRAINING-LINE-2.
451400     MOVE G-TRAINING-LINE-3       TO PC-P-G-TRAINING-LINE-3.
451500     MOVE G-TRAINING-AMT          TO PC-P-G-TRAINING-AMT.
451600     MOVE G-PPS-FINAL-PAY-AMT     TO PC-P-G-PPS-FINAL-PAY-AMT.
451700
451800* Prepare printed report of PPS screen Payment Calculations TAB
451900     MOVE G-MSA-LINE-1            TO PC-P-G-MSA-LINE-1.
452000     MOVE G-MSA-LINE-2            TO PC-P-G-MSA-LINE-2.
452100     MOVE G-MSA-LINE-3            TO PC-P-G-MSA-LINE-3.
452200     MOVE G-MSA-LINE-4            TO PC-P-G-MSA-LINE-4.
452300     MOVE G-MSA-LINE-5            TO PC-P-G-MSA-LINE-5.
452400     MOVE G-MSA-WAGE-AMT          TO PC-P-G-MSA-WAGE-AMT.
452500     MOVE G-2006-MSA-WAGE-AMT     TO PC-P-G-2006-MSA-WAGE-AMT.
452600     MOVE G-2007-MSA-WAGE-AMT     TO PC-P-G-2007-MSA-WAGE-AMT.
452700     MOVE G-2008-MSA-WAGE-AMT     TO PC-P-G-2008-MSA-WAGE-AMT.
452800     MOVE G-2008-MSA-WAGE-ADJ     TO PC-P-G-2008-MSA-WAGE-ADJ.
452900     MOVE G-CBSA-LINE-1           TO PC-P-G-CBSA-LINE-1.
453000     MOVE G-CBSA-LINE-2           TO PC-P-G-CBSA-LINE-2.
453100     MOVE G-CBSA-LINE-3           TO PC-P-G-CBSA-LINE-3.
453200     MOVE G-CBSA-LINE-4           TO PC-P-G-CBSA-LINE-4.
453300     MOVE G-CBSA-LINE-5           TO PC-P-G-CBSA-LINE-5.
453400     MOVE G-CBSA-LINE-6           TO PC-P-G-CBSA-LINE-6.
453500     MOVE G-CBSA-WAGE-PMT-RATE    TO PC-P-G-CBSA-WAGE-PMT-RATE-1.
453600     MOVE G-PPS-NAT-LABOR-PCT     TO PC-P-G-PPS-NAT-LABOR-PCT.
453700     MOVE G-CBSA-WAGE-INDEX       TO PC-P-G-CBSA-WAGE-INDEX.
453800     MOVE G-CBSA-WAGE-PMT-RATE    TO PC-P-G-CBSA-WAGE-PMT-RATE-2.
453900     MOVE G-PPS-NAT-NONLABOR-PCT  TO PC-P-G-PPS-NAT-NONLABOR-PCT.
454000     MOVE G-CBSA-WAGE-ADJ         TO PC-P-G-CBSA-WAGE-ADJ-2.
454100
454200*----------------------------------------------------------------*
454300 4200-WRITE-REPORT-TO-FILE.
454400*----------------------------------------------------------------*
454500*WRITE REPORT TO FILE FOR LATER PRINTING VIA PC_PRINT_FILE
454600     WRITE PC-PRINTER-LINE FROM PC-P-DATE-TIME-VERS-LINE
454700         AFTER ADVANCING 1 LINES.
454800     WRITE PC-PRINTER-LINE FROM PC-P-DASH-LINE
454900         AFTER ADVANCING 1 LINES.
455000     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-HEADER-LINE1U
455100         AFTER ADVANCING 3 LINE.
455200     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-HEADER-LINE1
455300         AFTER ADVANCING 1 LINE.
455400     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-HEADER-LINE1U
455500         AFTER ADVANCING 1 LINE.
455600     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-HEADER-LINE2
455700         AFTER ADVANCING 2 LINES.
455800     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-HEADER-LINE2U
455900         AFTER ADVANCING 1 LINE.
456000     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-DETAIL-LINE1
456100         AFTER ADVANCING 2 LINES.
456200     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-DETAIL-LINE2
456300         AFTER ADVANCING 2 LINES.
456400*    WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-DETAIL-LINE3
456500*        AFTER ADVANCING 1 LINE.
456600     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-DETAIL-LINE4
456700         AFTER ADVANCING 2 LINES.
456800*    WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-DETAIL-LINE5
456900*        AFTER ADVANCING 1 LINE.
457000     WRITE PC-PRINTER-LINE FROM PC-P-CLAIM-DETAIL-LINE6
457100         AFTER ADVANCING 2 LINES.
457200     WRITE PC-PRINTER-LINE FROM PC-P-DASH-LINE
457300         AFTER ADVANCING 3 LINES.
457400
457500* - - - Final Payment TAB
457600
457700     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE1U
457800         AFTER ADVANCING 3 LINES.
457900     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE1
458000         AFTER ADVANCING 1 LINE.
458100     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE1U
458200         AFTER ADVANCING 1 LINE.
458300     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE2
458400         AFTER ADVANCING 2 LINES.
458500     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE1
458600         AFTER ADVANCING 2 LINES.
458700     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE1U
458800         AFTER ADVANCING 1 LINE.
458900     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE2
459000         AFTER ADVANCING 1 LINE.
459100     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE3
459200         AFTER ADVANCING 1 LINE.
459300     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE4
459400         AFTER ADVANCING 1 LINE.
459500     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE5
459600         AFTER ADVANCING 2 LINES.
459700     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE5U
459800         AFTER ADVANCING 1 LINE.
459900     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE6
460000         AFTER ADVANCING 1 LINE.
460100     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE7
460200         AFTER ADVANCING 1 LINES.
460300     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE8
460400         AFTER ADVANCING 1 LINE.
460500     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE9
460600         AFTER ADVANCING 1 LINE.
460700     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE10
460800         AFTER ADVANCING 1 LINE.
460900     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE11
461000         AFTER ADVANCING 1 LINE.
461100     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE12
461200         AFTER ADVANCING 3 LINES.
461300     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE13
461400         AFTER ADVANCING 1 LINE.
461500     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE14
461600         AFTER ADVANCING 1 LINE.
461700     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE15
461800         AFTER ADVANCING 1 LINE.
461900     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE16
462000         AFTER ADVANCING 1 LINE.
462100
462200* - - - Payment Calculation TAB
462300
462400     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE3U
462500         AFTER ADVANCING 3 LINES.
462600     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE3
462700         AFTER ADVANCING 1 LINE.
462800     WRITE PC-PRINTER-LINE FROM PC-P-PPS-HEADER-LINE3U
462900         AFTER ADVANCING 1 LINE.
463000     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE17
463100         AFTER ADVANCING 2 LINES.
463200     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE17U
463300         AFTER ADVANCING 1 LINE.
463400     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE18
463500         AFTER ADVANCING 1 LINE.
463600     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE19
463700         AFTER ADVANCING 1 LINE.
463800     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE20
463900         AFTER ADVANCING 1 LINE.
464000     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE21
464100         AFTER ADVANCING 1 LINE.
464200     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE22
464300         AFTER ADVANCING 1 LINE.
464400     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE23
464500         AFTER ADVANCING 1 LINE.
464600     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE24
464700         AFTER ADVANCING 2 LINES.
464800     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE25
464900         AFTER ADVANCING 1 LINE.
465000     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE26
465100         AFTER ADVANCING 1 LINE.
465200     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE27
465300         AFTER ADVANCING 2 LINES.
465400     WRITE PC-PRINTER-LINE FROM PC-P-PPS-DETAIL-LINE28
465500         AFTER ADVANCING 1 LINE.
465600
465700*----------------------------------------------------------------*
465800 4300-GET-PRINT-ERROR-MSG.
465900*    For use by the GUI system.
466000*----------------------------------------------------------------*
466100     SET PC-P-STATUS-CODE-IDX TO 1.
466200*    DISPLAY 'SEARCHING PC-P-PRINT-STATUS-CODE-ENTRY'
466300     SEARCH PC-P-PRINT-STATUS-CODE-ENTRY VARYING
466400                                         PC-P-STATUS-CODE-IDX
466500            AT END
466600                MOVE PC-PRINT-STATUS-CODE TO G-FILE-STATUS
466700                MOVE 'An internal print error has occured.'
466800                  TO G-FILE-ERROR-DESC
466900            WHEN TBL-PRINT-STATUS-CODE(PC-P-STATUS-CODE-IDX) =
467000                PC-PRINT-STATUS-CODE
467100                MOVE PC-PRINT-STATUS-CODE TO G-FILE-STATUS
467200*               DISPLAY 'DESC = '
467300*                    PC-P-STATUS-CODE-DESC(PC-P-STATUS-CODE-IDX)
467400                MOVE PC-P-STATUS-CODE-DESC(PC-P-STATUS-CODE-IDX)
467500                   TO G-FILE-ERROR-DESC
467600     END-SEARCH.
467700
467800     MOVE 'Y' TO G-MAJOR-FILE-ERR-SW.
467900
468000 4300-EXIT.
468100      EXIT.
468200
468300/
468400*----------------------------------------------------------------*
468500 5000-PROCESS-HELP-SCREEN.
468600*----------------------------------------------------------------*
468700     MOVE 'CLAIM     ' TO G-BUTTON-CODE.
468800
468900 5000-PROCESS-HELP-SCREEN-EXIT.
469000     EXIT.
469100/
469200*----------------------------------------------------------------*
469300 6000-PROCESS-EXIT-SCREEN.
469400*----------------------------------------------------------------*
469500     MOVE ZERO TO CREATE-STATUS-CD.
469600*    DISPLAY 'Prior to delete file, CREATE-STATUS-CD = '
469700*            CREATE-STATUS-CD.
469800*    DISPLAY 'PC-P-FILE-NAME = ' PC-P-FILE-NAME.
469900
470000     IF WELCOME-CODE = 'N'  THEN
470100        CALL CBL-DELETE-FILE   USING  PC-P-FILE-NAME
470200                           RETURNING  CREATE-STATUS-CD
470300        END-CALL
470400
470500*       IF CREATE-STATUS-CD = ZERO  THEN
470600*          NEXT SENTENCE
470700*          DISPLAY 'Print file has been deleted'
470800*       ELSE
470900*          NEXT SENTENCE
471000*          DISPLAY 'Not able to delete print file'
471100*                  'Delete status code = ' CREATE-STATUS-CD
471200*       END-IF
471300
471400*       DISPLAY 'AFTER delete file status = ' CREATE-STATUS-CD
471500
471600        CALL CBL-DELETE-DIR   USING PC-DIRECTORY-NAME
471700                          RETURNING CREATE-STATUS-CD
471800        END-CALL
471900
472000*       IF CREATE-STATUS-CD = ZERO  THEN
472100*          NEXT SENTENCE
472200*          DISPLAY 'Directory has been deleted'
472300*       ELSE
472400*          NEXT SENTENCE
472500*          DISPLAY 'Not able to delete directory. '
472600*                  'Delete status code = ' CREATE-STATUS-CD
472700*       END-IF
472800     END-IF.
472900
473000 6000-PROCESS-EXIT-SCREEN-EXIT.
473100     EXIT.
473200/
473300******************************************************************
473400******************************************************************
473500*. . . THE CODE BELOW IS STRICTLY FOR USE ON THE MAINFRAME . . . .
473600******************************************************************
473700******************************************************************
473800
473900******************************************************************
474000 8000-MAINFRAME-PART  SECTION.
474100******************************************************************
474200 8000-MAINFRAME-CODE.
474300     MOVE MANAGER-VERSION             TO PRT-PPMGR-VERSION.
474400     MOVE FUNCTION CURRENT-DATE(1:12) TO RUN-DATE-TIME.
474500
474600     DISPLAY 'MGR VERSION   = ' PRT-PPMGR-VERSION.
474700     DISPLAY 'RUN DATE-TIME = ' RUN-DATE-TIME.
474800     DISPLAY ' '.
474900
475000     OPEN OUTPUT IBM-PRINTER.
475100     OPEN INPUT  BILLFILE.
475200
475300     MOVE 'N' TO IS-BILLFILE-EOF.
475400
475500     PERFORM UNTIL EOF-BILLFILE
475600        READ BILLFILE INTO BILL-NEW-DATA
475700           AT END
475800              MOVE 'Y' TO IS-BILLFILE-EOF
475900           NOT AT END
476000              ADD 1 TO BILL-RECS-CT
476100*             IF BILL-RECS-CT = 50  THEN
476200*                MOVE 'Y' TO IS-BILLFILE-EOF
476300*             END-IF
476400              PERFORM 9000-CALC-PAYMENT
476500              PERFORM 9100-PRINT-TEST-RECS
476600        END-READ
476700     END-PERFORM.
476800
476900     CLOSE BILLFILE.
477000     CLOSE IBM-PRINTER.
477100
477200     DISPLAY '   Bill-Recs . . . . . . .' BILL-RECS-CT.
477300     DISPLAY '00 Claim-Paid  . . . . . .' CLAIM-PAID-CT.
477400     DISPLAY '01 Rate-On-Bill. . . . . .' RATE-ON-BILL-CT.
477500     DISPLAY ' '.
477600     DISPLAY '02 no adjust . . . . . . .' NO-ADJUST-CT.
477700     DISPLAY '03 outlier . . . . . . . .' OUT-CT.
477800     DISPLAY '04 acute . . . . . . . . .' ACUTE-CT.
477900     DISPLAY '05 chronic . . . . . . . .' CHRONIC-CT.
478000     DISPLAY '06 acute  out. . . . . . .' ACUTE-OUT-CT.
478100     DISPLAY '07 chronic, out. . . . . .' CHRONIC-OUT-CT.
478200     DISPLAY '08 onset . . . . . . . . .' ONSET-CT.
478300     DISPLAY '09 onset, out. . . . . . .' ONSET-OUT-CT.
478400     DISPLAY '10 low vol . . . . . . . .' LOW-V-CT.
478500     DISPLAY '11 train . . . . . . . . .' TRAIN-CT.
478600     DISPLAY '12 low v, train. . . . . .' LOW-V-TRAIN-CT.
478700     DISPLAY '13 multiple adjust . . . .' MULTI-ADJUST-CT.
478800     DISPLAY '14 pediatric . . . . . . .' PEDIATRIC-CT.
478900     DISPLAY '15 pediatric, train. . . .' PEDIATRIC-TRAIN-CT.
479000     DISPLAY '16 pediatric, out. . . . .' PEDIATRIC-OUT-CT.
479100     DISPLAY '17 pediatric, out, train .' PEDIATRIC-OUT-TRAIN-CT.
479200     DISPLAY '18 acute, out, low v . . .' ACUTE-OUT-LOW-V-CT.
479300     DISPLAY '19 acute, out, low v train' ACUTE-OUT-LOW-V-TRAIN-CT
479400     DISPLAY '20 acute, low v. . . . . .' ACUTE-LOW-V-CT.
479500     DISPLAY '21 acute, low v, train . .' ACUTE-LOW-V-TRAIN-CT.
479600     DISPLAY '22 acute, train. . . . . .' ACUTE-TRAIN-CT.
479700     DISPLAY '23 chronic, out, low v . .' CHRONIC-OUT-LOW-V-CT.
479800     DISPLAY '24 chronic out low v train' CHRONIC-OUT-LV-TRAIN-CT.
479900     DISPLAY '25 chronic, low v. . . . .' CHRONIC-LOW-V-CT.
480000     DISPLAY '26 chronic, low v, train .' CHRONIC-LOW-V-TRAIN-CT.
480100     DISPLAY '27 chronic, train. . . . .' CHRONIC-TRAIN-CT.
480200     DISPLAY '28 out, low v. . . . . . .' OUT-LOW-CT.
480300     DISPLAY '29 out, low v, train . . .' OUT-LOW-TRAIN-CT.
480400     DISPLAY '30 onset, out, low v . . .' ONSET-OUT-LOW-CT.
480500     DISPLAY '31 low BMI . . . . . . . .' LOW-VOLUME-CT.
480600     DISPLAY '32 acute, train. . . . . .' LOW-VOL-ONSET-CT.
480700     DISPLAY '33 chronic, out, low v . .' OUT-TRAIN-CT.
480800     DISPLAY '34 chronic out low v train' OUT-TRAIN-CHRONIC-CT.
480900     DISPLAY '35 out, train, acute      ' OUT-TRAIN-ACUTE-CT.
481000     DISPLAY ' '.
481100     DISPLAY '50 Facility-Rate-Prob  . .' FACILITY-RATE-PROB-CT.
481200     DISPLAY '52 Provider-Type-Prob  . .' PROVIDER-TYPE-PROB-CT.
481300     DISPLAY '53 Speical-PMT-Prob. . . .' SPECIAL-PMT-PROB-CT.
481400     DISPLAY '54 Birth-Prob. . . . . . .' BIRTH-PROB-CT.
481500     DISPLAY '55 Weight-Prob . . . . . .' WEIGHT-PROB-CT.
481600     DISPLAY '56 Height-Prob . . . . . .' HEIGHT-PROB-CT.
481700     DISPLAY '57 Rev-Center-Prob . . . .' REV-CENTER-PROB-CT.
481800     DISPLAY '58 Cond-Code-Prob. . . . .' COND-CODE-PROB-CT.
481900     DISPLAY '60 MSA-CBSA-Prob . . . . .' MSA-CBSA-PROB-CT.
482000     DISPLAY '71 Exceed-Height-Prob. . .' EXCEED-HEIGHT-PROB-CT.
482100     DISPLAY '72 Exceed-Weight-Prob. . .' EXCEED-WEIGHT-PROB-CT.
482200     DISPLAY '73 Bad-Num-Dial-Session. .' BAD-NUM-DIAL-SES-CT.
482300     DISPLAY '74 Bad-Line-Item-Svc-Date.' BAD-SERVICE-DATE-CT.
482400     DISPLAY '75 Bad-Dial-Start-Date . .' BAD-DIAL-START-DATE-CT.
482500     DISPLAY '76 Tot-Outlier-Pmt . . . .' BAD-TOT-OUT-PAYMENT-CT.
482600     DISPLAY '81 Comor-CWF-Return-code .' BAD-COMOR-CWF-RTN-CT.
482700     DISPLAY '98 Thru-Date-Prob. . . . .' THRU-DATE-PROB-CT.
482800
482900/
483000 9000-CALC-PAYMENT.
483100******************************************************************
483200*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE PAYMENT         *
483300******************************************************************
483400******************************************************************
483500* OPTION (1)                                                     *
483600*       (1)  MOVE ' ' TO PRICER-OPTION-SW.                       *
483700*            CALL 'PPDRVxx_' USING BILL-NEW-DATA                 *
483800*                                  PPS-DATA-ALL                  *
483900*                                  PRICER-OPT-VERS-SW.           *
484000*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING.    *
484100*                        *  *  *  *                              *
484200* OPTION (2)                                                     *
484300*       (2)  MOVE 'M' TO PRICER-OPTION-SW.                       *
484400*            CALL 'PPDRVxx_' USING BILL-NEW-DATA                 *
484500*                                  PPS-DATA-ALL                  *
484600*                                  PRICER-OPT-VERS-SW            *
484700*                                  PPS-ADDITIONAL-VARIABLES.     *
484800*        THIS PASSES THE STANDARD VARIIABLES AND THE             *
484900*      ADDITIONAL VARIABLES USED FOR PRICING.                    *
485000*                        *  *  *  *                              *
485100******************************************************************
485200
485300*** OPTION (1)
485400*    MOVE ' ' TO PRICER-OPTION-SW.
485500     INITIALIZE  PPS-DATA-ALL.
485600
485700     DISPLAY ' '.
485800     DISPLAY ' '.
485900     DISPLAY ' '.
486000     DISPLAY ' '.
486100     DISPLAY 'Working on Record # ' BILL-RECS-CT.
486200*    DISPLAY BILL-NEW-DATA.
486300*    DISPLAY 'Calling ' CURRENT-YR-DRIVER.
486400     CALL  CURRENT-YR-DRIVER  USING BILL-NEW-DATA
486500                                    PPS-DATA-ALL.
486600*** OPTION (2)
486700*    MOVE 'M' TO PRICER-OPTION-SW.
486800*    CALL  PPDR012H   USING BILL-NEW-DATA
486900*                           PPS-DATA-ALL
487000*                           PRICER-OPT-VERS-SW
487100*                           PPS-ADDITIONAL-VARIABLES.
487200/
487300 9100-PRINT-TEST-RECS.
487400******************************************************************
487500*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL        *
487600******************************************************************
487700     IF B-THRU-CCYY  NOT EQUAL  HOLD-PRT-YR  THEN
487800        MOVE B-THRU-CCYY         TO PRT-YR
487900                                    HOLD-PRT-YR
488000        PERFORM 9200-PPS-HEADINGS
488100     ELSE
488200        IF LINE-CTR  >  MAX-LINES  THEN
488300           MOVE B-THRU-CCYY       TO PRT-YR
488400                                     HOLD-PRT-YR
488500           PERFORM 9200-PPS-HEADINGS
488600        END-IF
488700     END-IF.
488800
488900*    DISPLAY ' '.
489000*    DISPLAY '----:----1----:----2----:----3----:----4----:----5'.
489100*    DISPLAY DISPLAY-LINE-MEASUREMENT.
489200*    DISPLAY BILL-NEW-DATA.
489300*    DISPLAY PPS-DATA-ALL.
489400*    DISPLAY ' '.
489500*    DISPLAY 'BILL-NEW = ' BILL-PORTION.
489600*    DISPLAY 'PSF-DATA = ' PROVIDER-SPECIFIC-FILE-PORTION.
489700*    DISPLAY 'BUNDLED  = ' BUNDLED-BILL-PORTION.
489800*    DISPLAY 'COMORBID = ' COMORBIDITIES-PORTION.
489900*    DISPLAY 'BILL TEST= ' BILL-DATA-TEST.
490000*    DISPLAY ' '.
490100*    DISPLAY 'PPS-RTC  = ' PPS-RTC.
490200*    DISPLAY 'PPS-DATA = ' PPS-DATA.
490300*    DISPLAY 'PPS-OTHER= ' PPS-OTHER-DATA.
490400*    DISPLAY 'PPS-BUNDL= ' PPS-BUNDLED-DATA.
490500*    DISPLAY ' '.
490600*    DISPLAY '   END'.
490700
490800     IF PPS-RTC = 01  THEN
490900        ADD 1 TO RATE-ON-BILL-CT
491000        PERFORM 9120-PRINT-RATE-ON-BILL
491100     ELSE
491200        IF PPS-RTC < 50  THEN
491300           IF PPS-RTC = 00  THEN
491400              ADD 1 TO CLAIM-PAID-CT
491500           ELSE
491600              PERFORM 9210-GET-COUNTS
491700           END-IF
491800           PERFORM 9110-PRINT-GOOD-CLAIM-PAID
491900        ELSE
492000           IF PPS-RTC > 49 THEN
492100              PERFORM 9130-PRINT-ERROR
492200              PERFORM 9210-GET-COUNTS
492300           END-IF
492400        END-IF
492500     END-IF.
492600
492700 9110-PRINT-GOOD-CLAIM-PAID.
492800     MOVE SPACES                  TO PRT-DETAIL-LINE-1A.
492900* Format line 1A
493000     MOVE P-PROV-TYPE             TO PRT-PROV-TYPE.
493100     MOVE PPS-MSA                 TO PRT-MSA.
493200     MOVE PPS-CBSA                TO PRT-CBSA.
493300     MOVE P-PROV-WAIVE-BLEND-PAY-INDIC
493400                                  TO PRT-PROV-WAIVE-BLEND-INDIC.
493500     MOVE P-PROV-LOW-VOLUME-INDIC TO PRT-PROV-LOW-VOLUME-INDIC.
493600
493700     IF B-THRU-DATE NUMERIC  THEN
493800        MOVE B-THRU-DATE          TO PRT-CLAIM-DATE
493900     END-IF.
494000
494100     IF B-LINE-ITEM-DATE-SERVICE NUMERIC  THEN
494200        MOVE B-LINE-ITEM-DATE-SERVICE
494300                                  TO PRT-LINE-ITEM-DATE-SERVICE
494400     END-IF.
494500
494600     IF B-DIALYSIS-START-DATE NUMERIC  THEN
494700        MOVE B-DIALYSIS-START-DATE
494800                                  TO PRT-DIALYSIS-START-DATE
494900     END-IF.
495000
495100     IF B-DOB-DATE NUMERIC  THEN
495200        MOVE B-DOB-DATE           TO PRT-BIRTH-DATE
495300     END-IF.
495400
495500     IF B-PATIENT-HGT NUMERIC  THEN
495600        MOVE B-PATIENT-HGT        TO PRT-HEIGHT
495700     END-IF.
495800
495900     IF B-PATIENT-WGT NUMERIC  THEN
496000        MOVE B-PATIENT-WGT        TO PRT-WEIGHT
496100     END-IF.
496200
496300     MOVE PPS-COND-CODE           TO PRT-COND-CODE.
496400
496500     IF PPS-REV-CODE NUMERIC  THEN
496600        MOVE PPS-REV-CODE         TO PRT-REVENUE-CODE
496700     END-IF.
496800
496900     MOVE B-CLAIM-NUM-DIALYSIS-SESSIONS
497000                                  TO PRT-NUM-DIALYSIS-SESSIONS.
497100
497200     IF B-TOT-PRICE-SB-OUTLIER NUMERIC  THEN
497300        MOVE B-TOT-PRICE-SB-OUTLIER TO PRT-TOT-SB-OUTLIER-AMT
497400     END-IF.
497500
497600     MOVE COMORBID-DATA (1)       TO H-COMORBID-1
497700     MOVE COMORBID-DATA (2)       TO H-COMORBID-2
497800     MOVE COMORBID-DATA (3)       TO H-COMORBID-3
497900     MOVE COMORBID-DATA (4)       TO H-COMORBID-4
498000     MOVE COMORBID-DATA (5)       TO H-COMORBID-5
498100     MOVE COMORBID-DATA (6)       TO H-COMORBID-6
498200     MOVE H-COMORBID-DATA         TO PRT-COMORBID-DATA.
498300
498400     MOVE COMORBID-CWF-RETURN-CODE
498500                                  TO PRT-CWF-RETURN-CODE.
498600     MOVE COMORBID-RECURRENCE-COND-CODE
498700                                  TO PRT-RECURRENCE-COND-CODE.
498800
498900* Format line 2A
499000     MOVE SPACES                  TO PRT-DETAIL-LINE-2A.
499100     MOVE AGE-RETURN              TO PRT-AGE.
499200     MOVE PPS-BSA                 TO PRT-CR-BSA.
499300     MOVE BUN-BSA                 TO PRT-PPS-BSA.
499400     MOVE OUT-BSA                 TO PRT-OUT-BSA.
499500     MOVE PPS-BMI                 TO PRT-CR-BMI.
499600     MOVE BUN-BMI                 TO PRT-PPS-BMI.
499700     MOVE OUT-BMI                 TO PRT-OUT-BMI.
499800     MOVE PPS-RTC                 TO PRT-RTC.
499900     MOVE PPS-CALC-VERS-CD        TO PRT-DRIVER-CALC-VERS-CD.
500000
500100     COMPUTE CBSA-PERCENT = 100 * CBSA-PCT.
500200     COMPUTE MSA-PERCENT  = 100 * MSA-PCT.
500300     MOVE MSA-PERCENT             TO PRT-MSA-PERCENT.
500400     MOVE CBSA-PERCENT            TO PRT-CBSA-PERCENT.
500500
500600* FORMAT LINE 3A5-10.
500700     MOVE MSA-WAGE-AMT            TO PRT-MSA-WAGE.
500800     MOVE MSA-ADJ-YEAR-AMT        TO PRT-MSA-ADJ-YEAR-AMT.
500900     MOVE MSA-PERCENT             TO PRT-MSA-PERCENT.
501000     MOVE MSA-WAGE-ADJ            TO PRT-MSA-WAGE-ADJ.
501100     MOVE CBSA-WAGE-PMT-RATE      TO PRT-CBSA-PMT-RATE-A.
501200     MOVE LABOR-PCT               TO PRT-LABOR-PCT.
501300     MOVE CBSA-WAGE-INDEX         TO PRT-CBSA-INDEX.
501400     MOVE CBSA-WAGE-PMT-RATE      TO PRT-CBSA-PMT-RATE-B.
501500     COMPUTE NON-LABOR-PCT = 1 - LABOR-PCT.
501600     MOVE NON-LABOR-PCT           TO PRT-NON-LABOR-PCT.
501700     MOVE CBSA-PERCENT            TO PRT-CBSA-PERCENT.
501800     MOVE CBSA-WAGE-ADJ           TO PRT-CBSA-WAGE-ADJ.
501900     MOVE PPS-WAGE-ADJ-RATE       TO PRT-MSA-CBSA-WAGE-ADJ-RT-A
502000                                     PRT-MSA-CBSA-WAGE-ADJ-RT-B.
502100
502200* FORMAT LINE 3B5-10.
502300     MOVE PPS-AGE-FACTOR          TO PRT-AGE-FACTOR.
502400     MOVE PPS-BSA-FACTOR          TO PRT-BSA-FACTOR.
502500     MOVE PPS-BMI-FACTOR          TO PRT-BMI-FACTOR.
502600     MOVE PPS-BDGT-NEUT-RATE      TO PRT-BUDGET-NEUTRAL.
502700     MOVE DRUG-ADD-ON-RETURN      TO PRT-DRUG-ADD-ON.
502800     MOVE CASE-MIX-FCTR-ADJ-RATE  TO PRT-CASE-MIX-FCTR-ADJ-RATE.
502900
503000     IF AMT-INDIC = 'A'  THEN
503100        MOVE ZERO                 TO PRT-HEMO-CCPD-CAPD-VALUE
503200        MOVE BLOOD-DOLLAR         TO PRT-HEMO-CCPD-CAPD-AMT
503300     ELSE
503400        MOVE HEMO-CCPD-CAPD       TO PRT-HEMO-CCPD-CAPD-VALUE
503500        MOVE ZERO                 TO PRT-HEMO-CCPD-CAPD-AMT
503600     END-IF.
503700
503800     MOVE PPS-FINAL-PAY-AMT       TO PRT-FINAL-PAY-AMT.
503900
504000*    IF PPS-2011-BLEND-COMP-RATE  NUMERIC  THEN
504100*       MOVE PPS-2011-BLEND-COMP-RATE
504200*                                 TO PRT-PPS-BLEND-COMP-RATE
504300*    END-IF.
504400
504500*    IF PPS-2011-FULL-COMP-RATE  NUMERIC  THEN
504600*       MOVE PPS-2011-FULL-COMP-RATE
504700*                                 TO PRT-PPS-FULL-COMP-RATE
504800*    END-IF.
504900
505000*    IF PPS-2011-BLEND-COMP-RATE  NUMERIC  THEN
505100*       MOVE PPS-2011-BLEND-COMP-RATE
505200*                                 TO PRT-PPS-BLEND-COMP-RATE
505300*    END-IF.
505400
505500*    IF PPS-2011-FULL-COMP-RATE  NUMERIC  THEN
505600*       MOVE PPS-2011-FULL-COMP-RATE
505700*                                 TO PRT-PPS-FULL-COMP-RATE
505800*    END-IF.
505900
506000* FORMAT LINE 3A11.
506100
506200*    MOVE CBSA-WAGE-PMT-RATE      TO PRT-CBSA-PMT-RATE.
506300*    MOVE MSA-WAGE-AMT            TO PRT-MSA-WAGE.
506400*    IF CBSA-WAGE-INDEX NUMERIC  THEN
506500*       MOVE CBSA-WAGE-INDEX      TO PRT-CBSA-INDEX
506600*    END-IF.
506700
506800*    IF P-SPEC-PYMT-IND = '1'     THEN
506900*       MOVE '*'                  TO PRT-SPEC-WAGE-INDX
507000*       MOVE '*'                  TO PRT-ESRD-RATE-GT-ZERO
507100*    END-IF.
507200
507300
507400*    IF MSA-WAGE-ADJ NUMERIC      THEN
507500*       MOVE MSA-WAGE-ADJ         TO PRT-MSA-WAGE-ADJ
507600*    END-IF.
507700
507800*    IF CBSA-WAGE-ADJ NUMERIC     THEN
507900*       MOVE CBSA-WAGE-ADJ        TO PRT-CBSA-WAGE-ADJ
508000*    END-IF.
508100
508200*    MOVE PPS-WAGE-ADJ-RATE       TO PRT-MSA-CBSA-WAGE-ADJ-RT.
508300*    MOVE PPS-AGE-FACTOR          TO PRT-PPS-AGE-FACTOR.
508400*    MOVE PPS-BSA-FACTOR          TO PRT-PPS-BSA-FACTOR.
508500*    MOVE PPS-BMI-FACTOR          TO PRT-PPS-BMI-FACTOR.
508600
508700*    IF PPS-2011-BLEND-COMP-RATE  NUMERIC  THEN
508800*       MOVE PPS-2011-BLEND-COMP-RATE
508900*                                 TO PRT-PPS-BLEND-COMP-RATE
509000*    END-IF.
509100
509200*    IF PPS-2011-FULL-COMP-RATE  NUMERIC  THEN
509300*       MOVE PPS-2011-FULL-COMP-RATE
509400*                                 TO PRT-PPS-FULL-COMP-RATE
509500*    END-IF.
509600
509700* FORMAT LINE 3B11.
509800
509900*    MOVE PPS-AGE-FACTOR          TO PRT-PPS-AGE-FACTOR.
510000*    MOVE PPS-BSA-FACTOR          TO PRT-PPS-BSA-FACTOR.
510100*    MOVE PPS-BMI-FACTOR          TO PRT-PPS-BMI-FACTOR.
510200
510300*    IF PPS-2011-BLEND-COMP-RATE  NUMERIC  THEN
510400*       MOVE PPS-2011-BLEND-COMP-RATE
510500*                                 TO PRT-PPS-BLEND-COMP-RATE
510600*    END-IF.
510700
510800*    IF PPS-2011-FULL-COMP-RATE  NUMERIC  THEN
510900*       MOVE PPS-2011-FULL-COMP-RATE
511000*                                 TO PRT-PPS-FULL-COMP-RATE
511100*    END-IF.
511200
511300* FORMAT LINE 4A.
511400
511500     MOVE PPS-2011-AGE-FACTOR     TO PRT-BUN-AGE-FACTOR.
511600*    MOVE BUN-BSA                 TO PRT-BUN-BSA.
511700     MOVE PPS-2011-BSA-FACTOR     TO PRT-BUN-BSA-FACTOR.
511800*    MOVE BUN-BMI                 TO PRT-BUN-BMI.
511900     MOVE PPS-2011-BMI-FACTOR     TO PRT-BUN-BMI-FACTOR.
512000     MOVE BUN-ONSET-FACTOR        TO PRT-BUN-ONSET-FACTOR.
512100     MOVE BUN-COMORBID-MULTIPLIER TO PRT-BUN-COMORBID-MULTIPLIER.
512200     MOVE BUN-LOW-VOL-MULTIPLIER  TO PRT-BUN-LOW-VOL-MULTIPLIER.
512300*    MOVE OUT-ADJ-AVG-MAP-AMT     TO PRT-OUT-ADJ-AVG-MAP-AMT.
512400*    MOVE OUT-FIX-DOLLAR-LOSS     TO PRT-OUT-FIX-DOLLAR-LOSS.
512500
512600     IF PPS-2011-BLEND-PPS-RATE  NUMERIC  THEN
512700        MOVE PPS-2011-BLEND-PPS-RATE
512800                                  TO PRT-PPS-BLEND-PPS-RATE
512900     END-IF.
513000
513100* FORMAT LINE 4B.
513200     MOVE PPS-2011-AGE-FACTOR     TO PRT-BUN-AGE-FACTOR.
513300*    MOVE BUN-BSA                 TO PRT-BUN-BSA.
513400     MOVE PPS-2011-BSA-FACTOR     TO PRT-BUN-BSA-FACTOR.
513500*    MOVE BUN-BMI                 TO PRT-BUN-BMI.
513600     MOVE PPS-2011-BMI-FACTOR     TO PRT-BUN-BMI-FACTOR.
513700     MOVE BUN-ONSET-FACTOR        TO PRT-BUN-ONSET-FACTOR.
513800     MOVE BUN-COMORBID-MULTIPLIER TO PRT-BUN-COMORBID-MULTIPLIER.
513900     MOVE BUN-LOW-VOL-MULTIPLIER  TO PRT-BUN-LOW-VOL-MULTIPLIER.
514000*    MOVE OUT-ADJ-AVG-MAP-AMT     TO PRT-OUT-ADJ-AVG-MAP-AMT.
514100*    MOVE OUT-FIX-DOLLAR-LOSS     TO PRT-OUT-FIX-DOLLAR-LOSS.
514200
514300     IF PPS-2011-BLEND-PPS-RATE  NUMERIC  THEN
514400        MOVE PPS-2011-BLEND-PPS-RATE
514500                                  TO PRT-PPS-BLEND-PPS-RATE
514600     END-IF.
514700     IF PPS-2011-FULL-PPS-RATE  NUMERIC  THEN
514800        MOVE PPS-2011-FULL-PPS-RATE
514900                                  TO PRT-PPS-FULL-PPS-RATE
515000     END-IF.
515100
515200* FORMAT LINE 5A.
515300     MOVE OUT-AGE-FACTOR          TO PRT-OUT-AGE-FACTOR.
515400     MOVE OUT-BSA                 TO PRT-OUT-BSA.
515500     MOVE OUT-BSA-FACTOR          TO PRT-OUT-BSA-FACTOR.
515600     MOVE OUT-BMI                 TO PRT-OUT-BMI.
515700     MOVE OUT-BMI-FACTOR          TO PRT-OUT-BMI-FACTOR.
515800     MOVE OUT-ONSET-FACTOR        TO PRT-OUT-ONSET-FACTOR.
515900     MOVE OUT-COMORBID-MULTIPLIER TO PRT-OUT-COMORBID-MULTIPLIER.
516000     MOVE OUT-LOW-VOL-MULTIPLIER  TO PRT-OUT-LOW-VOL-MULTIPLIER.
516100     MOVE OUT-ADJ-AVG-MAP-AMT     TO PRT-OUT-ADJ-AVG-MAP-AMT.
516200     MOVE OUT-FIX-DOLLAR-LOSS     TO PRT-OUT-FIX-DOLLAR-LOSS.
516300     MOVE OUT-PREDICTED-MAP       TO PRT-OUT-PREDICTED-MAP.
516400     MOVE OUT-IMPUTED-MAP         TO PRT-OUT-IMPUTED-MAP.
516500     MOVE OUT-LOSS-SHARING-PCT    TO PRT-OUT-LOSS-SHARING-PCT.
516600
516700     IF PPS-2011-BLEND-OUTLIER-RATE  NUMERIC  THEN
516800        MOVE PPS-2011-BLEND-OUTLIER-RATE
516900                                  TO PRT-PPS-BLEND-OUTLIER-RATE
517000     END-IF.
517100
517200     IF PPS-2011-FULL-OUTLIER-RATE  NUMERIC  THEN
517300        MOVE PPS-2011-FULL-OUTLIER-RATE
517400                                  TO PRT-PPS-FULL-OUTLIER-RATE
517500     END-IF.
517600
517700*    DISPLAY 'GOING TO WRITE DETAIL-LINE-1A'.
517800     WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-1A
517900                            AFTER ADVANCING 1.
518000     WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-2A
518100                            AFTER ADVANCING 1.
518200     ADD 2                           TO LINE-CTR.
518300
518400     IF B-THRU-CCYY > 2010  THEN
518500        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-3A5-10
518600                               AFTER ADVANCING 1
518700        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-3B5-10
518800                               AFTER ADVANCING 1
518900        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-3A5-10
519000                               AFTER ADVANCING 1
519100        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-3B5-10
519200                               AFTER ADVANCING 1
519300        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-5A
519400                               AFTER ADVANCING 1
519500        ADD 5                        TO LINE-CTR
519600     ELSE
519700        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-3A5-10
519800                               AFTER ADVANCING 1
519900        WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-3B5-10
520000                               AFTER ADVANCING 1
520100        ADD 2                        TO LINE-CTR
520200     END-IF.
520300
520400     WRITE IBM-PRINTER-LINE FROM A-BLANK-LINE
520500                            AFTER ADVANCING 2.
520600     ADD 1                        TO LINE-CTR.
520700/
520800 9120-PRINT-RATE-ON-BILL.
520900* Format Line 1 for return code = 01
521000     MOVE SPACES                  TO PRT-DETAIL-LINE-1B.
521100     MOVE P-GEO-MSA               TO PRT-B-MSA.
521200     MOVE P-GEO-CBSA              TO PRT-B-CBSA.
521300     MOVE P-PROV-TYPE             TO PRT-B-PROV-TYPE.
521400     MOVE PPS-COND-CODE           TO PRT-B-COND-CODE.
521500
521600     IF PPS-REV-CODE NUMERIC      THEN
521700        MOVE PPS-REV-CODE         TO PRT-B-REVENUE-CODE
521800     END-IF.
521900
522000     IF B-THRU-DATE NUMERIC       THEN
522100        MOVE B-THRU-DATE          TO PRT-B-CLAIM-DATE
522200     END-IF.
522300
522400     IF B-DOB-DATE NUMERIC        THEN
522500        MOVE B-DOB-DATE           TO PRT-B-BIRTH-DATE
522600     END-IF.
522700
522800     IF B-PATIENT-HGT NUMERIC     THEN
522900        MOVE B-PATIENT-HGT        TO PRT-B-HEIGHT
523000     END-IF.
523100
523200     IF B-PATIENT-WGT NUMERIC     THEN
523300        MOVE B-PATIENT-WGT        TO PRT-B-WEIGHT
523400     END-IF.
523500
523600     MOVE PPS-RTC                 TO PRT-B-RTC.
523700     MOVE PPS-CALC-VERS-CD        TO PRT-B-DRIVER-CALC-VERS-CD.
523800     WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-1B
523900                            AFTER ADVANCING 1.
524000* Format Line 2 for return code = 01
524100     MOVE SPACES                  TO PRT-DETAIL-LINE-2A.
524200*    MOVE PPS-FINAL-PAY-AMT       TO PRT-FINAL-PAY-AMT.
524300
524400*    IF P-ESRD-RATE > ZERO  AND  (OLD-TEST-CASE  OR
524500*                                 BUNDLED-TEST)   THEN
524600*       MOVE '*'                  TO PRT-ESRD-RATE-GT-ZERO
524700*    END-IF.
524800
524900     WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-2A
525000                            AFTER ADVANCING 1.
525100     WRITE IBM-PRINTER-LINE FROM A-BLANK-LINE
525200                            AFTER ADVANCING 1.
525300     ADD 3 TO LINE-CTR.
525400
525500/
525600 9130-PRINT-ERROR.
525700* Format Line 1 for return code > 49
525800     MOVE SPACES                  TO PRT-DETAIL-LINE-1B.
525900     MOVE P-GEO-MSA               TO PRT-B-MSA.
526000     MOVE P-GEO-CBSA              TO PRT-B-CBSA.
526100     MOVE P-PROV-TYPE             TO PRT-B-PROV-TYPE.
526200     MOVE B-COND-CODE             TO PRT-B-COND-CODE.
526300
526400     IF PPS-REV-CODE NUMERIC      THEN
526500        MOVE B-REV-CODE           TO PRT-B-REVENUE-CODE
526600     END-IF.
526700
526800     IF B-THRU-DATE NUMERIC       THEN
526900        MOVE B-THRU-DATE          TO PRT-B-CLAIM-DATE
527000     END-IF.
527100
527200     IF B-DOB-DATE NUMERIC        THEN
527300        MOVE B-DOB-DATE           TO PRT-B-BIRTH-DATE
527400     END-IF.
527500
527600     IF B-PATIENT-HGT NUMERIC     THEN
527700        MOVE B-PATIENT-HEIGHT     TO PRT-B-ERR-HEIGHT
527800     END-IF.
527900
528000     IF B-PATIENT-WGT NUMERIC     THEN
528100        MOVE B-PATIENT-WEIGHT     TO PRT-B-ERR-WEIGHT
528200     END-IF.
528300
528400     MOVE PPS-RTC                 TO PRT-B-RTC.
528500     MOVE PPS-CALC-VERS-CD        TO PRT-B-DRIVER-CALC-VERS-CD.
528600     WRITE IBM-PRINTER-LINE FROM PRT-DETAIL-LINE-1B
528700                            AFTER ADVANCING 1.
528800     WRITE IBM-PRINTER-LINE FROM A-BLANK-LINE
528900                            AFTER ADVANCING 1.
529000     WRITE IBM-PRINTER-LINE FROM A-BLANK-LINE
529100                            AFTER ADVANCING 1.
529200     ADD 3 TO LINE-CTR.
529300
529400
529500 9200-PPS-HEADINGS.
529600     ADD 1 TO PG-NUMBER.
529700     MOVE PG-NUMBER               TO PAGE-NUM.
529800
529900     WRITE IBM-PRINTER-LINE FROM PRT-MAIN-TITLE
530000                            AFTER ADVANCING PAGE.
530100     WRITE IBM-PRINTER-LINE FROM COL-HEADER-1
530200                            AFTER ADVANCING 2.
530300     WRITE IBM-PRINTER-LINE FROM COL-HEADER-2
530400                            AFTER ADVANCING 1.
530500     MOVE 4                       TO LINE-CTR.
530600
530700     IF B-THRU-CCYY > 2010  THEN
530800        WRITE IBM-PRINTER-LINE FROM COL-HEADER-4A
530900                               AFTER ADVANCING 1
531000        WRITE IBM-PRINTER-LINE FROM COL-HEADER-4B
531100                               AFTER ADVANCING 1
531200        WRITE IBM-PRINTER-LINE FROM COL-HEADER-5A
531300                               AFTER ADVANCING 1
531400        WRITE IBM-PRINTER-LINE FROM COL-HEADER-5B
531500                               AFTER ADVANCING 1
531600        WRITE IBM-PRINTER-LINE FROM COL-HEADER-6
531700                               AFTER ADVANCING 1
531800        ADD 5                     TO LINE-CTR
531900     ELSE
532000        WRITE IBM-PRINTER-LINE FROM COL-HEADER-3A5-10
532100                               AFTER ADVANCING 1
532200        WRITE IBM-PRINTER-LINE FROM COL-HEADER-3B5-10
532300                               AFTER ADVANCING 1
532400        ADD 2                     TO LINE-CTR
532500     END-IF.
532600
532700     MOVE ALL '  -'               TO IBM-PRINTER-LINE.
532800     WRITE IBM-PRINTER-LINE AFTER ADVANCING 1.
532900     WRITE IBM-PRINTER-LINE FROM A-BLANK-LINE
533000                            AFTER ADVANCING 1.
533100     ADD 2                        TO LINE-CTR.
533200
533300 9210-GET-COUNTS.
533400*------------------------------------------------------
533500* Display results of testing so you can read it
533600* using H.2
533700* November 7, 2012
533800*------------------------------------------------------
533900     DISPLAY ' '.
534000     DISPLAY 'Display the Final Dollar Amounts'.
534100     DISPLAY 'PPS-2011-FULL-PPS-RATE       = '
534200                 PPS-2011-FULL-PPS-RATE.
534300     DISPLAY 'PPS-2011-FULL-OUTLIER-RATE   = '
534400                 PPS-2011-FULL-OUTLIER-RATE.
534500     DISPLAY ' '.
534600     DISPLAY 'Display the Composite (Old) payment variables:'.
534700     DISPLAY 'PPS-WAGE-ADJ-RATE            = '
534800                  PPS-WAGE-ADJ-RATE.
534900     DISPLAY 'PPS-AGE-FACTOR               = '
535000                 PPS-AGE-FACTOR.
535100     DISPLAY 'PPS-BSA-FACTOR               = '
535200                 PPS-BSA-FACTOR.
535300     DISPLAY 'PPS-BMI-FACTOR               = '
535400                 PPS-BMI-FACTOR.
535500     DISPLAY 'PPS-2011-BLEND-COMP-RATE     = '
535600                 PPS-2011-BLEND-COMP-RATE.
535700     DISPLAY 'PPS-2011-BLEND-PPS-RATE      = '
535800                 PPS-2011-BLEND-PPS-RATE.
535900     DISPLAY 'PPS-2011-BLEND-OUTLIER-RATE  = '
536000                 PPS-2011-BLEND-OUTLIER-RATE.
536100     DISPLAY 'PPS-2011-FULL-COMP-RATE      = '
536200                 PPS-2011-FULL-COMP-RATE.
536300     DISPLAY ' '.
536400     Display 'Display the PPS (New) payment variables:'.
536500     DISPLAY 'PPS-2011-WAGE-ADJ-RATE       = '
536600                 PPS-2011-WAGE-ADJ-RATE.
536700     DISPLAY 'PPS-2011-AGE-FACTOR          = '
536800                 PPS-2011-AGE-FACTOR.
536900     DISPLAY 'PPS-2011-BSA-FACTOR          = '
537000                 PPS-2011-BSA-FACTOR.
537100     DISPLAY 'PPS-2011-BMI-FACTOR          = '
537200                 PPS-2011-BMI-FACTOR.
537300     DISPLAY 'BUN-ONSET-FACTOR             = '
537400                  BUN-ONSET-FACTOR.
537500     DISPLAY 'BUN-COMORBID-MULTIPLIER      = '
537600                 BUN-COMORBID-MULTIPLIER.
537700     DISPLAY 'BUN-LOW-VOL-MULTIPLIER       = '
537800                 BUN-LOW-VOL-MULTIPLIER.
537900     DISPLAY 'BUN-ADJUSTED-BASE-WAGE-AMT   = '
538000                 BUN-ADJUSTED-BASE-WAGE-AMT.
538100     DISPLAY 'PPS-2011-FULL-OUTLIER-RATE   = '
538200                 PPS-2011-FULL-OUTLIER-RATE.
538300     DISPLAY 'PPS-2011-BDGT-NEUT-RATE      = '
538400                 PPS-2011-BDGT-NEUT-RATE.
538500     DISPLAY ' '.
538600     DISPLAY 'Display the Comorbid Factor Variables'.
538700     DISPLAY 'PRT-BUN-COMORBID-MULTIPLIER  = '
538800                 PRT-BUN-COMORBID-MULTIPLIER.
538900     DISPLAY 'PRT-OUT-COMORBID-MULTIPLIER  = '
539000                 PRT-OUT-COMORBID-MULTIPLIER.
539100     DISPLAY 'G-PPS-COMORBID-FACTOR        = '
539200                 G-PPS-COMORBID-FACTOR.
539300     DISPLAY 'G-OUT-COMORBID-FACTOR        = '
539400                 G-OUT-COMORBID-FACTOR.
539500     DISPLAY ' '.
539600     DISPLAY 'Display the Low-Volume Factor Variables'.
539700     DISPLAY 'OUT-LOW-VOL-MULTIPLIER       = '
539800                 OUT-LOW-VOL-MULTIPLIER.
539900     DISPLAY ' '.
540000     DISPLAY 'Display the Other Variables'.
540100     DISPLAY 'PPS-2011-COMORBID-PAY        = '
540200                 PPS-2011-COMORBID-PAY.
540300     DISPLAY 'PPS-2011-COMORBID-MA         = '
540400                 PPS-2011-COMORBID-MA.
540500     DISPLAY 'PPS-2011-COMORBID-MA-CC      = '
540600                 PPS-2011-COMORBID-MA-CC.
540700     DISPLAY 'OUT-ONSET-FACTOR             = '
540800                 OUT-ONSET-FACTOR.
540900     DISPLAY 'PPS-BUN-BASE-PMT-RATE        = '
541000                 PPS-BUN-BASE-PMT-RATE.
541100     DISPLAY 'PPS-2011-FULL-PPS-RATE       = '
541200                 PPS-2011-FULL-PPS-RATE.
541300     DISPLAY 'PPS-FINAL-PAY-AMT            = '
541400                 PPS-FINAL-PAY-AMT.
541500     DISPLAY 'PPS-RTC                      = '
541600                 PPS-RTC.
541700*    DISPLAY 'PPS-FINAL-PAY-AMT = ' PPS-FINAL-PAY-AMT.
541800*    DISPLAY 'PPS-MSA =           ' PPS-MSA.
541900*    DISPLAY 'PPS-CBSA =          ' PPS-CBSA.
542000*    DISPLAY 'PPS-WAGE-ADJ-RATE = ' PPS-WAGE-ADJ-RATE.
542100*    DISPLAY 'PPS-FINAL-PAY-AMT = ' PPS-FINAL-PAY-AMT.
542200*    DISPLAY 'PPS-CALC-VERS-CD  = ' PPS-CALC-VERS-CD.
542300*    DISPLAY 'PPS-COND-CODE =     ' PPS-COND-CODE.
542400*    DISPLAY 'PPS-REV-CODE =      ' PPS-REV-CODE.
542500*    DISPLAY 'B-DIALYSIS-START-DATE = '
542600*                  B-DIALYSIS-START-DATE.
542700*    DISPLAY 'B-LINE-ITEM-DATE-SERVICE = '
542800*                  B-LINE-ITEM-DATE-SERVICE.
542900     IF PPS-RTC > 49  THEN
543000       IF PPS-RTC = 50  THEN
543100          ADD 1 TO FACILITY-RATE-PROB-CT
543200       ELSE
543300         IF PPS-RTC = 52  THEN
543400            ADD 1 TO PROVIDER-TYPE-PROB-CT
543500         ELSE
543600           IF PPS-RTC = 53  THEN
543700              ADD 1 TO SPECIAL-PMT-PROB-CT
543800           ELSE
543900             IF PPS-RTC = 54  THEN
544000                ADD 1 TO BIRTH-PROB-CT
544100             ELSE
544200               IF PPS-RTC = 55  THEN
544300                  ADD 1 TO WEIGHT-PROB-CT
544400               ELSE
544500                 IF PPS-RTC = 56  THEN
544600                    ADD 1 TO HEIGHT-PROB-CT
544700                 ELSE
544800                   IF PPS-RTC = 57  THEN
544900                      ADD 1 TO REV-CENTER-PROB-CT
545000                   ELSE
545100                     IF PPS-RTC = 58  THEN
545200                        ADD 1 TO COND-CODE-PROB-CT
545300                     ELSE
545400                       IF PPS-RTC = 60  THEN
545500                          ADD 1 TO MSA-CBSA-PROB-CT
545600                       ELSE
545700                         IF PPS-RTC = 71  THEN
545800                            ADD 1 TO EXCEED-HEIGHT-PROB-CT
545900                         ELSE
546000                           IF PPS-RTC = 72  THEN
546100                              ADD 1 TO EXCEED-WEIGHT-PROB-CT
546200                           ELSE
546300                              ADD 1 TO THRU-DATE-PROB-CT
546400                           END-IF
546500                         END-IF
546600                       END-IF
546700                     END-IF
546800                   END-IF
546900                 END-IF
547000               END-IF
547100             END-IF
547200           END-IF
547300         END-IF
547400       END-IF
547500     ELSE
547600       IF PPS-RTC < 14  THEN
547700         IF PPS-RTC = 02  THEN
547800            ADD 1 TO NO-ADJUST-CT
547900         ELSE
548000           IF PPS-RTC = 03  THEN
548100              ADD 1 TO OUT-CT
548200           ELSE
548300             IF PPS-RTC = 04  THEN
548400                ADD 1 TO ACUTE-CT
548500             ELSE
548600               IF PPS-RTC = 05  THEN
548700                  ADD 1 TO CHRONIC-CT
548800               ELSE
548900                 IF PPS-RTC = 06  THEN
549000                    ADD 1 TO ACUTE-OUT-CT
549100                 ELSE
549200                   IF PPS-RTC = 07  THEN
549300                      ADD 1 TO CHRONIC-OUT-CT
549400                   ELSE
549500                     IF PPS-RTC = 08  THEN
549600                        ADD 1 TO ONSET-CT
549700                     ELSE
549800                       IF PPS-RTC = 09  THEN
549900                          ADD 1 TO ONSET-OUT-CT
550000                       ELSE
550100                         IF PPS-RTC = 10  THEN
550200                            ADD 1 TO LOW-V-CT
550300                         ELSE
550400                           IF PPS-RTC = 11  THEN
550500                              ADD 1 TO TRAIN-CT
550600                           ELSE
550700                             IF PPS-RTC = 12  THEN
550800                                ADD 1 TO LOW-V-TRAIN-CT
550900                             ELSE
551000                                ADD 1 TO MULTI-ADJUST-CT
551100                             END-IF
551200                           END-IF
551300                         END-IF
551400                       END-IF
551500                     END-IF
551600                   END-IF
551700                 END-IF
551800               END-IF
551900             END-IF
552000           END-IF
552100         END-IF
552200       ELSE
552300         IF PPS-RTC < 26  THEN
552400           IF PPS-RTC = 14  THEN
552500              ADD 1 TO PEDIATRIC-CT
552600           ELSE
552700             IF PPS-RTC = 15  THEN
552800                ADD 1 TO PEDIATRIC-TRAIN-CT
552900             ELSE
553000               IF PPS-RTC = 16  THEN
553100                  ADD 1 TO PEDIATRIC-OUT-CT
553200               ELSE
553300                 IF PPS-RTC = 17  THEN
553400                    ADD 1 TO PEDIATRIC-OUT-TRAIN-CT
553500                 ELSE
553600                   IF PPS-RTC = 18  THEN
553700                      ADD 1 TO ACUTE-OUT-LOW-V-CT
553800                   ELSE
553900                     IF PPS-RTC = 19  THEN
554000                        ADD 1 TO ACUTE-OUT-LOW-V-TRAIN-CT
554100                     ELSE
554200                       IF PPS-RTC = 20  THEN
554300                          ADD 1 TO ACUTE-LOW-V-CT
554400                       ELSE
554500                         IF PPS-RTC = 21  THEN
554600                            ADD 1 TO ACUTE-LOW-V-TRAIN-CT
554700                         ELSE
554800                           IF PPS-RTC = 22  THEN
554900                              ADD 1 TO ACUTE-TRAIN-CT
555000                           ELSE
555100                             IF PPS-RTC = 23  THEN
555200                                ADD 1 TO CHRONIC-OUT-LOW-V-CT
555300                             ELSE
555400                               IF PPS-RTC = 24  THEN
555500                                  ADD 1 TO
555600                                      CHRONIC-OUT-LV-TRAIN-CT
555700                               ELSE
555800                                  ADD 1 TO CHRONIC-LOW-V-CT
555900                               END-IF
556000                             END-IF
556100                           END-IF
556200                         END-IF
556300                       END-IF
556400                     END-IF
556500                   END-IF
556600                 END-IF
556700               END-IF
556800             END-IF
556900           END-IF
557000         ELSE
557100           IF PPS-RTC = 26  THEN
557200              ADD 1 TO CHRONIC-LOW-V-TRAIN-CT
557300           ELSE
557400             IF PPS-RTC = 27  THEN
557500                ADD 1 TO CHRONIC-TRAIN-CT
557600             ELSE
557700               IF PPS-RTC = 28  THEN
557800                  ADD 1 TO OUT-LOW-CT
557900               ELSE
558000                 IF PPS-RTC = 29  THEN
558100                    ADD 1 TO OUT-LOW-TRAIN-CT
558200                 ELSE
558300                   IF PPS-RTC = 30  THEN
558400                      ADD 1 TO ONSET-OUT-LOW-CT
558500                   ELSE
558600                     IF PPS-RTC = 31  THEN
558700                        ADD 1 TO LOW-VOLUME-CT
558800                     ELSE
558900                       IF PPS-RTC = 32  THEN
559000                          ADD 1 TO LOW-VOL-ONSET-CT
559100                       ELSE
559200                         IF PPS-RTC = 33  THEN
559300                            ADD 1 TO OUT-TRAIN-CT
559400                         ELSE
559500                           IF PPS-RTC = 34  THEN
559600                              ADD 1 TO OUT-TRAIN-CHRONIC-CT
559700                           ELSE
559800                              ADD 1 TO OUT-TRAIN-ACUTE-CT
559900                           END-IF
560000                         END-IF
560100                       END-IF
560200                     END-IF
560300                   END-IF
560400                 END-IF
560500               END-IF
560600             END-IF
560700           END-IF
560800         END-IF
560900       END-IF
561000     END-IF.
561100
561200*************    LAST STATEMENT OF MAINFRAME CODE    *************
