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