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