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