000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.                PPCAL160.
000300*REVISED.                   07-29-2015.
000400*AUTHOR.                    DDS TEAM.
000500*REMARKS.                   CMS.
000600 DATE-COMPILED.
000700
000800 ENVIRONMENT DIVISION.
000900 CONFIGURATION SECTION.
001000 SOURCE-COMPUTER.            IBM-370.
001100 OBJECT-COMPUTER.            IBM-370.
001200 INPUT-OUTPUT SECTION.
001300 FILE-CONTROL.
001400
001500 DATA DIVISION.
001600 FILE SECTION.
001700
001800 WORKING-STORAGE SECTION.
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE
002000     'PPCAL160      - W O R K I N G   S T O R A G E'.
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C16.0'.
002200 01  HMO-FLAG                       PIC X      VALUE 'N'.
002300 01  HMO-TAG                        PIC X      VALUE SPACE.
002400 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
002500 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
002600 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
002700 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
002800 01  WK-LOW-VOL25PCT                PIC 99V999999 VALUE 01.000.
002900 01  WK-LOW-VOL-ADDON               PIC 9(07)V9(02).
003000 01  WK-MODEL1-BUNDLE-DISPRCNT      PIC S9(01)V9(03).
003100 01  WK-HAC-TOTAL-PAYMENT           PIC 9(07)V9(02).
003200 01  WK-HAC-AMOUNT                  PIC S9(07)V9(02).
003300 01  R1                             PIC S9(04) COMP SYNC.
003400 01  R2                             PIC S9(04) COMP SYNC.
003500 01  R3                             PIC S9(04) COMP SYNC.
003600 01  R4                             PIC S9(04) COMP SYNC.
003700 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003800 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003900 01  H-MB-RATIO-EHR-FULL            PIC 9(01)V9(09).
004000 01  H-MB-RATIO-EHR-QUAL-FULL       PIC 9(01)V9(09).
004100 01  H-EHR-SUBSAV-QUANT             PIC S9(07)V9(02).
004200 01  H-EHR-SUBSAV-LV                PIC S9(07)V9(02).
004300 01  H-EHR-SUBSAV-QUANT-INCLV       PIC S9(07)V9(02).
004400 01  H-EHR-RESTORE-FULL-QUANT       PIC S9(07)V9(02).
004500
004600*---------------------------------------------------------*
004700* (YEARCHANGE 2016.0)
004800* LABOR & NON-LABOR RATES TABLE
004900*---------------------------------------------------------*
005000
005100 COPY RATEX160.
005200
005300*---------------------------------------------------------*
005400* (YEARCHANGE 2016.0)
005500* DIAGNOSIS RELATED GROUP (DRG) WEIGHT TABLE
005600*   + TABLE 5 FROM ANNUAL IPPS FINAL RULE
005700*---------------------------------------------------------*
005800
005900 COPY DRGSX160.
006000
006100*****YEARCHANGE 2015.0 ** NOT USED 2015 *******************
006200** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
006300** FOR FY 2011 ON
006400***************************************************************
006500
006600 01  PPS-SSRFBN-TABLE.
006700     02  WK-SSRFBN-DATA.
006800         05  FILLER   PIC X(58)  VALUE
006900     '01  099835  01 ALABAMA                                   '.
007000         05  FILLER   PIC X(58)  VALUE
007100     '02  099835  02 ALASKA                                    '.
007200         05  FILLER   PIC X(58)  VALUE
007300     '03  099835  03 ARIZONA                                   '.
007400         05  FILLER   PIC X(58)  VALUE
007500     '04  099835  04 ARKANSAS                                  '.
007600         05  FILLER   PIC X(58)  VALUE
007700     '05  099317  05 CALIFORNIA                                '.
007800          05  FILLER   PIC X(58)  VALUE
007900     '06  099413  06 COLORADO                                  '.
008000         05  FILLER   PIC X(58)  VALUE
008100     '07  098016  07 CONNECTICUT                               '.
008200         05  FILLER   PIC X(58)  VALUE
008300     '08  099835  08 DELAWARE                                  '.
008400         05  FILLER   PIC X(58)  VALUE
008500     '09  099835  09 DISTRICT OF CO                            '.
008600         05  FILLER   PIC X(58)  VALUE
008700     '10  099756  10 FLORIDA                                   '.
008800         05  FILLER   PIC X(58)  VALUE
008900     '11  099835  11 GEORGIA                                   '.
009000         05  FILLER   PIC X(58)  VALUE
009100     '12  099835  12 HAWAII                                    '.
009200         05  FILLER   PIC X(58)  VALUE
009300     '13  099835  13 IDAHO                                     '.
009400         05  FILLER   PIC X(58)  VALUE
009500     '14  099835  14 ILLINOIS                                  '.
009600         05  FILLER   PIC X(58)  VALUE
009700     '15  099813  15 INDIANA                                   '.
009800         05  FILLER   PIC X(58)  VALUE
009900     '16  099783  16 IOWA                                      '.
010000         05  FILLER   PIC X(58)  VALUE
010100     '17  099827  17 KANSAS                                    '.
010200         05  FILLER   PIC X(58)  VALUE
010300     '18  099835  18 KENTUCKY                                  '.
010400         05  FILLER   PIC X(58)  VALUE
010500     '19  099834  19 LOUISIANA                                 '.
010600         05  FILLER   PIC X(58)  VALUE
010700     '20  099835  20 MAINE                                     '.
010800         05  FILLER   PIC X(58)  VALUE
010900     '21  100000  21 MARYLAND                                  '.
011000         05  FILLER   PIC X(58)  VALUE
011100     '22  099834  22 MASSACHUSETTS                             '.
011200         05  FILLER   PIC X(58)  VALUE
011300     '23  099833  23 MICHIGAN                                  '.
011400         05  FILLER   PIC X(58)  VALUE
011500     '24  099835  24 MINNESOTA                                 '.
011600         05  FILLER   PIC X(58)  VALUE
011700     '25  099834  25 MISSISSIPPI                               '.
011800         05  FILLER   PIC X(58)  VALUE
011900     '26  099835  26 MISSOURI                                  '.
012000         05  FILLER   PIC X(58)  VALUE
012100     '27  099835  27 MONTANA                                   '.
012200         05  FILLER   PIC X(58)  VALUE
012300     '28  099835  28 NEBRASKA                                  '.
012400         05  FILLER   PIC X(58)  VALUE
012500     '29  099835  29 NEVADA                                    '.
012600         05  FILLER   PIC X(58)  VALUE
012700     '30  099699  30 NEW HAMPSHIRE                             '.
012800         05  FILLER   PIC X(58)  VALUE
012900     '31  098587  31 NEW JERSEY                                '.
013000         05  FILLER   PIC X(58)  VALUE
013100     '32  099577  32 NEW MEXICO                                '.
013200         05  FILLER   PIC X(58)  VALUE
013300     '33  099835  33 NEW YORK                                  '.
013400         05  FILLER   PIC X(58)  VALUE
013500     '34  099834  34 NORTH CAROLINA                            '.
013600         05  FILLER   PIC X(58)  VALUE
013700     '35  099833  35 NORTH DAKOTA                              '.
013800         05  FILLER   PIC X(58)  VALUE
013900     '36  099784  36 OHIO                                      '.
014000         05  FILLER   PIC X(58)  VALUE
014100     '37  099835  37 OKLAHOMA                                  '.
014200         05  FILLER   PIC X(58)  VALUE
014300     '38  099708  38 OREGON                                    '.
014400         05  FILLER   PIC X(58)  VALUE
014500     '39  099834  39 PENNSYLVANIA                              '.
014600         05  FILLER   PIC X(58)  VALUE
014700     '40  099835  40 PUERTO RICO                               '.
014800         05  FILLER   PIC X(58)  VALUE
014900     '41  099835  41 RHODE ISLAND                              '.
015000         05  FILLER   PIC X(58)  VALUE
015100     '42  099779  42 SOUTH CAROLINA                            '.
015200         05  FILLER   PIC X(58)  VALUE
015300     '43  099834  43 SOUTH DAKOTA                              '.
015400         05  FILLER   PIC X(58)  VALUE
015500     '44  099690  44 TENNESSEE                                 '.
015600         05  FILLER   PIC X(58)  VALUE
015700     '45  099832  45 TEXAS                                     '.
015800         05  FILLER   PIC X(58)  VALUE
015900     '46  099835  46 UTAH                                      '.
016000         05  FILLER   PIC X(58)  VALUE
016100     '47  099835  47 VERMONT                                   '.
016200         05  FILLER   PIC X(58)  VALUE
016300     '48  100000  48 VIRGIN ISLANDS                            '.
016400         05  FILLER   PIC X(58)  VALUE
016500     '49  099835  49 VIRGINIA                                  '.
016600         05  FILLER   PIC X(58)  VALUE
016700     '50  099792  50 WASHINGTON                                '.
016800         05  FILLER   PIC X(58)  VALUE
016900     '51  099712  51 WEST VIRGINIA                             '.
017000         05  FILLER   PIC X(58)  VALUE
017100     '52  099816  52 WISCONSIN                                 '.
017200         05  FILLER   PIC X(58)  VALUE
017300     '53  099835  53 WYOMING                                   '.
017400         05  FILLER   PIC X(58)  VALUE
017500     '55  099317  55 CALIFORNIA                                '.
017600         05  FILLER   PIC X(58)  VALUE
017700     '56  100000  56 CANADA                                    '.
017800         05  FILLER   PIC X(58)  VALUE
017900     '59  100000  59 MEXICO                                    '.
018000         05  FILLER   PIC X(58)  VALUE
018100     '64  100000  64 AMERICAN SAMOA                            '.
018200         05  FILLER   PIC X(58)  VALUE
018300     '65  100000  65 GUAM                                      '.
018400         05  FILLER   PIC X(58)  VALUE
018500     '66  100000  66 MARIANAS ISLANDS                          '.
018600         05  FILLER   PIC X(58)  VALUE
018700     '67  099832  67 TEXAS                                     '.
018800         05  FILLER   PIC X(58)  VALUE
018900     '68  099756  68 FLORIDA                                   '.
019000         05  FILLER   PIC X(58)  VALUE
019100     '69  099756  69 FLORIDA                                   '.
019200         05  FILLER   PIC X(58)  VALUE
019300     '70  099827  70 KANSAS                                    '.
019400         05  FILLER   PIC X(58)  VALUE
019500     '71  099834  71 LOUISIANA                                 '.
019600         05  FILLER   PIC X(58)  VALUE
019700     '72  099784  72 OHIO                                      '.
019800         05  FILLER   PIC X(58)  VALUE
019900     '73  099834  73 PENNSYLVANIA                              '.
020000         05  FILLER   PIC X(58)  VALUE
020100     '74  099832  74 TEXAS                                     '.
020200         05  FILLER   PIC X(58)  VALUE
020300     '75  099317  75 CALIFORNIA                                '.
020400         05  FILLER   PIC X(58)  VALUE
020500     '76  099783  76 IOWA                                      '.
020600         05  FILLER   PIC X(58)  VALUE
020700     '77  099835  77 MINNESOTA                                 '.
020800         05  FILLER   PIC X(58)  VALUE
020900     '78  099835  78 ILLINOIS                                  '.
021000         05  FILLER   PIC X(58)  VALUE
021100     '80  100000  80 MARYLAND                                  '.
021200     02  WK-SSRFBN-DATA2 REDEFINES WK-SSRFBN-DATA.
021300       05  SSRFBN-TAB OCCURS 72 ASCENDING KEY IS WK-SSRFBN-STATE
021400                               INDEXED BY SSRFBN-IDX.
021500           10  WK-SSRFBN-REASON-ALL.
021600              15 WK-SSRFBN-STATE  PIC 99.
021700              15 FILLER           PIC XX.
021800              15 WK-SSRFBN-RATE   PIC 9(1)V9(5).
021900              15 FILLER           PIC XX.
022000              15 WK-SSRFBN-CODE2  PIC 99.
022100              15 FILLER           PIC XX.
022200              15 WK-SSRFBN-STNAM  PIC X(20).
022300              15 WK-SSRFBN-REST   PIC X(22).
022400
022500*---------------------------------------------------------*
022600* (YEARCHANGE 2016.0)
022700* LOW VOLUME TABLE
022800*---------------------------------------------------------*
022900
023000 COPY LVOLX160.
023100
023200***********************************************************
023300*****YEARCHANGE 2015.0 ************************************
023400***********************************************************
023500***  PROVIDER ADJUSTMENT TABLE FOR UNCOMPENSATED CARE UCC
023600***  WAS CHANGED TO DATA COMING FROM THE PROVIDER FILE
023700***********************************************************
023800
023900 01  MES-ADD-PROV                   PIC X(53) VALUE SPACES.
024000 01  MES-CHG-PROV                   PIC X(53) VALUE SPACES.
024100 01  MES-PPS-PROV                   PIC X(06).
024200 01  MES-PPS-STATE                  PIC X(02).
024300 01  MES-INTRO                      PIC X(53) VALUE SPACES.
024400 01  MES-TOT-PAY                    PIC 9(07)V9(02) VALUE 0.
024500 01  MES-SSRFBN.
024600     05 MES-SSRFBN-STATE PIC 99.
024700     05 FILLER           PIC XX.
024800     05 MES-SSRFBN-RATE  PIC 9(1)V9(5).
024900     05 FILLER           PIC XX.
025000     05 MES-SSRFBN-CODE2 PIC 99.
025100     05 FILLER           PIC XX.
025200     05 MES-SSRFBN-STNAM PIC X(20).
025300     05 MES-SSRFBN-REST  PIC X(22).
025400
025500 01 WK-HLDDRG-DATA.
025600     05  HLDDRG-DATA.
025700         10  HLDDRG-DRGX               PIC X(03).
025800         10  FILLER1                   PIC X(01).
025900         10  HLDDRG-WEIGHT             PIC 9(02)V9(04).
026000         10  FILLER2                   PIC X(01).
026100         10  HLDDRG-GMALOS             PIC 9(02)V9(01).
026200         10  FILLER3                   PIC X(05).
026300         10  HLDDRG-LOW                PIC X(01).
026400         10  FILLER5                   PIC X(01).
026500         10  HLDDRG-ARITH-ALOS         PIC 9(02)V9(01).
026600         10  FILLER6                   PIC X(02).
026700         10  HLDDRG-PAC                PIC X(01).
026800         10  FILLER7                   PIC X(01).
026900         10  HLDDRG-SPPAC              PIC X(01).
027000         10  FILLER8                   PIC X(02).
027100         10  HLDDRG-DESC               PIC X(26).
027200
027300
027400 01 WK-HLDDRG-DATA2.
027500     05  HLDDRG-DATA2.
027600         10  HLDDRG-DRGX2               PIC X(03).
027700         10  FILLER21                   PIC X(01).
027800         10  HLDDRG-WEIGHT2             PIC 9(02)V9(04).
027900         10  FILLER22                   PIC X(01).
028000         10  HLDDRG-GMALOS2             PIC 9(02)V9(01).
028100         10  FILLER23                   PIC X(05).
028200         10  HLDDRG-LOW2                PIC X(01).
028300         10  FILLER25                   PIC X(01).
028400         10  HLDDRG-ARITH-ALOS2         PIC 9(02)V9(01).
028500         10  FILLER26                   PIC X(02).
028600         10  HLDDRG-TRANS-FLAGS.
028700                   88  D-DRG-POSTACUTE-50-50
028800                   VALUE 'Y Y'.
028900                   88  D-DRG-POSTACUTE-PERDIEM
029000                   VALUE 'Y  '.
029100             15  HLDDRG-PAC2            PIC X(01).
029200             15  FILLER27               PIC X(01).
029300             15  HLDDRG-SPPAC2          PIC X(01).
029400         10  FILLER28                   PIC X(02).
029500         10  HLDDRG-DESC2               PIC X(26).
029600         10  HLDDRG-VALID               PIC X(01).
029700
029800
029900 01  MES-LOWVOL.
030000     05  MES-LOWVOL-PROV             PIC X(6).
030100     05  FILLER                      PIC XXX.
030200     05  MESWK-LOWVOL-PROV-DISCHG    PIC 9999.
030300
030400
030500 01  WK-UNCOMP-CARE.
030600     05  WK-UNCOMP-CARE-PROV         PIC X(6).
030700     05  FILLER                      PIC X.
030800     05  WK-UNCOMP-CARE-AMOUNT       PIC 9(06)V9(02).
030900
031000 01  HLD-PPS-DATA.
031100         10  HLD-PPS-RTC                PIC 9(02).
031200         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
031300         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
031400         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
031500         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
031600         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
031700         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
031800         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
031900         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
032000         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
032100         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
032200         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
032300         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
032400         10  HLD-PPS-CALC-VERS          PIC X(05).
032500
032600 LINKAGE SECTION.
032700***************************************************************
032800*                 * * * * * * * * *                           *
032900*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
033000*    IN HOW TO PAY THE BILL.                                  *
033100*                         *****                               *
033200*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
033300*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
033400*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
033500*                 OUTLIER COMPUTATION.                        *
033600*                         *****                               *
033700*         REVIEW-CODE:                                        *
033800*            00 = PAY-WITH-OUTLIER.                           *
033900*                 WILL CALCULATE THE STANDARD PAYMENT.        *
034000*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
034100*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
034200*            03 = PAY-PERDIEM-DAYS.                           *
034300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
034400*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
034500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
034600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
034700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
034800*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
034900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
035000*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
035100*                 BILL EXCEED THE COST THRESHOLD.             *
035200*            06 = PAY-XFER-NO-COST                            *
035300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
035400*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
035500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
035600*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
035700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
035800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
035900*                 CALCULATE ANY COST OUTLIER PORTION          *
036000*                 OF THE PAYMENT.                             *
036100*            07 = PAY-WITHOUT-COST.                           *
036200*                 WILL CALCULATE THE STANDARD PAYMENT         *
036300*                 WITHOUT COST PORTION.                       *
036400*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
036500*                 50-50> NOW USES Y INDICATORS ON DRGS
036600*                        SEE TABLE 5 FROM ANNUAL IPPS FINAL
036700*                        RULE
036800* =======================================================
036900* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
037000* =======================================================
037100*
037200*
037300*     FULL PERDIEM >   NOW USES Y INDICATORS ON DRGS
037400*                      SEE TABLE 5 FROM ANNUAL IPPS FINAL
037500*                      RULE
037600*
037700*                               POST-ACUTE TRANSFERS          *
037800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
037900*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
038000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
038100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
038200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
038300*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
038400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
038500*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
038600*                 BILL EXCEED THE COST THRESHOLD.             *
038700*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
038800*                 POST-ACUTE TRANSFERS                        *
038900*                 50-50> NOW USES Y INDICATORS ON DRGS
039000*                        SEE TABLE 5 FROM ANNUAL IPPS FINAL
039100*                        RULE
039200* =======================================================
039300* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
039400* =======================================================
039500*
039600*     FULL PERDIEM >  NOW USES Y INDICATORS ON DRGS
039700*                     SEE TABLE 5
039800*
039900*
040000*                               POST-ACUTE TRANSFERS          *
040100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
040200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
040300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
040400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
040500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
040600*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
040700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
040800*                 PAYMENT.                                    *
040900***************************************************************
041000
041100**************************************************************
041200*      MILLINNIUM COMPATIBLE                                 *
041300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
041400*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
041500*      IN THE NEW FORMAT                                     *
041600**************************************************************
041700 01  BILL-NEW-DATA.
041800         10  B-NPI10.
041900             15  B-NPI8             PIC X(08).
042000             15  B-NPI-FILLER       PIC X(02).
042100         10  B-PROVIDER-NO          PIC X(06).
042200         10  B-REVIEW-CODE          PIC 9(02).
042300             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
042400             88  PAY-WITH-OUTLIER     VALUE 00 07.
042500             88  PAY-PERDIEM-DAYS     VALUE 03.
042600             88  PAY-XFER-NO-COST     VALUE 06.
042700             88  PAY-WITHOUT-COST     VALUE 07.
042800             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
042900             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
043000         10  B-DRG                  PIC 9(03).
043100
043200             88  B-DRG-SPIRATN-DRG
043300                   VALUE 163 164 165.
043400
043500             88  B-DRG-SPIRATN-DRG11
043600                   VALUE 199 200 201.
043700
043800
043900             88  B-DRG-AUTOLITT-DRG
044000                   VALUE 25 26 27.
044100
044200* =======================================================
044300* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
044400* =======================================================
044500*
044600*            88  B-DRG-POSTACUTE-PERDIEM
044700*                         VALUE  NOW USES Y INDICATORS ON DRGS
044800*                         SEE TABLE 5
044900*                         D-DRG-POSTACUTE-PERDIEM
045000
045100         10  B-LOS                  PIC 9(03).
045200         10  B-COVERED-DAYS         PIC 9(03).
045300         10  B-LTR-DAYS             PIC 9(02).
045400         10  B-DISCHARGE-DATE.
045500             15  B-DISCHG-CC        PIC 9(02).
045600             15  B-DISCHG-YY        PIC 9(02).
045700             15  B-DISCHG-MM        PIC 9(02).
045800             15  B-DISCHG-DD        PIC 9(02).
045900         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
046000         10  B-PRIN-PROC-CODE       PIC X(07).
046100             88  B-PROC-ZENITH-PRIN
046200                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
046300             88  B-PROC-VORAXAZE-PRIN
046400                   VALUE '3E033GQ' '3E043GQ'.
046500             88  B-PROC-ARGUS-PRIN
046600                   VALUE '08H005Z' '08H105Z'.
046700             88  B-PROC-KCENTRA-PRIN
046800                   VALUE '30283B1'.
046900             88  B-PROC-ZILVER-PRIN
047000                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
047100                         '047L34Z' '047L44Z'.
047200             88  B-PROC-CARDIO-PRIN
047300                   VALUE '02HQ30Z' '02HR30Z'.
047400             88  B-PROC-MITRACLP-PRIN
047500                   VALUE '02UG3JZ'.
047600             88  B-PROC-RNSSYS1-PRIN
047700                   VALUE '0NH00NZ'.
047800             88  B-PROC-RNSSYS2-PRIN
047900                   VALUE '00H00MZ'.
048000             88  B-PROC-BLINATU-PRIN
048100                   VALUE 'XW03351' 'XW04351'.
048200             88  B-PROC-LUTONIX-PRIN
048300                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
048400                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
048500                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
048600                         '047L341' '047L3D1' '047L3Z1' '047L441'
048700                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
048800                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
048900                         '047M441' '047M4D1' '047M4Z1' '047N041'
049000                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
049100                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
049200         10  B-OTHER-PROC-CODE1     PIC X(07).
049300             88  B-PROC-ZENITH-PROC1
049400                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
049500             88  B-PROC-VORAXAZE-PROC1
049600                   VALUE '3E033GQ' '3E043GQ'.
049700             88  B-PROC-ARGUS-PROC1
049800                   VALUE '08H005Z' '08H105Z'.
049900             88  B-PROC-KCENTRA-PROC1
050000                   VALUE '30283B1'.
050100             88  B-PROC-ZILVER-PROC1
050200                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
050300                         '047L34Z' '047L44Z'.
050400             88  B-PROC-CARDIO-PROC1
050500                   VALUE '02HQ30Z' '02HR30Z'.
050600             88  B-PROC-MITRACLP-PROC1
050700                   VALUE '02UG3JZ'.
050800             88  B-PROC-RNSSYS1-PROC1
050900                   VALUE '0NH00NZ'.
051000             88  B-PROC-RNSSYS2-PROC1
051100                   VALUE '00H00MZ'.
051200             88  B-PROC-BLINATU-PROC1
051300                   VALUE 'XW03351' 'XW04351'.
051400             88  B-PROC-LUTONIX-PROC1
051500                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
051600                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
051700                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
051800                         '047L341' '047L3D1' '047L3Z1' '047L441'
051900                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
052000                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
052100                         '047M441' '047M4D1' '047M4Z1' '047N041'
052200                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
052300                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
052400         10  B-OTHER-PROC-CODE2     PIC X(07).
052500             88  B-PROC-ZENITH-PROC2
052600                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
052700             88  B-PROC-VORAXAZE-PROC2
052800                   VALUE '3E033GQ' '3E043GQ'.
052900             88  B-PROC-ARGUS-PROC2
053000                   VALUE '08H005Z' '08H105Z'.
053100             88  B-PROC-KCENTRA-PROC2
053200                   VALUE '30283B1'.
053300             88  B-PROC-ZILVER-PROC2
053400                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
053500                         '047L34Z' '047L44Z'.
053600             88  B-PROC-CARDIO-PROC2
053700                   VALUE '02HQ30Z' '02HR30Z'.
053800             88  B-PROC-MITRACLP-PROC2
053900                   VALUE '02UG3JZ'.
054000             88  B-PROC-RNSSYS1-PROC2
054100                   VALUE '0NH00NZ'.
054200             88  B-PROC-RNSSYS2-PROC2
054300                   VALUE '00H00MZ'.
054400             88  B-PROC-BLINATU-PROC2
054500                   VALUE 'XW03351' 'XW04351'.
054600             88  B-PROC-LUTONIX-PROC2
054700                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
054800                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
054900                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
055000                         '047L341' '047L3D1' '047L3Z1' '047L441'
055100                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
055200                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
055300                         '047M441' '047M4D1' '047M4Z1' '047N041'
055400                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
055500                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
055600         10  B-OTHER-PROC-CODE3     PIC X(07).
055700             88  B-PROC-ZENITH-PROC3
055800                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
055900             88  B-PROC-VORAXAZE-PROC3
056000                   VALUE '3E033GQ' '3E043GQ'.
056100             88  B-PROC-ARGUS-PROC3
056200                   VALUE '08H005Z' '08H105Z'.
056300             88  B-PROC-KCENTRA-PROC3
056400                   VALUE '30283B1'.
056500             88  B-PROC-ZILVER-PROC3
056600                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
056700                         '047L34Z' '047L44Z'.
056800             88  B-PROC-CARDIO-PROC3
056900                   VALUE '02HQ30Z' '02HR30Z'.
057000             88  B-PROC-MITRACLP-PROC3
057100                   VALUE '02UG3JZ'.
057200             88  B-PROC-RNSSYS1-PROC3
057300                   VALUE '0NH00NZ'.
057400             88  B-PROC-RNSSYS2-PROC3
057500                   VALUE '00H00MZ'.
057600             88  B-PROC-BLINATU-PROC3
057700                   VALUE 'XW03351' 'XW04351'.
057800             88  B-PROC-LUTONIX-PROC3
057900                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
058000                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
058100                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
058200                         '047L341' '047L3D1' '047L3Z1' '047L441'
058300                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
058400                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
058500                         '047M441' '047M4D1' '047M4Z1' '047N041'
058600                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
058700                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
058800         10  B-OTHER-PROC-CODE4     PIC X(07).
058900             88  B-PROC-ZENITH-PROC4
059000                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
059100             88  B-PROC-VORAXAZE-PROC4
059200                   VALUE '3E033GQ' '3E043GQ'.
059300             88  B-PROC-ARGUS-PROC4
059400                   VALUE '08H005Z' '08H105Z'.
059500             88  B-PROC-KCENTRA-PROC4
059600                   VALUE '30283B1'.
059700             88  B-PROC-ZILVER-PROC4
059800                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
059900                         '047L34Z' '047L44Z'.
060000             88  B-PROC-CARDIO-PROC4
060100                   VALUE '02HQ30Z' '02HR30Z'.
060200             88  B-PROC-MITRACLP-PROC4
060300                   VALUE '02UG3JZ'.
060400             88  B-PROC-RNSSYS1-PROC4
060500                   VALUE '0NH00NZ'.
060600             88  B-PROC-RNSSYS2-PROC4
060700                   VALUE '00H00MZ'.
060800             88  B-PROC-BLINATU-PROC4
060900                   VALUE 'XW03351' 'XW04351'.
061000             88  B-PROC-LUTONIX-PROC4
061100                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
061200                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
061300                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
061400                         '047L341' '047L3D1' '047L3Z1' '047L441'
061500                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
061600                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
061700                         '047M441' '047M4D1' '047M4Z1' '047N041'
061800                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
061900                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
062000         10  B-OTHER-PROC-CODE5     PIC X(07).
062100             88  B-PROC-ZENITH-PROC5
062200                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
062300             88  B-PROC-VORAXAZE-PROC5
062400                   VALUE '3E033GQ' '3E043GQ'.
062500             88  B-PROC-ARGUS-PROC5
062600                   VALUE '08H005Z' '08H105Z'.
062700             88  B-PROC-KCENTRA-PROC5
062800                   VALUE '30283B1'.
062900             88  B-PROC-ZILVER-PROC5
063000                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
063100                         '047L34Z' '047L44Z'.
063200             88  B-PROC-CARDIO-PROC5
063300                   VALUE '02HQ30Z' '02HR30Z'.
063400             88  B-PROC-MITRACLP-PROC5
063500                   VALUE '02UG3JZ'.
063600             88  B-PROC-RNSSYS1-PROC5
063700                   VALUE '0NH00NZ'.
063800             88  B-PROC-RNSSYS2-PROC5
063900                   VALUE '00H00MZ'.
064000             88  B-PROC-BLINATU-PROC5
064100                   VALUE 'XW03351' 'XW04351'.
064200             88  B-PROC-LUTONIX-PROC5
064300                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
064400                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
064500                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
064600                         '047L341' '047L3D1' '047L3Z1' '047L441'
064700                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
064800                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
064900                         '047M441' '047M4D1' '047M4Z1' '047N041'
065000                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
065100                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
065200         10  B-OTHER-PROC-CODE6     PIC X(07).
065300             88  B-PROC-ZENITH-PROC6
065400                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
065500             88  B-PROC-VORAXAZE-PROC6
065600                   VALUE '3E033GQ' '3E043GQ'.
065700             88  B-PROC-ARGUS-PROC6
065800                   VALUE '08H005Z' '08H105Z'.
065900             88  B-PROC-KCENTRA-PROC6
066000                   VALUE '30283B1'.
066100             88  B-PROC-ZILVER-PROC6
066200                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
066300                         '047L34Z' '047L44Z'.
066400             88  B-PROC-CARDIO-PROC6
066500                   VALUE '02HQ30Z' '02HR30Z'.
066600             88  B-PROC-MITRACLP-PROC6
066700                   VALUE '02UG3JZ'.
066800             88  B-PROC-RNSSYS1-PROC6
066900                   VALUE '0NH00NZ'.
067000             88  B-PROC-RNSSYS2-PROC6
067100                   VALUE '00H00MZ'.
067200             88  B-PROC-BLINATU-PROC6
067300                   VALUE 'XW03351' 'XW04351'.
067400             88  B-PROC-LUTONIX-PROC6
067500                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
067600                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
067700                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
067800                         '047L341' '047L3D1' '047L3Z1' '047L441'
067900                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
068000                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
068100                         '047M441' '047M4D1' '047M4Z1' '047N041'
068200                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
068300                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
068400         10  B-OTHER-PROC-CODE7     PIC X(07).
068500             88  B-PROC-ZENITH-PROC7
068600                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
068700             88  B-PROC-VORAXAZE-PROC7
068800                   VALUE '3E033GQ' '3E043GQ'.
068900             88  B-PROC-ARGUS-PROC7
069000                   VALUE '08H005Z' '08H105Z'.
069100             88  B-PROC-KCENTRA-PROC7
069200                   VALUE '30283B1'.
069300             88  B-PROC-ZILVER-PROC7
069400                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
069500                         '047L34Z' '047L44Z'.
069600             88  B-PROC-CARDIO-PROC7
069700                   VALUE '02HQ30Z' '02HR30Z'.
069800             88  B-PROC-MITRACLP-PROC7
069900                   VALUE '02UG3JZ'.
070000             88  B-PROC-RNSSYS1-PROC7
070100                   VALUE '0NH00NZ'.
070200             88  B-PROC-RNSSYS2-PROC7
070300                   VALUE '00H00MZ'.
070400             88  B-PROC-BLINATU-PROC7
070500                   VALUE 'XW03351' 'XW04351'.
070600             88  B-PROC-LUTONIX-PROC7
070700                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
070800                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
070900                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
071000                         '047L341' '047L3D1' '047L3Z1' '047L441'
071100                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
071200                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
071300                         '047M441' '047M4D1' '047M4Z1' '047N041'
071400                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
071500                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
071600         10  B-OTHER-PROC-CODE8     PIC X(07).
071700             88  B-PROC-ZENITH-PROC8
071800                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
071900             88  B-PROC-VORAXAZE-PROC8
072000                   VALUE '3E033GQ' '3E043GQ'.
072100             88  B-PROC-ARGUS-PROC8
072200                   VALUE '08H005Z' '08H105Z'.
072300             88  B-PROC-KCENTRA-PROC8
072400                   VALUE '30283B1'.
072500             88  B-PROC-ZILVER-PROC8
072600                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
072700                         '047L34Z' '047L44Z'.
072800             88  B-PROC-CARDIO-PROC8
072900                   VALUE '02HQ30Z' '02HR30Z'.
073000             88  B-PROC-MITRACLP-PROC8
073100                   VALUE '02UG3JZ'.
073200             88  B-PROC-RNSSYS1-PROC8
073300                   VALUE '0NH00NZ'.
073400             88  B-PROC-RNSSYS2-PROC8
073500                   VALUE '00H00MZ'.
073600             88  B-PROC-BLINATU-PROC8
073700                   VALUE 'XW03351' 'XW04351'.
073800             88  B-PROC-LUTONIX-PROC8
073900                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
074000                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
074100                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
074200                         '047L341' '047L3D1' '047L3Z1' '047L441'
074300                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
074400                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
074500                         '047M441' '047M4D1' '047M4Z1' '047N041'
074600                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
074700                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
074800         10  B-OTHER-PROC-CODE9     PIC X(07).
074900             88  B-PROC-ZENITH-PROC9
075000                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
075100             88  B-PROC-VORAXAZE-PROC9
075200                   VALUE '3E033GQ' '3E043GQ'.
075300             88  B-PROC-ARGUS-PROC9
075400                   VALUE '08H005Z' '08H105Z'.
075500             88  B-PROC-KCENTRA-PROC9
075600                   VALUE '30283B1'.
075700             88  B-PROC-ZILVER-PROC9
075800                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
075900                         '047L34Z' '047L44Z'.
076000             88  B-PROC-CARDIO-PROC9
076100                   VALUE '02HQ30Z' '02HR30Z'.
076200             88  B-PROC-MITRACLP-PROC9
076300                   VALUE '02UG3JZ'.
076400             88  B-PROC-RNSSYS1-PROC9
076500                   VALUE '0NH00NZ'.
076600             88  B-PROC-RNSSYS2-PROC9
076700                   VALUE '00H00MZ'.
076800             88  B-PROC-BLINATU-PROC9
076900                   VALUE 'XW03351' 'XW04351'.
077000             88  B-PROC-LUTONIX-PROC9
077100                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
077200                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
077300                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
077400                         '047L341' '047L3D1' '047L3Z1' '047L441'
077500                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
077600                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
077700                         '047M441' '047M4D1' '047M4Z1' '047N041'
077800                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
077900                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
078000         10  B-OTHER-PROC-CODE10    PIC X(07).
078100             88  B-PROC-ZENITH-PROC10
078200                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
078300             88  B-PROC-VORAXAZE-PROC10
078400                   VALUE '3E033GQ' '3E043GQ'.
078500             88  B-PROC-ARGUS-PROC10
078600                   VALUE '08H005Z' '08H105Z'.
078700             88  B-PROC-KCENTRA-PROC10
078800                   VALUE '30283B1'.
078900             88  B-PROC-ZILVER-PROC10
079000                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
079100                         '047L34Z' '047L44Z'.
079200             88  B-PROC-CARDIO-PROC10
079300                   VALUE '02HQ30Z' '02HR30Z'.
079400             88  B-PROC-MITRACLP-PROC10
079500                   VALUE '02UG3JZ'.
079600             88  B-PROC-RNSSYS1-PROC10
079700                   VALUE '0NH00NZ'.
079800             88  B-PROC-RNSSYS2-PROC10
079900                   VALUE '00H00MZ'.
080000             88  B-PROC-BLINATU-PROC10
080100                   VALUE 'XW03351' 'XW04351'.
080200             88  B-PROC-LUTONIX-PROC10
080300                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
080400                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
080500                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
080600                         '047L341' '047L3D1' '047L3Z1' '047L441'
080700                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
080800                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
080900                         '047M441' '047M4D1' '047M4Z1' '047N041'
081000                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
081100                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
081200         10  B-OTHER-PROC-CODE11    PIC X(07).
081300             88  B-PROC-ZENITH-PROC11
081400                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
081500             88  B-PROC-VORAXAZE-PROC11
081600                   VALUE '3E033GQ' '3E043GQ'.
081700             88  B-PROC-ARGUS-PROC11
081800                   VALUE '08H005Z' '08H105Z'.
081900             88  B-PROC-KCENTRA-PROC11
082000                   VALUE '30283B1'.
082100             88  B-PROC-ZILVER-PROC11
082200                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
082300                         '047L34Z' '047L44Z'.
082400             88  B-PROC-CARDIO-PROC11
082500                   VALUE '02HQ30Z' '02HR30Z'.
082600             88  B-PROC-MITRACLP-PROC11
082700                   VALUE '02UG3JZ'.
082800             88  B-PROC-RNSSYS1-PROC11
082900                   VALUE '0NH00NZ'.
083000             88  B-PROC-RNSSYS2-PROC11
083100                   VALUE '00H00MZ'.
083200             88  B-PROC-BLINATU-PROC11
083300                   VALUE 'XW03351' 'XW04351'.
083400             88  B-PROC-LUTONIX-PROC11
083500                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
083600                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
083700                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
083800                         '047L341' '047L3D1' '047L3Z1' '047L441'
083900                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
084000                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
084100                         '047M441' '047M4D1' '047M4Z1' '047N041'
084200                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
084300                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
084400         10  B-OTHER-PROC-CODE12    PIC X(07).
084500             88  B-PROC-ZENITH-PROC12
084600                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
084700             88  B-PROC-VORAXAZE-PROC12
084800                   VALUE '3E033GQ' '3E043GQ'.
084900             88  B-PROC-ARGUS-PROC12
085000                   VALUE '08H005Z' '08H105Z'.
085100             88  B-PROC-KCENTRA-PROC12
085200                   VALUE '30283B1'.
085300             88  B-PROC-ZILVER-PROC12
085400                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
085500                         '047L34Z' '047L44Z'.
085600             88  B-PROC-CARDIO-PROC12
085700                   VALUE '02HQ30Z' '02HR30Z'.
085800             88  B-PROC-MITRACLP-PROC12
085900                   VALUE '02UG3JZ'.
086000             88  B-PROC-RNSSYS1-PROC12
086100                   VALUE '0NH00NZ'.
086200             88  B-PROC-RNSSYS2-PROC12
086300                   VALUE '00H00MZ'.
086400             88  B-PROC-BLINATU-PROC12
086500                   VALUE 'XW03351' 'XW04351'.
086600             88  B-PROC-LUTONIX-PROC12
086700                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
086800                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
086900                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
087000                         '047L341' '047L3D1' '047L3Z1' '047L441'
087100                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
087200                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
087300                         '047M441' '047M4D1' '047M4Z1' '047N041'
087400                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
087500                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
087600         10  B-OTHER-PROC-CODE13    PIC X(07).
087700             88  B-PROC-ZENITH-PROC13
087800                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
087900             88  B-PROC-VORAXAZE-PROC13
088000                   VALUE '3E033GQ' '3E043GQ'.
088100             88  B-PROC-ARGUS-PROC13
088200                   VALUE '08H005Z' '08H105Z'.
088300             88  B-PROC-KCENTRA-PROC13
088400                   VALUE '30283B1'.
088500             88  B-PROC-ZILVER-PROC13
088600                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
088700                         '047L34Z' '047L44Z'.
088800             88  B-PROC-CARDIO-PROC13
088900                   VALUE '02HQ30Z' '02HR30Z'.
089000             88  B-PROC-MITRACLP-PROC13
089100                   VALUE '02UG3JZ'.
089200             88  B-PROC-RNSSYS1-PROC13
089300                   VALUE '0NH00NZ'.
089400             88  B-PROC-RNSSYS2-PROC13
089500                   VALUE '00H00MZ'.
089600             88  B-PROC-BLINATU-PROC13
089700                   VALUE 'XW03351' 'XW04351'.
089800             88  B-PROC-LUTONIX-PROC13
089900                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
090000                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
090100                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
090200                         '047L341' '047L3D1' '047L3Z1' '047L441'
090300                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
090400                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
090500                         '047M441' '047M4D1' '047M4Z1' '047N041'
090600                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
090700                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
090800         10  B-OTHER-PROC-CODE14    PIC X(07).
090900             88  B-PROC-ZENITH-PROC14
091000                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
091100             88  B-PROC-VORAXAZE-PROC14
091200                   VALUE '3E033GQ' '3E043GQ'.
091300             88  B-PROC-ARGUS-PROC14
091400                   VALUE '08H005Z' '08H105Z'.
091500             88  B-PROC-KCENTRA-PROC14
091600                   VALUE '30283B1'.
091700             88  B-PROC-ZILVER-PROC14
091800                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
091900                         '047L34Z' '047L44Z'.
092000             88  B-PROC-CARDIO-PROC14
092100                   VALUE '02HQ30Z' '02HR30Z'.
092200             88  B-PROC-MITRACLP-PROC14
092300                   VALUE '02UG3JZ'.
092400             88  B-PROC-RNSSYS1-PROC14
092500                   VALUE '0NH00NZ'.
092600             88  B-PROC-RNSSYS2-PROC14
092700                   VALUE '00H00MZ'.
092800             88  B-PROC-BLINATU-PROC14
092900                   VALUE 'XW03351' 'XW04351'.
093000             88  B-PROC-LUTONIX-PROC14
093100                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
093200                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
093300                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
093400                         '047L341' '047L3D1' '047L3Z1' '047L441'
093500                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
093600                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
093700                         '047M441' '047M4D1' '047M4Z1' '047N041'
093800                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
093900                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
094000         10  B-OTHER-PROC-CODE15    PIC X(07).
094100             88  B-PROC-ZENITH-PROC15
094200                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
094300             88  B-PROC-VORAXAZE-PROC15
094400                   VALUE '3E033GQ' '3E043GQ'.
094500             88  B-PROC-ARGUS-PROC15
094600                   VALUE '08H005Z' '08H105Z'.
094700             88  B-PROC-KCENTRA-PROC15
094800                   VALUE '30283B1'.
094900             88  B-PROC-ZILVER-PROC15
095000                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
095100                         '047L34Z' '047L44Z'.
095200             88  B-PROC-CARDIO-PROC15
095300                   VALUE '02HQ30Z' '02HR30Z'.
095400             88  B-PROC-MITRACLP-PROC15
095500                   VALUE '02UG3JZ'.
095600             88  B-PROC-RNSSYS1-PROC15
095700                   VALUE '0NH00NZ'.
095800             88  B-PROC-RNSSYS2-PROC15
095900                   VALUE '00H00MZ'.
096000             88  B-PROC-BLINATU-PROC15
096100                   VALUE 'XW03351' 'XW04351'.
096200             88  B-PROC-LUTONIX-PROC15
096300                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
096400                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
096500                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
096600                         '047L341' '047L3D1' '047L3Z1' '047L441'
096700                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
096800                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
096900                         '047M441' '047M4D1' '047M4Z1' '047N041'
097000                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
097100                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
097200         10  B-OTHER-PROC-CODE16    PIC X(07).
097300             88  B-PROC-ZENITH-PROC16
097400                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
097500             88  B-PROC-VORAXAZE-PROC16
097600                   VALUE '3E033GQ' '3E043GQ'.
097700             88  B-PROC-ARGUS-PROC16
097800                   VALUE '08H005Z' '08H105Z'.
097900             88  B-PROC-KCENTRA-PROC16
098000                   VALUE '30283B1'.
098100             88  B-PROC-ZILVER-PROC16
098200                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
098300                         '047L34Z' '047L44Z'.
098400             88  B-PROC-CARDIO-PROC16
098500                   VALUE '02HQ30Z' '02HR30Z'.
098600             88  B-PROC-MITRACLP-PROC16
098700                   VALUE '02UG3JZ'.
098800             88  B-PROC-RNSSYS1-PROC16
098900                   VALUE '0NH00NZ'.
099000             88  B-PROC-RNSSYS2-PROC16
099100                   VALUE '00H00MZ'.
099200             88  B-PROC-BLINATU-PROC16
099300                   VALUE 'XW03351' 'XW04351'.
099400             88  B-PROC-LUTONIX-PROC16
099500                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
099600                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
099700                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
099800                         '047L341' '047L3D1' '047L3Z1' '047L441'
099900                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
100000                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
100100                         '047M441' '047M4D1' '047M4Z1' '047N041'
100200                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
100300                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
100400         10  B-OTHER-PROC-CODE17    PIC X(07).
100500             88  B-PROC-ZENITH-PROC17
100600                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
100700             88  B-PROC-VORAXAZE-PROC17
100800                   VALUE '3E033GQ' '3E043GQ'.
100900             88  B-PROC-ARGUS-PROC17
101000                   VALUE '08H005Z' '08H105Z'.
101100             88  B-PROC-KCENTRA-PROC17
101200                   VALUE '30283B1'.
101300             88  B-PROC-ZILVER-PROC17
101400                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
101500                         '047L34Z' '047L44Z'.
101600             88  B-PROC-CARDIO-PROC17
101700                   VALUE '02HQ30Z' '02HR30Z'.
101800             88  B-PROC-MITRACLP-PROC17
101900                   VALUE '02UG3JZ'.
102000             88  B-PROC-RNSSYS1-PROC17
102100                   VALUE '0NH00NZ'.
102200             88  B-PROC-RNSSYS2-PROC17
102300                   VALUE '00H00MZ'.
102400             88  B-PROC-BLINATU-PROC17
102500                   VALUE 'XW03351' 'XW04351'.
102600             88  B-PROC-LUTONIX-PROC17
102700                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
102800                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
102900                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
103000                         '047L341' '047L3D1' '047L3Z1' '047L441'
103100                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
103200                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
103300                         '047M441' '047M4D1' '047M4Z1' '047N041'
103400                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
103500                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
103600         10  B-OTHER-PROC-CODE18    PIC X(07).
103700             88  B-PROC-ZENITH-PROC18
103800                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
103900             88  B-PROC-VORAXAZE-PROC18
104000                   VALUE '3E033GQ' '3E043GQ'.
104100             88  B-PROC-ARGUS-PROC18
104200                   VALUE '08H005Z' '08H105Z'.
104300             88  B-PROC-KCENTRA-PROC18
104400                   VALUE '30283B1'.
104500             88  B-PROC-ZILVER-PROC18
104600                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
104700                         '047L34Z' '047L44Z'.
104800             88  B-PROC-CARDIO-PROC18
104900                   VALUE '02HQ30Z' '02HR30Z'.
105000             88  B-PROC-MITRACLP-PROC18
105100                   VALUE '02UG3JZ'.
105200             88  B-PROC-RNSSYS1-PROC18
105300                   VALUE '0NH00NZ'.
105400             88  B-PROC-RNSSYS2-PROC18
105500                   VALUE '00H00MZ'.
105600             88  B-PROC-BLINATU-PROC18
105700                   VALUE 'XW03351' 'XW04351'.
105800             88  B-PROC-LUTONIX-PROC18
105900                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
106000                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
106100                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
106200                         '047L341' '047L3D1' '047L3Z1' '047L441'
106300                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
106400                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
106500                         '047M441' '047M4D1' '047M4Z1' '047N041'
106600                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
106700                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
106800         10  B-OTHER-PROC-CODE19    PIC X(07).
106900             88  B-PROC-ZENITH-PROC19
107000                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
107100             88  B-PROC-VORAXAZE-PROC19
107200                   VALUE '3E033GQ' '3E043GQ'.
107300             88  B-PROC-ARGUS-PROC19
107400                   VALUE '08H005Z' '08H105Z'.
107500             88  B-PROC-KCENTRA-PROC19
107600                   VALUE '30283B1'.
107700             88  B-PROC-ZILVER-PROC19
107800                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
107900                         '047L34Z' '047L44Z'.
108000             88  B-PROC-CARDIO-PROC19
108100                   VALUE '02HQ30Z' '02HR30Z'.
108200             88  B-PROC-MITRACLP-PROC19
108300                   VALUE '02UG3JZ'.
108400             88  B-PROC-RNSSYS1-PROC19
108500                   VALUE '0NH00NZ'.
108600             88  B-PROC-RNSSYS2-PROC19
108700                   VALUE '00H00MZ'.
108800             88  B-PROC-BLINATU-PROC19
108900                   VALUE 'XW03351' 'XW04351'.
109000             88  B-PROC-LUTONIX-PROC19
109100                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
109200                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
109300                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
109400                         '047L341' '047L3D1' '047L3Z1' '047L441'
109500                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
109600                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
109700                         '047M441' '047M4D1' '047M4Z1' '047N041'
109800                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
109900                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
110000         10  B-OTHER-PROC-CODE20    PIC X(07).
110100             88  B-PROC-ZENITH-PROC20
110200                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
110300             88  B-PROC-VORAXAZE-PROC20
110400                   VALUE '3E033GQ' '3E043GQ'.
110500             88  B-PROC-ARGUS-PROC20
110600                   VALUE '08H005Z' '08H105Z'.
110700             88  B-PROC-KCENTRA-PROC20
110800                   VALUE '30283B1'.
110900             88  B-PROC-ZILVER-PROC20
111000                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
111100                         '047L34Z' '047L44Z'.
111200             88  B-PROC-CARDIO-PROC20
111300                   VALUE '02HQ30Z' '02HR30Z'.
111400             88  B-PROC-MITRACLP-PROC20
111500                   VALUE '02UG3JZ'.
111600             88  B-PROC-RNSSYS1-PROC20
111700                   VALUE '0NH00NZ'.
111800             88  B-PROC-RNSSYS2-PROC20
111900                   VALUE '00H00MZ'.
112000             88  B-PROC-BLINATU-PROC20
112100                   VALUE 'XW03351' 'XW04351'.
112200             88  B-PROC-LUTONIX-PROC20
112300                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
112400                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
112500                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
112600                         '047L341' '047L3D1' '047L3Z1' '047L441'
112700                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
112800                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
112900                         '047M441' '047M4D1' '047M4Z1' '047N041'
113000                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
113100                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
113200         10  B-OTHER-PROC-CODE21    PIC X(07).
113300             88  B-PROC-ZENITH-PROC21
113400                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
113500             88  B-PROC-VORAXAZE-PROC21
113600                   VALUE '3E033GQ' '3E043GQ'.
113700             88  B-PROC-ARGUS-PROC21
113800                   VALUE '08H005Z' '08H105Z'.
113900             88  B-PROC-KCENTRA-PROC21
114000                   VALUE '30283B1'.
114100             88  B-PROC-ZILVER-PROC21
114200                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
114300                         '047L34Z' '047L44Z'.
114400             88  B-PROC-CARDIO-PROC21
114500                   VALUE '02HQ30Z' '02HR30Z'.
114600             88  B-PROC-MITRACLP-PROC21
114700                   VALUE '02UG3JZ'.
114800             88  B-PROC-RNSSYS1-PROC21
114900                   VALUE '0NH00NZ'.
115000             88  B-PROC-RNSSYS2-PROC21
115100                   VALUE '00H00MZ'.
115200             88  B-PROC-BLINATU-PROC21
115300                   VALUE 'XW03351' 'XW04351'.
115400             88  B-PROC-LUTONIX-PROC21
115500                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
115600                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
115700                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
115800                         '047L341' '047L3D1' '047L3Z1' '047L441'
115900                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
116000                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
116100                         '047M441' '047M4D1' '047M4Z1' '047N041'
116200                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
116300                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
116400         10  B-OTHER-PROC-CODE22    PIC X(07).
116500             88  B-PROC-ZENITH-PROC22
116600                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
116700             88  B-PROC-VORAXAZE-PROC22
116800                   VALUE '3E033GQ' '3E043GQ'.
116900             88  B-PROC-ARGUS-PROC22
117000                   VALUE '08H005Z' '08H105Z'.
117100             88  B-PROC-KCENTRA-PROC22
117200                   VALUE '30283B1'.
117300             88  B-PROC-ZILVER-PROC22
117400                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
117500                         '047L34Z' '047L44Z'.
117600             88  B-PROC-CARDIO-PROC22
117700                   VALUE '02HQ30Z' '02HR30Z'.
117800             88  B-PROC-MITRACLP-PROC22
117900                   VALUE '02UG3JZ'.
118000             88  B-PROC-RNSSYS1-PROC22
118100                   VALUE '0NH00NZ'.
118200             88  B-PROC-RNSSYS2-PROC22
118300                   VALUE '00H00MZ'.
118400             88  B-PROC-BLINATU-PROC22
118500                   VALUE 'XW03351' 'XW04351'.
118600             88  B-PROC-LUTONIX-PROC22
118700                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
118800                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
118900                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
119000                         '047L341' '047L3D1' '047L3Z1' '047L441'
119100                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
119200                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
119300                         '047M441' '047M4D1' '047M4Z1' '047N041'
119400                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
119500                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
119600         10  B-OTHER-PROC-CODE23    PIC X(07).
119700             88  B-PROC-ZENITH-PROC23
119800                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
119900             88  B-PROC-VORAXAZE-PROC23
120000                   VALUE '3E033GQ' '3E043GQ'.
120100             88  B-PROC-ARGUS-PROC23
120200                   VALUE '08H005Z' '08H105Z'.
120300             88  B-PROC-KCENTRA-PROC23
120400                   VALUE '30283B1'.
120500             88  B-PROC-ZILVER-PROC23
120600                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
120700                         '047L34Z' '047L44Z'.
120800             88  B-PROC-CARDIO-PROC23
120900                   VALUE '02HQ30Z' '02HR30Z'.
121000             88  B-PROC-MITRACLP-PROC23
121100                   VALUE '02UG3JZ'.
121200             88  B-PROC-RNSSYS1-PROC23
121300                   VALUE '0NH00NZ'.
121400             88  B-PROC-RNSSYS2-PROC23
121500                   VALUE '00H00MZ'.
121600             88  B-PROC-BLINATU-PROC23
121700                   VALUE 'XW03351' 'XW04351'.
121800             88  B-PROC-LUTONIX-PROC23
121900                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
122000                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
122100                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
122200                         '047L341' '047L3D1' '047L3Z1' '047L441'
122300                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
122400                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
122500                         '047M441' '047M4D1' '047M4Z1' '047N041'
122600                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
122700                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
122800         10  B-OTHER-PROC-CODE24    PIC X(07).
122900             88  B-PROC-ZENITH-PROC24
123000                   VALUE '04U03JZ' '04U04JZ' '04V03DZ' '04V04DZ'.
123100             88  B-PROC-VORAXAZE-PROC24
123200                   VALUE '3E033GQ' '3E043GQ'.
123300             88  B-PROC-ARGUS-PROC24
123400                   VALUE '08H005Z' '08H105Z'.
123500             88  B-PROC-KCENTRA-PROC24
123600                   VALUE '30283B1'.
123700             88  B-PROC-ZILVER-PROC24
123800                   VALUE '047K04Z' '047K34Z' '047K44Z' '047L04Z'
123900                         '047L34Z' '047L44Z'.
124000             88  B-PROC-CARDIO-PROC24
124100                   VALUE '02HQ30Z' '02HR30Z'.
124200             88  B-PROC-MITRACLP-PROC24
124300                   VALUE '02UG3JZ'.
124400             88  B-PROC-RNSSYS1-PROC24
124500                   VALUE '0NH00NZ'.
124600             88  B-PROC-RNSSYS2-PROC24
124700                   VALUE '00H00MZ'.
124800             88  B-PROC-BLINATU-PROC24
124900                   VALUE 'XW03351' 'XW04351'.
125000             88  B-PROC-LUTONIX-PROC24
125100                   VALUE '047K041' '047K0D1' '047K0Z1' '047K341'
125200                         '047K3D1' '047K3Z1' '047K441' '047K4D1'
125300                         '047K4Z1' '047L041' '047L0D1' '047L0Z1'
125400                         '047L341' '047L3D1' '047L3Z1' '047L441'
125500                         '047L4D1' '047L4Z1' '047M041' '047M0D1'
125600                         '047M0Z1' '047M341' '047M3D1' '047M3Z1'
125700                         '047M441' '047M4D1' '047M4Z1' '047N041'
125800                         '047N0D1' '047N0Z1' '047N341' '047N3D1'
125900                         '047N3Z1' '047N441' '047N4D1' '047N4Z1'.
126000         10  B-OTHER-DIAG-CODE1     PIC X(07).
126100             88  B-DIAG-AUTOLITT-DIAG
126200                   VALUE '1910   ' '1911   ' '1912   ' '1913  '
126300                         '1914   ' '1915   ' '1916   ' '1917  '
126400                         '1918   ' '1919   ' 'C710   ' 'C711  '
126500                         'C712   ' 'C713   ' 'C714   ' 'C715  '
126600                         'C716   ' 'C717   ' 'C718   ' 'C719  '.
126700             88  B-DIAG-KCENTRA-DIAG1
126800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
126900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
127000                         'D6832  ' 'D684   '.
127100         10  B-OTHER-DIAG-CODE2     PIC X(07).
127200             88  B-DIAG-KCENTRA-DIAG2
127300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
127400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
127500                         'D6832  ' 'D684   '.
127600         10  B-OTHER-DIAG-CODE3     PIC X(07).
127700             88  B-DIAG-KCENTRA-DIAG3
127800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
127900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
128000                         'D6832  ' 'D684   '.
128100         10  B-OTHER-DIAG-CODE4     PIC X(07).
128200             88  B-DIAG-KCENTRA-DIAG4
128300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
128400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
128500                         'D6832  ' 'D684   '.
128600         10  B-OTHER-DIAG-CODE5     PIC X(07).
128700             88  B-DIAG-KCENTRA-DIAG5
128800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
128900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
129000                         'D6832  ' 'D684   '.
129100         10  B-OTHER-DIAG-CODE6     PIC X(07).
129200             88  B-DIAG-KCENTRA-DIAG6
129300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
129400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
129500                         'D6832  ' 'D684   '.
129600         10  B-OTHER-DIAG-CODE7     PIC X(07).
129700             88  B-DIAG-KCENTRA-DIAG7
129800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
129900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
130000                         'D6832  ' 'D684   '.
130100         10  B-OTHER-DIAG-CODE8     PIC X(07).
130200             88  B-DIAG-KCENTRA-DIAG8
130300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
130400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
130500                         'D6832  ' 'D684   '.
130600         10  B-OTHER-DIAG-CODE9     PIC X(07).
130700             88  B-DIAG-KCENTRA-DIAG9
130800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
130900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
131000                         'D6832  ' 'D684   '.
131100         10  B-OTHER-DIAG-CODE10    PIC X(07).
131200             88  B-DIAG-KCENTRA-DIAG10
131300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
131400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
131500                         'D6832  ' 'D684   '.
131600         10  B-OTHER-DIAG-CODE11    PIC X(07).
131700             88  B-DIAG-KCENTRA-DIAG11
131800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
131900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
132000                         'D6832  ' 'D684   '.
132100         10  B-OTHER-DIAG-CODE12    PIC X(07).
132200             88  B-DIAG-KCENTRA-DIAG12
132300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
132400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
132500                         'D6832  ' 'D684   '.
132600         10  B-OTHER-DIAG-CODE13    PIC X(07).
132700             88  B-DIAG-KCENTRA-DIAG13
132800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
132900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
133000                         'D6832  ' 'D684   '.
133100         10  B-OTHER-DIAG-CODE14    PIC X(07).
133200             88  B-DIAG-KCENTRA-DIAG14
133300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
133400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
133500                         'D6832  ' 'D684   '.
133600         10  B-OTHER-DIAG-CODE15    PIC X(07).
133700             88  B-DIAG-KCENTRA-DIAG15
133800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
133900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
134000                         'D6832  ' 'D684   '.
134100         10  B-OTHER-DIAG-CODE16    PIC X(07).
134200             88  B-DIAG-KCENTRA-DIAG16
134300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
134400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
134500                         'D6832  ' 'D684   '.
134600         10  B-OTHER-DIAG-CODE17    PIC X(07).
134700             88  B-DIAG-KCENTRA-DIAG17
134800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
134900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
135000                         'D6832  ' 'D684   '.
135100         10  B-OTHER-DIAG-CODE18    PIC X(07).
135200             88  B-DIAG-KCENTRA-DIAG18
135300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
135400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
135500                         'D6832  ' 'D684   '.
135600         10  B-OTHER-DIAG-CODE19    PIC X(07).
135700             88  B-DIAG-KCENTRA-DIAG19
135800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
135900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
136000                         'D6832  ' 'D684   '.
136100         10  B-OTHER-DIAG-CODE20    PIC X(07).
136200             88  B-DIAG-KCENTRA-DIAG20
136300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
136400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
136500                         'D6832  ' 'D684   '.
136600         10  B-OTHER-DIAG-CODE21    PIC X(07).
136700             88  B-DIAG-KCENTRA-DIAG21
136800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
136900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
137000                         'D6832  ' 'D684   '.
137100         10  B-OTHER-DIAG-CODE22    PIC X(07).
137200             88  B-DIAG-KCENTRA-DIAG22
137300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
137400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
137500                         'D6832  ' 'D684   '.
137600         10  B-OTHER-DIAG-CODE23    PIC X(07).
137700             88  B-DIAG-KCENTRA-DIAG23
137800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
137900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
138000                         'D6832  ' 'D684   '.
138100         10  B-OTHER-DIAG-CODE24    PIC X(07).
138200             88  B-DIAG-KCENTRA-DIAG24
138300                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
138400                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
138500                         'D6832  ' 'D684   '.
138600         10  B-OTHER-DIAG-CODE25    PIC X(07).
138700             88  B-DIAG-KCENTRA-DIAG25
138800                   VALUE 'D66    ' 'D67    ' 'D681   ' 'D682   '
138900                         'D680   ' 'D68311 ' 'D68312 ' 'D68318 '
139000                         'D6832  ' 'D684   '.
139100         10  B-DEMO-DATA.
139200             15  B-DEMO-CODE1           PIC X(02).
139300             15  B-DEMO-CODE2           PIC X(02).
139400             15  B-DEMO-CODE3           PIC X(02).
139500             15  B-DEMO-CODE4           PIC X(02).
139600         10  B-NDC-DATA.
139700             15  B-NDC-NUMBER           PIC X(11).
139800               88  B-NDC-DIFICID-NDC
139900                   VALUE '52015008001'.
140000         10  FILLER                     PIC X(73).
140100
140200
140300***************************************************************
140400*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
140500*    AND PASSED BACK TO THE CALLING PROGRAM                   *
140600*            RETURN CODE VALUES (PPS-RTC)                     *
140700*                                                             *
140800*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
140900*                                                             *
141000*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
141100*                                                             *
141200*           30,00 = PAID NORMAL DRG PAYMENT                   *
141300*                                                             *
141400*              01 = PAID AS A DAY-OUTLIER.                    *
141500*                   NOTE:                                     *
141600*                     DAY-OUTLIER NO LONGER BEING PAID        *
141700*                         AS OF 10/01/97                      *
141800*                                                             *
141900*              02 = PAID AS A COST-OUTLIER.                   *
142000*                                                             *
142100*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
142200*                   AND INCLUDING THE FULL DRG.               *
142300*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
142400*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
142500*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
142600*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
142700*                   AND INCLUDING THE FULL DRG. PROVIDER      *
142800*                   REFUSED COST OUTLIER.                     *
142900*           40,10 = POST-ACUTE TRANSFER                       *
143000*                   SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE
143100*
143200* =======================================================
143300* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
143400* =======================================================
143500*
143600*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
143700*                       THE FOLLOWING DRG'S                   *
143800*                   DRG =  VALUE  NOW USES Y INDICATORS ON DRGS
143900*                       SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE
144000*                          D-DRG-POSTACUTE-PERDIEM
144100*
144200*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
144300*                    PERDIEM DAYS = OR > GM  ALOS             *
144400*              16 = PAID AS A COST-OUTLIER WITH               *
144500*                    PERDIEM DAYS = OR > GM  ALOS             *
144600*                                                             *
144700*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
144800*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
144900*              52 = INVALID CBSA# IN PROVIDER FILE            *
145000*                   OR INVALID WAGE INDEX                     *
145100*                                      OR                     *
145200*                   INVALID PROVIDER TYPES ON PROVIDER FILE   *
145300*              53 = WAIVER STATE - NOT CALCULATED BY PPS OR   *
145400*                   OR                                         *
145500*                   INVALID STATE CODE IN COMBINATION WITH     *
145600*                   HAC FLAG                                  *
145700*              54 = INVALID DRG                               *
145800*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
145900*                                      OR                     *
146000*                   DISCHARGE DATE < CBSA EFF START DATE      *
146100*                   FOR PPS                                   *
146200*                                      OR                     *
146300*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
146400*                   DISCHARGE DATE                            *
146500*              56 = INVALID LENGTH OF STAY                    *
146600*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
146700*                                        NOT 11)              *
146800*              58 = TOTAL CHARGES NOT NUMERIC                 *
146900*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
147000*                   OR BILL-LTR-DAYS > 60                     *
147100*              62 = INVALID NUMBER OF COVERED DAYS            *
147200*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER        *
147300*                   SPECIFIC FILE FOR CAPITAL                  *
147400*                   OR                                         *
147500*                   INVALID READMISSION FLAG IN PSF FILE       *
147600*                   OR                                         *
147700*                   BLANK READMISSION FLAG IN PSF FILE         *
147800*                   OR                                         *
147900*                   READMISSION ADJUSTMENT IS INVALID OR       *
148000*                   OUT OF RANGE IN PSF FILE                   *
148100*                   OR                                         *
148200*                   BLANK READMISSION ADJUSTMENT IN PSF FILE   *
148300*                   OR                                         *
148400*                   INVALID STATE CODE IN COMBINATION WITH     *
148500*                   READMISSION FLAG IN PSF FILE               *
148600*                   OR                                         *
148700*                   INVALID EHR FLAG IN PSF FILE               *
148800*                   (MUST BE A "Y" OR BLANK)                   *
148900*              67 = COST OUTLIER WITH LOS > COVERED DAYS      **
149000*                   OR COST OUTLIER THRESHOLD CALUCULATION    **
149100*              68 = INVALID VALUE BASED PURCHASE FLAG IN PSF   *
149200*                   FILE                                       *
149300*                   OR                                         *
149400*                   BLANK VALUE BASED PURCHASE FLAG IN PSF FILE*
149500*                   OR                                         *
149600*                   VALUE BASED PURCHASE ADJUSTMEMT IS INVALID *
149700*                   OR OUT OF RANGE IN PSF FILE                *
149800*                   INDICATOR                                  *
149900*                   OR                                         *
150000*                   BLANK VALUE BASED PURCHASE ADJUSTMEMT IN   *
150100*                   PSF FILE                                   *
150200*                   OR                                         *
150300*                   INVALID COMBINATION OF HOSPITAL QUALITY    *
150400*                   INDICATOR                                  *
150500*                   AND VALUE BASED PURCHASE FLAG IN PSF FILE  *
150600*                   OR                                         *
150700*                   INVALID STATE CODE IN COMBINATION WITH VALUE
150800*                   BASED PURCHASE FLAG IN PSF FILE            *
150900*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
151000***************************************************************
151100 01  PPS-DATA.
151200         10  PPS-RTC                PIC 9(02).
151300         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
151400         10  PPS-OUTLIER-DAYS       PIC 9(03).
151500         10  PPS-AVG-LOS            PIC 9(02)V9(01).
151600         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
151700         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
151800         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
151900         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
152000         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
152100         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
152200         10  PPS-REG-DAYS-USED      PIC 9(03).
152300         10  PPS-LTR-DAYS-USED      PIC 9(02).
152400         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
152500         10  PPS-CALC-VERS          PIC X(05).
152600
152700*****************************************************************
152800*            THESE ARE THE VERSIONS OF THE PPCAL
152900*           PROGRAMS THAT WILL BE PASSED BACK----
153000*          ASSOCIATED WITH THE BILL BEING PROCESSED
153100*****************************************************************
153200 01  PRICER-OPT-VERS-SW.
153300     02  PRICER-OPTION-SW          PIC X(01).
153400         88  ALL-TABLES-PASSED          VALUE 'A'.
153500         88  PROV-RECORD-PASSED         VALUE 'P'.
153600         88  ADDITIONAL-VARIABLES       VALUE 'M'.
153700         88  PC-PRICER                  VALUE 'C'.
153800     02  PPS-VERSIONS.
153900         10  PPDRV-VERSION         PIC X(05).
154000
154100*****************************************************************
154200*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
154300*          ASSOCIATED WITH THE BILL BEING PROCESSED
154400*****************************************************************
154500 01  PPS-ADDITIONAL-VARIABLES.
154600     05  PPS-HSP-PCT                PIC 9(01)V9(02).
154700     05  PPS-FSP-PCT                PIC 9(01)V9(02).
154800     05  PPS-NAT-PCT                PIC 9(01)V9(02).
154900     05  PPS-REG-PCT                PIC 9(01)V9(02).
155000     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
155100     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
155200     05  PPS-DRG-WT                 PIC 9(02)V9(04).
155300     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
155400     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
155500     05  PPS-REG-LABOR              PIC 9(05)V9(02).
155600     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
155700     05  PPS-OPER-COLA              PIC 9(01)V9(03).
155800     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
155900     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
156000     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
156100     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
156200     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
156300     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
156400     05  PPS-CAPITAL-VARIABLES.
156500         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
156600         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
156700         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
156800         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
156900         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
157000         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
157100         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
157200         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
157300     05  PPS-CAPITAL2-VARIABLES.
157400         10  PPS-CAPI2-PAY-CODE             PIC X(1).
157500         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
157600         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
157700
157800     05  PPS-OTHER-VARIABLES.
157900         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
158000         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
158100         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
158200         10  PPS-VAL-BASED-PURCH-PARTIPNT   PIC X.
158300         10  PPS-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
158400         10  PPS-HOSP-READMISSION-REDU      PIC X.
158500         10  PPS-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
158600         10  PPS-OPERATNG-DATA.
158700             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
158800             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
158900             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
159000
159100     05  PPS-PC-OTH-VARIABLES.
159200         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
159300         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
159400         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
159500         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
159600         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
159700         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
159800         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(04).
159900         10  PPS-PC-HMO-FLAG                PIC X(01).
160000         10  PPS-PC-COT-FLAG                PIC X(01).
160100         10  PPS-OPER-HSP-PART2             PIC 9(07)V9(02).
160200         10  PPS-BUNDLE-ADJUST-PAY          PIC S9(07)V99.
160300
160400     05  PPS-ADDITIONAL-PAY-INFO-DATA.
160500         10 PPS-UNCOMP-CARE-AMOUNT          PIC S9(07)V9(02).
160600         10 PPS-BUNDLE-ADJUST-AMT           PIC S9(07)V9(02).
160700         10 PPS-VAL-BASED-PURCH-ADJUST-AMT  PIC S9(07)V9(02).
160800         10 PPS-READMIS-ADJUST-AMT          PIC S9(07)V9(02).
160900     05  PPS-ADDITIONAL-PAY-INFO-DATA2.
161000         10  PPS-HAC-PROG-REDUC-IND      PIC X.
161100         10  PPS-EHR-PROG-REDUC-IND      PIC X.
161200         10  PPS-EHR-ADJUST-AMT          PIC S9(07)V9(02).
161300         10  PPS-STNDRD-VALUE            PIC S9(07)V9(02).
161400         10  PPS-HAC-PAYMENT-AMT         PIC S9(07)V9(02).
161500         10  PPS-FLX7-PAYMENT            PIC S9(07)V9(02).
161600     05 PPS-FILLER                       PIC X(0906).
161700
161800 01  PROV-NEW-HOLD.
161900     02  PROV-NEWREC-HOLD1.
162000         05  P-NEW-NPI10.
162100             10  P-NEW-NPI8             PIC X(08).
162200             10  P-NEW-NPI-FILLER       PIC X(02).
162300         05  P-NEW-PROVIDER-NO.
162400             88  P-NEW-DSH-ADJ-PROVIDERS
162500                             VALUE '180049' '190044' '190144'
162600                                   '190191' '330047' '340085'
162700                                   '370016' '370149' '420043'.
162800             10  P-NEW-STATE            PIC 9(02).
162900                 88  P-VBP-INVALID-STATE
163000                             VALUE 21 80 40.
163100                 88  P-READ-INVALID-STATE
163200                             VALUE 40.
163300                 88  P-HAC-INVALID-STATE
163400                             VALUE 40.
163500             10  FILLER                 PIC X(04).
163600         05  P-NEW-DATE-DATA.
163700             10  P-NEW-EFF-DATE.
163800                 15  P-NEW-EFF-DT-CC    PIC 9(02).
163900                 15  P-NEW-EFF-DT-YY    PIC 9(02).
164000                 15  P-NEW-EFF-DT-MM    PIC 9(02).
164100                 15  P-NEW-EFF-DT-DD    PIC 9(02).
164200             10  P-NEW-FY-BEGIN-DATE.
164300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
164400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
164500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
164600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
164700             10  P-NEW-REPORT-DATE.
164800                 15  P-NEW-REPORT-DT-CC PIC 9(02).
164900                 15  P-NEW-REPORT-DT-YY PIC 9(02).
165000                 15  P-NEW-REPORT-DT-MM PIC 9(02).
165100                 15  P-NEW-REPORT-DT-DD PIC 9(02).
165200             10  P-NEW-TERMINATION-DATE.
165300                 15  P-NEW-TERM-DT-CC   PIC 9(02).
165400                 15  P-NEW-TERM-DT-YY   PIC 9(02).
165500                 15  P-NEW-TERM-DT-MM   PIC 9(02).
165600                 15  P-NEW-TERM-DT-DD   PIC 9(02).
165700         05  P-NEW-WAIVER-CODE          PIC X(01).
165800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
165900         05  P-NEW-INTER-NO             PIC 9(05).
166000         05  P-NEW-PROVIDER-TYPE        PIC X(02).
166100             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
166200             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
166300                                                  '15' '17'
166400                                                  '22'.
166500             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
166600             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
166700             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
166800             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
166900             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
167000             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
167100             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
167200             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
167300             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
167400             88  P-N-EACH                   VALUE '21' '22'.
167500             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
167600             88  P-N-NHCMQ-II-SNF           VALUE '32'.
167700             88  P-N-NHCMQ-III-SNF          VALUE '33'.
167800             88  P-N-INVALID-PROV-TYPES     VALUE '14' '15'.
167900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
168000             88  P-N-NEW-ENGLAND            VALUE  1.
168100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
168200             88  P-N-SOUTH-ATLANTIC         VALUE  3.
168300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
168400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
168500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
168600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
168700             88  P-N-MOUNTAIN               VALUE  8.
168800             88  P-N-PACIFIC                VALUE  9.
168900         05  P-NEW-CURRENT-DIV   REDEFINES
169000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
169100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
169200         05  P-NEW-MSA-DATA.
169300             10  P-NEW-CHG-CODE-INDEX       PIC X.
169400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
169500             10  P-NEW-GEO-LOC-MSA9   REDEFINES
169600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
169700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
169800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
169900             10  P-NEW-STAND-AMT-LOC-MSA9
170000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
170100                 15  P-NEW-RURAL-1ST.
170200                     20  P-NEW-STAND-RURAL  PIC XX.
170300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
170400                 15  P-NEW-RURAL-2ND        PIC XX.
170500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
170600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
170700                 88  P-NEW-SCH-YR82       VALUE   '82'.
170800                 88  P-NEW-SCH-YR87       VALUE   '87'.
170900         05  P-NEW-LUGAR                    PIC X.
171000         05  P-NEW-TEMP-RELIEF-IND          PIC X.
171100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
171200         05  FILLER                         PIC X(05).
171300     02  PROV-NEWREC-HOLD2.
171400         05  P-NEW-VARIABLES.
171500             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
171600             10  P-NEW-COLA              PIC  9(01)V9(03).
171700             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
171800             10  P-NEW-BED-SIZE          PIC  9(05).
171900             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
172000             10  P-NEW-CMI               PIC  9(01)V9(04).
172100             10  P-NEW-SSI-RATIO         PIC  V9(04).
172200             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
172300             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
172400             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
172500             10  P-NEW-DSH-PERCENT       PIC  V9(04).
172600             10  P-NEW-FYE-DATE          PIC  X(08).
172700         05  P-NEW-CBSA-DATA.
172800             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
172900             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
173000             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
173100             10  P-NEW-CBSA-GEO-RURAL REDEFINES
173200                 P-NEW-CBSA-GEO-LOC.
173300                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
173400                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
173500                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
173600
173700             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
173800             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
173900             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
174000     02  PROV-NEWREC-HOLD3.
174100         05  P-NEW-PASS-AMT-DATA.
174200             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
174300             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
174400             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
174500             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
174600         05  P-NEW-CAPI-DATA.
174700             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
174800             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
174900             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
175000             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
175100             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
175200             15  P-NEW-CAPI-NEW-HOSP       PIC X.
175300             15  P-NEW-CAPI-IME            PIC 9V9999.
175400             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
175500         05  P-HVBP-HRR-DATA.
175600             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
175700             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
175800             15  P-HOSP-READMISSION-REDU    PIC X.
175900             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
176000         05  P-MODEL1-BUNDLE-DATA.
176100             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
176200             15  P-HAC-REDUC-IND            PIC X.
176300             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
176400             15  P-EHR-REDUC-IND            PIC X.
176500         05  FILLER                         PIC X(09).
176600
176700*****************************************************************
176800 01  WAGE-NEW-CBSA-INDEX-RECORD.
176900     05  W-CBSA                        PIC X(5).
177000     05  W-CBSA-SIZE                   PIC X.
177100         88  LARGE-URBAN       VALUE 'L'.
177200         88  OTHER-URBAN       VALUE 'O'.
177300         88  ALL-RURAL         VALUE 'R'.
177400     05  W-CBSA-EFF-DATE               PIC X(8).
177500     05  FILLER                        PIC X.
177600     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
177700     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
177800
177900*******************************************************
178000*    HOLD VARIABLES POPULATED IN PPCAL___***          *
178100*******************************************************
178200 COPY PPHOLDAR.
178300
178400******************************************************************
178500 PROCEDURE DIVISION  USING BILL-NEW-DATA
178600                           PPS-DATA
178700                           PRICER-OPT-VERS-SW
178800                           PPS-ADDITIONAL-VARIABLES
178900                           PROV-NEW-HOLD
179000                           WAGE-NEW-CBSA-INDEX-RECORD
179100                           PPHOLDAR-HOLD-AREA.
179200
179300***************************************************************
179400*    PROCESSING:                                              *
179500*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
179600*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
179700*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
179800*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
179900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
180000*           GOBACK.                                           *
180100*        D. ASSEMBLE PRICING COMPONENTS.                      *
180200*        E. CALCULATE THE PRICE.                              *
180300***************************************************************
180400     INITIALIZE WK-HLDDRG-DATA
180500                WK-HLDDRG-DATA2.
180600
180700     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
180800     MOVE ZEROES TO WK-UNCOMP-CARE-AMOUNT.
180900     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT.
181000     MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT.
181100     MOVE ZEROES TO H-READMIS-ADJUST-AMT.
181200     MOVE 'N' TO TEMP-RELIEF-FLAG.
181300     MOVE 'N' TO OUTLIER-RECON-FLAG.
181400     MOVE ZEROES TO WK-HAC-AMOUNT.
181500     MOVE ZEROES TO WK-HAC-TOTAL-PAYMENT.
181600     MOVE ZEROES TO H-NEW-TECH-PAY-ADD-ON.
181700     MOVE ZEROES TO PPS-NEW-TECH-PAY-ADD-ON.
181800
181900     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
182000
182100     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
182200     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
182300     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
182400     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
182500     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
182600     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
182700     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
182800     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
182900     MOVE H-ADDITIONAL-PAY-INFO-DATA TO
183000                            PPS-ADDITIONAL-PAY-INFO-DATA.
183100     MOVE H-ADDITIONAL-PAY-INFO-DATA2 TO
183200                            PPS-ADDITIONAL-PAY-INFO-DATA2.
183300
183400
183500     COMPUTE PPS-OPER-HSP-PART2 ROUNDED =  1 *  H-HSP-RATE.
183600     MOVE    WK-UNCOMP-CARE-AMOUNT TO PPS-UNCOMP-CARE-AMOUNT.
183700     MOVE    H-BUNDLE-ADJUST-AMT TO PPS-BUNDLE-ADJUST-AMT.
183800     MOVE    H-VAL-BASED-PURCH-ADJUST-AMT TO
183900                           PPS-VAL-BASED-PURCH-ADJUST-AMT.
184000     MOVE    H-READMIS-ADJUST-AMT TO PPS-READMIS-ADJUST-AMT.
184100     MOVE    P-MODEL1-BUNDLE-DISPRCNT TO
184200                               PPS-MODEL1-BUNDLE-DISPRCNT.
184300
184400     MOVE P-HAC-REDUC-IND  TO  PPS-HAC-PROG-REDUC-IND.
184500     MOVE P-EHR-REDUC-IND  TO  PPS-EHR-PROG-REDUC-IND.
184600     MOVE H-EHR-ADJUST-AMT TO  PPS-EHR-ADJUST-AMT.
184700*    MOVE H-STNDRD-VALUE   TO  PPS-STNDRD-VALUE.
184800     MOVE H-STANDARD-ALLOWED-AMOUNT  TO  PPS-STNDRD-VALUE.
184900     MOVE WK-HAC-AMOUNT  TO   PPS-HAC-PAYMENT-AMT.
185000     MOVE 0     TO    PPS-FLX7-PAYMENT.
185100
185200     IF (PPS-RTC = '00' OR '03' OR '10' OR
185300                   '12' OR '14')
185400        MOVE 'Y' TO OUTLIER-RECON-FLAG
185500        MOVE PPS-DATA TO HLD-PPS-DATA
185600        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
185700        MOVE HLD-PPS-DATA TO PPS-DATA.
185800
185900     IF  PPS-RTC < 50
186000         IF  P-NEW-WAIVER-STATE
186100             MOVE 53 TO PPS-RTC
186200             MOVE ALL '0' TO PPS-OPER-HSP-PART
186300                             PPS-OPER-FSP-PART
186400                             PPS-OPER-OUTLIER-PART
186500                             PPS-OUTLIER-DAYS
186600                             PPS-REG-DAYS-USED
186700                             PPS-LTR-DAYS-USED
186800                             PPS-TOTAL-PAYMENT
186900                             WK-HAC-TOTAL-PAYMENT
187000                             PPS-OPER-DSH-ADJ
187100                             PPS-OPER-IME-ADJ
187200                             H-DSCHG-FRCTN
187300                             H-DRG-WT-FRCTN
187400                             HOLD-ADDITIONAL-VARIABLES
187500                             HOLD-CAPITAL-VARIABLES
187600                             HOLD-CAPITAL2-VARIABLES
187700                             HOLD-OTHER-VARIABLES
187800                             HOLD-PC-OTH-VARIABLES
187900                             H-ADDITIONAL-PAY-INFO-DATA
188000                             H-ADDITIONAL-PAY-INFO-DATA2.
188100
188200     GOBACK.
188300
188400 0200-MAINLINE-CONTROL.
188500
188600     MOVE 'N' TO HMO-TAG.
188700
188800     IF PPS-PC-HMO-FLAG = 'Y' OR
188900               HMO-FLAG = 'Y'
189000        MOVE 'Y' TO HMO-TAG.
189100
189200     IF P-NEW-STATE NOT = 40
189300        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
189400
189500     MOVE ALL '0' TO PPS-DATA
189600                     H-OPER-DSH-SCH
189700                     H-OPER-DSH-RRC
189800                     HOLD-PPS-COMPONENTS
189900                     HOLD-PPS-COMPONENTS
190000                     HOLD-ADDITIONAL-VARIABLES
190100                     HOLD-CAPITAL-VARIABLES
190200                     HOLD-CAPITAL2-VARIABLES
190300                     HOLD-OTHER-VARIABLES
190400                     HOLD-PC-OTH-VARIABLES
190500                     H-ADDITIONAL-PAY-INFO-DATA
190600                     H-ADDITIONAL-PAY-INFO-DATA2
190700                     H-EHR-SUBSAV-QUANT
190800                     H-EHR-SUBSAV-LV
190900                     H-EHR-SUBSAV-QUANT-INCLV
191000                     H-EHR-RESTORE-FULL-QUANT
191100                     H-OPER-BILL-STDZ-COSTS
191200                     H-CAPI-BILL-STDZ-COSTS
191300                     H-OPER-STDZ-COST-OUTLIER
191400                     H-CAPI-STDZ-COST-OUTLIER
191500                     H-OPER-STDZ-DOLLAR-THRESHOLD
191600                     H-CAPI-STDZ-DOLLAR-THRESHOLD
191700                     WK-LOW-VOL-ADDON
191800                     WK-HAC-AMOUNT
191900                     WK-HAC-TOTAL-PAYMENT.
192000
192100     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
192200        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
192300
192400     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
192500        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
192600
192700     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
192800        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
192900
193000     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
193100        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
193200
193300     IF P-HOSP-HRR-ADJUSTMT     NOT NUMERIC
193400        MOVE 0 TO P-HOSP-HRR-ADJUSTMT.
193500
193600     IF P-VAL-BASED-PURCH-ADJUST NOT NUMERIC
193700        MOVE 0 TO P-VAL-BASED-PURCH-ADJUST.
193800
193900     IF P-MODEL1-BUNDLE-DISPRCNT NOT NUMERIC
194000        MOVE 0 TO P-MODEL1-BUNDLE-DISPRCNT.
194100
194200
194300     PERFORM 1000-EDIT-THE-BILL-INFO.
194400
194500     IF  PPS-RTC = 00
194600         PERFORM 2000-ASSEMBLE-PPS-VARIABLES.
194700
194800     IF  PPS-RTC = 00
194900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
195000
195100     IF OUTLIER-RECON-FLAG = 'Y'
195200        MOVE 'N' TO OUTLIER-RECON-FLAG
195300        GO TO 0200-EXIT.
195400
195500     IF PPS-RTC = 00
195600        IF H-PERDIEM-DAYS = H-ALOS OR
195700           H-PERDIEM-DAYS > H-ALOS
195800           MOVE 14 TO PPS-RTC.
195900
196000     IF PPS-RTC = 02
196100        IF H-PERDIEM-DAYS = H-ALOS OR
196200           H-PERDIEM-DAYS > H-ALOS
196300           MOVE 16 TO PPS-RTC.
196400
196500 0200-EXIT.   EXIT.
196600
196700 1000-EDIT-THE-BILL-INFO.
196800
196900     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
197000     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
197100
197200**   IF  PPS-RTC = 00
197300*        IF  P-NEW-WAIVER-STATE
197400*            MOVE 53 TO PPS-RTC.
197500
197600     IF  PPS-RTC = 00
197700         IF   HLDDRG-VALID = 'I'
197800             MOVE 54 TO PPS-RTC.
197900
198000     IF  PPS-RTC = 00
198100            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
198200                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
198300                MOVE 55 TO PPS-RTC.
198400
198500     IF  PPS-RTC = 00
198600         IF P-NEW-TERMINATION-DATE > 00000000
198700            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
198800                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
198900                  MOVE 55 TO PPS-RTC.
199000
199100     IF  PPS-RTC = 00
199200         IF  B-LOS NOT NUMERIC
199300             MOVE 56 TO PPS-RTC
199400         ELSE
199500         IF  B-LOS = 0
199600             IF B-REVIEW-CODE NOT = 00 AND
199700                              NOT = 03 AND
199800                              NOT = 06 AND
199900                              NOT = 07 AND
200000                              NOT = 09 AND
200100                              NOT = 11
200200             MOVE 56 TO PPS-RTC.
200300
200400     IF  PPS-RTC = 00
200500         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
200600             MOVE 61 TO PPS-RTC
200700         ELSE
200800             MOVE B-LTR-DAYS TO H-LTR-DAYS.
200900
201000     IF  PPS-RTC = 00
201100         IF  B-COVERED-DAYS NOT NUMERIC
201200             MOVE 62 TO PPS-RTC
201300         ELSE
201400         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
201500             MOVE 62 TO PPS-RTC
201600         ELSE
201700             MOVE B-COVERED-DAYS TO H-COV-DAYS.
201800
201900     IF  PPS-RTC = 00
202000         IF  H-LTR-DAYS  > H-COV-DAYS
202100             MOVE 62 TO PPS-RTC
202200         ELSE
202300             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
202400
202500     IF  PPS-RTC = 00
202600         IF  NOT VALID-REVIEW-CODE
202700             MOVE 57 TO PPS-RTC.
202800
202900     IF  PPS-RTC = 00
203000         IF  B-CHARGES-CLAIMED NOT NUMERIC
203100             MOVE 58 TO PPS-RTC.
203200
203300     IF PPS-RTC = 00
203400           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
203500                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'B' AND
203600                                            NOT = 'C'
203700                 MOVE 65 TO PPS-RTC.
203800
203900***  MDH PROVISION ENDS 3/31/2015
204000***  CODE COMMENTED OUT IN ORDER TO EXTEND EXPIRING PROVISON
204100
204200*    IF PPS-RTC = 00 AND
204300*       B-DISCHARGE-DATE > 20150331 AND
204400*       P-N-INVALID-PROV-TYPES
204500*                MOVE 52 TO PPS-RTC.
204600
204700 2000-ASSEMBLE-PPS-VARIABLES.
204800***  GET THE PROVIDER SPECIFIC VARIABLES.
204900***  GET THE PROVIDER SPECIFIC VARIABLES.
205000
205100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
205200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
205300
205400     IF  (P-NEW-STATE = 02 OR 12)
205500         MOVE P-NEW-COLA TO H-OPER-COLA
205600     ELSE
205700         MOVE 1.000  TO H-OPER-COLA.
205800
205900***************************************************************
206000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
206100
206200     PERFORM 2600-GET-DRG-WEIGHT THRU 2600-EXIT.
206300
206400     PERFORM 4410-UNCOMP-CARE-CODE-RTN THRU 4410-EXIT.
206500
206600     MOVE P-NEW-STATE            TO MES-PPS-STATE.
206700*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
206800** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
206900** FOR FY 2011
207000***************************************************************
207100*    PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
207200*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
207300***************************************************************
207400***  GET THE WAGE-INDEX
207500
207600     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
207700     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
207800     MOVE P-NEW-STATE            TO MES-PPS-STATE.
207900
208000*****YEARCHANGE 2011.0 ** NOT USED 2013 *******************
208100
208200***************************************************************
208300***  GET THE LABOR, NON-LABOR STANDARD RATES
208400
208500     IF  P-NEW-STATE = 40
208600         MOVE 2 TO R2
208700         MOVE 3 TO R4
208800     ELSE
208900         MOVE 1 TO R2
209000         MOVE 1 TO R4.
209100
209200     IF  LARGE-URBAN
209300         MOVE 1 TO R3
209400     ELSE
209500         MOVE 2 TO R3.
209600
209700     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
209800        (P-EHR-REDUC-IND = ' ')           AND
209900        (H-WAGE-INDEX > 01.0000))
210000        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
210100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
210200
210300     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
210400        (P-EHR-REDUC-IND = ' ')               AND
210500         (H-WAGE-INDEX > 01.0000))
210600        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
210700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
210800
210900     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
211000        (P-EHR-REDUC-IND = ' ')            AND
211100         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
211200        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
211300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
211400
211500     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
211600        (P-EHR-REDUC-IND = ' ')               AND
211700         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
211800        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
211900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
212000
212100
212200     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
212300        (P-EHR-REDUC-IND = 'Y')           AND
212400        (H-WAGE-INDEX > 01.0000))
212500        PERFORM 2300-GET-LAB-NONLAB-TB5-RATES
212600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
212700
212800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
212900        (P-EHR-REDUC-IND = 'Y')               AND
213000         (H-WAGE-INDEX > 01.0000))
213100        PERFORM 2300-GET-LAB-NONLAB-TB6-RATES
213200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
213300
213400     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
213500        (P-EHR-REDUC-IND = 'Y')            AND
213600         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
213700        PERFORM 2300-GET-LAB-NONLAB-TB7-RATES
213800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
213900
214000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
214100        (P-EHR-REDUC-IND = 'Y')               AND
214200         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
214300        PERFORM 2300-GET-LAB-NONLAB-TB8-RATES
214400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
214500
214600     IF P-NEW-STATE = 40
214700        IF (H-PR-WAGE-INDEX > 01.0000)
214800            PERFORM 2300-GET-PR-LAB-TB1-RATES
214900            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
215000
215100     IF P-NEW-STATE = 40
215200        IF (H-PR-WAGE-INDEX < 01.0000 OR
215300            H-PR-WAGE-INDEX = 01.0000)
215400            PERFORM 2300-GET-PR-LAB-TB3-RATES
215500            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
215600*
215700*    IF P-NEW-STATE = 40
215800*       IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
215900*           (H-PR-WAGE-INDEX > 01.0000))
216000*            PERFORM 2300-GET-PR-LAB-TB1-RATES
216100*            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
216200*
216300*    IF P-NEW-STATE = 40
216400*       IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
216500*            (H-PR-WAGE-INDEX > 01.0000))
216600*             PERFORM 2300-GET-PR-LAB-TB2-RATES
216700*                 VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
216800*
216900*    IF P-NEW-STATE = 40
217000*       IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
217100*       (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
217200*         PERFORM 2300-GET-PR-LAB-TB3-RATES
217300*             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
217400*
217500*    IF P-NEW-STATE = 40
217600*       IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
217700*       (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
217800*         PERFORM 2300-GET-PR-LAB-TB4-RATES
217900*             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
218000*
218100***************************************************************
218200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
218300***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
218400
218500     MOVE 0.00  TO H-OPER-HSP-PCT.
218600     MOVE 1.00  TO H-OPER-FSP-PCT.
218700
218800***************************************************************
218900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
219000***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
219100
219200      MOVE 1.00 TO H-NAT-PCT.
219300      MOVE 0.00 TO H-REG-PCT.
219400
219500     IF  P-NEW-STATE = 40
219600         MOVE 0.75 TO H-NAT-PCT
219700         MOVE 0.25 TO H-REG-PCT.
219800
219900     IF  P-N-SCH-REBASED-FY90 OR
220000         P-N-EACH OR
220100         P-N-MDH-REBASED-FY90
220200         MOVE 1.00 TO H-OPER-HSP-PCT.
220300
220400 2300-GET-LAB-NONLAB-TB1-RATES.
220500
220600     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
220700         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
220800         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
220900         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
221000         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
221100
221200 2300-GET-LAB-NONLAB-TB2-RATES.
221300
221400     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
221500         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
221600         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
221700         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
221800         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
221900
222000 2300-GET-LAB-NONLAB-TB3-RATES.
222100
222200     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
222300         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
222400         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
222500         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
222600         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
222700
222800 2300-GET-LAB-NONLAB-TB4-RATES.
222900
223000     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
223100         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
223200         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
223300         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
223400         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
223500
223600 2300-GET-LAB-NONLAB-TB5-RATES.
223700
223800     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
223900         MOVE TB5-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
224000         MOVE TB5-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
224100         MOVE TB5-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
224200         MOVE TB5-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
224300
224400 2300-GET-LAB-NONLAB-TB6-RATES.
224500
224600     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
224700         MOVE TB6-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
224800         MOVE TB6-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
224900         MOVE TB6-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
225000         MOVE TB6-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
225100
225200 2300-GET-LAB-NONLAB-TB7-RATES.
225300
225400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
225500         MOVE TB7-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
225600         MOVE TB7-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
225700         MOVE TB7-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
225800         MOVE TB7-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
225900
226000 2300-GET-LAB-NONLAB-TB8-RATES.
226100
226200     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
226300         MOVE TB8-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
226400         MOVE TB8-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
226500         MOVE TB8-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
226600         MOVE TB8-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
226700
226800 2300-GET-PR-LAB-TB1-RATES.
226900
227000     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
227100         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
227200         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
227300
227400*2300-GET-PR-LAB-TB2-RATES.
227500*
227600*    IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
227700*        MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
227800*        MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
227900
228000 2300-GET-PR-LAB-TB3-RATES.
228100
228200     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
228300         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
228400         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
228500
228600*2300-GET-PR-LAB-TB4-RATES.
228700*
228800*    IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
228900*        MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
229000*        MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
229100
229200*
229300 2600-GET-DRG-WEIGHT.
229400
229500     IF  B-DISCHARGE-DATE NOT < WK-DRGX-EFF-DATE
229600     SET DRG-IDX TO 1
229700     SEARCH DRG-TAB VARYING DRG-IDX
229800         AT END
229900           MOVE ' NO DRG CODE    FOUND' TO HLDDRG-DESC
230000           MOVE 'I' TO  HLDDRG-VALID
230100           MOVE 0 TO HLDDRG-WEIGHT
230200           MOVE 54 TO PPS-RTC
230300           GO TO 2600-EXIT
230400       WHEN WK-DRG-DRGX(DRG-IDX) = B-DRG
230500         MOVE DRG-DATA-TAB(DRG-IDX) TO HLDDRG-DATA.
230600
230700
230800     MOVE HLDDRG-DATA TO WK-HLDDRG-DATA2.
230900     MOVE  HLDDRG-DRGX         TO HLDDRG-DRGX2.
231000     MOVE  HLDDRG-WEIGHT       TO HLDDRG-WEIGHT2
231100                                  H-DRG-WT.
231200     MOVE  HLDDRG-GMALOS       TO HLDDRG-GMALOS2
231300                                  H-ALOS.
231400     MOVE  HLDDRG-LOW          TO HLDDRG-LOW2.
231500     MOVE  HLDDRG-ARITH-ALOS   TO HLDDRG-ARITH-ALOS2
231600                                  H-ARITH-ALOS.
231700     MOVE  HLDDRG-PAC          TO HLDDRG-PAC2.
231800     MOVE  HLDDRG-SPPAC        TO HLDDRG-SPPAC2.
231900     MOVE  HLDDRG-DESC         TO HLDDRG-DESC2.
232000     MOVE  'V'                 TO HLDDRG-VALID.
232100     MOVE ZEROES               TO H-DAYS-CUTOFF.
232200
232300 2600-EXIT.   EXIT.
232400*
232500 3000-CALC-PAYMENT.
232600***************************************************************
232700
232800     PERFORM 3100-CALC-STAY-UTILIZATION.
232900     PERFORM 3300-CALC-OPER-FSP-AMT.
233000     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
233100
233200***********************************************************
233300***  OPERATING IME CALCULATION
233400
233500     COMPUTE H-OPER-IME-TEACH ROUNDED =
233600            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
233700
233800***********************************************************
233900*
234000*    IF P-N-SCH-REBASED-FY90 OR
234100*       P-N-EACH OR
234200*       P-N-MDH-REBASED-FY90
234300*        PERFORM 3450-CALC-ADDITIONAL-HSP.
234400*
234500     MOVE 00                 TO  PPS-RTC.
234600     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
234700     MOVE H-ALOS             TO  PPS-AVG-LOS.
234800     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
234900
235000     MOVE B-LOS TO H-PERDIEM-DAYS.
235100     IF H-PERDIEM-DAYS < 1
235200         MOVE 1 TO H-PERDIEM-DAYS.
235300     ADD 1 TO H-PERDIEM-DAYS.
235400
235500     MOVE 1 TO H-DSCHG-FRCTN.
235600
235700     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
235800
235900     IF (PAY-PERDIEM-DAYS  OR
236000         PAY-XFER-NO-COST) OR
236100        (PAY-XFER-SPEC-DRG AND
236200         D-DRG-POSTACUTE-PERDIEM)
236300       IF H-ALOS > 0
236400         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
236500         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
236600         IF H-DSCHG-FRCTN > 1
236700              MOVE 1 TO H-DSCHG-FRCTN
236800              MOVE 1 TO H-TRANSFER-ADJ
236900         ELSE
237000              COMPUTE H-DRG-WT-FRCTN ROUNDED =
237100                  H-TRANSFER-ADJ * H-DRG-WT
237200         END-IF
237300        END-IF
237400     END-IF.
237500
237600
237700     IF (PAY-XFER-SPEC-DRG AND
237800         D-DRG-POSTACUTE-50-50) AND
237900         H-ALOS > 0
238000         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
238100         COMPUTE H-DSCHG-FRCTN  ROUNDED =
238200                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
238300         IF H-DSCHG-FRCTN > 1
238400              MOVE 1 TO H-DSCHG-FRCTN
238500              MOVE 1 TO H-TRANSFER-ADJ
238600         ELSE
238700              COMPUTE H-DRG-WT-FRCTN ROUNDED =
238800            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
238900
239000
239100***********************************************************
239200***  CAPITAL DSH CALCULATION
239300
239400     MOVE 0 TO H-CAPI-DSH.
239500
239600     IF P-NEW-BED-SIZE NOT NUMERIC
239700         MOVE 0 TO P-NEW-BED-SIZE.
239800
239900     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
240000         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
240100                  (.2025 * (P-NEW-SSI-RATIO
240200                          + P-NEW-MEDICAID-RATIO)) - 1.
240300
240400***********************************************************
240500***  CAPITAL IME TEACH CALCULATION
240600
240700     MOVE 0 TO H-WK-CAPI-IME-TEACH.
240800
240900     IF P-NEW-CAPI-IME NUMERIC
241000        IF P-NEW-CAPI-IME > 1.5000
241100           MOVE 1.5000 TO P-NEW-CAPI-IME.
241200
241300*****YEARCHANGE 2009.5 ****************************************
241400***
241500***  PER POLICY, WE REMOVED THE .5 MULTIPLER
241600***
241700***********************************************************
241800     IF P-NEW-CAPI-IME NUMERIC
241900        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
242000         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
242100
242200*****YEARCHANGE 2009.5 ****************************************
242300***********************************************************
242400     MOVE 0.00 TO H-DAYOUT-PCT.
242500     MOVE 0.80 TO H-CSTOUT-PCT.
242600
242700*****************************************************************
242800**
242900** BURN DRGS FOR FY14 ARE 927, 928, 929, 933, 934 AND 935.
243000**
243100*****************************************************************
243200
243300     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
243400             MOVE 0.90 TO H-CSTOUT-PCT.
243500
243600*****YEARCHANGE 2015.0 ****************************************
243700***     NATIONAL PERCENTAGE
243800     MOVE 0.6960   TO H-LABOR-PCT.
243900     MOVE 0.3040   TO H-NONLABOR-PCT.
244000
244100*****YEARCHANGE 2015.0 ****************************************
244200***     PUERTO RICO PERCENTAGE
244300     MOVE 0.6320   TO H-PR-LABOR-PCT.
244400     MOVE 0.3680   TO H-PR-NONLABOR-PCT.
244500*****YEARCHANGE 2015.0 ****************************************
244600
244700     IF (H-WAGE-INDEX < 01.0000 OR
244800         H-WAGE-INDEX = 01.0000)
244900        MOVE 0.6200 TO H-LABOR-PCT
245000        MOVE 0.3800 TO H-NONLABOR-PCT.
245100***
245200     IF P-NEW-STATE = 40
245300       IF (H-PR-WAGE-INDEX < 01.0000 OR
245400           H-PR-WAGE-INDEX = 01.0000)
245500          MOVE 0.6200 TO H-PR-LABOR-PCT
245600          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
245700
245800
245900     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
246000             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
246100     ELSE
246200             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
246300
246400     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
246500             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
246600     ELSE
246700             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
246800
246900***********************************************************
247000*****YEARCHANGE 2010.0 ************************************
247100***  CAPITAL PAYMENT METHOD B - YEARCHNG
247200***  CAPITAL PAYMENT METHOD B
247300
247400     IF W-CBSA-SIZE = 'L'
247500        MOVE 1.00 TO H-CAPI-LARG-URBAN
247600     ELSE
247700        MOVE 1.00 TO H-CAPI-LARG-URBAN.
247800
247900     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
248000     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
248100
248200*****YEARCHANGE 2016.0 ************************************
248300     COMPUTE H-FEDERAL-RATE ROUNDED =
248400                                 (0438.75 * H-CAPI-GAF).
248500     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
248600                                 (0212.55 * H-PR-CAPI-GAF).
248700*****YEARCHANGE 2015.1 ************************************
248800
248900     COMPUTE H-CAPI-COLA ROUNDED =
249000                     (.3152 * (H-OPER-COLA - 1) + 1).
249100
249200     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
249300
249400     IF P-NEW-STATE = 40
249500        COMPUTE  H-CAPI-FED-RATE ROUNDED =
249600                 (H-NAT-PCT * H-FEDERAL-RATE) +
249700                 (H-REG-PCT * H-PUERTO-RICO-RATE).
249800***********************************************************
249900***  CAPITAL FSP CALCULATION
250000***  CAPITAL FSP CALCULATION
250100
250200     COMPUTE H-CAPI-FSP-PART ROUNDED =
250300                               H-DRG-WT       *
250400                               H-CAPI-FED-RATE *
250500                               H-CAPI-COLA *
250600                               H-CAPI-LARG-URBAN.
250700
250800***********************************************************
250900***  CAPITAL PAYMENT METHOD A
251000***  CAPITAL PAYMENT METHOD A
251100
251200     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
251300        MOVE 1.00 TO H-CAPI-SCH
251400     ELSE
251500        MOVE 0.85 TO H-CAPI-SCH.
251600
251700***********************************************************
251800***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
251900***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
252000
252100     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
252200                    (P-NEW-CAPI-OLD-HARM-RATE *
252300                    H-CAPI-SCH).
252400
252500***********************************************************
252600        IF PAY-PERDIEM-DAYS
252700            IF  H-PERDIEM-DAYS < H-ALOS
252800                IF  NOT (B-DRG = 789)
252900                    PERFORM 3500-CALC-PERDIEM-AMT
253000                    MOVE 03 TO PPS-RTC.
253100
253200        IF PAY-XFER-SPEC-DRG
253300            IF  H-PERDIEM-DAYS < H-ALOS
253400                IF  NOT (B-DRG = 789)
253500                    PERFORM 3550-CALC-PERDIEM-AMT.
253600
253700        IF  PAY-XFER-NO-COST
253800            MOVE 00 TO PPS-RTC
253900            IF H-PERDIEM-DAYS < H-ALOS
254000               IF  NOT (B-DRG = 789)
254100                   PERFORM 3500-CALC-PERDIEM-AMT
254200                   MOVE 06 TO PPS-RTC.
254300
254400     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
254500
254600     PERFORM 6000-CALC-READMIS-REDU THRU 6000-EXIT.
254700
254800     IF PPS-RTC = 65 OR 67 OR 68
254900               GO TO 3000-CONTINUE.
255000
255100     PERFORM 7000-CALC-VALUE-BASED-PURCH THRU 7000-EXIT.
255200
255300     IF PPS-RTC = 65 OR 67 OR 68
255400               GO TO 3000-CONTINUE.
255500
255600     PERFORM 8000-CALC-BUNDLE-REDU  THRU 8000-EXIT.
255700
255800     IF PPS-RTC = 65 OR 67 OR 68
255900               GO TO 3000-CONTINUE.
256000
256100     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
256200
256300     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
256400
256500     IF PPS-RTC = 65 OR 67 OR 68
256600               GO TO 3000-CONTINUE.
256700
256800        IF PAY-XFER-SPEC-DRG
256900            IF  H-PERDIEM-DAYS < H-ALOS
257000                IF  NOT (B-DRG = 789)
257100                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
257200
257300
257400        IF  PAY-PERDIEM-DAYS
257500            IF  H-OPER-OUTCST-PART > 0
257600                MOVE H-OPER-OUTCST-PART TO
257700                     H-OPER-OUTLIER-PART
257800                MOVE 05 TO PPS-RTC
257900            ELSE
258000            IF  PPS-RTC NOT = 03
258100                MOVE 00 TO PPS-RTC
258200                MOVE 0  TO H-OPER-OUTLIER-PART.
258300
258400        IF  PAY-PERDIEM-DAYS
258500            IF  H-CAPI-OUTCST-PART > 0
258600                MOVE H-CAPI-OUTCST-PART TO
258700                     H-CAPI-OUTLIER-PART
258800                MOVE 05 TO PPS-RTC
258900            ELSE
259000            IF  PPS-RTC NOT = 03
259100                MOVE 0  TO H-CAPI-OUTLIER-PART.
259200
259300
259400     IF P-N-SCH-REBASED-FY90 OR
259500        P-N-EACH OR
259600        P-N-MDH-REBASED-FY90
259700         PERFORM 3450-CALC-ADDITIONAL-HSP.
259800
259900
260000 3000-CONTINUE.
260100
260200***********************************************************
260300***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
260400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
260500
260600     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
260700
260800***********************************************************
260900
261000     IF  PPS-RTC = 67
261100         MOVE H-OPER-DOLLAR-THRESHOLD TO
261200              WK-H-OPER-DOLLAR-THRESHOLD.
261300
261400     IF  PPS-RTC < 50
261500         PERFORM 3800-CALC-TOT-AMT THRU 3800-EXIT.
261600
261700     IF  PPS-RTC < 50
261800         NEXT SENTENCE
261900     ELSE
262000         MOVE ALL '0' TO PPS-OPER-HSP-PART
262100                         PPS-OPER-FSP-PART
262200                         PPS-OPER-OUTLIER-PART
262300                         PPS-OUTLIER-DAYS
262400                         PPS-REG-DAYS-USED
262500                         PPS-LTR-DAYS-USED
262600                         PPS-TOTAL-PAYMENT
262700                         WK-HAC-TOTAL-PAYMENT
262800                         PPS-OPER-DSH-ADJ
262900                         PPS-OPER-IME-ADJ
263000                         H-DSCHG-FRCTN
263100                         H-DRG-WT-FRCTN
263200                         HOLD-ADDITIONAL-VARIABLES
263300                         HOLD-CAPITAL-VARIABLES
263400                         HOLD-CAPITAL2-VARIABLES
263500                         HOLD-OTHER-VARIABLES
263600                         HOLD-PC-OTH-VARIABLES
263700                        H-ADDITIONAL-PAY-INFO-DATA
263800                        H-ADDITIONAL-PAY-INFO-DATA2.
263900
264000     IF  PPS-RTC = 67
264100         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
264200                 H-OPER-DOLLAR-THRESHOLD.
264300
264400 3000-EXIT.  EXIT.
264500
264600 3100-CALC-STAY-UTILIZATION.
264700
264800     MOVE 0 TO PPS-REG-DAYS-USED.
264900     MOVE 0 TO PPS-LTR-DAYS-USED.
265000
265100     IF H-REG-DAYS > 0
265200        IF H-REG-DAYS > B-LOS
265300           MOVE B-LOS TO PPS-REG-DAYS-USED
265400        ELSE
265500           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
265600     ELSE
265700        IF H-LTR-DAYS > B-LOS
265800           MOVE B-LOS TO PPS-LTR-DAYS-USED
265900        ELSE
266000           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
266100
266200
266300
266400 3300-CALC-OPER-FSP-AMT.
266500***********************************************************
266600***  OPERATING FSP CALCULATION
266700***  OPERATING FSP CALCULATION
266800
266900     COMPUTE H-OPER-FSP-PART ROUNDED =
267000           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
267100            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
267200                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
267300
267400     IF P-NEW-STATE = 40
267500       COMPUTE H-OPER-FSP-PART ROUNDED =
267600           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
267700            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
267800                           +
267900           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
268000            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
268100                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
268200
268300
268400 3500-CALC-PERDIEM-AMT.
268500***********************************************************
268600***  REVIEW CODE = 03 OR 06
268700***  OPERATING PERDIEM-AMT CALCULATION
268800***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
268900
269000        COMPUTE H-OPER-FSP-PART ROUNDED =
269100        H-OPER-FSP-PART * H-TRANSFER-ADJ
269200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
269300
269400***********************************************************
269500***********************************************************
269600***  REVIEW CODE = 03 OR 06
269700***  CAPITAL   PERDIEM-AMT CALCULATION
269800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
269900
270000        COMPUTE H-CAPI-FSP-PART ROUNDED =
270100        H-CAPI-FSP-PART * H-TRANSFER-ADJ
270200        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
270300
270400***********************************************************
270500***  REVIEW CODE = 03 OR 06
270600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
270700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
270800
270900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
271000        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
271100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
271200
271300 3550-CALC-PERDIEM-AMT.
271400***********************************************************
271500***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
271600***  OPERATING PERDIEM-AMT CALCULATION
271700***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
271800
271900     IF (D-DRG-POSTACUTE-50-50)
272000        MOVE 10 TO PPS-RTC
272100        COMPUTE H-OPER-FSP-PART ROUNDED =
272200        H-OPER-FSP-PART * H-DSCHG-FRCTN
272300        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
272400
272500     IF (D-DRG-POSTACUTE-PERDIEM)
272600        MOVE 12 TO PPS-RTC
272700        COMPUTE H-OPER-FSP-PART ROUNDED =
272800        H-OPER-FSP-PART *  H-TRANSFER-ADJ
272900        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
273000
273100***********************************************************
273200***  CAPITAL PERDIEM-AMT CALCULATION
273300***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
273400
273500     IF (D-DRG-POSTACUTE-50-50)
273600        MOVE 10 TO PPS-RTC
273700        COMPUTE H-CAPI-FSP-PART ROUNDED =
273800        H-CAPI-FSP-PART * H-DSCHG-FRCTN
273900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
274000
274100     IF (D-DRG-POSTACUTE-PERDIEM)
274200        MOVE 12 TO PPS-RTC
274300        COMPUTE H-CAPI-FSP-PART ROUNDED =
274400        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
274500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
274600
274700***********************************************************
274800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
274900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
275000
275100     IF (D-DRG-POSTACUTE-50-50)
275200        MOVE 10 TO PPS-RTC
275300        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
275400        H-CAPI-OLD-HARMLESS * H-DSCHG-FRCTN
275500        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
275600
275700     IF (D-DRG-POSTACUTE-PERDIEM)
275800        MOVE 12 TO PPS-RTC
275900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
276000        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
276100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
276200
276300 3560-CHECK-RTN-CODE.
276400
276500     IF (D-DRG-POSTACUTE-50-50)
276600        MOVE 10 TO PPS-RTC.
276700     IF (D-DRG-POSTACUTE-PERDIEM)
276800        MOVE 12 TO PPS-RTC.
276900
277000 3560-EXIT.    EXIT.
277100
277200***********************************************************
277300 3600-CALC-OUTLIER.
277400***********************************************************
277500*---------------------------------------------------------*
277600* (YEARCHANGE 2016.0)
277700* COST OUTLIER OPERATING AND CAPITAL CALCULATION
277800*---------------------------------------------------------*
277900
278000     IF OUTLIER-RECON-FLAG = 'Y'
278100        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
278200               (H-OPER-CSTCHG-RATIO + .2).
278300
278400     IF H-CAPI-CSTCHG-RATIO > 0 OR
278500        H-OPER-CSTCHG-RATIO > 0
278600        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
278700                H-OPER-CSTCHG-RATIO /
278800               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
278900        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
279000                H-CAPI-CSTCHG-RATIO /
279100               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
279200     ELSE
279300        MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
279400                  H-CAPI-SHARE-DOLL-THRESHOLD.
279500
279600*---------------------------------------------------------*
279700* (YEARCHANGE 2016.0)
279800* OUTLIER THRESHOLD AMOUNTS
279900*---------------------------------------------------------*
280000
280100     MOVE 22539.00 TO H-CST-THRESH.
280200
280300     IF (B-REVIEW-CODE = '03') AND
280400         H-PERDIEM-DAYS < H-ALOS
280500        COMPUTE H-CST-THRESH ROUNDED =
280600                      (H-CST-THRESH * H-TRANSFER-ADJ)
280700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
280800
280900     IF ((B-REVIEW-CODE = '09') AND
281000         (H-PERDIEM-DAYS < H-ALOS))
281100         IF (D-DRG-POSTACUTE-PERDIEM)
281200            COMPUTE H-CST-THRESH ROUNDED =
281300                      (H-CST-THRESH * H-TRANSFER-ADJ)
281400                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
281500
281600     IF ((B-REVIEW-CODE = '09') AND
281700         (H-PERDIEM-DAYS < H-ALOS))
281800         IF (D-DRG-POSTACUTE-50-50)
281900           COMPUTE H-CST-THRESH ROUNDED =
282000          H-CST-THRESH * H-DSCHG-FRCTN
282100                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
282200
282300     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
282400        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
282500         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
282600          H-OPER-SHARE-DOLL-THRESHOLD.
282700
282800     IF P-NEW-STATE = 40
282900        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
283000           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
283100            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
283200             H-OPER-SHARE-DOLL-THRESHOLD
283300        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
283400               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
283500               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
283600
283700***********************************************************
283800
283900     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
284000          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
284100          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
284200
284300
284400     IF P-NEW-STATE = 40
284500        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
284600           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
284700           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
284800        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
284900               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
285000               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
285100
285200***********************************************************
285300******NOW INCLUDES UNCOMPENSATED CARE**********************
285400
285500     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
285600         ((H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH))
285700                       +
285800           ((H-OPER-FSP-PART * H-OPER-DSH) * .25))
285900                       +
286000             H-OPER-DOLLAR-THRESHOLD
286100                       +
286200                WK-UNCOMP-CARE-AMOUNT
286300                       +
286400                 H-NEW-TECH-PAY-ADD-ON.
286500
286600     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
286700      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
286800                       +
286900             H-CAPI-DOLLAR-THRESHOLD.
287000
287100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
287200         MOVE 0 TO H-CAPI-COST-OUTLIER.
287300
287400
287500***********************************************************
287600***  OPERATING COST CALCULATION
287700
287800     COMPUTE H-OPER-BILL-COSTS ROUNDED =
287900         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
288000         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
288100
288200
288300     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
288400         COMPUTE H-OPER-OUTCST-PART ROUNDED =
288500         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
288600                         H-OPER-COST-OUTLIER).
288700
288800     IF PAY-WITHOUT-COST OR
288900        PAY-XFER-NO-COST OR
289000        PAY-XFER-SPEC-DRG-NO-COST
289100         MOVE 0 TO H-OPER-OUTCST-PART.
289200
289300***********************************************************
289400***  CAPITAL COST CALCULATION
289500
289600     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
289700             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
289800         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
289900
290000     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
290100         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
290200         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
290300                         H-CAPI-COST-OUTLIER).
290400
290500***********************************************************
290600***  'A' NOT VALID FY 2015 ON
290700
290800*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
290900*      COMPUTE H-CAPI-OUTCST-PART ROUNDED =
291000*             (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
291100
291200     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
291300        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
291400               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
291500
291600     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
291700        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
291800        MOVE 0 TO H-CAPI-OUTCST-PART
291900                  H-OPER-OUTCST-PART.
292000
292100     IF PAY-WITHOUT-COST OR
292200        PAY-XFER-NO-COST OR
292300        PAY-XFER-SPEC-DRG-NO-COST
292400         MOVE 0 TO H-CAPI-OUTCST-PART.
292500
292600***********************************************************
292700***  DETERMINES THE BILL TO BE COST  OUTLIER
292800
292900     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
293000         MOVE 0 TO H-CAPI-OUTDAY-PART
293100                   H-CAPI-OUTCST-PART.
293200
293300     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
293400                 MOVE H-OPER-OUTCST-PART TO
293500                      H-OPER-OUTLIER-PART
293600                 MOVE H-CAPI-OUTCST-PART TO
293700                      H-CAPI-OUTLIER-PART
293800                 MOVE 02 TO PPS-RTC.
293900
294000     IF OUTLIER-RECON-FLAG = 'Y'
294100        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
294200           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
294300           GO TO 3600-EXIT
294400        ELSE
294500           GO TO 3600-EXIT
294600     ELSE
294700        NEXT SENTENCE.
294800
294900
295000***********************************************************
295100***  DETERMINES IF COST OUTLIER
295200***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
295300***         RETURN CODE OF 02
295400
295500     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
295600
295700     IF PPS-RTC = 02
295800       IF H-CAPI-CSTCHG-RATIO > 0 OR
295900          H-OPER-CSTCHG-RATIO > 0
296000             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
296100                     (H-CAPI-COST-OUTLIER  +
296200                      H-OPER-COST-OUTLIER)
296300                             /
296400                    (H-CAPI-CSTCHG-RATIO  +
296500                     H-OPER-CSTCHG-RATIO)
296600             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD
296700       ELSE MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
296800
296900***********************************************************
297000***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
297100***         RETURN CODE OF 67
297200
297300     IF PPS-RTC = 02
297400         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
297500            PPS-PC-COT-FLAG = 'Y'
297600             MOVE 67 TO PPS-RTC.
297700***********************************************************
297800
297900***********************************************************
298000***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
298100***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
298200***********************************************************
298300*
298400***********************************************************
298500***  'A' NOT VALID FY 2015 ON
298600*
298700*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
298800*       COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
298900*               H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
299000*        ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
299100
299200     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
299300        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
299400                H-CAPI-OUTLIER-PART.
299500
299600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C' AND
299700        H-CAPI-PAYCDE-PCT1 > 0
299800        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
299900                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
300000         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART
300100     ELSE MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
300200
300300 3600-EXIT.   EXIT.
300400
300500***********************************************************
300600 3450-CALC-ADDITIONAL-HSP.
300700***********************************************************
300800*---------------------------------------------------------*
300900* (YEARCHANGE 2016.0)
301000* OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR SOLE COMMUNITY
301100* AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
301200* NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
301300*---------------------------------------------------------*
301400***  GET THE RBN UPDATING FACTOR
301500
301600*****YEARCHANGE 2013.0 ****************************************
301700     MOVE 0.998431 TO H-BUDG-NUTR130.
301800
301900*****YEARCHANGE 2014.0 ****************************************
302000     MOVE 0.997989 TO H-BUDG-NUTR140.
302100
302200*****YEARCHANGE 2015.1 ****************************************
302300     MOVE 0.998761 TO H-BUDG-NUTR150.
302400
302500*****YEARCHANGE 2016.0 ****************************************
302600     MOVE 0.998405 TO H-BUDG-NUTR160.
302700
302800
302900***  GET THE MARKET BASKET UPDATE FACTOR
303000*****YEARCHANGE 2013.0 ****************************************
303100        MOVE 1.0180 TO H-UPDATE-130.
303200
303300*****YEARCHANGE 2014.0 ****************************************
303400        MOVE 1.0170 TO H-UPDATE-140.
303500
303600*****YEARCHANGE 2015.0 ****************************************
303700        MOVE 1.02200 TO H-UPDATE-150.
303800
303900*****YEARCHANGE 2016.0 ****************************************
304000        MOVE 1.01700 TO H-UPDATE-160.
304100
304200
304300*** APPLY APPROPRIATE MARKET BASKET UPDATE FACTOR PER PSF FLAGS
304400*****YEARCHANGE 2016.0 ****************************************
304500     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
304600        P-EHR-REDUC-IND = ' '
304700        MOVE 1.01700 TO H-UPDATE-160.
304800
304900*****YEARCHANGE 2016.0 ****************************************
305000     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
305100        P-EHR-REDUC-IND = 'Y'
305200        MOVE 1.00500 TO H-UPDATE-160.
305300
305400*****YEARCHANGE 2016.0 ****************************************
305500     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
305600        P-EHR-REDUC-IND = ' '
305700        MOVE 1.01100 TO H-UPDATE-160.
305800
305900*****YEARCHANGE 2016.0 ****************************************
306000     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
306100        P-EHR-REDUC-IND = 'Y'
306200        MOVE 0.99900 TO H-UPDATE-160.
306300
306400
306500*****YEARCHANGE 2016.0 ****************************************
306600     IF P-NEW-STATE = 40
306700        MOVE 1.0170 TO H-UPDATE-160.
306800
306900
307000********YEARCHANGE 2016.0 *************************************
307100*** CASE MIX ADJUSTMENT AS OF FY 2015
307200*** SHORT STAY ADJUSTMENT AS OF FY 2014
307300     MOVE 0.9480 TO H-CASE-MIX-ADJ.
307400     MOVE 0.9980 TO H-SHORT-STAY-ADJ.
307500
307600     COMPUTE H-UPDATE-FACTOR ROUNDED =
307700                       (H-UPDATE-130 *
307800                        H-UPDATE-140 *
307900                        H-UPDATE-150 *
308000                        H-UPDATE-160 *
308100                        H-BUDG-NUTR130 *
308200                        H-BUDG-NUTR140 *
308300                        H-BUDG-NUTR150 *
308400                        H-BUDG-NUTR160 *
308500                        H-CASE-MIX-ADJ * H-SHORT-STAY-ADJ).
308600
308700     COMPUTE H-HSP-RATE ROUNDED =
308800         H-FAC-SPEC-RATE * H-UPDATE-FACTOR * H-DRG-WT.
308900***************************************************************
309000*
309100*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
309200*       COMPUTE H-HSP-RATE ROUNDED =
309300*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
309400*    ELSE
309500*       COMPUTE H-HSP-RATE ROUNDED =
309600*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
309700*
309800***************************************************************
309900********YEARCHANGE 2011.0 *************************************
310000***     OUTLIER OFFSETS NO LONGER USED IN HSP COMPARISON
310100***     WE NOW USE THE ACTUAL OPERATING OUTLIER PAYMEMT
310200***     IN THE HSP COMPARRISON
310300
310400********YEARCHANGE 2014.0 *XXXXXX******************************
310500*      THE HSP BUCKET FOR SCH                      ************
310600*      ADDED UNCOMPENSATED CARE TO COMPARRISON FOR 2014 *******
310700***************************************************************
310800     COMPUTE H-FSP-RATE ROUNDED =
310900        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
311000         H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
311100                           *
311200             (1 + H-OPER-IME-TEACH + (H-OPER-DSH * .25))
311300                               +
311400                         H-OPER-OUTLIER-PART
311500                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
311600
311700     IF P-NEW-STATE = 40
311800       COMPUTE H-FSP-RATE ROUNDED =
311900         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
312000         H-NAT-NONLABOR * H-OPER-COLA))  * H-DRG-WT-FRCTN)
312100                           *
312200         (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
312300                            H-OPER-OUTLIER-PART
312400                               +
312500        ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
312600         H-REG-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
312700                           *
312800             (1 + H-OPER-IME-TEACH +(H-OPER-DSH * .25))
312900                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
313000
313100****************************************************************
313200****         INCLUDE UNCOMPENSATED CARE PER CLAIM IN HSP
313300*****        CHOICE
313400
313500
313600     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
313700           COMPUTE H-OPER-HSP-PART ROUNDED =
313800             (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT))
313900                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
314000     ELSE
314100         MOVE 0 TO H-OPER-HSP-PART.
314200
314300***************************************************************
314400***  YEARCHANGE TURNING MDH BACK ON ***************************
314500***************************************************************
314600***         GET THE MDH REBASE
314700
314800
314900     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
315000         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
315100           COMPUTE H-OPER-HSP-PART ROUNDED =
315200         (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)) * .75
315300                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
315400
315500***********************************************************
315600 3800-CALC-TOT-AMT.
315700***********************************************************
315800***  CALCULATE TOTALS FOR CAPITAL
315900
316000     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
316100
316200***********************************************************
316300***  'A' NOT VALID FY 2015 ON
316400*
316500*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
316600*       MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
316700*       MOVE 0.00 TO H-CAPI-HSP-PCT.
316800
316900     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
317000        MOVE 0    TO H-CAPI-OLD-HARMLESS
317100        MOVE 1.00 TO H-CAPI-FSP-PCT
317200        MOVE 0.00 TO H-CAPI-HSP-PCT.
317300
317400     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
317500        MOVE 0    TO H-CAPI-OLD-HARMLESS
317600        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
317700        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
317800
317900     COMPUTE H-CAPI-HSP ROUNDED =
318000         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
318100
318200     COMPUTE H-CAPI-FSP ROUNDED =
318300         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
318400
318500     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
318600
318700     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
318800
318900     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
319000             H-CAPI-FSP
319100              * H-CAPI-DSH.
319200
319300     COMPUTE H-CAPI-IME-ADJ ROUNDED =
319400          H-CAPI-FSP *
319500                 H-WK-CAPI-IME-TEACH.
319600
319700     COMPUTE H-CAPI-OUTLIER ROUNDED =
319800             1.00 * H-CAPI-OUTLIER-PART.
319900
320000     COMPUTE H-CAPI2-B-FSP ROUNDED =
320100             1.00 * H-CAPI2-B-FSP-PART.
320200
320300     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
320400             1.00 * H-CAPI2-B-OUTLIER-PART.
320500***********************************************************
320600***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
320700***        THIS ZEROES OUT ALL CAPITAL DATA
320800
320900     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
321000        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
321100***********************************************************
321200
321300***********************************************************
321400***  CALCULATE FINAL TOTALS FOR OPERATING
321500
321600     IF (H-CAPI-OUTLIER > 0 AND
321700         PPS-OPER-OUTLIER-PART = 0)
321800            COMPUTE PPS-OPER-OUTLIER-PART =
321900                    PPS-OPER-OUTLIER-PART + .01.
322000
322100***********************************************************
322200*LOW VOLUME CALCULATIONS
322300***********************************************************
322400*---------------------------------------------------------*
322500* (YEARCHANGE 2016.0)
322600* LOW VOLUME PAYMENT ADD-ON PERCENT
322700*---------------------------------------------------------*
322800
322900     MOVE 01.000 TO WK-LOW-VOL25PCT.
323000
323100     IF P-NEW-TEMP-RELIEF-IND = 'Y'
323200     MOVE P-NEW-PROVIDER-NO      TO MES-PPS-PROV
323300     PERFORM 4400-LOWVOL-CODE-RTN THRU 4400-EXIT.
323400
323500     IF P-NEW-TEMP-RELIEF-IND = 'Y'
323600     AND MESWK-LOWVOL-PROV-DISCHG < 200
323700            MOVE 00.250 TO WK-LOW-VOL25PCT
323800            GO TO LOW-VOL-CALC.
323900
324000***  CALCULATE THE LOW VOLUME DISCHARGE PERCENT
324100***  SLIDING SCALE ADD ON FOR
324200
324300     IF P-NEW-TEMP-RELIEF-IND = 'Y'
324400        AND MESWK-LOWVOL-PROV-DISCHG > 200
324500        AND MESWK-LOWVOL-PROV-DISCHG < 1600
324600            COMPUTE  WK-LOW-VOL25PCT ROUNDED =
324700            ((4 / 14) - (MESWK-LOWVOL-PROV-DISCHG / 5600))
324800            GO TO LOW-VOL-CALC
324900     ELSE
325000           MOVE 01.000 TO WK-LOW-VOL25PCT.
325100
325200 LOW-VOL-CALC.
325300
325400     MOVE ZERO TO PPS-OPER-DSH-ADJ.
325500************************************************
325600* FOR FY 2014 WE APPLY AN ADJUSTMENT OF 0.25 TO CALCULATE
325700* EMPERICAL DSH
325800************************************************
325900     IF  H-OPER-DSH NUMERIC
326000         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
326100                     (PPS-OPER-FSP-PART  * H-OPER-DSH) * .25.
326200
326300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
326400                         PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
326500
326600
326700     COMPUTE PPS-OPER-FSP-PART ROUNDED =
326800                           H-OPER-FSP-PART * H-OPER-FSP-PCT.
326900
327000     COMPUTE PPS-OPER-HSP-PART ROUNDED =
327100                           H-OPER-HSP-PART * H-OPER-HSP-PCT.
327200
327300     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
327400                         H-OPER-OUTLIER-PART * H-OPER-FSP-PCT.
327500
327600     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
327700                                H-NEW-TECH-PAY-ADD-ON.
327800
327900     IF  WK-LOW-VOL25PCT < 1.000000
328000     COMPUTE WK-LOW-VOL-ADDON  ROUNDED =
328100       (PPS-OPER-HSP-PART +
328200        PPS-OPER-FSP-PART +
328300        PPS-OPER-IME-ADJ +
328400        PPS-OPER-DSH-ADJ +
328500        PPS-OPER-OUTLIER-PART +
328600        H-CAPI-FSP +
328700        H-CAPI-IME-ADJ +
328800        H-CAPI-DSH-ADJ +
328900        H-CAPI-OUTLIER +
329000        WK-UNCOMP-CARE-AMOUNT +
329100        PPS-NEW-TECH-PAY-ADD-ON) * WK-LOW-VOL25PCT
329200     ELSE
329300     COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0.
329400
329500 LOW-VOL-END.
329600
329700     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
329800
329900     IF HMO-TAG  = 'Y'
330000        PERFORM 3850-HMO-IME-ADJ.
330100
330200***********************************************************
330300***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
330400
330500     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
330600             H-CAPI-FSP + H-CAPI-IME-ADJ +
330700             H-CAPI-DSH-ADJ + H-CAPI-OUTLIER.
330800
330900         PERFORM 9000-CALC-EHR-SAVING   THRU 9000-EXIT.
331000         PERFORM 9010-CALC-STANDARD-CHG THRU 9010-EXIT.
331100
331200***********************************************************
331300* HOSPITAL ACQUIRED CONDITION (HAC) PENALTY & REDUCTION FACTOR
331400***********************************************************
331500*---------------------------------------------------------*
331600* (YEARCHANGE 2016.0)
331700* HOSPITAL ACQUIRED CONDITION (HAC) REDUCTION FACTOR
331800*   + FOR FY 2015 AN ADJUSTMENT OF 0.01 TO CALCULATE
331900*     HOSPITAL ACQUIRED CONDITION (HAC) PENALTY
332000*   + BASED ON INDICATOR FROM THE PPS FILE
332100*   + NOT VALID IN PUERTO RICO
332200*   + TOTAL PAYMENT NOW INCLUDES UNCOMPENSATED CARE AMOUNT
332300*---------------------------------------------------------*
332400
332500     COMPUTE WK-HAC-TOTAL-PAYMENT ROUNDED =
332600        PPS-OPER-HSP-PART +
332700        PPS-OPER-FSP-PART +
332800        PPS-OPER-IME-ADJ +
332900        PPS-OPER-DSH-ADJ +
333000        PPS-OPER-OUTLIER-PART +
333100        H-CAPI-TOTAL-PAY +
333200        WK-UNCOMP-CARE-AMOUNT +
333300        PPS-NEW-TECH-PAY-ADD-ON +
333400        WK-LOW-VOL-ADDON +
333500        H-READMIS-ADJUST-AMT +
333600        H-VAL-BASED-PURCH-ADJUST-AMT.
333700
333800     MOVE ZERO TO WK-HAC-AMOUNT.
333900
334000     IF P-NEW-STATE = 40  AND
334100        P-HAC-REDUC-IND = 'Y'
334200           MOVE 53 TO PPS-RTC
334300           GO TO 3800-EXIT.
334400
334500     IF  P-HAC-REDUC-IND = 'Y'
334600         COMPUTE   WK-HAC-AMOUNT     ROUNDED =
334700                   WK-HAC-TOTAL-PAYMENT * -0.01
334800     ELSE
334900         COMPUTE   WK-HAC-AMOUNT     ROUNDED = 0.
335000
335100***********************************************************
335200***  TOTAL PAYMENT NOW INCLUDES HAC PENALTY AMOUNT
335300************************************************
335400     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
335500                 WK-HAC-TOTAL-PAYMENT
335600                           +
335700                 H-WK-PASS-AMT-PLUS-MISC
335800                           +
335900                 H-BUNDLE-ADJUST-AMT
336000                           +
336100                 WK-HAC-AMOUNT.
336200
336300     MOVE     P-VAL-BASED-PURCH-PARTIPNT TO
336400              H-VAL-BASED-PURCH-PARTIPNT.
336500
336600     MOVE     P-VAL-BASED-PURCH-ADJUST   TO
336700              H-VAL-BASED-PURCH-ADJUST.
336800
336900     MOVE     P-HOSP-READMISSION-REDU    TO
337000              H-HOSP-READMISSION-REDU.
337100
337200     MOVE     P-HOSP-HRR-ADJUSTMT        TO
337300              H-HOSP-HRR-ADJUSTMT.
337400
337500 3800-EXIT.   EXIT.
337600
337700 3850-HMO-IME-ADJ.
337800***********************************************************
337900***  HMO CALC FOR PASS-THRU ADDON
338000
338100     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
338200          (P-NEW-PASS-AMT-PLUS-MISC -
338300          (P-NEW-PASS-AMT-ORGAN-ACQ +
338400           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
338500
338600***********************************************************
338700***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
338800
338900     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
339000                   PPS-OPER-IME-ADJ * .0.
339100
339200***********************************************************
339300
339400
339500 3900A-CALC-OPER-DSH.
339600
339700***  OPERATING DSH CALCULATION
339800
339900      MOVE 0.0000 TO H-OPER-DSH.
340000
340100      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
340200                                     + P-NEW-MEDICAID-RATIO).
340300
340400***********************************************************
340500**1**    0-99 BEDS
340600***  NOT TO EXCEED 12%
340700
340800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
340900                               AND H-WK-OPER-DSH > .1499
341000                               AND H-WK-OPER-DSH < .2020
341100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
341200                                      * .65 + .025
341300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
341400
341500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
341600                               AND H-WK-OPER-DSH > .2019
341700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
341800                                      * .825 + .0588
341900        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
342000
342100***********************************************************
342200**2**   100 + BEDS
342300***  NO CAP >> CAN EXCEED 12%
342400
342500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
342600                               AND H-WK-OPER-DSH > .1499
342700                               AND H-WK-OPER-DSH < .2020
342800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
342900                                      * .65 + .025.
343000
343100      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
343200                               AND H-WK-OPER-DSH > .2019
343300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
343400                                      * .825 + .0588.
343500
343600***********************************************************
343700**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
343800***  NOT TO EXCEED 12%
343900
344000      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
344100                               AND H-WK-OPER-DSH > .1499
344200                               AND H-WK-OPER-DSH < .2020
344300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
344400                                 * .65 + .025
344500        IF H-OPER-DSH > .1200
344600              MOVE .1200 TO H-OPER-DSH.
344700
344800      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
344900                               AND H-WK-OPER-DSH > .2019
345000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
345100                                 * .825 + .0588
345200        IF H-OPER-DSH > .1200
345300                 MOVE .1200 TO H-OPER-DSH.
345400***********************************************************
345500**4**   OTHER RURAL HOSPITALS 500 BEDS +
345600***  NO CAP >> CAN EXCEED 12%
345700
345800      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
345900                               AND H-WK-OPER-DSH > .1499
346000                               AND H-WK-OPER-DSH < .2020
346100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
346200                                 * .65 + .025.
346300
346400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
346500                               AND H-WK-OPER-DSH > .2019
346600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
346700                                 * .825 + .0588.
346800
346900***********************************************************
347000**7**   RURAL HOSPITALS SCH
347100***  NOT TO EXCEED 12%
347200
347300      IF W-CBSA-SIZE = 'R'
347400         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
347500                               AND H-WK-OPER-DSH > .1499
347600                               AND H-WK-OPER-DSH < .2020
347700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
347800                                 * .65 + .025
347900        IF H-OPER-DSH > .1200
348000                 MOVE .1200 TO H-OPER-DSH.
348100
348200      IF W-CBSA-SIZE = 'R'
348300         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
348400                               AND H-WK-OPER-DSH > .2019
348500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
348600                                 * .825 + .0588
348700        IF H-OPER-DSH > .1200
348800                 MOVE .1200 TO H-OPER-DSH.
348900
349000***********************************************************
349100**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
349200***  RRC OVERRIDES SCH CAP
349300***  NO CAP >> CAN EXCEED 12%
349400
349500         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
349600                                   '17' OR '22')
349700                               AND H-WK-OPER-DSH > .1499
349800                               AND H-WK-OPER-DSH < .2020
349900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
350000                                 * .65 + .025.
350100
350200         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
350300                                   '17' OR '22')
350400                               AND H-WK-OPER-DSH > .2019
350500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
350600                                 * .825 + .0588.
350700
350800      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
350900
351000 3900A-EXIT.   EXIT.
351100
351200 4000-CALC-TECH-ADDON.
351300
351400***********************************************************
351500***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
351600
351700     COMPUTE PPS-OPER-HSP-PART ROUNDED =
351800         H-OPER-HSP-PCT * H-OPER-HSP-PART.
351900
352000     COMPUTE PPS-OPER-FSP-PART ROUNDED =
352100         H-OPER-FSP-PCT * H-OPER-FSP-PART.
352200
352300     MOVE ZERO TO PPS-OPER-DSH-ADJ.
352400
352500     IF  H-OPER-DSH NUMERIC
352600             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
352700             (PPS-OPER-FSP-PART
352800              * H-OPER-DSH) * .25.
352900
353000     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
353100             PPS-OPER-FSP-PART *
353200             H-OPER-IME-TEACH.
353300
353400     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
353500             PPS-OPER-FSP-PART +
353600             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ +
353700             WK-UNCOMP-CARE-AMOUNT.
353800
353900***********************************************************
354000***********************************************************
354100* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
354200
354300*    PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
354400*
354500*    IF   B-DIAG-AUTOLITT-DIAG AND
354600*         B-DRG-AUTOLITT-DRG
354700*       PERFORM 4500-AUTOLIT-TECH-ADD-ON THRU 4500-EXIT.
354800
354900***********************************************************
355000*  DIFICID DISCONTINUED FOR FY 2015
355100*    IF   B-NDC-DIFICID-NDC
355200*      PERFORM 4600-DIFICID-TECH-ADD-ON THRU 4600-EXIT.
355300
355400*    IF   B-PROC-ZENITH-PRIN    OR
355500*         B-PROC-ZENITH-PROC1   OR
355600*         B-PROC-ZENITH-PROC2   OR
355700*         B-PROC-ZENITH-PROC3   OR
355800*         B-PROC-ZENITH-PROC4   OR
355900*         B-PROC-ZENITH-PROC5   OR
356000*         B-PROC-ZENITH-PROC6   OR
356100*         B-PROC-ZENITH-PROC7   OR
356200*         B-PROC-ZENITH-PROC8   OR
356300*         B-PROC-ZENITH-PROC9   OR
356400*         B-PROC-ZENITH-PROC10 OR
356500*         B-PROC-ZENITH-PROC11 OR
356600*         B-PROC-ZENITH-PROC12 OR
356700*         B-PROC-ZENITH-PROC13 OR
356800*         B-PROC-ZENITH-PROC14 OR
356900*         B-PROC-ZENITH-PROC15 OR
357000*         B-PROC-ZENITH-PROC16 OR
357100*         B-PROC-ZENITH-PROC17 OR
357200*         B-PROC-ZENITH-PROC18 OR
357300*         B-PROC-ZENITH-PROC19 OR
357400*         B-PROC-ZENITH-PROC20 OR
357500*         B-PROC-ZENITH-PROC21 OR
357600*         B-PROC-ZENITH-PROC22 OR
357700*         B-PROC-ZENITH-PROC23 OR
357800*         B-PROC-ZENITH-PROC24
357900*      PERFORM 4700-ZENITH-TECH-ADD-ON THRU 4700-EXIT
358000*    ELSE
358100*      MOVE ZEROES TO H-NEW-TECH-ADDON-ZENITH.
358200
358300*    IF   B-PROC-VORAXAZE-PRIN  OR
358400*         B-PROC-VORAXAZE-PROC1 OR
358500*         B-PROC-VORAXAZE-PROC2 OR
358600*         B-PROC-VORAXAZE-PROC3 OR
358700*         B-PROC-VORAXAZE-PROC4 OR
358800*         B-PROC-VORAXAZE-PROC5 OR
358900*         B-PROC-VORAXAZE-PROC6 OR
359000*         B-PROC-VORAXAZE-PROC7 OR
359100*         B-PROC-VORAXAZE-PROC8 OR
359200*         B-PROC-VORAXAZE-PROC9 OR
359300*         B-PROC-VORAXAZE-PROC10 OR
359400*         B-PROC-VORAXAZE-PROC11 OR
359500*         B-PROC-VORAXAZE-PROC12 OR
359600*         B-PROC-VORAXAZE-PROC13 OR
359700*         B-PROC-VORAXAZE-PROC14 OR
359800*         B-PROC-VORAXAZE-PROC15 OR
359900*         B-PROC-VORAXAZE-PROC16 OR
360000*         B-PROC-VORAXAZE-PROC17 OR
360100*         B-PROC-VORAXAZE-PROC18 OR
360200*         B-PROC-VORAXAZE-PROC19 OR
360300*         B-PROC-VORAXAZE-PROC20 OR
360400*         B-PROC-VORAXAZE-PROC21 OR
360500*         B-PROC-VORAXAZE-PROC22 OR
360600*         B-PROC-VORAXAZE-PROC23 OR
360700*         B-PROC-VORAXAZE-PROC24
360800*      PERFORM 4800-VORAXAZE-TECH-ADD-ON THRU 4800-EXIT
360900*    ELSE
361000*      MOVE ZEROES TO H-NEW-TECH-ADDON-VORAXAZE.
361100
361200     IF   B-PROC-ARGUS-PRIN     OR
361300          B-PROC-ARGUS-PROC1 OR
361400          B-PROC-ARGUS-PROC2 OR
361500          B-PROC-ARGUS-PROC3 OR
361600          B-PROC-ARGUS-PROC4 OR
361700          B-PROC-ARGUS-PROC5 OR
361800          B-PROC-ARGUS-PROC6 OR
361900          B-PROC-ARGUS-PROC7 OR
362000          B-PROC-ARGUS-PROC8 OR
362100          B-PROC-ARGUS-PROC9 OR
362200          B-PROC-ARGUS-PROC10 OR
362300          B-PROC-ARGUS-PROC11 OR
362400          B-PROC-ARGUS-PROC12 OR
362500          B-PROC-ARGUS-PROC13 OR
362600          B-PROC-ARGUS-PROC14 OR
362700          B-PROC-ARGUS-PROC15 OR
362800          B-PROC-ARGUS-PROC16 OR
362900          B-PROC-ARGUS-PROC17 OR
363000          B-PROC-ARGUS-PROC18 OR
363100          B-PROC-ARGUS-PROC19 OR
363200          B-PROC-ARGUS-PROC20 OR
363300          B-PROC-ARGUS-PROC21 OR
363400          B-PROC-ARGUS-PROC22 OR
363500          B-PROC-ARGUS-PROC23 OR
363600          B-PROC-ARGUS-PROC24
363700       PERFORM 4810-ARGUS-TECH-ADD-ON THRU 4810-EXIT
363800     ELSE
363900       MOVE ZEROES TO H-NEW-TECH-ADDON-ARGUS.
364000
364100     IF   B-DIAG-KCENTRA-DIAG1  OR
364200          B-DIAG-KCENTRA-DIAG2  OR
364300          B-DIAG-KCENTRA-DIAG3  OR
364400          B-DIAG-KCENTRA-DIAG4  OR
364500          B-DIAG-KCENTRA-DIAG5  OR
364600          B-DIAG-KCENTRA-DIAG6  OR
364700          B-DIAG-KCENTRA-DIAG7  OR
364800          B-DIAG-KCENTRA-DIAG8  OR
364900          B-DIAG-KCENTRA-DIAG9  OR
365000          B-DIAG-KCENTRA-DIAG10 OR
365100          B-DIAG-KCENTRA-DIAG11 OR
365200          B-DIAG-KCENTRA-DIAG12 OR
365300          B-DIAG-KCENTRA-DIAG13 OR
365400          B-DIAG-KCENTRA-DIAG14 OR
365500          B-DIAG-KCENTRA-DIAG15 OR
365600          B-DIAG-KCENTRA-DIAG16 OR
365700          B-DIAG-KCENTRA-DIAG17 OR
365800          B-DIAG-KCENTRA-DIAG18 OR
365900          B-DIAG-KCENTRA-DIAG19 OR
366000          B-DIAG-KCENTRA-DIAG20 OR
366100          B-DIAG-KCENTRA-DIAG21 OR
366200          B-DIAG-KCENTRA-DIAG22 OR
366300          B-DIAG-KCENTRA-DIAG23 OR
366400          B-DIAG-KCENTRA-DIAG24 OR
366500          B-DIAG-KCENTRA-DIAG25
366600       MOVE ZEROES TO H-NEW-TECH-ADDON-KCENTRA
366700     ELSE
366800       PERFORM 4820-KCENTRA-TECH-ADD-ON THRU 4820-EXIT.
366900
367000*    IF   B-PROC-ZILVER-PRIN    OR
367100*         B-PROC-ZILVER-PROC1 OR
367200*         B-PROC-ZILVER-PROC2 OR
367300*         B-PROC-ZILVER-PROC3 OR
367400*         B-PROC-ZILVER-PROC4 OR
367500*         B-PROC-ZILVER-PROC5 OR
367600*         B-PROC-ZILVER-PROC6 OR
367700*         B-PROC-ZILVER-PROC7 OR
367800*         B-PROC-ZILVER-PROC8 OR
367900*         B-PROC-ZILVER-PROC9 OR
368000*         B-PROC-ZILVER-PROC10 OR
368100*         B-PROC-ZILVER-PROC11 OR
368200*         B-PROC-ZILVER-PROC12 OR
368300*         B-PROC-ZILVER-PROC13 OR
368400*         B-PROC-ZILVER-PROC14 OR
368500*         B-PROC-ZILVER-PROC15 OR
368600*         B-PROC-ZILVER-PROC16 OR
368700*         B-PROC-ZILVER-PROC17 OR
368800*         B-PROC-ZILVER-PROC18 OR
368900*         B-PROC-ZILVER-PROC19 OR
369000*         B-PROC-ZILVER-PROC20 OR
369100*         B-PROC-ZILVER-PROC21 OR
369200*         B-PROC-ZILVER-PROC22 OR
369300*         B-PROC-ZILVER-PROC23 OR
369400*         B-PROC-ZILVER-PROC24
369500*      PERFORM 4830-ZILVER-TECH-ADD-ON THRU 4830-EXIT
369600*    ELSE
369700*      MOVE ZEROES TO H-NEW-TECH-ADDON-ZILVER.
369800
369900     IF   B-PROC-CARDIO-PRIN    OR
370000          B-PROC-CARDIO-PROC1 OR
370100          B-PROC-CARDIO-PROC2 OR
370200          B-PROC-CARDIO-PROC3 OR
370300          B-PROC-CARDIO-PROC4 OR
370400          B-PROC-CARDIO-PROC5 OR
370500          B-PROC-CARDIO-PROC6 OR
370600          B-PROC-CARDIO-PROC7 OR
370700          B-PROC-CARDIO-PROC8 OR
370800          B-PROC-CARDIO-PROC9 OR
370900          B-PROC-CARDIO-PROC10 OR
371000          B-PROC-CARDIO-PROC11 OR
371100          B-PROC-CARDIO-PROC12 OR
371200          B-PROC-CARDIO-PROC13 OR
371300          B-PROC-CARDIO-PROC14 OR
371400          B-PROC-CARDIO-PROC15 OR
371500          B-PROC-CARDIO-PROC16 OR
371600          B-PROC-CARDIO-PROC17 OR
371700          B-PROC-CARDIO-PROC18 OR
371800          B-PROC-CARDIO-PROC19 OR
371900          B-PROC-CARDIO-PROC20 OR
372000          B-PROC-CARDIO-PROC21 OR
372100          B-PROC-CARDIO-PROC22 OR
372200          B-PROC-CARDIO-PROC23 OR
372300          B-PROC-CARDIO-PROC24
372400       PERFORM 5010-CARDIO-MEMES-ADD-ON THRU 5010-EXIT
372500     ELSE
372600       MOVE ZEROES TO H-NEW-TECH-ADDON-CARDIO.
372700
372800     IF   B-PROC-MITRACLP-PRIN    OR
372900          B-PROC-MITRACLP-PROC1 OR
373000          B-PROC-MITRACLP-PROC2 OR
373100          B-PROC-MITRACLP-PROC3 OR
373200          B-PROC-MITRACLP-PROC4 OR
373300          B-PROC-MITRACLP-PROC5 OR
373400          B-PROC-MITRACLP-PROC6 OR
373500          B-PROC-MITRACLP-PROC7 OR
373600          B-PROC-MITRACLP-PROC8 OR
373700          B-PROC-MITRACLP-PROC9 OR
373800          B-PROC-MITRACLP-PROC10 OR
373900          B-PROC-MITRACLP-PROC11 OR
374000          B-PROC-MITRACLP-PROC12 OR
374100          B-PROC-MITRACLP-PROC13 OR
374200          B-PROC-MITRACLP-PROC14 OR
374300          B-PROC-MITRACLP-PROC15 OR
374400          B-PROC-MITRACLP-PROC16 OR
374500          B-PROC-MITRACLP-PROC17 OR
374600          B-PROC-MITRACLP-PROC18 OR
374700          B-PROC-MITRACLP-PROC19 OR
374800          B-PROC-MITRACLP-PROC20 OR
374900          B-PROC-MITRACLP-PROC21 OR
375000          B-PROC-MITRACLP-PROC22 OR
375100          B-PROC-MITRACLP-PROC23 OR
375200          B-PROC-MITRACLP-PROC24
375300       PERFORM 5020-MITRA-CLIP-ADD-ON THRU 5020-EXIT
375400     ELSE
375500       MOVE ZEROES TO H-NEW-TECH-ADDON-MITRACLP.
375600
375700     IF   B-PROC-RNSSYS1-PRIN    OR
375800          B-PROC-RNSSYS1-PROC1 OR
375900          B-PROC-RNSSYS1-PROC2 OR
376000          B-PROC-RNSSYS1-PROC3 OR
376100          B-PROC-RNSSYS1-PROC4 OR
376200          B-PROC-RNSSYS1-PROC5 OR
376300          B-PROC-RNSSYS1-PROC6 OR
376400          B-PROC-RNSSYS1-PROC7 OR
376500          B-PROC-RNSSYS1-PROC8 OR
376600          B-PROC-RNSSYS1-PROC9 OR
376700          B-PROC-RNSSYS1-PROC10 OR
376800          B-PROC-RNSSYS1-PROC11 OR
376900          B-PROC-RNSSYS1-PROC12 OR
377000          B-PROC-RNSSYS1-PROC13 OR
377100          B-PROC-RNSSYS1-PROC14 OR
377200          B-PROC-RNSSYS1-PROC15 OR
377300          B-PROC-RNSSYS1-PROC16 OR
377400          B-PROC-RNSSYS1-PROC17 OR
377500          B-PROC-RNSSYS1-PROC18 OR
377600          B-PROC-RNSSYS1-PROC19 OR
377700          B-PROC-RNSSYS1-PROC20 OR
377800          B-PROC-RNSSYS1-PROC21 OR
377900          B-PROC-RNSSYS1-PROC22 OR
378000          B-PROC-RNSSYS1-PROC23 OR
378100          B-PROC-RNSSYS1-PROC24
378200       PERFORM 5030-RNS-SYS-ADD-ON THRU 5030-EXIT
378300     ELSE
378400       MOVE ZEROES TO H-NEW-TECH-ADDON-RNSSYS.
378500
378600     IF   B-PROC-BLINATU-PRIN   OR
378700          B-PROC-BLINATU-PROC1 OR
378800          B-PROC-BLINATU-PROC2 OR
378900          B-PROC-BLINATU-PROC3 OR
379000          B-PROC-BLINATU-PROC4 OR
379100          B-PROC-BLINATU-PROC5 OR
379200          B-PROC-BLINATU-PROC6 OR
379300          B-PROC-BLINATU-PROC7 OR
379400          B-PROC-BLINATU-PROC8 OR
379500          B-PROC-BLINATU-PROC9 OR
379600          B-PROC-BLINATU-PROC10 OR
379700          B-PROC-BLINATU-PROC11 OR
379800          B-PROC-BLINATU-PROC12 OR
379900          B-PROC-BLINATU-PROC13 OR
380000          B-PROC-BLINATU-PROC14 OR
380100          B-PROC-BLINATU-PROC15 OR
380200          B-PROC-BLINATU-PROC16 OR
380300          B-PROC-BLINATU-PROC17 OR
380400          B-PROC-BLINATU-PROC18 OR
380500          B-PROC-BLINATU-PROC19 OR
380600          B-PROC-BLINATU-PROC20 OR
380700          B-PROC-BLINATU-PROC21 OR
380800          B-PROC-BLINATU-PROC22 OR
380900          B-PROC-BLINATU-PROC23 OR
381000          B-PROC-BLINATU-PROC24
381100       PERFORM 4900-BLINATU-TECH-ADD-ON THRU 4900-EXIT
381200     ELSE
381300       MOVE ZEROES TO H-NEW-TECH-ADDON-BLINATU.
381400
381500     IF   B-PROC-LUTONIX-PRIN   OR
381600          B-PROC-LUTONIX-PROC1 OR
381700          B-PROC-LUTONIX-PROC2 OR
381800          B-PROC-LUTONIX-PROC3 OR
381900          B-PROC-LUTONIX-PROC4 OR
382000          B-PROC-LUTONIX-PROC5 OR
382100          B-PROC-LUTONIX-PROC6 OR
382200          B-PROC-LUTONIX-PROC7 OR
382300          B-PROC-LUTONIX-PROC8 OR
382400          B-PROC-LUTONIX-PROC9 OR
382500          B-PROC-LUTONIX-PROC10 OR
382600          B-PROC-LUTONIX-PROC11 OR
382700          B-PROC-LUTONIX-PROC12 OR
382800          B-PROC-LUTONIX-PROC13 OR
382900          B-PROC-LUTONIX-PROC14 OR
383000          B-PROC-LUTONIX-PROC15 OR
383100          B-PROC-LUTONIX-PROC16 OR
383200          B-PROC-LUTONIX-PROC17 OR
383300          B-PROC-LUTONIX-PROC18 OR
383400          B-PROC-LUTONIX-PROC19 OR
383500          B-PROC-LUTONIX-PROC20 OR
383600          B-PROC-LUTONIX-PROC21 OR
383700          B-PROC-LUTONIX-PROC22 OR
383800          B-PROC-LUTONIX-PROC23 OR
383900          B-PROC-LUTONIX-PROC24
384000       PERFORM 4910-LUTONIX-TECH-ADD-ON THRU 4910-EXIT
384100     ELSE
384200       MOVE ZEROES TO H-NEW-TECH-ADDON-LUTONIX.
384300
384400***********************************************************
384500*  ALL NEW TECH MUST BE CALCULATED BEFORE
384600*  5000-CAP-CALC-TECH-ADD-ON
384700***********************************************************
384800     PERFORM 5000-CAP-CALC-TECH-ADD-ON THRU 5000-EXIT.
384900
385000     COMPUTE H-OPER-BASE-DRG-PAY ROUNDED =
385100             H-OPER-FSP-PART +
385200             H-NEW-TECH-PAY-ADD-ON.
385300
385400*
385500 4000-EXIT.    EXIT.
385600***********************************************************
385700
385800*4100-ISLET-ISOLATION-ADD-ON.
385900***********************************************************
386000***  TECHNICAL TRANSPLANTATION OF CELLS
386100***
386200*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
386300*** ISLETS OF LANGERHAUS) AND
386400*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
386500*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
386600*** TIMES IN ANY OTHER PROC-CODE
386700***********************************************************
386800*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
386900*** V70.7
387000***********************************************************
387100*
387200*    MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
387300*              H-TECH-ADDON-ISLET-CNTR2
387400*              H-NEW-TECH-ADDON-ISLET.
387500*
387600*    IF '5285   ' =  B-PRIN-PROC-CODE     OR
387700*                    B-OTHER-PROC-CODE1   OR
387800*                    B-OTHER-PROC-CODE2   OR
387900*                    B-OTHER-PROC-CODE3   OR
388000*                    B-OTHER-PROC-CODE4   OR
388100*                    B-OTHER-PROC-CODE5   OR
388200*                    B-OTHER-PROC-CODE6   OR
388300*                    B-OTHER-PROC-CODE7   OR
388400*                    B-OTHER-PROC-CODE8   OR
388500*                    B-OTHER-PROC-CODE9   OR
388600*                    B-OTHER-PROC-CODE10  OR
388700*                    B-OTHER-PROC-CODE11  OR
388800*                    B-OTHER-PROC-CODE12  OR
388900*                    B-OTHER-PROC-CODE13  OR
389000*                    B-OTHER-PROC-CODE14  OR
389100*                    B-OTHER-PROC-CODE15  OR
389200*                    B-OTHER-PROC-CODE16  OR
389300*                    B-OTHER-PROC-CODE17  OR
389400*                    B-OTHER-PROC-CODE18  OR
389500*                    B-OTHER-PROC-CODE19  OR
389600*                    B-OTHER-PROC-CODE20  OR
389700*                    B-OTHER-PROC-CODE21  OR
389800*                    B-OTHER-PROC-CODE22  OR
389900*                    B-OTHER-PROC-CODE23  OR
390000*                    B-OTHER-PROC-CODE24
390100*          NEXT SENTENCE
390200*    ELSE
390300*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
390400*          GO TO 4100-ADD-TECH-CASES.
390500*
390600*    IF '5285   ' =  B-PRIN-PROC-CODE
390700*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
390800*                      H-TECH-ADDON-ISLET-CNTR + 1.
390900*
391000*    IF '5285   ' =  B-OTHER-PROC-CODE1
391100*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
391200*                      H-TECH-ADDON-ISLET-CNTR + 1.
391300*
391400*    IF '5285   ' =  B-OTHER-PROC-CODE2
391500*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
391600*                      H-TECH-ADDON-ISLET-CNTR + 1.
391700*
391800*    IF '5285   ' =  B-OTHER-PROC-CODE3
391900*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
392000*                      H-TECH-ADDON-ISLET-CNTR + 1.
392100*
392200*    IF '5285   ' =  B-OTHER-PROC-CODE4
392300*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
392400*                      H-TECH-ADDON-ISLET-CNTR + 1.
392500*
392600*
392700*    IF '5285   ' =  B-OTHER-PROC-CODE5
392800*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
392900*                      H-TECH-ADDON-ISLET-CNTR + 1.
393000*
393100*    IF '5285   ' =  B-OTHER-PROC-CODE6
393200*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
393300*                      H-TECH-ADDON-ISLET-CNTR + 1.
393400*
393500*    IF '5285   ' =  B-OTHER-PROC-CODE7
393600*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
393700*                      H-TECH-ADDON-ISLET-CNTR + 1.
393800*
393900*    IF '5285   ' =  B-OTHER-PROC-CODE8
394000*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
394100*                      H-TECH-ADDON-ISLET-CNTR + 1.
394200*
394300*    IF '5285   ' =  B-OTHER-PROC-CODE9
394400*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
394500*                      H-TECH-ADDON-ISLET-CNTR + 1.
394600*
394700*    IF '5285   ' =  B-OTHER-PROC-CODE10
394800*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
394900*                      H-TECH-ADDON-ISLET-CNTR + 1.
395000*
395100*    IF '5285   ' =  B-OTHER-PROC-CODE11
395200*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
395300*                      H-TECH-ADDON-ISLET-CNTR + 1.
395400*
395500*    IF '5285   ' =  B-OTHER-PROC-CODE12
395600*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
395700*                      H-TECH-ADDON-ISLET-CNTR + 1.
395800*
395900*    IF '5285   ' =  B-OTHER-PROC-CODE13
396000*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
396100*                      H-TECH-ADDON-ISLET-CNTR + 1.
396200*
396300*    IF '5285   ' =  B-OTHER-PROC-CODE14
396400*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
396500*                      H-TECH-ADDON-ISLET-CNTR + 1.
396600*
396700*    IF '5285   ' =  B-OTHER-PROC-CODE15
396800*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
396900*                      H-TECH-ADDON-ISLET-CNTR + 1.
397000*
397100*    IF '5285   ' =  B-OTHER-PROC-CODE16
397200*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
397300*                      H-TECH-ADDON-ISLET-CNTR + 1.
397400*
397500*    IF '5285   ' =  B-OTHER-PROC-CODE17
397600*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
397700*                      H-TECH-ADDON-ISLET-CNTR + 1.
397800*
397900*    IF '5285   ' =  B-OTHER-PROC-CODE18
398000*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
398100*                      H-TECH-ADDON-ISLET-CNTR + 1.
398200*
398300*    IF '5285   ' =  B-OTHER-PROC-CODE19
398400*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
398500*                      H-TECH-ADDON-ISLET-CNTR + 1.
398600*
398700*    IF '5285   ' =  B-OTHER-PROC-CODE20
398800*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
398900*                      H-TECH-ADDON-ISLET-CNTR + 1.
399000*
399100*    IF '5285   ' =  B-OTHER-PROC-CODE21
399200*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
399300*                      H-TECH-ADDON-ISLET-CNTR + 1.
399400*
399500*    IF '5285   ' =  B-OTHER-PROC-CODE22
399600*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
399700*                      H-TECH-ADDON-ISLET-CNTR + 1.
399800*
399900*    IF '5285   ' =  B-OTHER-PROC-CODE23
400000*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
400100*                      H-TECH-ADDON-ISLET-CNTR + 1.
400200*
400300*    IF '5285   ' =  B-OTHER-PROC-CODE24
400400*     COMPUTE H-TECH-ADDON-ISLET-CNTR =
400500*                      H-TECH-ADDON-ISLET-CNTR + 1.
400600*
400700*    IF  H-TECH-ADDON-ISLET-CNTR = 1
400800*    MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
400900*          GO TO 4100-ADD-TECH-CASES.
401000*
401100*    IF  H-TECH-ADDON-ISLET-CNTR > 1
401200*    MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
401300*          GO TO 4100-ADD-TECH-CASES.
401400*
401500*    MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
401600*
401700*
401800*4100-ADD-TECH-CASES.
401900*
402000*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
402100*            H-NEW-TECH-PAY-ADD-ON +
402200*            H-NEW-TECH-ADDON-ISLET.
402300*
402400*4100-EXIT.    EXIT.
402500*
402600*
402700*
402800***********************************************************
402900* THIS IS A SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
403000* DISCHARGE COUNTS.
403100***********************************************************
403200 4400-LOWVOL-CODE-RTN.
403300
403400     SET LOWVOL-IDX TO 1.
403500     SEARCH LOWVOL-TAB VARYING LOWVOL-IDX
403600         AT END
403700           MOVE ' NO LOWVOL PROVIDER FOUND' TO MES-LOWVOL
403800           MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG
403900       WHEN WK-LOWVOL-PROV (LOWVOL-IDX) = MES-PPS-PROV
404000         MOVE WK-LOWVOL-PROV-DISCHG(LOWVOL-IDX)
404100                            TO MESWK-LOWVOL-PROV-DISCHG.
404200
404300 4400-EXIT.   EXIT.
404400
404500***********************************************************
404600*
404700****YEARCHANGE 2015.0**************************************
404800* THIS SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
404900* DISCHARGE COUNTS WAS REPLACED BY A FIELD ON THE PSF PROVIDER
405000* FILE
405100***********************************************************
405200 4410-UNCOMP-CARE-CODE-RTN.
405300
405400*    MOVE P-NEW-PROVIDER-NO  TO MES-PPS-PROV.
405500*
405600*    SET UNCOMP-CARE-IDX TO 1.
405700*    SEARCH UNCOMP-CARE-TAB VARYING UNCOMP-CARE-IDX
405800*        AT END
405900*          MOVE 0 TO  WK-UNCOMP-CARE-AMOUNT
406000*      WHEN TB-UNCOMP-CARE-PROV (UNCOMP-CARE-IDX) = MES-PPS-PROV
406100*        MOVE TB-UNCOMP-CARE-AMOUNT (UNCOMP-CARE-IDX)
406200*                           TO WK-UNCOMP-CARE-AMOUNT.
406300*
406400        COMPUTE WK-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
406500
406600        COMPUTE H-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
406700
406800 4410-EXIT.   EXIT.
406900
407000****YEARCHANGE 2015.0**************************************
407100***********************************************************
407200*
407300*
407400***********************************************************
407500*4500-AUTOLIT-TECH-ADD-ON.
407600***********************************************************
407700***** CASES INVOLVING AUTOLITT PROCESS DECOMPRESSION SYSTEM
407800***********************************************************
407900*
408000*    MOVE 0 TO H-NEW-TECH-ADDON-AUTOLITT
408100*              H-LESSER-AUTOLITT-STOP-1
408200*              H-LESSER-AUTOLITT-STOP-2
408300*              H-CSTMED-AUTOLITT-STOP.
408400*
408500*
408600*
408700*    IF '1761   ' =  B-PRIN-PROC-CODE     OR
408800*                    B-OTHER-PROC-CODE1   OR
408900*                    B-OTHER-PROC-CODE2   OR
409000*                    B-OTHER-PROC-CODE3   OR
409100*                    B-OTHER-PROC-CODE4   OR
409200*                    B-OTHER-PROC-CODE5   OR
409300*                    B-OTHER-PROC-CODE6   OR
409400*                    B-OTHER-PROC-CODE7   OR
409500*                    B-OTHER-PROC-CODE8   OR
409600*                    B-OTHER-PROC-CODE9   OR
409700*                    B-OTHER-PROC-CODE10  OR
409800*                    B-OTHER-PROC-CODE11  OR
409900*                    B-OTHER-PROC-CODE12  OR
410000*                    B-OTHER-PROC-CODE13  OR
410100*                    B-OTHER-PROC-CODE14  OR
410200*                    B-OTHER-PROC-CODE15  OR
410300*                    B-OTHER-PROC-CODE16  OR
410400*                    B-OTHER-PROC-CODE17  OR
410500*                    B-OTHER-PROC-CODE18  OR
410600*                    B-OTHER-PROC-CODE19  OR
410700*                    B-OTHER-PROC-CODE20  OR
410800*                    B-OTHER-PROC-CODE21  OR
410900*                    B-OTHER-PROC-CODE22  OR
411000*                    B-OTHER-PROC-CODE23  OR
411100*                    B-OTHER-PROC-CODE24
411200*          GO TO 4500-COMPUTE-AUTOLITT
411300*    ELSE
411400*          NEXT SENTENCE.
411500*
411600*          MOVE ZEROES TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
411700*          GO TO 4500-ADD-TECH-CASES.
411800*
411900*4500-COMPUTE-AUTOLITT.
412000*
412100*    MOVE  5300.00 TO H-CSTMED-AUTOLITT-STOP.
412200*
412300*    COMPUTE H-LESSER-AUTOLITT-STOP-1 ROUNDED =
412400*                 H-CSTMED-AUTOLITT-STOP.
412500*
412600*    COMPUTE H-LESSER-AUTOLITT-STOP-2 ROUNDED =
412700*         (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
412800*                    H-BASE-DRG-PAYMENT)) * .5.
412900*
413000*    IF H-LESSER-AUTOLITT-STOP-2 > 0
413100*       IF H-LESSER-AUTOLITT-STOP-1 < H-LESSER-AUTOLITT-STOP-2
413200*        MOVE H-LESSER-AUTOLITT-STOP-1 TO
413300*                               H-NEW-TECH-ADDON-AUTOLITT-STOP
413400*       ELSE
413500*        MOVE H-LESSER-AUTOLITT-STOP-2 TO
413600*                               H-NEW-TECH-ADDON-AUTOLITT-STOP
413700*    ELSE
413800*       MOVE ZEROES          TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
413900*
414000*
414100*4500-ADD-TECH-CASES.
414200*
414300*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
414400*            H-NEW-TECH-PAY-ADD-ON +
414500*            H-NEW-TECH-ADDON-AUTOLITT-STOP.
414600*
414700*4500-EXIT.    EXIT.
414800*
414900*
415000***********************************************************
415100*4600-DIFICID-TECH-ADD-ON.
415200***********************************************************
415300***** CASES INVOLVING DIFICID PROCESS DECOMPRESSION SYSTEM
415400***********************************************************
415500***** PER HPAR 8041H TEST WAS CHANGED FR 0845 TO 00845
415600***********************************************************
415700*
415800*
415900*    MOVE 0 TO H-NEW-TECH-ADDON-DIFICID
416000*              H-LESSER-DIFICID-STOP-1
416100*              H-LESSER-DIFICID-STOP-2
416200*              H-CSTMED-DIFICID-STOP.
416300*
416400*    IF '00845  ' =  B-OTHER-DIAG-CODE1   OR
416500*                    B-OTHER-DIAG-CODE2   OR
416600*                    B-OTHER-DIAG-CODE3   OR
416700*                    B-OTHER-DIAG-CODE4   OR
416800*                    B-OTHER-DIAG-CODE5   OR
416900*                    B-OTHER-DIAG-CODE6   OR
417000*                    B-OTHER-DIAG-CODE7   OR
417100*                    B-OTHER-DIAG-CODE8   OR
417200*                    B-OTHER-DIAG-CODE9   OR
417300*                    B-OTHER-DIAG-CODE10  OR
417400*                    B-OTHER-DIAG-CODE11  OR
417500*                    B-OTHER-DIAG-CODE12  OR
417600*                    B-OTHER-DIAG-CODE13  OR
417700*                    B-OTHER-DIAG-CODE14  OR
417800*                    B-OTHER-DIAG-CODE15  OR
417900*                    B-OTHER-DIAG-CODE16  OR
418000*                    B-OTHER-DIAG-CODE17  OR
418100*                    B-OTHER-DIAG-CODE18  OR
418200*                    B-OTHER-DIAG-CODE19  OR
418300*                    B-OTHER-DIAG-CODE20  OR
418400*                    B-OTHER-DIAG-CODE21  OR
418500*                    B-OTHER-DIAG-CODE22  OR
418600*                    B-OTHER-DIAG-CODE23  OR
418700*                    B-OTHER-DIAG-CODE24  OR
418800*                    B-OTHER-DIAG-CODE25
418900*          GO TO 4600-COMPUTE-DIFICID
419000*    ELSE
419100*          NEXT SENTENCE.
419200*
419300*          MOVE ZEROES TO H-NEW-TECH-ADDON-DIFICID.
419400*          GO TO 4600-ADD-TECH-CASES.
419500*
419600*4600-COMPUTE-DIFICID.
419700*
419800*    MOVE  868.00 TO H-CSTMED-DIFICID-STOP.
419900*
420000*    COMPUTE H-LESSER-DIFICID-STOP-1 ROUNDED =
420100*                 H-CSTMED-DIFICID-STOP.
420200*
420300*    COMPUTE H-LESSER-DIFICID-STOP-2 ROUNDED =
420400*         (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
420500*                    H-BASE-DRG-PAYMENT)) * .5.
420600*
420700*    IF H-LESSER-DIFICID-STOP-2 > 0
420800*       IF H-LESSER-DIFICID-STOP-1 < H-LESSER-DIFICID-STOP-2
420900*        MOVE H-LESSER-DIFICID-STOP-1 TO
421000*                               H-NEW-TECH-ADDON-DIFICID
421100*       ELSE
421200*        MOVE H-LESSER-DIFICID-STOP-2 TO
421300*                               H-NEW-TECH-ADDON-DIFICID
421400*    ELSE
421500*       MOVE ZEROES          TO H-NEW-TECH-ADDON-DIFICID.
421600*
421700*
421800*
421900*4600-ADD-TECH-CASES.
422000*
422100*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
422200*            H-NEW-TECH-PAY-ADD-ON +
422300*            H-NEW-TECH-ADDON-DIFICID.
422400*
422500*4600-EXIT.    EXIT.
422600
422700***********************************************************
422800*4700-ZENITH-TECH-ADD-ON.
422900***********************************************************
423000***** CASES INVOLVING ZENITH PROCESS DECOMPRESSION SYSTEM
423100***********************************************************
423200*
423300*    MOVE 0 TO H-NEW-TECH-ADDON-ZENITH
423400*              H-LESSER-ZENITH-STOP-1
423500*              H-LESSER-ZENITH-STOP-2
423600*              H-CSTMED-ZENITH-STOP.
423700*
423800*4700-COMPUTE-ZENITH.
423900*
424000*    MOVE  8171.50 TO H-CSTMED-ZENITH-STOP.
424100*
424200*    COMPUTE H-LESSER-ZENITH-STOP-1 ROUNDED =
424300*                 H-CSTMED-ZENITH-STOP.
424400*
424500*    COMPUTE H-LESSER-ZENITH-STOP-2 ROUNDED =
424600*         (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
424700*                    H-BASE-DRG-PAYMENT)) * .5.
424800*
424900*    IF H-LESSER-ZENITH-STOP-2 > 0
425000*       IF H-LESSER-ZENITH-STOP-1 < H-LESSER-ZENITH-STOP-2
425100*        MOVE H-LESSER-ZENITH-STOP-1 TO
425200*                               H-NEW-TECH-ADDON-ZENITH
425300*       ELSE
425400*        MOVE H-LESSER-ZENITH-STOP-2 TO
425500*                               H-NEW-TECH-ADDON-ZENITH
425600*    ELSE
425700*       MOVE ZEROES          TO H-NEW-TECH-ADDON-ZENITH.
425800*
425900*
426000*4700-ADD-TECH-CASES.
426100*
426200*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
426300*            H-NEW-TECH-PAY-ADD-ON +
426400*            H-NEW-TECH-ADDON-ZENITH.
426500*
426600*4700-EXIT.    EXIT.
426700
426800***********************************************************
426900*4800-VORAXAZE-TECH-ADD-ON.
427000***********************************************************
427100***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
427200***********************************************************
427300*
427400*    MOVE 0 TO H-NEW-TECH-ADDON-VORAXAZE
427500*              H-LESSER-VORAXAZE-STOP-1
427600*              H-LESSER-VORAXAZE-STOP-2
427700*              H-CSTMED-VORAXAZE-STOP.
427800*
427900*4800-COMPUTE-VORAXAZE.
428000*
428100*    MOVE  47250.00 TO H-CSTMED-VORAXAZE-STOP.
428200*
428300*    COMPUTE H-LESSER-VORAXAZE-STOP-1 ROUNDED =
428400*                 H-CSTMED-VORAXAZE-STOP.
428500*
428600*    COMPUTE H-LESSER-VORAXAZE-STOP-2 ROUNDED =
428700*         (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
428800*                    H-BASE-DRG-PAYMENT)) * .5.
428900*
429000*    IF H-LESSER-VORAXAZE-STOP-2 > 0
429100*       IF H-LESSER-VORAXAZE-STOP-1 < H-LESSER-VORAXAZE-STOP-2
429200*        MOVE H-LESSER-VORAXAZE-STOP-1 TO
429300*                               H-NEW-TECH-ADDON-VORAXAZE
429400*       ELSE
429500*        MOVE H-LESSER-VORAXAZE-STOP-2 TO
429600*                               H-NEW-TECH-ADDON-VORAXAZE
429700*    ELSE
429800*       MOVE ZEROES          TO H-NEW-TECH-ADDON-VORAXAZE.
429900*
430000*
430100*4800-ADD-TECH-CASES.
430200*
430300*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
430400*            H-NEW-TECH-PAY-ADD-ON +
430500*            H-NEW-TECH-ADDON-VORAXAZE.
430600*
430700*4800-EXIT.    EXIT.
430800
430900***********************************************************
431000 4810-ARGUS-TECH-ADD-ON.
431100***********************************************************
431200***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
431300***********************************************************
431400
431500     MOVE 0 TO H-NEW-TECH-ADDON-ARGUS
431600               H-LESSER-ARGUS-STOP-1
431700               H-LESSER-ARGUS-STOP-2
431800               H-CSTMED-ARGUS-STOP.
431900
432000 4810-COMPUTE-ARGUS.
432100
432200     MOVE  72028.75 TO H-CSTMED-ARGUS-STOP.
432300
432400     COMPUTE H-LESSER-ARGUS-STOP-1 ROUNDED =
432500                  H-CSTMED-ARGUS-STOP.
432600
432700     COMPUTE H-LESSER-ARGUS-STOP-2 ROUNDED =
432800          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
432900                     H-BASE-DRG-PAYMENT)) * .5.
433000
433100     IF H-LESSER-ARGUS-STOP-2 > 0
433200        IF H-LESSER-ARGUS-STOP-1 < H-LESSER-ARGUS-STOP-2
433300         MOVE H-LESSER-ARGUS-STOP-1 TO
433400                                H-NEW-TECH-ADDON-ARGUS
433500        ELSE
433600         MOVE H-LESSER-ARGUS-STOP-2 TO
433700                                H-NEW-TECH-ADDON-ARGUS
433800     ELSE
433900        MOVE ZEROES          TO H-NEW-TECH-ADDON-ARGUS.
434000
434100
434200 4810-ADD-TECH-CASES.
434300
434400     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
434500             H-NEW-TECH-PAY-ADD-ON +
434600             H-NEW-TECH-ADDON-ARGUS.
434700*
434800 4810-EXIT.    EXIT.
434900
435000
435100***********************************************************
435200 4820-KCENTRA-TECH-ADD-ON.
435300***********************************************************
435400***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
435500***********************************************************
435600
435700     MOVE 0 TO H-NEW-TECH-ADDON-KCENTRA
435800               H-LESSER-KCENTRA-STOP-1
435900               H-LESSER-KCENTRA-STOP-2
436000               H-CSTMED-KCENTRA-STOP.
436100
436200
436300     IF   B-PROC-KCENTRA-PRIN   OR
436400          B-PROC-KCENTRA-PROC1  OR
436500          B-PROC-KCENTRA-PROC2  OR
436600          B-PROC-KCENTRA-PROC3  OR
436700          B-PROC-KCENTRA-PROC4  OR
436800          B-PROC-KCENTRA-PROC5  OR
436900          B-PROC-KCENTRA-PROC6  OR
437000          B-PROC-KCENTRA-PROC7  OR
437100          B-PROC-KCENTRA-PROC8  OR
437200          B-PROC-KCENTRA-PROC9  OR
437300          B-PROC-KCENTRA-PROC10 OR
437400          B-PROC-KCENTRA-PROC11 OR
437500          B-PROC-KCENTRA-PROC12 OR
437600          B-PROC-KCENTRA-PROC13 OR
437700          B-PROC-KCENTRA-PROC14 OR
437800          B-PROC-KCENTRA-PROC15 OR
437900          B-PROC-KCENTRA-PROC16 OR
438000          B-PROC-KCENTRA-PROC17 OR
438100          B-PROC-KCENTRA-PROC18 OR
438200          B-PROC-KCENTRA-PROC19 OR
438300          B-PROC-KCENTRA-PROC20 OR
438400          B-PROC-KCENTRA-PROC21 OR
438500          B-PROC-KCENTRA-PROC22 OR
438600          B-PROC-KCENTRA-PROC23 OR
438700          B-PROC-KCENTRA-PROC24
438800           GO TO 4820-COMPUTE-KCENTRA
438900     ELSE
439000           NEXT SENTENCE.
439100
439200           MOVE ZEROES TO H-NEW-TECH-ADDON-KCENTRA.
439300           GO TO 4820-ADD-TECH-CASES.
439400
439500 4820-COMPUTE-KCENTRA.
439600
439700     MOVE  01587.50 TO H-CSTMED-KCENTRA-STOP.
439800
439900     COMPUTE H-LESSER-KCENTRA-STOP-1 ROUNDED =
440000                  H-CSTMED-KCENTRA-STOP.
440100
440200     COMPUTE H-LESSER-KCENTRA-STOP-2 ROUNDED =
440300          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
440400                     H-BASE-DRG-PAYMENT)) * .5.
440500
440600     IF H-LESSER-KCENTRA-STOP-2 > 0
440700        IF H-LESSER-KCENTRA-STOP-1 < H-LESSER-KCENTRA-STOP-2
440800         MOVE H-LESSER-KCENTRA-STOP-1 TO
440900                                H-NEW-TECH-ADDON-KCENTRA
441000        ELSE
441100         MOVE H-LESSER-KCENTRA-STOP-2 TO
441200                                H-NEW-TECH-ADDON-KCENTRA
441300     ELSE
441400        MOVE ZEROES          TO H-NEW-TECH-ADDON-KCENTRA.
441500
441600
441700 4820-ADD-TECH-CASES.
441800
441900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
442000             H-NEW-TECH-PAY-ADD-ON +
442100             H-NEW-TECH-ADDON-KCENTRA.
442200*
442300 4820-EXIT.    EXIT.
442400
442500
442600***********************************************************
442700*4830-ZILVER-TECH-ADD-ON.
442800***********************************************************
442900***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
443000***********************************************************
443100*
443200*    MOVE 0 TO H-NEW-TECH-ADDON-ZILVER
443300*              H-LESSER-ZILVER-STOP-1
443400*              H-LESSER-ZILVER-STOP-2
443500*              H-CSTMED-ZILVER-STOP.
443600*
443700*4830-COMPUTE-ZILVER.
443800*
443900*    MOVE  01705.25 TO H-CSTMED-ZILVER-STOP.
444000*
444100*    COMPUTE H-LESSER-ZILVER-STOP-1 ROUNDED =
444200*                 H-CSTMED-ZILVER-STOP.
444300*
444400*    COMPUTE H-LESSER-ZILVER-STOP-2 ROUNDED =
444500*         (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
444600*                    H-BASE-DRG-PAYMENT)) * .5.
444700*
444800*    IF H-LESSER-ZILVER-STOP-2 > 0
444900*       IF H-LESSER-ZILVER-STOP-1 < H-LESSER-ZILVER-STOP-2
445000*        MOVE H-LESSER-ZILVER-STOP-1 TO
445100*                               H-NEW-TECH-ADDON-ZILVER
445200*       ELSE
445300*        MOVE H-LESSER-ZILVER-STOP-2 TO
445400*                               H-NEW-TECH-ADDON-ZILVER
445500*    ELSE
445600*       MOVE ZEROES          TO H-NEW-TECH-ADDON-ZILVER.
445700*
445800*
445900*4830-ADD-TECH-CASES.
446000*
446100*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
446200*            H-NEW-TECH-PAY-ADD-ON +
446300*            H-NEW-TECH-ADDON-ZILVER.
446400*
446500*4830-EXIT.    EXIT.
446600
446700
446800***********************************************************
446900 5000-CAP-CALC-TECH-ADD-ON.
447000***********************************************************
447100***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
447200***********************************************************
447300
447400     MOVE 0 TO H-NEW-TECH-ADDON-CAP.
447500     MOVE 0 TO H-NEW-TECH-ADDON-CAPDIF.
447600
447700     COMPUTE H-OPER-BILL-COSTS ROUNDED =
447800         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
447900         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
448000
448100     COMPUTE H-NEW-TECH-ADDON-CAP ROUNDED =
448200                 (H-BASE-DRG-PAYMENT + H-NEW-TECH-PAY-ADD-ON).
448300
448400     COMPUTE H-NEW-TECH-ADDON-CAPDIF ROUNDED =
448500                 (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
448600
448700     IF (H-NEW-TECH-ADDON-CAP > H-OPER-BILL-COSTS) AND
448800         H-NEW-TECH-ADDON-CAPDIF  > 0
448900        COMPUTE H-NEW-TECH-PAY-ADD-ON  ROUNDED =
449000             (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
449100
449200*
449300 5000-EXIT.    EXIT.
449400
449500***********************************************************
449600 5010-CARDIO-MEMES-ADD-ON.
449700***********************************************************
449800***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
449900***********************************************************
450000
450100     MOVE 0 TO H-NEW-TECH-ADDON-CARDIO
450200               H-LESSER-CARDIO-STOP-1
450300               H-LESSER-CARDIO-STOP-2
450400               H-CSTMED-CARDIO-STOP.
450500
450600 5010-COMPUTE-CARDIO.
450700
450800     MOVE  08875.00 TO H-CSTMED-CARDIO-STOP.
450900
451000     COMPUTE H-LESSER-CARDIO-STOP-1 ROUNDED =
451100                  H-CSTMED-CARDIO-STOP.
451200
451300     COMPUTE H-LESSER-CARDIO-STOP-2 ROUNDED =
451400          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
451500                     H-BASE-DRG-PAYMENT)) * .5.
451600
451700     IF H-LESSER-CARDIO-STOP-2 > 0
451800        IF H-LESSER-CARDIO-STOP-1 < H-LESSER-CARDIO-STOP-2
451900         MOVE H-LESSER-CARDIO-STOP-1 TO
452000                                H-NEW-TECH-ADDON-CARDIO
452100        ELSE
452200         MOVE H-LESSER-CARDIO-STOP-2 TO
452300                                H-NEW-TECH-ADDON-CARDIO
452400     ELSE
452500        MOVE ZEROES          TO H-NEW-TECH-ADDON-CARDIO.
452600
452700
452800 5010-ADD-TECH-CASES.
452900
453000     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
453100             H-NEW-TECH-PAY-ADD-ON +
453200             H-NEW-TECH-ADDON-CARDIO.
453300*
453400 5010-EXIT.    EXIT.
453500***********************************************************
453600***********************************************************
453700 5020-MITRA-CLIP-ADD-ON.
453800***********************************************************
453900***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
454000***********************************************************
454100
454200     MOVE 0 TO H-NEW-TECH-ADDON-MITRACLP
454300               H-LESSER-MITRACLP-STOP-1
454400               H-LESSER-MITRACLP-STOP-2
454500               H-CSTMED-MITRACLP-STOP.
454600
454700 5020-COMPUTE-MITRACLP.
454800
454900     MOVE  15000.00 TO H-CSTMED-MITRACLP-STOP.
455000
455100     COMPUTE H-LESSER-MITRACLP-STOP-1 ROUNDED =
455200                  H-CSTMED-MITRACLP-STOP.
455300
455400     COMPUTE H-LESSER-MITRACLP-STOP-2 ROUNDED =
455500          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
455600                     H-BASE-DRG-PAYMENT)) * .5.
455700
455800     IF H-LESSER-MITRACLP-STOP-2 > 0
455900        IF H-LESSER-MITRACLP-STOP-1 < H-LESSER-MITRACLP-STOP-2
456000         MOVE H-LESSER-MITRACLP-STOP-1 TO
456100                                H-NEW-TECH-ADDON-MITRACLP
456200        ELSE
456300         MOVE H-LESSER-MITRACLP-STOP-2 TO
456400                                H-NEW-TECH-ADDON-MITRACLP
456500     ELSE
456600        MOVE ZEROES          TO H-NEW-TECH-ADDON-MITRACLP.
456700
456800
456900 5020-ADD-TECH-CASES.
457000
457100     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
457200             H-NEW-TECH-PAY-ADD-ON +
457300             H-NEW-TECH-ADDON-MITRACLP.
457400*
457500 5020-EXIT.    EXIT.
457600
457700***********************************************************
457800***********************************************************
457900 5030-RNS-SYS-ADD-ON.
458000***********************************************************
458100***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
458200***********************************************************
458300
458400     MOVE 0 TO H-NEW-TECH-ADDON-RNSSYS
458500               H-LESSER-RNSSYS-STOP-1
458600               H-LESSER-RNSSYS-STOP-2
458700               H-CSTMED-RNSSYS-STOP.
458800
458900     IF   B-PROC-RNSSYS2-PRIN    OR
459000          B-PROC-RNSSYS2-PROC1 OR
459100          B-PROC-RNSSYS2-PROC2 OR
459200          B-PROC-RNSSYS2-PROC3 OR
459300          B-PROC-RNSSYS2-PROC4 OR
459400          B-PROC-RNSSYS2-PROC5 OR
459500          B-PROC-RNSSYS2-PROC6 OR
459600          B-PROC-RNSSYS2-PROC7 OR
459700          B-PROC-RNSSYS2-PROC8 OR
459800          B-PROC-RNSSYS2-PROC9 OR
459900          B-PROC-RNSSYS2-PROC10 OR
460000          B-PROC-RNSSYS2-PROC11 OR
460100          B-PROC-RNSSYS2-PROC12 OR
460200          B-PROC-RNSSYS2-PROC13 OR
460300          B-PROC-RNSSYS2-PROC14 OR
460400          B-PROC-RNSSYS2-PROC15 OR
460500          B-PROC-RNSSYS2-PROC16 OR
460600          B-PROC-RNSSYS2-PROC17 OR
460700          B-PROC-RNSSYS2-PROC18 OR
460800          B-PROC-RNSSYS2-PROC19 OR
460900          B-PROC-RNSSYS2-PROC20 OR
461000          B-PROC-RNSSYS2-PROC21 OR
461100          B-PROC-RNSSYS2-PROC22 OR
461200          B-PROC-RNSSYS2-PROC23 OR
461300          B-PROC-RNSSYS2-PROC24
461400           GO TO 5030-COMPUTE-RNSSYS
461500     ELSE
461600           NEXT SENTENCE.
461700
461800           MOVE ZEROES TO H-NEW-TECH-ADDON-RNSSYS.
461900           GO TO 5030-ADD-TECH-CASES.
462000
462100 5030-COMPUTE-RNSSYS.
462200
462300     MOVE  18475.00 TO H-CSTMED-RNSSYS-STOP.
462400
462500     COMPUTE H-LESSER-RNSSYS-STOP-1 ROUNDED =
462600                  H-CSTMED-RNSSYS-STOP.
462700
462800     COMPUTE H-LESSER-RNSSYS-STOP-2 ROUNDED =
462900          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
463000                     H-BASE-DRG-PAYMENT)) * .5.
463100
463200     IF H-LESSER-RNSSYS-STOP-2 > 0
463300        IF H-LESSER-RNSSYS-STOP-1 < H-LESSER-RNSSYS-STOP-2
463400         MOVE H-LESSER-RNSSYS-STOP-1 TO
463500                                H-NEW-TECH-ADDON-RNSSYS
463600        ELSE
463700         MOVE H-LESSER-RNSSYS-STOP-2 TO
463800                                H-NEW-TECH-ADDON-RNSSYS
463900     ELSE
464000        MOVE ZEROES          TO H-NEW-TECH-ADDON-RNSSYS.
464100
464200
464300 5030-ADD-TECH-CASES.
464400
464500     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
464600             H-NEW-TECH-PAY-ADD-ON +
464700             H-NEW-TECH-ADDON-RNSSYS.
464800*
464900*
465000 5030-EXIT.    EXIT.
465100
465200***********************************************************
465300 4900-BLINATU-TECH-ADD-ON.
465400***********************************************************
465500***** CASES INVOLVING BLINATUMOMAB
465600***********************************************************
465700
465800     MOVE 0 TO H-NEW-TECH-ADDON-BLINATU
465900               H-LESSER-BLINATU-STOP-1
466000               H-LESSER-BLINATU-STOP-2
466100               H-CSTMED-BLINATU-STOP.
466200
466300 4900-COMPUTE-BLINATU.
466400
466500     MOVE  27017.85 TO H-CSTMED-BLINATU-STOP.
466600
466700     COMPUTE H-LESSER-BLINATU-STOP-1 ROUNDED =
466800                  H-CSTMED-BLINATU-STOP.
466900
467000     COMPUTE H-LESSER-BLINATU-STOP-2 ROUNDED =
467100          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
467200                     H-BASE-DRG-PAYMENT)) * .5.
467300
467400     IF H-LESSER-BLINATU-STOP-2 > 0
467500        IF H-LESSER-BLINATU-STOP-1 < H-LESSER-BLINATU-STOP-2
467600         MOVE H-LESSER-BLINATU-STOP-1 TO
467700                                H-NEW-TECH-ADDON-BLINATU
467800        ELSE
467900         MOVE H-LESSER-BLINATU-STOP-2 TO
468000                                H-NEW-TECH-ADDON-BLINATU
468100     ELSE
468200        MOVE ZEROES          TO H-NEW-TECH-ADDON-BLINATU.
468300
468400
468500 4900-ADD-TECH-CASES.
468600
468700     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
468800             H-NEW-TECH-PAY-ADD-ON +
468900             H-NEW-TECH-ADDON-BLINATU.
469000*
469100 4900-EXIT.    EXIT.
469200
469300
469400***********************************************************
469500 4910-LUTONIX-TECH-ADD-ON.
469600***********************************************************
469700***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
469800***********************************************************
469900
470000     MOVE 0 TO H-NEW-TECH-ADDON-LUTONIX
470100               H-LESSER-LUTONIX-STOP-1
470200               H-LESSER-LUTONIX-STOP-2
470300               H-CSTMED-LUTONIX-STOP.
470400
470500 4910-COMPUTE-LUTONIX.
470600
470700     MOVE  01035.72 TO H-CSTMED-LUTONIX-STOP.
470800
470900     COMPUTE H-LESSER-LUTONIX-STOP-1 ROUNDED =
471000                  H-CSTMED-LUTONIX-STOP.
471100
471200     COMPUTE H-LESSER-LUTONIX-STOP-2 ROUNDED =
471300          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
471400                     H-BASE-DRG-PAYMENT)) * .5.
471500
471600     IF H-LESSER-LUTONIX-STOP-2 > 0
471700        IF H-LESSER-LUTONIX-STOP-1 < H-LESSER-LUTONIX-STOP-2
471800         MOVE H-LESSER-LUTONIX-STOP-1 TO
471900                                H-NEW-TECH-ADDON-LUTONIX
472000        ELSE
472100         MOVE H-LESSER-LUTONIX-STOP-2 TO
472200                                H-NEW-TECH-ADDON-LUTONIX
472300     ELSE
472400        MOVE ZEROES          TO H-NEW-TECH-ADDON-LUTONIX.
472500
472600
472700 4910-ADD-TECH-CASES.
472800
472900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
473000             H-NEW-TECH-PAY-ADD-ON +
473100             H-NEW-TECH-ADDON-LUTONIX.
473200*
473300 4910-EXIT.    EXIT.
473400
473500***********************************************************
473600 6000-CALC-READMIS-REDU.
473700***********************************************************
473800*---------------------------------------------------------*
473900* (YEARCHANGE 2016.0)
474000* READMISSIONS PROCESS ADJUSTMENTS
474100*   + FY16: RANGE OF ALLOWABLE FACTORS (< 0.97 OR > 1.0)
474200*---------------------------------------------------------*
474300
474400     MOVE 0 TO H-READMIS-ADJUST-AMT.
474500
474600     IF P-HOSP-READMISSION-REDU = '1'
474700           GO TO 6000-EDIT-READMISN
474800     ELSE
474900           NEXT SENTENCE.
475000
475100     IF P-HOSP-READMISSION-REDU = '0' AND
475200        P-HOSP-HRR-ADJUSTMT = 0.0000
475300           MOVE ZEROES TO H-READMIS-ADJUST-AMT
475400           GO TO 6000-EXIT.
475500
475600     IF P-HOSP-READMISSION-REDU = '0' AND
475700        P-HOSP-HRR-ADJUSTMT > 0.0000
475800           MOVE 65 TO PPS-RTC
475900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
476000           GO TO 6000-EXIT.
476100
476200
476300     IF P-HOSP-READMISSION-REDU = '2' OR '3' OR '4' OR '5' OR
476400                                  '6' OR '7' OR '8' OR
476500                                  '9' OR ' '
476600           MOVE 65 TO PPS-RTC
476700           MOVE ZEROES TO H-READMIS-ADJUST-AMT
476800           GO TO 6000-EXIT.
476900
477000 6000-EDIT-READMISN.
477100
477200     IF P-HOSP-HRR-ADJUSTMT < 0.9700
477300           MOVE 65 TO PPS-RTC
477400           MOVE ZEROES TO H-READMIS-ADJUST-AMT
477500           GO TO 6000-EXIT.
477600
477700
477800     IF P-HOSP-HRR-ADJUSTMT > 1.0000
477900           MOVE 65 TO PPS-RTC
478000           MOVE ZEROES TO H-READMIS-ADJUST-AMT
478100           GO TO 6000-EXIT.
478200
478300     IF P-READ-INVALID-STATE
478400           MOVE 65 TO PPS-RTC
478500           MOVE ZEROES TO H-READMIS-ADJUST-AMT
478600           GO TO 6000-EXIT.
478700
478800
478900 6000-COMPUTE-READMISN.
479000
479100
479200        COMPUTE H-READMIS-ADJUST-AMT         ROUNDED =
479300              ((P-HOSP-HRR-ADJUSTMT * H-OPER-BASE-DRG-PAY) -
479400                H-OPER-BASE-DRG-PAY).
479500
479600
479700 6000-EXIT.    EXIT.
479800
479900***********************************************************
480000 7000-CALC-VALUE-BASED-PURCH.
480100***********************************************************
480200*---------------------------------------------------------*
480300* (YEARCHANGE 2016.0)
480400* VALUE BASED PURCHASING (VBP) ADJUSTMENTS
480500*   + FY16: RANGE OF ALLOWABLE FACTORS (< 0.9825 OR > 2.0)
480600*---------------------------------------------------------*
480700
480800     MOVE 0 TO H-VAL-BASED-PURCH-ADJUST-AMT.
480900
481000     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N' OR 'Y'
481100           NEXT SENTENCE
481200     ELSE
481300           MOVE 68 TO PPS-RTC
481400           GO TO 7000-EXIT.
481500
481600     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N'
481700           GO TO 7000-EXIT.
481800
481900     IF  P-VAL-BASED-PURCH-PARTIPNT = 'Y' AND
482000         P-NEW-CBSA-HOSP-QUAL-IND = '1'
482100           NEXT SENTENCE
482200     ELSE
482300           MOVE 68 TO PPS-RTC
482400           GO TO 7000-EXIT.
482500
482600     IF  P-VBP-INVALID-STATE
482700           MOVE 68 TO PPS-RTC
482800           GO TO 7000-EXIT
482900     ELSE
483000           NEXT SENTENCE.
483100
483200     IF P-VAL-BASED-PURCH-ADJUST < 0.9825000000 OR
483300        P-VAL-BASED-PURCH-ADJUST > 2.0000000000
483400           MOVE 68 TO PPS-RTC
483500           MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT
483600           GO TO 7000-EXIT
483700     ELSE
483800           GO TO 7000-COMPUTE-VAL-BASED-PUR.
483900
484000 7000-COMPUTE-VAL-BASED-PUR.
484100
484200     COMPUTE H-VAL-BASED-PURCH-ADJUST-AMT  ROUNDED =
484300              ((P-VAL-BASED-PURCH-ADJUST *
484400                  H-OPER-BASE-DRG-PAY) -
484500                  H-OPER-BASE-DRG-PAY).
484600*
484700 7000-EXIT.    EXIT.
484800
484900***********************************************************
485000 8000-CALC-BUNDLE-REDU.
485100***********************************************************
485200***** CASES INVOLVING BUNDLE PROCESS ADJUSTMENTS
485300***********************************************************
485400
485500
485600     MOVE 0 TO H-BUNDLE-ADJUST-AMT.
485700     MOVE 0 TO WK-MODEL1-BUNDLE-DISPRCNT.
485800
485900     IF '61' =  B-DEMO-CODE1  OR
486000                B-DEMO-CODE2  OR
486100                B-DEMO-CODE3  OR
486200                B-DEMO-CODE4
486300         NEXT SENTENCE
486400     ELSE
486500         MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
486600           GO TO 8000-EXIT.
486700
486800     IF P-MODEL1-BUNDLE-DISPRCNT > .00
486900           GO TO 8000-COMPUTE-BUNDLE
487000     ELSE
487100           NEXT SENTENCE.
487200
487300     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
487400           GO TO 8000-EXIT.
487500
487600 8000-COMPUTE-BUNDLE.
487700
487800     IF  B-DISCHARGE-DATE < 20140401 AND
487900         P-MODEL1-BUNDLE-DISPRCNT = .01
488000         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
488100          (1 - (P-MODEL1-BUNDLE-DISPRCNT * .5))
488200     ELSE
488300         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
488400          (1 - (P-MODEL1-BUNDLE-DISPRCNT * 1)).
488500
488600        COMPUTE H-BUNDLE-ADJUST-AMT      ROUNDED =
488700              ((WK-MODEL1-BUNDLE-DISPRCNT *
488800                                     H-OPER-BASE-DRG-PAY) -
488900                H-OPER-BASE-DRG-PAY).
489000
489100        COMPUTE H-BUNDLE-ADJUST-AMT ROUNDED = H-BUNDLE-ADJUST-AMT.
489200
489300 8000-EXIT.    EXIT.
489400
489500***********************************************************
489600 9000-CALC-EHR-SAVING.
489700***********************************************************
489800*---------------------------------------------------------*
489900* (YEARCHANGE 2016.0)
490000* CASES INVOLVING EHR SAVINGS
490100*   + FY16: ANNUAL UPDATE TO BELOW VALUES
490200*   + EHR-FULL = FULL MB / NO EHR MB
490300*   + EHR-QUAL-FULL = NO QUAL MB / NO QUAL & NO EHR MB
490400*---------------------------------------------------------*
490500
490600     MOVE 1.011940299 TO H-MB-RATIO-EHR-FULL.
490700     MOVE 1.012012012 TO H-MB-RATIO-EHR-QUAL-FULL.
490800     MOVE 0 TO H-EHR-SUBSAV-QUANT.
490900     MOVE 0 TO H-EHR-SUBSAV-LV.
491000     MOVE 0 TO H-EHR-SUBSAV-QUANT-INCLV.
491100     MOVE 0 TO H-EHR-RESTORE-FULL-QUANT.
491200
491300     IF P-EHR-REDUC-IND = 'Y'
491400         NEXT SENTENCE
491500     ELSE
491600         GO TO 9000-EXIT.
491700
491800 9000-COMPUTE-EHR.
491900
492000*
492100* LOGIC TO IMPLEMENT EHR SAVINGS CALCULATION -
492200* ACTUAL EHR REDUCTIONS WILL BE BUILT INTO NEW RATE
492300* TABLES (5,6,7,&8) UP FRONT BUT OESS WANTS TO HAVE THE
492400* AMOUNT OF MONEY THE EHR POLICY 'SAVED' IN ITS OWN FIELD
492500* WHICH INVOLVES RESTORING THE FULL MARKET  BASKET
492600* TO THE PAYMENT TO GET THE 'WOULD'VE PAID' AND THEN
492700* TAKING THE DIFFERENCE BETWEEN ACTUAL PAID AND
492800* WOULD'VE PAID FOR THE SAVINGS.  OUTLIERS ARE TO BE
492900* LEFT OUT AT MOMENT SINCE OUTLIER SHOULD BE LOWER
493000* ON THE FULL RATE THAN IT WINDS UP BEING ON THE
493100* REDUCED RATE - LIKEWISE NEW TECH IS BEING LEFT
493200* OUT.
493300*
493400*
493500* FOR EHR NEED TO EXCLUDE NEW TECH AND OUTLIERS FROM
493600* SAVINGS CALCULATION SO CALCULATE AN OPERATING
493700* PAYMENT SUBTOTAL ON SO CALCULATE AN OPERATING
493800* PAYMENT SUBTOTAL ON EHR PAYMENTS THAT EXCLUDES
493900* OUTLIERS AND NEW TECH FOR CLAIMS WITH AN EHR FLAG
494000*
494100*
494200
494300      COMPUTE H-EHR-SUBSAV-QUANT =
494400           (PPS-OPER-HSP-PART +
494500            PPS-OPER-FSP-PART +
494600            PPS-OPER-DSH-ADJ +
494700            PPS-OPER-IME-ADJ +
494800            H-READMIS-ADJUST-AMT +
494900            H-VAL-BASED-PURCH-ADJUST-AMT +
495000            H-BUNDLE-ADJUST-AMT).
495100
495200*
495300*
495400* NEED TO ENSURE THAT LOW VOLUME, IF APPLICABLE IS
495500* INCLUDED - CAN'T USE PRICER'S LOW VOLUME PAYMENT
495600* AS THAT INCLUDES NEW TECH OUTLIERS AND CAPITAL -
495700* READM VBP AND BUNDLE
495800* DON'T MULTIPLY BY LV ADJUSTMENT SO MAKE A NEW LV AMT
495900* FOR ERH SAVINGS FIELD;
496000*
496100*
496200*
496300
496400      MOVE 0 TO H-EHR-SUBSAV-LV.
496500
496600      IF  WK-LOW-VOL25PCT < 1.000000
496700
496800      COMPUTE H-EHR-SUBSAV-LV =
496900          (PPS-OPER-HSP-PART +
497000           PPS-OPER-FSP-PART +
497100           PPS-OPER-DSH-ADJ +
497200           PPS-OPER-IME-ADJ )  * WK-LOW-VOL25PCT.
497300
497400      COMPUTE H-EHR-SUBSAV-QUANT-INCLV =
497500           H-EHR-SUBSAV-QUANT + H-EHR-SUBSAV-LV.
497600
497700*
497800* H-MB-RATIO-EHR-FULL IS THE RATIO OF THE FULL MARKET
497900* BASKET TO THE REDUCED EHR MB - NEED TO CARRY 2 RATIOS
498000* FOR PROVIDERS FAILING EHR AND FOR PROVIDERS FAILING EHR
498100* AND QUALITY IN COMBINATION.  EHR SAVINGS REQUIRES
498200* BACKING OFF THE LOW UPDATE AND MULTIPLYING ON THE
498300* FULL UPDATE SO USING RATIO OF LOW/FULL AND LOW/QUALHIT
498400* OF .625 ONLY.
498500*
498600
498700       COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
498800       H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-FULL.
498900
499000     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1'
499100        COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
499200          H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-QUAL-FULL.
499300
499400        COMPUTE  H-EHR-ADJUST-AMT ROUNDED =
499500          H-EHR-RESTORE-FULL-QUANT - H-EHR-SUBSAV-QUANT-INCLV.
499600
499700
499800
499900 9000-EXIT.    EXIT.
500000
500100
500200*---------------------------------------------------------*
500300* (YEARCHANGE 2016.0)
500400*---------------------------------------------------------*
500500 9010-CALC-STANDARD-CHG.
500600
500700***********************************************************
500800***CM-P3 STANDARDIZED OPERATING COST CALCULATION
500900
501000     IF ((H-LABOR-PCT * H-WAGE-INDEX) +
501100               (H-NONLABOR-PCT * H-OPER-COLA)) > 0
501200        COMPUTE  H-OPER-BILL-STDZ-COSTS ROUNDED =
501300        (B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO) /
501400        ((H-LABOR-PCT * H-WAGE-INDEX) +
501500               (H-NONLABOR-PCT * H-OPER-COLA))
501600     ELSE MOVE 0 TO H-OPER-BILL-STDZ-COSTS.
501700
501800***********************************************************
501900***CM-P3 STANDARDIZED CAPITAL COST CALCULATION
502000
502100     IF (H-CAPI-GAF * H-CAPI-COLA) > 0
502200       COMPUTE  H-CAPI-BILL-STDZ-COSTS ROUNDED =
502300        (B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO) /
502400               (H-CAPI-GAF * H-CAPI-COLA)
502500     ELSE MOVE 0 TO H-CAPI-BILL-STDZ-COSTS.
502600
502700***********************************************************
502800***CM-P3 STANDARDIZED OPERATING TRESHOLD
502900
503000     MOVE 5467.39 TO H-OPER-BASE.
503100
503200     COMPUTE   H-OPER-STDZ-DOLLAR-THRESHOLD ROUNDED =
503300      (H-CST-THRESH * H-OPER-SHARE-DOLL-THRESHOLD)  +
503400                        +
503500           (H-OPER-BASE * H-DRG-WT-FRCTN)
503600                        +
503700              H-NEW-TECH-PAY-ADD-ON.
503800
503900******************************************************
504000***CM-P3 STANDARDIZED CAPITAL TRESHOLD
504100
504200     MOVE 438.75 TO H-CAPI-BASE.
504300
504400     COMPUTE   H-CAPI-STDZ-DOLLAR-THRESHOLD ROUNDED =
504500     (H-CST-THRESH * H-CAPI-SHARE-DOLL-THRESHOLD)
504600                     +
504700     (H-CAPI-BASE * H-DRG-WT-FRCTN).
504800
504900
505000******************************************************
505100***CM-P3 STANDARDIZED OPERATING OUTLIER CALCULATION
505200
505300     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
505400        (H-OPER-STDZ-DOLLAR-THRESHOLD +
505500                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
505600                          AND
505700         H-OPER-BILL-STDZ-COSTS > H-OPER-STDZ-DOLLAR-THRESHOLD
505800
505900       COMPUTE  H-OPER-STDZ-COST-OUTLIER ROUNDED =
506000        (H-CSTOUT-PCT  *
506100        (H-OPER-BILL-STDZ-COSTS - H-OPER-STDZ-DOLLAR-THRESHOLD))
506200
506300     ELSE
506400       MOVE 0 TO H-OPER-STDZ-COST-OUTLIER.
506500
506600******************************************************
506700***CM-P3 STANDARDIZED CAPITAL OUTLIER CALCULATION
506800
506900     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
507000        (H-OPER-STDZ-DOLLAR-THRESHOLD +
507100                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
507200                          AND
507300         H-CAPI-BILL-STDZ-COSTS > H-CAPI-STDZ-DOLLAR-THRESHOLD
507400
507500      COMPUTE  H-CAPI-STDZ-COST-OUTLIER ROUNDED =
507600      (H-CSTOUT-PCT  *
507700      (H-CAPI-BILL-STDZ-COSTS - H-CAPI-STDZ-DOLLAR-THRESHOLD))
507800     ELSE
507900      MOVE 0 TO H-CAPI-STDZ-COST-OUTLIER.
508000
508100*******************************************************
508200***CM-P3 STANDARDIZED ALLOWED AMOUNT CALCULATION
508300
508400      COMPUTE H-STANDARD-ALLOWED-AMOUNT ROUNDED =
508500       (H-OPER-BASE + H-CAPI-BASE)
508600                 *
508700       H-DRG-WT-FRCTN
508800                 +
508900       H-OPER-STDZ-COST-OUTLIER
509000                 +
509100       H-CAPI-STDZ-COST-OUTLIER
509200                 +
509300       H-NEW-TECH-PAY-ADD-ON.
509400
509500 9010-EXIT.    EXIT.
509600
509700***********************************************************
509800******        L A S T   S O U R C E   S T A T E M E N T   *****
