000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. ESCAL100.
000300*AUTHORS.    CMS.
000400*       EFFECTIVE JANUARY 1, 2010
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* 11/07/08- ALL CODE FOR 2006-2008 WAGE ADJUSTED PAYMENTS WERE   *
006900*           REMOVED BECAUSE THERE IS NO LONGER A BLEND BETWEEN   *
007000*           MSA AND CBSA STARTING 1/1/2009.                      *
007100*           THE DRUG ADDON FACTOR WAS CHANGED TO 1.1520          *
007200*           THE HOSPITAL AND INDEPENDENT ESRD FACILITY PAYMENT   *
007300*           RATES ARE NOW THE SAME.  THE TWO VARIABLES WERE LEFT *
007400*           IN THE PROGRAM IN CASE THEY DECIDE TO MAKE THEM      *
007500*           DIFFERENT IN THE FUTURE.                             *
007600* 12/03/08- RENAMED THIS SUBROUTINE ESCAL091 AND CHANGED THE     *
007700*           APPROPRIATE VERSION INFORMATION.  THE 9.0 VERSION OF *
007800*           THE PRICER WAS SENT OUT IN NOVEMBER.  AFTERWARDS THE *
007900*           POLICY PEOPLE WHO SET THE WAGE INDEXES, CHANGED THEIR*
008000*           MINDS ABOUT CBSA 16700 AND RESCINDED THE WAGE INDEX. *
008100*           THIS NECESSITATED A RE-RELEASE OF THE ESRD PRICER IN *
008200*           ORDER TO MAKE SURE THAT THE FI'S ARE USING THE LATEST*
008300*           VERSION AT THE START OF CY2009.                      *
008400* 11/02/09- Renamed this subroutine ESCAL100 and changed the     *
008500*           appropriate version information.  Changed the        *
008600*           composite rate (Hosp-Based-Pmt-Rate and Indp-ESRD-Fac*
008700*           -Pmt-Rate) to 135.15.  Also changed the Drug-Addon to*
008800*           1.1500.                                              *
008900*         - Began reorganization of program so that it can be    *
009000*           used with the Bundled rate payment system as well as *
009100*           the Composite rate payment system.  In that light,   *
009200*           changed WAGE-NEW-CBSA-RECORD to COM-CBSA-WAGE-RECORD *
009300*           and added BUN-CBSA-WAGE-RECORD which is not used in  *
009400*           this version of the program.  Changed corresponding  *
009500*           variable names to agree with the new name.           *
009600* FUTURE    THIS PROGRAM IS INTENDED TO BE USED IN A RUNNING TEN *
009700*           YEAR (CURRENT YEAR AND NINE PRIOR YEARS) MODE SINCE  *
009800*           THAT IS THE ONLY MANNER IN WHICH BILLS CAN BE SUBMIT-*
009900*           TED AND CORRECTED.  THEREFORE THE CODE FOR THE 2005  *
010000*           MSA WILL BE PHASED OUT BEGINNING IN 2009 AND COMPLET-*
010100*           LY GONE IN 2013 WHEN THE MSA-CBSA BLEND WILL NO      *
010200*           LONGER BE NEEDED.                                    *
010300******************************************************************
010400 DATE-COMPILED.
010500 ENVIRONMENT DIVISION.
010600 CONFIGURATION SECTION.
010700 SOURCE-COMPUTER.            IBM-Z990.
010800 OBJECT-COMPUTER.            ITTY-BITTY-MACHINE-CORPORATION.
010900 INPUT-OUTPUT  SECTION.
011000 FILE-CONTROL.
011100
011200 DATA DIVISION.
011300 FILE SECTION.
011400/
011500 WORKING-STORAGE SECTION.
011600 01  W-STORAGE-REF                  PIC X(46)  VALUE
011700     'ESCAL100      - W O R K I N G   S T O R A G E'.
011800 01  CAL-VERSION                    PIC X(05)  VALUE 'C10.0'.
011900
012000 01  DISPLAY-LINE-MEASUREMENT.
012100     05  FILLER                     PIC X(50) VALUE
012200         '....:...10....:...20....:...30....:...40....:...50'.
012300     05  FILLER                     PIC X(50) VALUE
012400         '....:...60....:...70....:...80....:...90....:..100'.
012500     05  FILLER                     PIC X(20) VALUE
012600         '....:..110....:..120'.
012700
012800 01  PRINT-LINE-MEASUREMENT.
012900     05  FILLER                     PIC X(51) VALUE
013000         'X....:...10....:...20....:...30....:...40....:...50'.
013100     05  FILLER                     PIC X(50) VALUE
013200         '....:...60....:...70....:...80....:...90....:..100'.
013300     05  FILLER                     PIC X(32) VALUE
013400         '....:..110....:..120....:..130..'.
013500
013600 01  HOLD-PPS-COMPONENTS.
013700     05  H-PYMT-AMT                 PIC 9(07)V9(02).
013800     05  H-WAGE-ADJ-PYMT-AMT        PIC 9(07)V9(02).
013900     05  H-MSA-COMPOSITE-PYMT       PIC 9(07)V9(02).
014000     05  H-WAGE-ADJ-PYMT-OLD        PIC 9(07)V9(02).
014100     05  H-WAGE-ADJ-PYMT-NEW        PIC 9(07)V9(02).
014200     05  H-WAGE-ADJ                 PIC 9(02)V9(04).
014300     05  H-PYMT-RATE                PIC 9(04)V9(02).
014400     05  H-FIXED-LOSS-AMT           PIC 9(07)V9(02).
014500     05  H-ESRD-FAC-RATE            PIC 9(07)V9(02).
014600     05  H-PATIENT-AGE              PIC 9(03).
014700     05  H-AGE-FACTOR               PIC 9(01)V9(03).
014800     05  H-BSA-FACTOR               PIC 9(01)V9(04).
014900     05  H-BMI-FACTOR               PIC 9(01)V9(04).
015000     05  H-BSA                      PIC 9(03)V9(04).
015100     05  H-BMI                      PIC 9(03)V9(04).
015200     05  H-DRUG-ADDON               PIC 9(01)V9(04).
015300
015400* THE FOLLOWING THREE VARIABLES WILL CHANGE FROM YEAR TO YEAR
015500 01  DRUG-ADDON                     PIC 9(01)V9(04) VALUE 1.1500.
015600 01  HOSP-BASED-PMT-RATE            PIC 9(04)V9(02) VALUE 135.15.
015700 01  INDP-ESRD-FAC-PMT-RATE         PIC 9(04)V9(02) VALUE 135.15.
015800
015900* The next two percentages MUST add up to 1 (I.E. 100%)
016000* They will continue to change until CY2009 when CBSA will be 1.00
016100 01  MSA-BLEND-PCT                  PIC 9(01)V9(02) VALUE 0.00.
016200 01  CBSA-BLEND-PCT                 PIC 9(01)V9(02) VALUE 1.00.
016300
016400* THE NEXT TWO PERCENTAGES MUST ADD UP TO 1 (I.E. 100%)
016500* They will continue to change until CY2014 WHEN
016600* BUNdled CBSA will be 1.00
016700 01  COM-CBSA-BLEND-PCT             PIC 9(01)V9(02) VALUE 1.00.
016800 01  BUN-CBSA-BLEND-PCT             PIC 9(01)V9(02) VALUE 0.00.
016900
017000
017100* CONSTANTS AREA
017200* THE NEXT TWO PERCENTAGES MUST ADD UP TO 1 (I.E. 100%)
017300 01  NAT-LABOR-PCT                  PIC 9(01)V9(05) VALUE 0.53711.
017400 01  NAT-NONLABOR-PCT               PIC 9(01)V9(05) VALUE 0.46289.
017500
017600 01  HEMO-PERI-CCPD-AMT             PIC 9(02)       VALUE 20.
017700 01  CAPD-AMT                       PIC 9(02)       VALUE 12.
017800 01  CAPD-OR-CCPD-FACTOR            PIC 9(01)V9(06) VALUE
017900                                                       0.428571.
018000* THE ABOVE NUMBER TECHNICALLY REPRESENTS THE FRACTIONAL
018100* NUMBER 3/7 WHICH IS THREE DAYS PER WEEK THAT A PERSON CAN
018200* RECEIVE DIALYSIS.
018300
018400* BEGINNING 01/01/2009 THERE WILL BE NO BLEND BETWEEN MSA & CBSA
018500* THEREFORE THE MSA-WAGE-FACTOR FOR YEARS 2006-2008 WERE REMOVED
018600
018700*  THE FOLLOWING NUMBER THAT IS LOADED INTO THE PAYMENT EQUATION
018800*  IS MEANT TO BUDGET NEUTRALIZE CHANGES IN THE CASE MIX INDEX
018900*  AND   --DOES NOT CHANGE--
019000 01  CASE-MIX-BDGT-NEUT-FACTOR      PIC 9(01)V9(04) VALUE 0.9116.
019100
019200
019300******************************************************************
019400*                                                                *
019500*   ******** POSSIBLE RETURN CODES FROM THIS PROGRAM ********    *
019600*                                                                *
019700*    ****  PPS-RTC 00-49 = BILL PAYMENT INFORMATION CODES        *
019800*                                                                *
019900*            00 = ESRD PPS PAYMENT CALCULATED                    *
020000*                                                                *
020100*    ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID             *
020200*                                                                *
020300*            52 = PROVIDER TYPE NOT = '40' OR '41' OR '05'       *
020400*            53 = SPECIAL PAYMENT INDICATOR NOT = '1' OR BLANK   *
020500*            54 = DATE OF BIRTH  NOT NUMERIC OR = ZERO           *
020600*            55 = PATIENT WEIGHT NOT NUMERIC OR = ZERO           *
020700*            56 = PATIENT HEIGHT NOT NUMERIC OR = ZERO           *
020800*            57 = REVENUE CENTER CODE NOT IN RANGE               *
020900*            58 = CONDITION CODE NOT = '73' OR '74' OR BLANK     *
021000*            71 = EXCEEDS MAXIMUM HEIGHT ALLOWANCE               *
021100*            72 = EXCEEDS MAXIMUM WEIGHT ALLOWANCE               *
021200******************************************************************
021300/
021400 LINKAGE SECTION.
021500 COPY BILLCPY.
021600*COPY "BILLCPY.CPY".
021700/
021800 COPY WAGECPY.
021900*COPY "WAGECPY.CPY".
022000/
022100 PROCEDURE DIVISION  USING BILL-NEW-DATA
022200                           PPS-DATA-ALL
022300                           WAGE-NEW-RATE-RECORD
022400                           COM-CBSA-WAGE-RECORD.
022500
022600******************************************************************
022700* THERE ARE VARIOUS WAYS TO COMPUTE A FINAL DOLLAR AMOUNT.  THE  *
022800* METHOD USED IN THIS PROGRAM IS TO USE ROUNDED INTERMEDIATE     *
022900* VARIABLES.  THIS WAS DONE TO SIMPLIFY THE CALCULATIONS SO THAT *
023000* WHEN SOMETHING GOES AWRY, ONE IS NOT LEFT WONDERING WHERE IN   *
023100* A VAST COMPUTE STATEMENT, THINGS HAVE GONE AWRY.  THE METHOD   *
023200* UTILIZED HERE HAS BEEN APPROVED BY WIL GEHNE AND JOEY BRYSON   *
023300* BOTH OF WHOM WORK IN THE DIVISION OF INSTITUTIONAL CLAIMS      *
023400* PROCESSING (DICP).                                             *
023500*                                                                *
023600*                                                                *
023700*    PROCESSING:                                                 *
023800*        A. WILL PROCESS CLAIMS BASED ON AGE/HEIGHT/WEIGHT       *
023900*        B. INITIALIZE ESCAL HOLD VARIABLES.                     *
024000*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE           *
024100*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM           *
024200*           CANNOT BE PROCESSED, SET A RETURN CODE AND           *
024300*           GOBACK.                                              *
024400*        D. ASSEMBLE PRICING COMPONENTS.                         *
024500*        E. CALCULATE THE PRICE.                                 *
024600******************************************************************
024700
024800 0000-MAINLINE-CONTROL.
024900
025000     PERFORM 0100-INITIAL-ROUTINE.
025100
025200     IF PPS-RTC = 00  THEN
025300        PERFORM 1000-EDIT-THE-BILL-INFO
025400     END-IF.
025500
025600     IF PPS-RTC = 00  THEN
025700        PERFORM 2000-ASSEMBLE-PPS-VARIABLES
025800        PERFORM 3000-CALC-PAYMENT
025900     END-IF.
026000
026100     PERFORM 9000-MOVE-RESULTS.
026200
026300     GOBACK.
026400/
026500 0100-INITIAL-ROUTINE.
026600
026700******************************************************************
026800**   NEW PAYMENT RATES FOR NEW LEGISLATION                      **
026900******************************************************************
027000     INITIALIZE PPS-DATA-ALL.
027100     INITIALIZE BILL-DATA-TEST.
027200     INITIALIZE HOLD-PPS-COMPONENTS.
027300     MOVE CAL-VERSION                  TO PPS-CALC-VERS-CD.
027400
027500* PROVIDER TYPE '40' AND '05' ARE HOSPITAL BASED ESRD FACILITIES
027600     IF P-PROV-TYPE = '40' OR '05'  THEN
027700        MOVE NAT-LABOR-PCT             TO PPS-NAT-LABOR-PCT
027800        MOVE NAT-NONLABOR-PCT          TO PPS-NAT-NONLABOR-PCT
027900        MOVE HOSP-BASED-PMT-RATE       TO H-PYMT-RATE
028000        MOVE 0.00                      TO H-WAGE-ADJ-PYMT-OLD
028100        MOVE W-NEW-RATE1-RECORD        TO MSA-WAGE-AMT
028200        MOVE COM-CBSA-W-INDEX          TO H-WAGE-ADJ
028300     ELSE
028400* PROVIDER TYPE '41' IS AN INDEPENDENT ESRD FACILITY
028500        IF P-PROV-TYPE = '41'  THEN
028600           MOVE NAT-LABOR-PCT          TO PPS-NAT-LABOR-PCT
028700           MOVE NAT-NONLABOR-PCT       TO PPS-NAT-NONLABOR-PCT
028800           MOVE INDP-ESRD-FAC-PMT-RATE TO H-PYMT-RATE
028900           MOVE 0.00                   TO H-WAGE-ADJ-PYMT-OLD
029000           MOVE W-NEW-RATE2-RECORD     TO MSA-WAGE-AMT
029100           MOVE COM-CBSA-W-INDEX       TO H-WAGE-ADJ
029200        ELSE
029300           MOVE 52                     TO PPS-RTC
029400           MOVE ZERO                   TO PPS-WAGE-ADJ-RATE
029500        END-IF
029600     END-IF.
029700
029800     MOVE H-WAGE-ADJ-PYMT-OLD          TO MSA-ADJ-YEAR-AMT.
029900
030000******************************************************************
030100**  NEW DRUG ADD-ON FOR NEW LEGISLATION                         **
030200******************************************************************
030300
030400     MOVE CASE-MIX-BDGT-NEUT-FACTOR    TO PPS-BDGT-NEUT-RATE.
030500     MOVE DRUG-ADDON                   TO H-DRUG-ADDON.
030600/
030700******************************************************************
030800***  BILL DATA EDITS IF ANY FAIL SET PPS-RTC                   ***
030900***  AND DO NOT ATTEMPT TO PRICE.                              ***
031000******************************************************************
031100 1000-EDIT-THE-BILL-INFO.
031200
031300     IF PPS-RTC = 00  THEN
031400        IF P-SPEC-PYMT-IND NOT = '1' AND ' '  THEN
031500           MOVE 53                     TO PPS-RTC
031600        END-IF
031700     END-IF.
031800
031900     IF PPS-RTC = 00  THEN
032000        IF (B-DOB-DATE = ZERO)  OR  (B-DOB-DATE NOT NUMERIC)  THEN
032100           MOVE 54                     TO PPS-RTC
032200        END-IF
032300     END-IF.
032400
032500     IF PPS-RTC = 00  THEN
032600        IF (B-PATIENT-WGT = 0)  OR  (B-PATIENT-WGT NOT NUMERIC)
032700           MOVE 55                     TO PPS-RTC
032800        END-IF
032900     END-IF.
033000
033100     IF PPS-RTC = 00  THEN
033200        IF (B-PATIENT-HGT = 0)  OR  (B-PATIENT-HGT NOT NUMERIC)
033300           MOVE 56                     TO PPS-RTC
033400        END-IF
033500     END-IF.
033600
033700     IF PPS-RTC = 00  THEN
033800        IF B-REV-CODE  = '0821' OR '0831' OR '0841' OR '0851'
033900                                OR '0880' OR '0881'
034000           NEXT SENTENCE
034100        ELSE
034200           MOVE 57                     TO PPS-RTC
034300        END-IF
034400     END-IF.
034500
034600     IF PPS-RTC = 00  THEN
034700        IF B-COND-CODE NOT = '73' AND '74' AND '  '
034800           MOVE 58                     TO PPS-RTC
034900        END-IF
035000     END-IF.
035100
035200     IF PPS-RTC = 00  THEN
035300        IF B-PATIENT-HGT > 300.00
035400           MOVE 71                     TO PPS-RTC
035500        END-IF
035600     END-IF.
035700
035800     IF PPS-RTC = 00  THEN
035900        IF B-PATIENT-WGT > 500.00  THEN
036000           MOVE 72                     TO PPS-RTC
036100        END-IF
036200     END-IF.
036300
036400     IF PPS-RTC = 00  THEN
036500        PERFORM 1200-CALC-AGE
036600     END-IF.
036700
036800
036900 1200-CALC-AGE.
037000******************************************************************
037100***  CALCULATE PATIENT AGE                                     ***
037200******************************************************************
037300
037400     COMPUTE H-PATIENT-AGE = B-THRU-CCYY - B-DOB-CCYY.
037500
037600     IF B-DOB-MM > B-THRU-MM  THEN
037700        COMPUTE H-PATIENT-AGE = H-PATIENT-AGE - 1
037800     END-IF.
037900
038000******************************************************************
038100***  SET AGE ADJUSTMENT FACTOR                                 ***
038200******************************************************************
038300
038400     IF H-PATIENT-AGE < 18  THEN
038500        MOVE 1.620                     TO H-AGE-FACTOR
038600     ELSE
038700        IF H-PATIENT-AGE > 17 AND H-PATIENT-AGE < 45  THEN
038800           MOVE 1.223                  TO H-AGE-FACTOR
038900        ELSE
039000           IF H-PATIENT-AGE > 44 AND H-PATIENT-AGE < 60  THEN
039100              MOVE 1.055               TO H-AGE-FACTOR
039200           ELSE
039300              IF H-PATIENT-AGE > 59 AND H-PATIENT-AGE < 70  THEN
039400                 MOVE 1.000            TO H-AGE-FACTOR
039500              ELSE
039600                 IF H-PATIENT-AGE > 69 AND H-PATIENT-AGE < 80
039700                    MOVE 1.094         TO H-AGE-FACTOR
039800                 ELSE
039900                    IF H-PATIENT-AGE > 79  THEN
040000                       MOVE 1.174      TO H-AGE-FACTOR
040100                    END-IF
040200                 END-IF
040300              END-IF
040400           END-IF
040500        END-IF
040600     END-IF.
040700
040800/
040900 2000-ASSEMBLE-PPS-VARIABLES.
041000******************************************************************
041100***  CALCULATE PPS PRICING VARIABLES                           ***
041200******************************************************************
041300
041400     COMPUTE H-BSA ROUNDED = (.007184 *
041500         (B-PATIENT-HGT ** .725) * (B-PATIENT-WGT ** .425))
041600
041700     COMPUTE H-BMI ROUNDED = (B-PATIENT-WGT /
041800         (B-PATIENT-HGT ** 2)) * 10000.
041900
042000     IF H-PATIENT-AGE > 17  THEN
042100        COMPUTE H-BSA-FACTOR ROUNDED =
042200             1.037 ** ((H-BSA - 1.84) / .1)
042300     ELSE
042400        MOVE 1.000                     TO H-BSA-FACTOR
042500     END-IF.
042600
042700     IF (H-PATIENT-AGE > 17) AND (H-BMI < 18.5)  THEN
042800        MOVE 1.112                     TO H-BMI-FACTOR
042900     ELSE
043000        MOVE 1.000                     TO H-BMI-FACTOR
043100     END-IF.
043200
043300/
043400******************************************************************
043500***  IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)            ***
043600***      CALCULATE THE STANDARD PAYMENT AMOUNT.                ***
043700***    - BLEND 25% OLD RATE (MSA) WITH 75% NEW RATE (CBSA).    ***
043800******************************************************************
043900 3000-CALC-PAYMENT.
044000
044100* BEGINNING 01/01/2009 THERE WILL BE NO BLEND BETWEEN MSA & CBSA
044200
044300     COMPUTE H-WAGE-ADJ-PYMT-NEW ROUNDED =
044400         (((H-PYMT-RATE * PPS-NAT-LABOR-PCT) * H-WAGE-ADJ) +
044500           (H-PYMT-RATE * PPS-NAT-NONLABOR-PCT)) *
044600            CBSA-BLEND-PCT.
044700
044800     COMPUTE H-WAGE-ADJ-PYMT-AMT =
044900             H-WAGE-ADJ-PYMT-NEW + H-WAGE-ADJ-PYMT-OLD.
045000
045100     COMPUTE H-PYMT-AMT ROUNDED = H-WAGE-ADJ-PYMT-AMT *
045200          H-BMI-FACTOR * H-BSA-FACTOR * PPS-BDGT-NEUT-RATE *
045300          H-AGE-FACTOR * H-DRUG-ADDON.
045400
045500     MOVE H-PYMT-AMT                   TO CASE-MIX-FCTR-ADJ-RATE.
045600     MOVE SPACES                       TO COND-CD-73.
045700
045800     IF (B-COND-CODE = '73') AND (B-REV-CODE = '0821' OR '0831'
045900                                                      OR '0851')
046000        COMPUTE H-PYMT-AMT = H-PYMT-AMT + HEMO-PERI-CCPD-AMT
046100        MOVE 'A'                       TO AMT-INDIC
046200        MOVE HEMO-PERI-CCPD-AMT        TO BLOOD-DOLLAR
046300     ELSE
046400        IF (B-COND-CODE = '73')  AND  (B-REV-CODE = '0841')  THEN
046500           COMPUTE H-PYMT-AMT = H-PYMT-AMT + CAPD-AMT
046600           MOVE 'A'                    TO AMT-INDIC
046700           MOVE CAPD-AMT               TO BLOOD-DOLLAR
046800        ELSE
046900           IF (B-COND-CODE = '74')  AND
047000              (B-REV-CODE = '0841' OR '0851')  THEN
047100              COMPUTE H-PYMT-AMT ROUNDED = H-PYMT-AMT *
047200                                           CAPD-OR-CCPD-FACTOR
047300              MOVE CAPD-OR-CCPD-FACTOR TO HEMO-CCPD-CAPD
047400           ELSE
047500              MOVE 'A'                 TO AMT-INDIC
047600              MOVE ZERO                TO BLOOD-DOLLAR
047700           END-IF
047800        END-IF
047900     END-IF.
048000
048100     MOVE H-PYMT-AMT                   TO PPS-FINAL-PAY-AMT.
048200     MOVE H-WAGE-ADJ-PYMT-AMT          TO PPS-WAGE-ADJ-RATE.
048300/
048400 9000-MOVE-RESULTS.
048500
048600     IF PPS-RTC < 50  THEN
048700        MOVE B-COND-CODE               TO PPS-COND-CODE
048800        MOVE B-REV-CODE                TO PPS-REV-CODE
048900        MOVE P-GEO-MSA                 TO PPS-MSA
049000        MOVE P-GEO-CBSA                TO PPS-CBSA
049100        MOVE H-AGE-FACTOR              TO PPS-AGE-FACTOR
049200        MOVE H-BSA-FACTOR              TO PPS-BSA-FACTOR
049300        MOVE H-BMI-FACTOR              TO PPS-BMI-FACTOR
049400        IF OLD-TEST-CASE  THEN
049500           MOVE H-DRUG-ADDON           TO DRUG-ADD-ON-RETURN
049600           MOVE H-WAGE-ADJ-PYMT-OLD    TO MSA-WAGE-ADJ
049700           MOVE H-WAGE-ADJ-PYMT-NEW    TO CBSA-WAGE-ADJ
049800           MOVE CBSA-BLEND-PCT         TO CBSA-PCT
049900           MOVE MSA-BLEND-PCT          TO MSA-PCT
050000           MOVE H-PYMT-RATE            TO CBSA-WAGE-PMT-RATE
050100           MOVE H-PATIENT-AGE          TO AGE-RETURN
050200           MOVE H-WAGE-ADJ             TO CBSA-WAGE-INDEX
050300           MOVE NAT-LABOR-PCT          TO LABOR-PCT
050400        END-IF
050500     ELSE
050600        IF OLD-TEST-CASE  THEN
050700           INITIALIZE PPS-COND-CODE
050800           INITIALIZE PPS-REV-CODE
050900           INITIALIZE PPS-MSA
051000           INITIALIZE PPS-CBSA
051100           INITIALIZE PPS-AGE-FACTOR
051200           INITIALIZE PPS-BSA-FACTOR
051300           INITIALIZE PPS-BMI-FACTOR
051400           INITIALIZE DRUG-ADD-ON-RETURN
051500           INITIALIZE MSA-WAGE-ADJ
051600           INITIALIZE CBSA-PCT
051700           INITIALIZE MSA-PCT
051800           INITIALIZE CASE-MIX-FCTR-ADJ-RATE
051900           INITIALIZE CBSA-WAGE-PMT-RATE
052000           INITIALIZE HEMO-CCPD-CAPD
052100           INITIALIZE AGE-RETURN
052200        END-IF
052300     END-IF.
052400
052500******        L A S T   S O U R C E   S T A T E M E N T      *****
