000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. ESCAL091.
000300*PROGRAM-ID. ESCAL090...Note that there is NO ESCAL090 calculating
000400*            subroutine due to a rescinding of ONE CBSA'S WAGE
000500*            INDEX which was sent out with the ESDRV090 subroutine
000600*            prior to the start of the calendar year.
000700*            There is NO difference between the original ESCAL090
000800*            and ESCAL091 except the notational difference in the
000900*            version number.
001000*AUTHORS.    CMS.
001100*       EFFECTIVE JANUARY 1, 2009
001200******************************************************************
001300* 4/06/05 - ALLOW PROVIDER TYPE '05' FOR PEDIATRIC HOSP          *
001400*         - TO BE EFFECTIVE WITH THE NEXT RELEASE                *
001500*         - CHANGED IN 0100-INITIAL-ROUTINE WITH PROVIDER        *
001600*           TYPE '40'                                            *
001700* 1/01/06 - NEW CBSA TABLE FOR CY2006                            *
001800*         - UPDATE 2005 MSA COMPOSITE RATES WITH 1.6% INCREASE   *
001900* 1/18/07 - THE MSA-WAGE-FACTOR-2007 WAS NOT IMPLEMENTED DURING  *
002000*           THE FIRST THREE MONTHS OF 2007                       *
002100*         - MSA-CBSA BLEND PERCENT NOW SET AT 50% MSA 50% CBSA   *
002200*         - ADDITIONAL VARIABLES WERE CREATED IN ORDER TO MAKE   *
002300*           CHANGING VALUES EASIER (IN WORKING STORAGE RATHER    *
002400*           THAN IN THE PROCEDURE DIVISION)                      *
002500*         - THIS PROGRAM NOW REFLECTS ENHANCEMENTS MADE SO THAT  *
002600*           TESTING OF THE CODE DOES NOT REQUIRE COMMENTING      *
002700*           IN/OUT LINES OF CODE.  IN ADDITION CALCULATED        *
002800*           VARIABLES ARE NOW PASSED BACK WHEN TEST CASES ARE    *
002900*           ENCOUNTERED IN ORDER FOR THE MASTER DRIVER TO PRINT  *
003000*           MORE INFORMATION ABOUT WHAT WENT ON IN THIS PROGRAM  *
003100* 1/19/07 - INDEPENDENT ESRD FACILITY WAGE NOW    $132.49        *
003200*           HOSPITAL BASED ESRD FACILTIY WAGE NOW $136.68        *
003300*           DRUG ADD-ON ADJUSTMENT AFTER 4/1/07   1.1490         *
003400* 1/26/07 - MSA COMPOSITE PAYMENT RATES INCREASED 1.6% ABOVE THE *
003500*           2006 RATES.  THIS MEANS THAT THE RATES PASSED FROM   *
003600*           THE DRIVER, WHICH ARE 2005 RATES, NEED TO BE         *
003700*           MULTIPLIED BY 1.016 AND THEN ROUNDED TO GET THE 2006 *
003800*           RATE AND THEN THAT RESULT MULTIPLIED BY ANOTHER 1.016*
003900*           AND ROUNDED AGAIN TO GET THE 4/1/2007 RATE.  THIS    *
004000*           NECESSARY ROUNDING MAKES THE RESULTS AGREE WITH THOSE*
004100*           PUBLISHED IN THE FEDERAL REGISTER.  THIS METHOD WAS  *
004200*           VERIFIED VIA TEDIOUS EXCEL SPREADSHEET CALCULATIONS  *
004300* 10/30/07- MSA COMPOSITE PAYMENT RATES DID NOT INCREASE FROM THE*
004400*           2007/04/01 RATES.  THE COMPOSITE BASE RATES DID NOT  *
004500*           CHANGE FROM THE 07/04/01 FACILITY RATES.             *
004600*           THE BLEND OF MSA TO CBSA WAS CHANGED TO 25% MSA AND  *
004700*           75% CBSA.                                            *
004800*           THE DRUG ADDON FACTOR WAS INCREASED TO 1.1550        *
004900*           ALL OTHER FIGURES REMAINED THE SAME.                 *
005000* 11/21/07- CHANGES WERE MADE TO ALL THE CALCULATION SUBROUTINES *
005100*           BEGINNING IN 2005 IN ORDER TO ENSURE THAT THE        *
005200*           PC-PRICER CAN USE THE **EXACT** SAME CODE THAT EXISTS*
005300*           ON THE MAINFRAME.  IN ORDER TO ENSURE THAT THE       *
005400*           LINKAGE SECTION REMAINS THE SAME, THE FILLER AREAS   *
005500*           LOCATED AT THE END OF EACH '05' LEVEL HAVE BEEN      *
005600*           MODIFIED TO INCLUDE VARIABLES NEEDED FOR PROOFING OF *
005700*           THE MAINFRAME CODE AS WELL AS DISPLAYING ON THE PC-  *
005800*           PRICER.                                              *
005900*                THE VARIABLE LABELED 'P-ESRD-RATE' IS NEVER     *
006000*           USED IN CALCUALTIONS SINCE THE DRIVER IS THE ONLY ONE*
006100*           THAT USES IT IN SPECIAL CIRCUMSTANCES AT THE FISCAL  *
006200*           INTERMEDIARIES.  THEREFORE A DUAL USE WAS MADE OF IT *
006300*           SO THAT THE PC-PRICER CAN MAKE USE OF THE VERY       *
006400*           LIMITED SPACE LEFT.  THE VARIABLE NAME WAS REDEFINED *
006500*           TO 'CASE-MIX-FCTR-ADJ-RATE' TO REFLECT IT'S USAGE ON *
006600*           THE PC-PRICER.                                       *
006700*                  USAGE OF THE THESE FILLER AREAS AND THE       *
006800*           'CASE-MIX-FCTR-ADJ-RATE' VARIABLE WILL ONLY OCCUR    *
006900*           WHEN A 'T' (FOR TESTING) IS IN THE LAST COLUMN OF THE*
007000*           INPUT RECORD.  OTHERWISE THESE VARIABLES WILL CONTAIN*
007100*           SPACES WHEN NOT IN TEST MODE.  MOST OF THE MOVES TO  *
007200*           THESE VARIABLES OCCURS IN THE 9000-MOVE-RESULTS PARA-*
007300*           GRAPH.  A FEW MOVES MUST OCCUR IN OTHER AREAS OF THE *
007400*           PROGRAM.                                             *
007500* 11/07/08- ALL CODE FOR 2006-2008 WAGE ADJUSTED PAYMENTS WERE   *
007600*           REMOVED BECAUSE THERE IS NO LONGER A BLEND BETWEEN   *
007700*           MSA AND CBSA STARTING 1/1/2009.                      *
007800*           THE DRUG ADDON FACTOR WAS CHANGED TO 1.1520          *
007900*           THE HOSPITAL AND INDEPENDENT ESRD FACILITY PAYMENT   *
008000*           RATES ARE NOW THE SAME.  THE TWO VARIABLES WERE LEFT *
008100*           IN THE PROGRAM IN CASE THEY DECIDE TO MAKE THEM      *
008200*           DIFFERENT IN THE FUTURE.                             *
008300* 12/03/08- RENAMED THIS SUBROUTINE ESCAL091 AND CHANGED THE     *
008400*           APPROPRIATE VERSION INFORMATION.  THE 9.0 VERSION OF *
008500*           THE PRICER WAS SENT OUT IN NOVEMBER.  AFTERWARDS THE *
008600*           POLICY PEOPLE WHO SET THE WAGE INDEXES, CHANGED THEIR*
008700*           MINDS ABOUT CBSA 16700 AND RESCINDED THE WAGE INDEX. *
008800*           THIS NECESSITATED A RE-RELEASE OF THE ESRD PRICER IN *
008900*           ORDER TO MAKE SURE THAT THE FI'S ARE USING THE LATEST*
009000*           VERSION AT THE START OF CY2009.                      *
009100* FUTURE    THIS PROGRAM IS INTENDED TO BE USED IN A RUNNING FOUR*
009200*           YEAR (CURRENT YEAR AND THREE PRIOR YEARS) MODE SINCE *
009300*           THAT IS THE ONLY MANNER IN WHICH BILLS CAN BE SUBMIT-*
009400*           TED AND CORRECTED.  THEREFORE THE CODE FOR THE 2005  *
009500*           MSA WILL BE PHASED OUT BEGINNING IN 2009 AND COMPLET-*
009600*           LY GONE IN 2013 WHEN THE MSA-CBSA BLEND WILL NO      *
009700*           LONGER BE NEEDED.                                    *
009800******************************************************************
009900 DATE-COMPILED.
010000 ENVIRONMENT DIVISION.
010100 CONFIGURATION SECTION.
010200 SOURCE-COMPUTER.            IBM-Z990.
010300 OBJECT-COMPUTER.            IBM.
010400 INPUT-OUTPUT  SECTION.
010500 FILE-CONTROL.
010600
010700 DATA DIVISION.
010800 FILE SECTION.
010900/
011000 WORKING-STORAGE SECTION.
011100 01  W-STORAGE-REF                  PIC X(46)  VALUE
011200     'ESCAL091      - W O R K I N G   S T O R A G E'.
011300 01  CAL-VERSION                    PIC X(05)  VALUE 'C09.1'.
011400
011500 01  DISPLAY-LINE-MEASUREMENT.
011600     05  FILLER                     PIC X(50) VALUE
011700         '....:...10....:...20....:...30....:...40....:...50'.
011800     05  FILLER                     PIC X(50) VALUE
011900         '....:...60....:...70....:...80....:...90....:..100'.
012000     05  FILLER                     PIC X(20) VALUE
012100         '....:..110....:..120'.
012200
012300 01  PRINT-LINE-MEASUREMENT.
012400     05  FILLER                     PIC X(51) VALUE
012500         'X....:...10....:...20....:...30....:...40....:...50'.
012600     05  FILLER                     PIC X(50) VALUE
012700         '....:...60....:...70....:...80....:...90....:..100'.
012800     05  FILLER                     PIC X(32) VALUE
012900         '....:..110....:..120....:..130..'.
013000
013100 01  HOLD-PPS-COMPONENTS.
013200     05  H-PYMT-AMT                 PIC 9(07)V9(02).
013300     05  H-WAGE-ADJ-PYMT-AMT        PIC 9(07)V9(02).
013400     05  H-MSA-COMPOSITE-PYMT       PIC 9(07)V9(02).
013500     05  H-WAGE-ADJ-PYMT-OLD        PIC 9(07)V9(02).
013600     05  H-WAGE-ADJ-PYMT-NEW        PIC 9(07)V9(02).
013700     05  H-WAGE-ADJ                 PIC 9(02)V9(04).
013800     05  H-PYMT-RATE                PIC 9(04)V9(02).
013900     05  H-FIXED-LOSS-AMT           PIC 9(07)V9(02).
014000     05  H-ESRD-FAC-RATE            PIC 9(07)V9(02).
014100     05  H-PATIENT-AGE              PIC 9(03).
014200     05  H-AGE-FACTOR               PIC 9(01)V9(03).
014300     05  H-BSA-FACTOR               PIC 9(01)V9(04).
014400     05  H-BMI-FACTOR               PIC 9(01)V9(04).
014500     05  H-BSA                      PIC 9(03)V9(04).
014600     05  H-BMI                      PIC 9(03)V9(04).
014700     05  H-DRUG-ADDON               PIC 9(01)V9(04).
014800
014900* THE FOLLOWING THREE VARIABLES WILL CHANGE FROM YEAR TO YEAR
015000 01  DRUG-ADDON                     PIC 9(01)V9(04) VALUE 1.1520.
015100 01  HOSP-BASED-PMT-RATE            PIC 9(04)V9(02) VALUE 133.81.
015200 01  INDP-ESRD-FAC-PMT-RATE         PIC 9(04)V9(02) VALUE 133.81.
015300
015400* THE NEXT TWO PERCENTAGES MUST ADD UP TO 1 (I.E. 100%)
015500* THEY WILL CONTINUE TO CHANGE UNTIL CY2009 WHEN CBSA WILL BE 1.00
015600 01  MSA-BLEND-PCT                  PIC 9(01)V9(02) VALUE 0.00.
015700 01  CBSA-BLEND-PCT                 PIC 9(01)V9(02) VALUE 1.00.
015800
015900
016000* CONSTANTS AREA
016100* THE NEXT TWO PERCENTAGES MUST ADD UP TO 1 (I.E. 100%)
016200 01  NAT-LABOR-PCT                  PIC 9(01)V9(05) VALUE 0.53711.
016300 01  NAT-NONLABOR-PCT               PIC 9(01)V9(05) VALUE 0.46289.
016400
016500 01  HEMO-PERI-CCPD-AMT             PIC 9(02)       VALUE 20.
016600 01  CAPD-AMT                       PIC 9(02)       VALUE 12.
016700 01  CAPD-OR-CCPD-FACTOR            PIC 9(01)V9(06) VALUE
016800                                                       0.428571.
016900* THE ABOVE NUMBER TECHNICALLY REPRESENTS THE FRACTIONAL
017000* NUMBER 3/7 WHICH IS THREE DAYS PER WEEK THAT A PERSON CAN
017100* RECEIVE DIALYSIS.
017200
017300* BEGINNING 01/01/2009 THERE WILL BE NO BLEND BETWEEN MSA & CBSA
017400* THEREFORE THE MSA-WAGE-FACTOR FOR YEARS 2006-2008 WERE REMOVED
017500
017600*  THE FOLLOWING NUMBER THAT IS LOADED INTO THE PAYMENT EQUATION
017700*  IS MEANT TO BUDGET NEUTRALIZE CHANGES IN THE CASE MIX INDEX
017800*  AND   --DOES NOT CHANGE--
017900 01  CASE-MIX-BDGT-NEUT-FACTOR      PIC 9(01)V9(04) VALUE 0.9116.
018000
018100
018200******************************************************************
018300*                                                                *
018400*   ******** POSSIBLE RETURN CODES FROM THIS PROGRAM ********    *
018500*                                                                *
018600*    ****  PPS-RTC 00-49 = BILL PAYMENT INFORMATION CODES        *
018700*                                                                *
018800*            00 = ESRD PPS PAYMENT CALCULATED                    *
018900*                                                                *
019000*    ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID             *
019100*                                                                *
019200*            52 = PROVIDER TYPE NOT = '40' OR '41' OR '05'       *
019300*            53 = SPECIAL PAYMENT INDICATOR NOT = '1' OR BLANK   *
019400*            54 = DATE OF BIRTH  NOT NUMERIC OR = ZERO           *
019500*            55 = PATIENT WEIGHT NOT NUMERIC OR = ZERO           *
019600*            56 = PATIENT HEIGHT NOT NUMERIC OR = ZERO           *
019700*            57 = REVENUE CENTER CODE NOT IN RANGE               *
019800*            58 = CONDITION CODE NOT = '73' OR '74' OR BLANK     *
019900*            71 = EXCEEDS MAXIMUM HEIGHT ALLOWANCE               *
020000*            72 = EXCEEDS MAXIMUM WEIGHT ALLOWANCE               *
020100******************************************************************
020200/
020300 LINKAGE SECTION.
020400 COPY BILLCPY.
020500*COPY "BILLCPY.CPY".
020600/
020700 COPY WAGECPY.
020800*COPY "WAGECPY.CPY".
020900/
021000 PROCEDURE DIVISION  USING BILL-NEW-DATA
021100                           PPS-DATA-ALL
021200                           WAGE-NEW-RATE-RECORD
021300                           COM-CBSA-WAGE-RECORD.
021400
021500******************************************************************
021600* THERE ARE VARIOUS WAYS TO COMPUTE A FINAL DOLLAR AMOUNT.  THE  *
021700* METHOD USED IN THIS PROGRAM IS TO USE ROUNDED INTERMEDIATE     *
021800* VARIABLES.  THIS WAS DONE TO SIMPLIFY THE CALCULATIONS SO THAT *
021900* WHEN SOMETHING GOES AWRY, ONE IS NOT LEFT WONDERING WHERE IN   *
022000* A VAST COMPUTE STATEMENT, THINGS HAVE GONE AWRY.  THE METHOD   *
022100* UTILIZED HERE HAS BEEN APPROVED BY CMS.                        *
022200*                                                                *
022300*                                                                *
022400*                                                                *
022500*                                                                *
022600*    PROCESSING:                                                 *
022700*        A. WILL PROCESS CLAIMS BASED ON AGE/HEIGHT/WEIGHT       *
022800*        B. INITIALIZE ESCAL HOLD VARIABLES.                     *
022900*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE           *
023000*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM           *
023100*           CANNOT BE PROCESSED, SET A RETURN CODE AND           *
023200*           GOBACK.                                              *
023300*        D. ASSEMBLE PRICING COMPONENTS.                         *
023400*        E. CALCULATE THE PRICE.                                 *
023500******************************************************************
023600
023700 0000-MAINLINE-CONTROL.
023800
023900     PERFORM 0100-INITIAL-ROUTINE.
024000
024100     IF PPS-RTC = 00  THEN
024200        PERFORM 1000-EDIT-THE-BILL-INFO
024300     END-IF.
024400
024500     IF PPS-RTC = 00  THEN
024600        PERFORM 2000-ASSEMBLE-PPS-VARIABLES
024700        PERFORM 3000-CALC-PAYMENT
024800     END-IF.
024900
025000     PERFORM 9000-MOVE-RESULTS.
025100
025200     GOBACK.
025300/
025400 0100-INITIAL-ROUTINE.
025500
025600******************************************************************
025700**   NEW PAYMENT RATES FOR NEW LEGISLATION                      **
025800******************************************************************
025900     INITIALIZE PPS-DATA-ALL.
026000     INITIALIZE BILL-DATA-TEST.
026100     INITIALIZE HOLD-PPS-COMPONENTS.
026200     MOVE ZEROS                        TO PPS-RTC.
026300     MOVE CAL-VERSION                  TO PPS-CALC-VERS-CD.
026400
026500* PROVIDER TYPE '40' AND '05' ARE HOSPITAL BASED ESRD FACILITIES
026600     IF P-PROV-TYPE = '40' OR '05'  THEN
026700        MOVE NAT-LABOR-PCT             TO PPS-NAT-LABOR-PCT
026800        MOVE NAT-NONLABOR-PCT          TO PPS-NAT-NONLABOR-PCT
026900        MOVE HOSP-BASED-PMT-RATE       TO H-PYMT-RATE
027000        MOVE 0.00                      TO H-WAGE-ADJ-PYMT-OLD
027100        MOVE W-NEW-RATE1-RECORD        TO MSA-WAGE-AMT
027200        MOVE COM-CBSA-W-INDEX          TO H-WAGE-ADJ
027300     ELSE
027400* PROVIDER TYPE '41' IS AN INDEPENDENT ESRD FACILITY
027500        IF P-PROV-TYPE = '41'  THEN
027600           MOVE NAT-LABOR-PCT          TO PPS-NAT-LABOR-PCT
027700           MOVE NAT-NONLABOR-PCT       TO PPS-NAT-NONLABOR-PCT
027800           MOVE INDP-ESRD-FAC-PMT-RATE TO H-PYMT-RATE
027900           MOVE 0.00                   TO H-WAGE-ADJ-PYMT-OLD
028000           MOVE W-NEW-RATE2-RECORD     TO MSA-WAGE-AMT
028100           MOVE COM-CBSA-W-INDEX       TO H-WAGE-ADJ
028200        ELSE
028300           MOVE 52                     TO PPS-RTC
028400           MOVE ZERO                   TO PPS-WAGE-ADJ-RATE
028500        END-IF
028600     END-IF.
028700
028800     MOVE H-WAGE-ADJ-PYMT-OLD          TO MSA-ADJ-YEAR-AMT.
028900
029000******************************************************************
029100**  NEW DRUG ADD-ON FOR NEW LEGISLATION                         **
029200******************************************************************
029300
029400     MOVE CASE-MIX-BDGT-NEUT-FACTOR    TO PPS-BDGT-NEUT-RATE.
029500     MOVE DRUG-ADDON                   TO H-DRUG-ADDON.
029600/
029700******************************************************************
029800***  BILL DATA EDITS IF ANY FAIL SET PPS-RTC                   ***
029900***  AND DO NOT ATTEMPT TO PRICE.                              ***
030000******************************************************************
030100 1000-EDIT-THE-BILL-INFO.
030200
030300     IF PPS-RTC = 00  THEN
030400        IF P-SPEC-PYMT-IND NOT = '1' AND ' '  THEN
030500           MOVE 53                     TO PPS-RTC
030600        END-IF
030700     END-IF.
030800
030900     IF PPS-RTC = 00  THEN
031000        IF (B-DOB-DATE = ZERO)  OR  (B-DOB-DATE NOT NUMERIC)  THEN
031100           MOVE 54                     TO PPS-RTC
031200        END-IF
031300     END-IF.
031400
031500     IF PPS-RTC = 00  THEN
031600        IF (B-PATIENT-WGT = 0)  OR  (B-PATIENT-WGT NOT NUMERIC)
031700           MOVE 55                     TO PPS-RTC
031800        END-IF
031900     END-IF.
032000
032100     IF PPS-RTC = 00  THEN
032200        IF (B-PATIENT-HGT = 0)  OR  (B-PATIENT-HGT NOT NUMERIC)
032300           MOVE 56                     TO PPS-RTC
032400        END-IF
032500     END-IF.
032600
032700     IF PPS-RTC = 00  THEN
032800        IF B-REV-CODE  = '0821' OR '0831' OR '0841' OR '0851'
032900                                OR '0880' OR '0881'
033000           NEXT SENTENCE
033100        ELSE
033200           MOVE 57                     TO PPS-RTC
033300        END-IF
033400     END-IF.
033500
033600     IF PPS-RTC = 00  THEN
033700        IF B-COND-CODE NOT = '73' AND '74' AND '  '
033800           MOVE 58                     TO PPS-RTC
033900        END-IF
034000     END-IF.
034100
034200     IF PPS-RTC = 00  THEN
034300        IF B-PATIENT-HGT > 300.00
034400           MOVE 71                     TO PPS-RTC
034500        END-IF
034600     END-IF.
034700
034800     IF PPS-RTC = 00  THEN
034900        IF B-PATIENT-WGT > 500.00  THEN
035000           MOVE 72                     TO PPS-RTC
035100        END-IF
035200     END-IF.
035300
035400     IF PPS-RTC = 00  THEN
035500        PERFORM 1200-CALC-AGE
035600     END-IF.
035700
035800
035900 1200-CALC-AGE.
036000******************************************************************
036100***  CALCULATE PATIENT AGE                                     ***
036200******************************************************************
036300
036400     COMPUTE H-PATIENT-AGE = B-THRU-CCYY - B-DOB-CCYY.
036500
036600     IF B-DOB-MM > B-THRU-MM  THEN
036700        COMPUTE H-PATIENT-AGE = H-PATIENT-AGE - 1
036800     END-IF.
036900
037000******************************************************************
037100***  SET AGE ADJUSTMENT FACTOR                                 ***
037200******************************************************************
037300
037400     IF H-PATIENT-AGE < 18  THEN
037500        MOVE 1.620                     TO H-AGE-FACTOR
037600     ELSE
037700        IF H-PATIENT-AGE > 17 AND H-PATIENT-AGE < 45  THEN
037800           MOVE 1.223                  TO H-AGE-FACTOR
037900        ELSE
038000           IF H-PATIENT-AGE > 44 AND H-PATIENT-AGE < 60  THEN
038100              MOVE 1.055               TO H-AGE-FACTOR
038200           ELSE
038300              IF H-PATIENT-AGE > 59 AND H-PATIENT-AGE < 70  THEN
038400                 MOVE 1.000            TO H-AGE-FACTOR
038500              ELSE
038600                 IF H-PATIENT-AGE > 69 AND H-PATIENT-AGE < 80
038700                    MOVE 1.094         TO H-AGE-FACTOR
038800                 ELSE
038900                    IF H-PATIENT-AGE > 79  THEN
039000                       MOVE 1.174      TO H-AGE-FACTOR
039100                    END-IF
039200                 END-IF
039300              END-IF
039400           END-IF
039500        END-IF
039600     END-IF.
039700
039800/
039900 2000-ASSEMBLE-PPS-VARIABLES.
040000******************************************************************
040100***  CALCULATE PPS PRICING VARIABLES                           ***
040200******************************************************************
040300
040400     COMPUTE H-BSA ROUNDED = (.007184 *
040500         (B-PATIENT-HGT ** .725) * (B-PATIENT-WGT ** .425))
040600
040700     COMPUTE H-BMI ROUNDED = (B-PATIENT-WGT /
040800         (B-PATIENT-HGT ** 2)) * 10000.
040900
041000     IF H-PATIENT-AGE > 17  THEN
041100        COMPUTE H-BSA-FACTOR ROUNDED =
041200             1.037 ** ((H-BSA - 1.84) / .1)
041300     ELSE
041400        MOVE 1.000                     TO H-BSA-FACTOR
041500     END-IF.
041600
041700     IF (H-PATIENT-AGE > 17) AND (H-BMI < 18.5)  THEN
041800        MOVE 1.112                     TO H-BMI-FACTOR
041900     ELSE
042000        MOVE 1.000                     TO H-BMI-FACTOR
042100     END-IF.
042200
042300/
042400******************************************************************
042500***  IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)            ***
042600***      CALCULATE THE STANDARD PAYMENT AMOUNT.                ***
042700***    - BLEND 25% OLD RATE (MSA) WITH 75% NEW RATE (CBSA).    ***
042800******************************************************************
042900 3000-CALC-PAYMENT.
043000
043100* BEGINNING 01/01/2009 THERE WILL BE NO BLEND BETWEEN MSA & CBSA
043200
043300     COMPUTE H-WAGE-ADJ-PYMT-NEW ROUNDED =
043400         (((H-PYMT-RATE * PPS-NAT-LABOR-PCT) * H-WAGE-ADJ) +
043500           (H-PYMT-RATE * PPS-NAT-NONLABOR-PCT)) * CBSA-BLEND-PCT.
043600
043700     COMPUTE H-WAGE-ADJ-PYMT-AMT =
043800             H-WAGE-ADJ-PYMT-NEW + H-WAGE-ADJ-PYMT-OLD.
043900
044000     COMPUTE H-PYMT-AMT ROUNDED = H-WAGE-ADJ-PYMT-AMT *
044100          H-BMI-FACTOR * H-BSA-FACTOR * PPS-BDGT-NEUT-RATE *
044200          H-AGE-FACTOR * H-DRUG-ADDON.
044300
044400     MOVE H-PYMT-AMT                   TO CASE-MIX-FCTR-ADJ-RATE.
044500     MOVE SPACES                       TO COND-CD-73.
044600
044700     IF (B-COND-CODE = '73') AND (B-REV-CODE = '0821' OR '0831'
044800                                                      OR '0851')
044900        COMPUTE H-PYMT-AMT = H-PYMT-AMT + HEMO-PERI-CCPD-AMT
045000        MOVE 'A'                       TO AMT-INDIC
045100        MOVE HEMO-PERI-CCPD-AMT        TO BLOOD-DOLLAR
045200     ELSE
045300        IF (B-COND-CODE = '73')  AND  (B-REV-CODE = '0841')  THEN
045400           COMPUTE H-PYMT-AMT = H-PYMT-AMT + CAPD-AMT
045500           MOVE 'A'                    TO AMT-INDIC
045600           MOVE CAPD-AMT               TO BLOOD-DOLLAR
045700        ELSE
045800           IF (B-COND-CODE = '74')  AND
045900              (B-REV-CODE = '0841' OR '0851')  THEN
046000              COMPUTE H-PYMT-AMT ROUNDED = H-PYMT-AMT *
046100                                           CAPD-OR-CCPD-FACTOR
046200              MOVE CAPD-OR-CCPD-FACTOR TO HEMO-CCPD-CAPD
046300           ELSE
046400              MOVE 'A'                 TO AMT-INDIC
046500              MOVE ZERO                TO BLOOD-DOLLAR
046600           END-IF
046700        END-IF
046800     END-IF.
046900
047000     MOVE H-PYMT-AMT                   TO PPS-FINAL-PAY-AMT.
047100     MOVE H-WAGE-ADJ-PYMT-AMT          TO PPS-WAGE-ADJ-RATE.
047200/
047300 9000-MOVE-RESULTS.
047400
047500     IF PPS-RTC < 50  THEN
047600        MOVE B-COND-CODE               TO PPS-COND-CODE
047700        MOVE B-REV-CODE                TO PPS-REV-CODE
047800        MOVE P-GEO-MSA                 TO PPS-MSA
047900        MOVE P-GEO-CBSA                TO PPS-CBSA
048000        MOVE H-AGE-FACTOR              TO PPS-AGE-FACTOR
048100        MOVE H-BSA-FACTOR              TO PPS-BSA-FACTOR
048200        MOVE H-BMI-FACTOR              TO PPS-BMI-FACTOR
048300        IF OLD-TEST-CASE  THEN
048400           MOVE H-DRUG-ADDON           TO DRUG-ADD-ON-RETURN
048500           MOVE H-WAGE-ADJ-PYMT-OLD    TO MSA-WAGE-ADJ
048600           MOVE H-WAGE-ADJ-PYMT-NEW    TO CBSA-WAGE-ADJ
048700           MOVE CBSA-BLEND-PCT         TO CBSA-PCT
048800           MOVE MSA-BLEND-PCT          TO MSA-PCT
048900           MOVE H-PYMT-RATE            TO CBSA-WAGE-PMT-RATE
049000           MOVE H-PATIENT-AGE          TO AGE-RETURN
049100           MOVE H-WAGE-ADJ             TO CBSA-WAGE-INDEX
049200           MOVE NAT-LABOR-PCT          TO LABOR-PCT
049300        END-IF
049400     ELSE
049500        IF OLD-TEST-CASE  THEN
049600           INITIALIZE PPS-COND-CODE
049700           INITIALIZE PPS-REV-CODE
049800           INITIALIZE PPS-MSA
049900           INITIALIZE PPS-CBSA
050000           INITIALIZE PPS-AGE-FACTOR
050100           INITIALIZE PPS-BSA-FACTOR
050200           INITIALIZE PPS-BMI-FACTOR
050300           INITIALIZE DRUG-ADD-ON-RETURN
050400           INITIALIZE MSA-WAGE-ADJ
050500           INITIALIZE CBSA-PCT
050600           INITIALIZE MSA-PCT
050700           INITIALIZE CASE-MIX-FCTR-ADJ-RATE
050800           INITIALIZE CBSA-WAGE-PMT-RATE
050900           INITIALIZE HEMO-CCPD-CAPD
051000           INITIALIZE AGE-RETURN
051100        END-IF
051200     END-IF.
051300
051400******        L A S T   S O U R C E   S T A T E M E N T      *****