000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL156.
000300*AUTHOR.   15-04-15 03 PM   DDS TEAM.
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL156      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C15.6'.
002000 01  HMO-FLAG                       PIC X      VALUE 'N'.
002100 01  HMO-TAG                        PIC X      VALUE SPACE.
002200 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
002300 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
002400 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
002500 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
002600 01  WK-LOW-VOL25PCT                PIC 99V999999 VALUE 01.000.
002700 01  WK-LOW-VOL-ADDON               PIC 9(07)V9(02).
002800 01  WK-MODEL1-BUNDLE-DISPRCNT      PIC S9(01)V9(03).
002900 01  WK-HAC-TOTAL-PAYMENT           PIC 9(07)V9(02).
003000 01  WK-HAC-AMOUNT                  PIC S9(07)V9(02).
003100 01  R1                             PIC S9(04) COMP SYNC.
003200 01  R2                             PIC S9(04) COMP SYNC.
003300 01  R3                             PIC S9(04) COMP SYNC.
003400 01  R4                             PIC S9(04) COMP SYNC.
003500 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003600 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003700 01  H-MB-RATIO-EHR-FULL            PIC 9(01)V9(09).
003800 01  H-MB-RATIO-EHR-QUAL-FULL       PIC 9(01)V9(09).
003900 01  H-EHR-SUBSAV-QUANT             PIC S9(07)V9(02).
004000 01  H-EHR-SUBSAV-LV                PIC S9(07)V9(02).
004100 01  H-EHR-SUBSAV-QUANT-INCLV       PIC S9(07)V9(02).
004200 01  H-EHR-RESTORE-FULL-QUANT       PIC S9(07)V9(02).
004300
004400
004500***************************************************************
004600*   NOTE EHR = ' ' NO REDUCTION                  **************
004700*   NOTE EHR = 'Y'    REDUCTION                  **************
004800***************************************************************
004900**************YEARCHANGE 2015.1 *******************************
005000* TABLE 1                                                     *
005100* NATIONAL (69.6% LABOR SHARE/30.4% NONLABOR SHARE)
005200* PUERTO RICO  (63.2% LABOR SHARE/36.8% NONLABOR SHARE)
005300*    (FULL    UPDATE                                          *
005400*    (QUALITY = 1 WAGE INDEX > 1 EHR = ' '                    *
005500***************************************************************
005600 01  TB1-RATE-TABLE.
005700     02  TB1-RATE-WORK.
005800*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
005900*                  R3=1     /     R3=2
006000*               LARGE URBAN / OTHER URBAN
006100*               LABOR / NON / LABOR / NON
006200*                     /LABOR/       /LABOR
006300*             --------------------------------------------
006400         05  FILLER PIC X(08) VALUE '20141001'.
006500         05  TB1-NAT    PIC X(30) VALUE
006600            ' 0378475 165310 0378475 165310'.
006700         05  TB1-PR     PIC X(30) VALUE
006800            ' 0160997 093745 0160997 093745'.
006900         05  TB1-NATPR  PIC X(30) VALUE
007000            ' 0378475 165310 0378475 165310'.
007100***************************************************************
007200     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
007300         05  TB1-RATE-PERIOD            OCCURS 1.
007400             10  TB1-RATE-EFF-DATE      PIC X(08).
007500             10  TB1-REG-NAT            OCCURS 3.
007600                 15  TB1-LARGE-OTHER    OCCURS 2.
007700                     20  FILLER         PIC X(01).
007800                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
007900                     20  FILLER         PIC X(01).
008000                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
008100
008200***************************************************************
008300************YEARCHANGE 2015.1 *********************************
008400* TABLE 2                                                     *
008500* NATIONAL (69.6% LABOR SHARE/30.4% NONLABOR SHARE)
008600* PUERTO RICO  (63.2% LABOR SHARE/36.8% NONLABOR SHARE)
008700*    (REDUCED UPDATE                                          *
008800*    (QUALITY NOT = 1 WAGE INDEX > 1 EHR = ' '                *
008900***************************************************************
009000 01  TB2-RATE-TABLE.
009100     02  TB2-RATE-WORK.
009200*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
009300*                  R3=1     /     R3=2
009400*               LARGE URBAN / OTHER URBAN
009500*               LABOR / NON / LABOR / NON
009600*                     /LABOR/       /LABOR
009700*             --------------------------------------------
009800         05  FILLER PIC X(08) VALUE '20141001'.
009900         05  TB2-NAT    PIC X(30) VALUE
010000            ' 0375790 164137 0375790 164137'.
010100         05  TB2-PR     PIC X(30) VALUE
010200            ' 0160997 093745 0160997 093745'.
010300         05  TB2-NATPR  PIC X(30) VALUE
010400            ' 0378475 163257 0378475 163257'.
010500***************************************************************
010600     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
010700         05  TB2-RATE-PERIOD             OCCURS 1.
010800             10  TB2-RATE-EFF-DATE       PIC X(08).
010900             10  TB2-REG-NAT             OCCURS 3.
011000                 15  TB2-LARGE-OTHER     OCCURS 2.
011100                     20  FILLER          PIC X(01).
011200                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
011300                     20  FILLER          PIC X(01).
011400                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
011500***************************************************************
011600************YEARCHANGE 2015.1 *********************************
011700* TABLE 3                                                     *
011800*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
011900*    (FULL UPDATE                                             *
012000*    (QUALITY = 1 WAGE INDEX <= 1 EHR = ' ')                  *
012100***************************************************************
012200 01  TB3-RATE-TABLE.
012300     02  TB3-RATE-WORK.
012400*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
012500*                  R3=1     /     R3=2
012600*               LARGE URBAN / OTHER URBAN
012700*               LABOR / NON / LABOR / NON
012800*                     /LABOR/       /LABOR
012900*             --------------------------------------------
013000         05  FILLER PIC X(08) VALUE '20141001'.
013100         05  TB3-NAT    PIC X(30) VALUE
013200            ' 0337147 206638 0337147 206638'.
013300         05  TB3-PR     PIC X(30) VALUE
013400            ' 0157940 096802 0157940 096802'.
013500         05  TB3-NATPR  PIC X(30) VALUE
013600            ' 0337147 206638 0337147 206638'.
013700****************************************************************
013800     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
013900         05  TB3-RATE-PERIOD            OCCURS 1.
014000             10  TB3-RATE-EFF-DATE      PIC X(08).
014100             10  TB3-REG-NAT            OCCURS 3.
014200                 15  TB3-LARGE-OTHER    OCCURS 2.
014300                     20  FILLER         PIC X(01).
014400                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
014500                     20  FILLER         PIC X(01).
014600                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
014700
014800***************************************************************
014900**********YEARCHANGE 2015.1 ***********************************
015000* TABLE 4                                                     *
015100*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
015200*    (REDUCED UPDATE                                          *
015300*    (QUALITY NOT = 1 WAGE INDEX <=1 EHR = ' ')               *
015400***************************************************************
015500 01  TB4-RATE-TABLE.
015600     02  TB4-RATE-WORK.
015700*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
015800*                  R3=1     /     R3=2
015900*               LARGE URBAN / OTHER URBAN
016000*               LABOR / NON / LABOR / NON
016100*                     /LABOR/       /LABOR
016200*             --------------------------------------------
016300         05  FILLER PIC X(08) VALUE '20141001'.
016400         05  TB4-NAT    PIC X(30) VALUE
016500            ' 0334755 205172 0334755 205172'.
016600         05  TB4-PR     PIC X(30) VALUE
016700            ' 0157940 096802 0157940 096802'.
016800         05  TB4-NATPR  PIC X(30) VALUE
016900            ' 0337147 206638 0337147 206638'.
017000***************************************************************
017100     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
017200         05  TB4-RATE-PERIOD             OCCURS 1.
017300             10  TB4-RATE-EFF-DATE       PIC X(08).
017400             10  TB4-REG-NAT             OCCURS 3.
017500                 15  TB4-LARGE-OTHER     OCCURS 2.
017600                     20  FILLER          PIC X(01).
017700                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
017800                     20  FILLER          PIC X(01).
017900                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
018000
018100**=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*
018200***************************************************************
018300**************YEARCHANGE 2015.1 *******************************
018400* TABLE 5   RATES WITH E.H.R. LOWER MARKET BASKET             *
018500* NATIONAL (69.6% LABOR SHARE/30.4% NONLABOR SHARE)
018600* PUERTO RICO  (63.2% LABOR SHARE/36.8% NONLABOR SHARE)
018700*    (FULL    UPDATE                                          *
018800*    (QUALITY = 1 WAGE INDEX > 1 EHR = 'Y')                   *
018900***************************************************************
019000 01  TB5-RATE-TABLE.
019100     02  TB5-RATE-WORK.
019200*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
019300*                  R3=1     /     R3=2
019400*               LARGE URBAN / OTHER URBAN
019500*               LABOR / NON / LABOR / NON
019600*                     /LABOR/       /LABOR
019700*             --------------------------------------------
019800         05  FILLER PIC X(08) VALUE '20141001'.
019900         05  TB5-NAT    PIC X(30) VALUE
020000            ' 0375790 164137 0375790 164137'.
020100         05  TB5-PR     PIC X(30) VALUE
020200            ' 0160997 093745 0160997 093745'.
020300         05  TB5-NATPR  PIC X(30) VALUE
020400            ' 0378475 165310 0378475 165310'.
020500***************************************************************
020600     02  TB5-RATE-TAB REDEFINES TB5-RATE-WORK.
020700         05  TB5-RATE-PERIOD            OCCURS 1.
020800             10  TB5-RATE-EFF-DATE      PIC X(08).
020900             10  TB5-REG-NAT            OCCURS 3.
021000                 15  TB5-LARGE-OTHER    OCCURS 2.
021100                     20  FILLER         PIC X(01).
021200                     20  TB5-REG-LABOR  PIC 9(05)V9(02).
021300                     20  FILLER         PIC X(01).
021400                     20  TB5-REG-NLABOR PIC 9(04)V9(02).
021500
021600***************************************************************
021700************YEARCHANGE 2015.1 *********************************
021800* TABLE 6 RATES WITH E.H.R. LOWER MARKET BASKET               *
021900* NATIONAL (69.6% LABOR SHARE/30.4% NONLABOR SHARE)
022000* PUERTO RICO  (63.2% LABOR SHARE/36.8% NONLABOR SHARE)
022100*    (REDUCED UPDATE                                          *
022200*    (QUALITY NOT = 1 WAGE INDEX > 1 EHR = 'Y')               *
022300***************************************************************
022400 01  TB6-RATE-TABLE.
022500     02  TB6-RATE-WORK.
022600*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
022700*                  R3=1     /     R3=2
022800*               LARGE URBAN / OTHER URBAN
022900*               LABOR / NON / LABOR / NON
023000*                     /LABOR/       /LABOR
023100*             --------------------------------------------
023200         05  FILLER PIC X(08) VALUE '20141001'.
023300         05  TB6-NAT    PIC X(30) VALUE
023400            ' 0373105 162965 0373105 162965'.
023500         05  TB6-PR     PIC X(30) VALUE
023600            ' 0160997 093745 0160997 093745'.
023700         05  TB6-NATPR  PIC X(30) VALUE
023800            ' 0378475 165310 0378475 165310'.
023900***************************************************************
024000     02  TB6-RATE-TAB REDEFINES TB6-RATE-WORK.
024100         05  TB6-RATE-PERIOD             OCCURS 1.
024200             10  TB6-RATE-EFF-DATE       PIC X(08).
024300             10  TB6-REG-NAT             OCCURS 3.
024400                 15  TB6-LARGE-OTHER     OCCURS 2.
024500                     20  FILLER          PIC X(01).
024600                     20  TB6-REG-LABOR   PIC 9(05)V9(02).
024700                     20  FILLER          PIC X(01).
024800                     20  TB6-REG-NLABOR  PIC 9(04)V9(02).
024900***************************************************************
025000************YEARCHANGE 2015.1 *********************************
025100* TABLE 7  RATES WITH E.H.R. LOWER MARKET BASKET              *
025200*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
025300*    (FULL UPDATE                                             *
025400*    (QUALITY = 1 WAGE INDEX <= 1 EHR = 'Y')                  *
025500***************************************************************
025600 01  TB7-RATE-TABLE.
025700     02  TB7-RATE-WORK.
025800*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
025900*                  R3=1     /     R3=2
026000*               LARGE URBAN / OTHER URBAN
026100*               LABOR / NON / LABOR / NON
026200*                     /LABOR/       /LABOR
026300*             --------------------------------------------
026400         05  FILLER PIC X(08) VALUE '20141001'.
026500         05  TB7-NAT    PIC X(30) VALUE
026600            ' 0334755 205172 0334755 205172'.
026700         05  TB7-PR     PIC X(30) VALUE
026800            ' 0157940 096802 0157940 096802'.
026900         05  TB7-NATPR  PIC X(30) VALUE
027000            ' 0337147 206638 0337147 206638'.
027100****************************************************************
027200     02  TB7-RATE-TAB REDEFINES TB7-RATE-WORK.
027300         05  TB7-RATE-PERIOD            OCCURS 1.
027400             10  TB7-RATE-EFF-DATE      PIC X(08).
027500             10  TB7-REG-NAT            OCCURS 3.
027600                 15  TB7-LARGE-OTHER    OCCURS 2.
027700                     20  FILLER         PIC X(01).
027800                     20  TB7-REG-LABOR  PIC 9(05)V9(02).
027900                     20  FILLER         PIC X(01).
028000                     20  TB7-REG-NLABOR PIC 9(04)V9(02).
028100
028200***************************************************************
028300**********YEARCHANGE 2015.1 ***********************************
028400* TABLE 8 RATES WITH E.H.R. LOWER MARKET BASKET               *
028500*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
028600*    (REDUCED UPDATE                                          *
028700*    (QUALITY NOT = 1 WAGE INDEX <=1 EHR = 'Y')               *
028800***************************************************************
028900 01  TB8-RATE-TABLE.
029000     02  TB8-RATE-WORK.
029100*RATE 20141001 REGION  LABOR AND NON-LABOR RATES
029200*                  R3=1     /     R3=2
029300*               LARGE URBAN / OTHER URBAN
029400*               LABOR / NON / LABOR / NON
029500*                     /LABOR/       /LABOR
029600*             --------------------------------------------
029700         05  FILLER PIC X(08) VALUE '20141001'.
029800         05  TB8-NAT    PIC X(30) VALUE
029900            ' 0332363 203707 0332363 203707'.
030000         05  TB8-PR     PIC X(30) VALUE
030100            ' 0157940 096802 0157940 096802'.
030200         05  TB8-NATPR  PIC X(30) VALUE
030300            ' 0337147 206638 0337147 206638'.
030400***************************************************************
030500     02  TB8-RATE-TAB REDEFINES TB8-RATE-WORK.
030600         05  TB8-RATE-PERIOD             OCCURS 1.
030700             10  TB8-RATE-EFF-DATE       PIC X(08).
030800             10  TB8-REG-NAT             OCCURS 3.
030900                 15  TB8-LARGE-OTHER     OCCURS 2.
031000                     20  FILLER          PIC X(01).
031100                     20  TB8-REG-LABOR   PIC 9(05)V9(02).
031200                     20  FILLER          PIC X(01).
031300                     20  TB8-REG-NLABOR  PIC 9(04)V9(02).
031400
031500***************************************************************
031600**********YEARCHANGE 2015.1 ***********************************
031700***************************************************************
031800*  TABLE 5 FROM ANNUAL IPPS FINAL RULE
031900***************************************************************
032000 01  WK-DRGX-EFF-DATE      PIC X(08) VALUE '20141001'.
032100 01  PPS-DRG-TABLE.
032200     02  WK-DRG-DATA.
032300****** 08/01/2014 **********
032400         05  FILLER   PIC X(57)  VALUE
032500     '001 253920 286       368       HEART TRANSPLANT OR IMPLAN'.
032600         05  FILLER   PIC X(57)  VALUE
032700     '002 156820 157       187       HEART TRANSPLANT OR IMPLAN'.
032800         05  FILLER   PIC X(57)  VALUE
032900     '003 176399 263       322  Y    ECMO OR TRACH W MV 96+ HRS'.
033000         05  FILLER   PIC X(57)  VALUE
033100     '004 108533 202       244  Y    TRACH W MV 96+ HRS OR PDX '.
033200         05  FILLER   PIC X(57)  VALUE
033300     '005 104973 152       207       LIVER TRANSPLANT W MCC OR '.
033400         05  FILLER   PIC X(57)  VALUE
033500     '006 047461 079       088       LIVER TRANSPLANT W/O MCC  '.
033600         05  FILLER   PIC X(57)  VALUE
033700     '007 092986 159       186       LUNG TRANSPLANT           '.
033800         05  FILLER   PIC X(57)  VALUE
033900     '008 053302 098       113       SIMULTANEOUS PANCREAS/KIDN'.
034000         05  FILLER   PIC X(57)  VALUE
034100     '010 040849 078       096       PANCREAS TRANSPLANT       '.
034200         05  FILLER   PIC X(57)  VALUE
034300     '011 047380 113       141       TRACHEOSTOMY FOR FACE,MOUT'.
034400         05  FILLER   PIC X(57)  VALUE
034500     '012 033293 084       100       TRACHEOSTOMY FOR FACE,MOUT'.
034600         05  FILLER   PIC X(57)  VALUE
034700     '013 021357 058       066       TRACHEOSTOMY FOR FACE,MOUT'.
034800         05  FILLER   PIC X(57)  VALUE
034900     '014 109883 200       251       ALLOGENEIC BONE MARROW TRA'.
035000         05  FILLER   PIC X(57)  VALUE
035100     '016 058780 175       191       AUTOLOGOUS BONE MARROW TRA'.
035200         05  FILLER   PIC X(57)  VALUE
035300     '017 041603 089       124       AUTOLOGOUS BONE MARROW TRA'.
035400         05  FILLER   PIC X(57)  VALUE
035500     '020 094423 139       168       INTRACRANIAL VASCULAR PROC'.
035600         05  FILLER   PIC X(57)  VALUE
035700     '021 071555 119       134       INTRACRANIAL VASCULAR PROC'.
035800         05  FILLER   PIC X(57)  VALUE
035900     '022 044934 063       078       INTRACRANIAL VASCULAR PROC'.
036000         05  FILLER   PIC X(57)  VALUE
036100     '023 052939 079       110  Y    CRANIO W MAJOR DEV IMPL/AC'.
036200         05  FILLER   PIC X(57)  VALUE
036300     '024 037461 044       063  Y    CRANIO W MAJOR DEV IMPL/AC'.
036400         05  FILLER   PIC X(57)  VALUE
036500     '025 043374 074       097  Y    CRANIOTOMY & ENDOVASCULAR '.
036600         05  FILLER   PIC X(57)  VALUE
036700     '026 030011 047       061  Y    CRANIOTOMY & ENDOVASCULAR '.
036800         05  FILLER   PIC X(57)  VALUE
036900     '027 022824 025       033  Y    CRANIOTOMY & ENDOVASCULAR '.
037000         05  FILLER   PIC X(57)  VALUE
037100     '028 053968 096       123  Y Y  SPINAL PROCEDURES W MCC   '.
037200         05  FILLER   PIC X(57)  VALUE
037300     '029 031573 048       064  Y Y  SPINAL PROCEDURES W CC OR '.
037400         05  FILLER   PIC X(57)  VALUE
037500     '030 017835 026       034  Y Y  SPINAL PROCEDURES W/O CC/M'.
037600         05  FILLER   PIC X(57)  VALUE
037700     '031 041493 077       110  Y    VENTRICULAR SHUNT PROCEDUR'.
037800         05  FILLER   PIC X(57)  VALUE
037900     '032 020325 033       047  Y    VENTRICULAR SHUNT PROCEDUR'.
038000         05  FILLER   PIC X(57)  VALUE
038100     '033 015602 020       025  Y    VENTRICULAR SHUNT PROCEDUR'.
038200         05  FILLER   PIC X(57)  VALUE
038300     '034 037008 045       066       CAROTID ARTERY STENT PROCE'.
038400         05  FILLER   PIC X(57)  VALUE
038500     '035 022109 020       029       CAROTID ARTERY STENT PROCE'.
038600         05  FILLER   PIC X(57)  VALUE
038700     '036 017313 013       015       CAROTID ARTERY STENT PROCE'.
038800         05  FILLER   PIC X(57)  VALUE
038900     '037 031459 056       080       EXTRACRANIAL PROCEDURES W '.
039000         05  FILLER   PIC X(57)  VALUE
039100     '038 015870 023       034       EXTRACRANIAL PROCEDURES W '.
039200         05  FILLER   PIC X(57)  VALUE
039300     '039 010582 013       016       EXTRACRANIAL PROCEDURES W/'.
039400         05  FILLER   PIC X(57)  VALUE
039500     '040 037960 083       112  Y Y  PERIPH/CRANIAL NERVE & OTH'.
039600         05  FILLER   PIC X(57)  VALUE
039700     '041 021267 049       062  Y Y  PERIPH/CRANIAL NERVE & OTH'.
039800         05  FILLER   PIC X(57)  VALUE
039900     '042 018586 027       035  Y Y  PERIPH/CRANIAL NERVE & OTH'.
040000         05  FILLER   PIC X(57)  VALUE
040100     '052 015813 042       057       SPINAL DISORDERS & INJURIE'.
040200         05  FILLER   PIC X(57)  VALUE
040300     '053 009294 027       035       SPINAL DISORDERS & INJURIE'.
040400         05  FILLER   PIC X(57)  VALUE
040500     '054 013048 039       053  Y    NERVOUS SYSTEM NEOPLASMS W'.
040600         05  FILLER   PIC X(57)  VALUE
040700     '055 010191 030       041  Y    NERVOUS SYSTEM NEOPLASMS W'.
040800         05  FILLER   PIC X(57)  VALUE
040900     '056 017615 052       071  Y    DEGENERATIVE NERVOUS SYSTE'.
041000         05  FILLER   PIC X(57)  VALUE
041100     '057 010099 036       048  Y    DEGENERATIVE NERVOUS SYSTE'.
041200         05  FILLER   PIC X(57)  VALUE
041300     '058 016336 052       071       MULTIPLE SCLEROSIS & CEREB'.
041400         05  FILLER   PIC X(57)  VALUE
041500     '059 010290 039       047       MULTIPLE SCLEROSIS & CEREB'.
041600         05  FILLER   PIC X(57)  VALUE
041700     '060 007867 030       036       MULTIPLE SCLEROSIS & CEREB'.
041800         05  FILLER   PIC X(57)  VALUE
041900     '061 027571 057       074       ACUTE ISCHEMIC STROKE W US'.
042000         05  FILLER   PIC X(57)  VALUE
042100     '062 018555 041       048       ACUTE ISCHEMIC STROKE W US'.
042200         05  FILLER   PIC X(57)  VALUE
042300     '063 015098 030       034       ACUTE ISCHEMIC STROKE W US'.
042400         05  FILLER   PIC X(57)  VALUE
042500     '064 017381 046       063  Y    INTRACRANIAL HEMORRHAGE OR'.
042600         05  FILLER   PIC X(57)  VALUE
042700     '065 010643 034       042  Y    INTRACRANIAL HEMORRHAGE OR'.
042800         05  FILLER   PIC X(57)  VALUE
042900     '066 007530 024       028  Y    INTRACRANIAL HEMORRHAGE OR'.
043000         05  FILLER   PIC X(57)  VALUE
043100     '067 014527 041       054       NONSPECIFIC CVA & PRECEREB'.
043200         05  FILLER   PIC X(57)  VALUE
043300     '068 008395 024       030       NONSPECIFIC CVA & PRECEREB'.
043400         05  FILLER   PIC X(57)  VALUE
043500     '069 006985 021       026       TRANSIENT ISCHEMIA        '.
043600         05  FILLER   PIC X(57)  VALUE
043700     '070 016438 048       065  Y    NONSPECIFIC CEREBROVASCULA'.
043800         05  FILLER   PIC X(57)  VALUE
043900     '071 009748 035       045  Y    NONSPECIFIC CEREBROVASCULA'.
044000         05  FILLER   PIC X(57)  VALUE
044100     '072 006947 023       029  Y    NONSPECIFIC CEREBROVASCULA'.
044200         05  FILLER   PIC X(57)  VALUE
044300     '073 013290 040       053       CRANIAL & PERIPHERAL NERVE'.
044400         05  FILLER   PIC X(57)  VALUE
044500     '074 008847 030       038       CRANIAL & PERIPHERAL NERVE'.
044600         05  FILLER   PIC X(57)  VALUE
044700     '075 016595 052       066       VIRAL MENINGITIS W CC/MCC '.
044800         05  FILLER   PIC X(57)  VALUE
044900     '076 008629 032       038       VIRAL MENINGITIS W/O CC/MC'.
045000         05  FILLER   PIC X(57)  VALUE
045100     '077 016245 046       060       HYPERTENSIVE ENCEPHALOPATH'.
045200         05  FILLER   PIC X(57)  VALUE
045300     '078 009361 032       040       HYPERTENSIVE ENCEPHALOPATH'.
045400         05  FILLER   PIC X(57)  VALUE
045500     '079 006677 023       027       HYPERTENSIVE ENCEPHALOPATH'.
045600         05  FILLER   PIC X(57)  VALUE
045700     '080 012790 037       052       NONTRAUMATIC STUPOR & COMA'.
045800         05  FILLER   PIC X(57)  VALUE
045900     '081 007850 027       036       NONTRAUMATIC STUPOR & COMA'.
046000         05  FILLER   PIC X(57)  VALUE
046100     '082 019142 032       054       TRAUMATIC STUPOR & COMA, C'.
046200         05  FILLER   PIC X(57)  VALUE
046300     '083 012401 033       042       TRAUMATIC STUPOR & COMA, C'.
046400         05  FILLER   PIC X(57)  VALUE
046500     '084 008592 021       026       TRAUMATIC STUPOR & COMA, C'.
046600         05  FILLER   PIC X(57)  VALUE
046700     '085 019770 047       065  Y    TRAUMATIC STUPOR & COMA, C'.
046800         05  FILLER   PIC X(57)  VALUE
046900     '086 011181 032       041  Y    TRAUMATIC STUPOR & COMA, C'.
047000         05  FILLER   PIC X(57)  VALUE
047100     '087 007460 021       026  Y    TRAUMATIC STUPOR & COMA, C'.
047200         05  FILLER   PIC X(57)  VALUE
047300     '088 015708 038       054       CONCUSSION W MCC          '.
047400         05  FILLER   PIC X(57)  VALUE
047500     '089 009588 027       033       CONCUSSION W CC           '.
047600         05  FILLER   PIC X(57)  VALUE
047700     '090 007353 018       022       CONCUSSION W/O CC/MCC     '.
047800         05  FILLER   PIC X(57)  VALUE
047900     '091 015978 042       059  Y    OTHER DISORDERS OF NERVOUS'.
048000         05  FILLER   PIC X(57)  VALUE
048100     '092 008989 031       039  Y    OTHER DISORDERS OF NERVOUS'.
048200         05  FILLER   PIC X(57)  VALUE
048300     '093 006783 022       027  Y    OTHER DISORDERS OF NERVOUS'.
048400         05  FILLER   PIC X(57)  VALUE
048500     '094 033357 082       107       BACTERIAL & TUBERCULOUS IN'.
048600         05  FILLER   PIC X(57)  VALUE
048700     '095 023844 060       076       BACTERIAL & TUBERCULOUS IN'.
048800         05  FILLER   PIC X(57)  VALUE
048900     '096 020726 045       053       BACTERIAL & TUBERCULOUS IN'.
049000         05  FILLER   PIC X(57)  VALUE
049100     '097 031625 085       109       NON-BACTERIAL INFECT OF NE'.
049200         05  FILLER   PIC X(57)  VALUE
049300     '098 017189 055       069       NON-BACTERIAL INFECT OF NE'.
049400         05  FILLER   PIC X(57)  VALUE
049500     '099 011609 038       047       NON-BACTERIAL INFECT OF NE'.
049600         05  FILLER   PIC X(57)  VALUE
049700     '100 015304 042       056  Y    SEIZURES W MCC            '.
049800         05  FILLER   PIC X(57)  VALUE
049900     '101 007567 026       032  Y    SEIZURES W/O MCC          '.
050000         05  FILLER   PIC X(57)  VALUE
050100     '102 010073 030       040       HEADACHES W MCC           '.
050200         05  FILLER   PIC X(57)  VALUE
050300     '103 006915 023       029       HEADACHES W/O MCC         '.
050400         05  FILLER   PIC X(57)  VALUE
050500     '113 018611 038       052       ORBITAL PROCEDURES W CC/MC'.
050600         05  FILLER   PIC X(57)  VALUE
050700     '114 011568 024       031       ORBITAL PROCEDURES W/O CC/'.
050800         05  FILLER   PIC X(57)  VALUE
050900     '115 012780 035       046       EXTRAOCULAR PROCEDURES EXC'.
051000         05  FILLER   PIC X(57)  VALUE
051100     '116 014005 033       046       INTRAOCULAR PROCEDURES W C'.
051200         05  FILLER   PIC X(57)  VALUE
051300     '117 008239 018       022       INTRAOCULAR PROCEDURES W/O'.
051400         05  FILLER   PIC X(57)  VALUE
051500     '121 010635 040       050       ACUTE MAJOR EYE INFECTIONS'.
051600         05  FILLER   PIC X(57)  VALUE
051700     '122 006352 031       038       ACUTE MAJOR EYE INFECTIONS'.
051800         05  FILLER   PIC X(57)  VALUE
051900     '123 006732 020       025       NEUROLOGICAL EYE DISORDERS'.
052000         05  FILLER   PIC X(57)  VALUE
052100     '124 011432 034       046       OTHER DISORDERS OF THE EYE'.
052200         05  FILLER   PIC X(57)  VALUE
052300     '125 006852 024       031       OTHER DISORDERS OF THE EYE'.
052400         05  FILLER   PIC X(57)  VALUE
052500     '129 023284 038       054       MAJOR HEAD & NECK PROCEDUR'.
052600         05  FILLER   PIC X(57)  VALUE
052700     '130 012599 023       028       MAJOR HEAD & NECK PROCEDUR'.
052800         05  FILLER   PIC X(57)  VALUE
052900     '131 023703 041       057       CRANIAL/FACIAL PROCEDURES '.
053000         05  FILLER   PIC X(57)  VALUE
053100     '132 014248 022       027       CRANIAL/FACIAL PROCEDURES '.
053200         05  FILLER   PIC X(57)  VALUE
053300     '133 018644 037       054       OTHER EAR, NOSE, MOUTH & T'.
053400         05  FILLER   PIC X(57)  VALUE
053500     '134 010083 019       024       OTHER EAR, NOSE, MOUTH & T'.
053600         05  FILLER   PIC X(57)  VALUE
053700     '135 019150 042       057       SINUS & MASTOID PROCEDURES'.
053800         05  FILLER   PIC X(57)  VALUE
053900     '136 010509 018       024       SINUS & MASTOID PROCEDURES'.
054000         05  FILLER   PIC X(57)  VALUE
054100     '137 013735 037       049       MOUTH PROCEDURES W CC/MCC '.
054200         05  FILLER   PIC X(57)  VALUE
054300     '138 007888 019       024       MOUTH PROCEDURES W/O CC/MC'.
054400         05  FILLER   PIC X(57)  VALUE
054500     '139 009856 016       021       SALIVARY GLAND PROCEDURES '.
054600         05  FILLER   PIC X(57)  VALUE
054700     '146 019749 058       082       EAR, NOSE, MOUTH & THROAT '.
054800         05  FILLER   PIC X(57)  VALUE
054900     '147 012869 039       054       EAR, NOSE, MOUTH & THROAT '.
055000         05  FILLER   PIC X(57)  VALUE
055100     '148 008205 023       031       EAR, NOSE, MOUTH & THROAT '.
055200         05  FILLER   PIC X(57)  VALUE
055300     '149 006342 020       025       DYSEQUILIBRIUM            '.
055400         05  FILLER   PIC X(57)  VALUE
055500     '150 012943 037       049       EPISTAXIS W MCC           '.
055600         05  FILLER   PIC X(57)  VALUE
055700     '151 006690 022       027       EPISTAXIS W/O MCC         '.
055800         05  FILLER   PIC X(57)  VALUE
055900     '152 010162 036       045       OTITIS MEDIA & URI W MCC  '.
056000         05  FILLER   PIC X(57)  VALUE
056100     '153 006884 027       032       OTITIS MEDIA & URI W/O MCC'.
056200         05  FILLER   PIC X(57)  VALUE
056300     '154 013703 041       054       OTHER EAR, NOSE, MOUTH & T'.
056400         05  FILLER   PIC X(57)  VALUE
056500     '155 008848 031       039       OTHER EAR, NOSE, MOUTH & T'.
056600         05  FILLER   PIC X(57)  VALUE
056700     '156 006516 023       028       OTHER EAR, NOSE, MOUTH & T'.
056800         05  FILLER   PIC X(57)  VALUE
056900     '157 015814 047       063       DENTAL & ORAL DISEASES W M'.
057000         05  FILLER   PIC X(57)  VALUE
057100     '158 008519 030       039       DENTAL & ORAL DISEASES W C'.
057200         05  FILLER   PIC X(57)  VALUE
057300     '159 005935 020       025       DENTAL & ORAL DISEASES W/O'.
057400         05  FILLER   PIC X(57)  VALUE
057500     '163 050332 108       132  Y    MAJOR CHEST PROCEDURES W M'.
057600         05  FILLER   PIC X(57)  VALUE
057700     '164 026010 054       066  Y    MAJOR CHEST PROCEDURES W C'.
057800         05  FILLER   PIC X(57)  VALUE
057900     '165 018220 033       039  Y    MAJOR CHEST PROCEDURES W/O'.
058000         05  FILLER   PIC X(57)  VALUE
058100     '166 036610 087       111  Y    OTHER RESP SYSTEM O.R. PRO'.
058200         05  FILLER   PIC X(57)  VALUE
058300     '167 019818 052       066  Y    OTHER RESP SYSTEM O.R. PRO'.
058400         05  FILLER   PIC X(57)  VALUE
058500     '168 013291 031       039  Y    OTHER RESP SYSTEM O.R. PRO'.
058600         05  FILLER   PIC X(57)  VALUE
058700     '175 015271 052       063  Y    PULMONARY EMBOLISM W MCC  '.
058800         05  FILLER   PIC X(57)  VALUE
058900     '176 009670 035       042  Y    PULMONARY EMBOLISM W/O MCC'.
059000         05  FILLER   PIC X(57)  VALUE
059100     '177 019492 062       077  Y    RESPIRATORY INFECTIONS & I'.
059200         05  FILLER   PIC X(57)  VALUE
059300     '178 013909 050       061  Y    RESPIRATORY INFECTIONS & I'.
059400         05  FILLER   PIC X(57)  VALUE
059500     '179 009693 037       045  Y    RESPIRATORY INFECTIONS & I'.
059600         05  FILLER   PIC X(57)  VALUE
059700     '180 016869 053       069       RESPIRATORY NEOPLASMS W MC'.
059800         05  FILLER   PIC X(57)  VALUE
059900     '181 011582 037       049       RESPIRATORY NEOPLASMS W CC'.
060000         05  FILLER   PIC X(57)  VALUE
060100     '182 008088 026       033       RESPIRATORY NEOPLASMS W/O '.
060200         05  FILLER   PIC X(57)  VALUE
060300     '183 015101 048       060       MAJOR CHEST TRAUMA W MCC  '.
060400         05  FILLER   PIC X(57)  VALUE
060500     '184 009889 034       040       MAJOR CHEST TRAUMA W CC   '.
060600         05  FILLER   PIC X(57)  VALUE
060700     '185 006628 024       028       MAJOR CHEST TRAUMA W/O CC/'.
060800         05  FILLER   PIC X(57)  VALUE
060900     '186 015452 048       062  Y    PLEURAL EFFUSION W MCC    '.
061000         05  FILLER   PIC X(57)  VALUE
061100     '187 010691 035       045  Y    PLEURAL EFFUSION W CC     '.
061200         05  FILLER   PIC X(57)  VALUE
061300     '188 007609 026       032  Y    PLEURAL EFFUSION W/O CC/MC'.
061400         05  FILLER   PIC X(57)  VALUE
061500     '189 012136 039       050       PULMONARY EDEMA & RESPIRAT'.
061600         05  FILLER   PIC X(57)  VALUE
061700     '190 011743 042       051  Y    CHRONIC OBSTRUCTIVE PULMON'.
061800         05  FILLER   PIC X(57)  VALUE
061900     '191 009370 034       042  Y    CHRONIC OBSTRUCTIVE PULMON'.
062000         05  FILLER   PIC X(57)  VALUE
062100     '192 007190 028       033  Y    CHRONIC OBSTRUCTIVE PULMON'.
062200         05  FILLER   PIC X(57)  VALUE
062300     '193 014491 049       060  Y    SIMPLE PNEUMONIA & PLEURIS'.
062400         05  FILLER   PIC X(57)  VALUE
062500     '194 009688 038       045  Y    SIMPLE PNEUMONIA & PLEURIS'.
062600         05  FILLER   PIC X(57)  VALUE
062700     '195 007044 029       034  Y    SIMPLE PNEUMONIA & PLEURIS'.
062800         05  FILLER   PIC X(57)  VALUE
062900     '196 016635 054       069  Y    INTERSTITIAL LUNG DISEASE '.
063000         05  FILLER   PIC X(57)  VALUE
063100     '197 010615 037       046  Y    INTERSTITIAL LUNG DISEASE '.
063200         05  FILLER   PIC X(57)  VALUE
063300     '198 008054 028       034  Y    INTERSTITIAL LUNG DISEASE '.
063400         05  FILLER   PIC X(57)  VALUE
063500     '199 018345 058       075       PNEUMOTHORAX W MCC        '.
063600         05  FILLER   PIC X(57)  VALUE
063700     '200 010084 034       044       PNEUMOTHORAX W CC         '.
063800         05  FILLER   PIC X(57)  VALUE
063900     '201 007096 025       032       PNEUMOTHORAX W/O CC/MCC   '.
064000         05  FILLER   PIC X(57)  VALUE
064100     '202 008775 032       039       BRONCHITIS & ASTHMA W CC/M'.
064200         05  FILLER   PIC X(57)  VALUE
064300     '203 006535 025       030       BRONCHITIS & ASTHMA W/O CC'.
064400         05  FILLER   PIC X(57)  VALUE
064500     '204 007041 021       027       RESPIRATORY SIGNS & SYMPTO'.
064600         05  FILLER   PIC X(57)  VALUE
064700     '205 013999 040       053  Y    OTHER RESPIRATORY SYSTEM D'.
064800         05  FILLER   PIC X(57)  VALUE
064900     '206 007942 025       032  Y    OTHER RESPIRATORY SYSTEM D'.
065000         05  FILLER   PIC X(57)  VALUE
065100     '207 053425 124       144  Y    RESPIRATORY SYSTEM DIAGNOS'.
065200         05  FILLER   PIC X(57)  VALUE
065300     '208 022969 050       068       RESPIRATORY SYSTEM DIAGNOS'.
065400         05  FILLER   PIC X(57)  VALUE
065500     '215 154348 112       172       OTHER HEART ASSIST SYSTEM '.
065600         05  FILLER   PIC X(57)  VALUE
065700     '216 095238 130       158  Y Y  CARDIAC VALVE & OTH MAJ CA'.
065800         05  FILLER   PIC X(57)  VALUE
065900     '217 063291 088       099  Y Y  CARDIAC VALVE & OTH MAJ CA'.
066000         05  FILLER   PIC X(57)  VALUE
066100     '218 055693 064       073  Y Y  CARDIAC VALVE & OTH MAJ CA'.
066200         05  FILLER   PIC X(57)  VALUE
066300     '219 077067 098       119  Y Y  CARDIAC VALVE & OTH MAJ CA'.
066400         05  FILLER   PIC X(57)  VALUE
066500     '220 052056 066       073  Y Y  CARDIAC VALVE & OTH MAJ CA'.
066600         05  FILLER   PIC X(57)  VALUE
066700     '221 046347 049       054  Y Y  CARDIAC VALVE & OTH MAJ CA'.
066800         05  FILLER   PIC X(57)  VALUE
066900     '222 086570 099       120       CARDIAC DEFIB IMPLANT W CA'.
067000         05  FILLER   PIC X(57)  VALUE
067100     '223 062924 044       060       CARDIAC DEFIB IMPLANT W CA'.
067200         05  FILLER   PIC X(57)  VALUE
067300     '224 076733 079       098       CARDIAC DEFIB IMPLANT W CA'.
067400         05  FILLER   PIC X(57)  VALUE
067500     '225 058610 041       049       CARDIAC DEFIB IMPLANT W CA'.
067600         05  FILLER   PIC X(57)  VALUE
067700     '226 069573 064       087       CARDIAC DEFIBRILLATOR IMPL'.
067800         05  FILLER   PIC X(57)  VALUE
067900     '227 054493 024       035       CARDIAC DEFIBRILLATOR IMPL'.
068000         05  FILLER   PIC X(57)  VALUE
068100     '228 073113 112       135       OTHER CARDIOTHORACIC PROCE'.
068200         05  FILLER   PIC X(57)  VALUE
068300     '229 044606 065       075       OTHER CARDIOTHORACIC PROCE'.
068400         05  FILLER   PIC X(57)  VALUE
068500     '230 040755 043       050       OTHER CARDIOTHORACIC PROCE'.
068600         05  FILLER   PIC X(57)  VALUE
068700     '231 077247 106       125       CORONARY BYPASS W PTCA W M'.
068800         05  FILLER   PIC X(57)  VALUE
068900     '232 055976 079       086       CORONARY BYPASS W PTCA W/O'.
069000         05  FILLER   PIC X(57)  VALUE
069100     '233 073493 118       133  Y    CORONARY BYPASS W CARDIAC '.
069200         05  FILLER   PIC X(57)  VALUE
069300     '234 048816 080       086  Y    CORONARY BYPASS W CARDIAC '.
069400         05  FILLER   PIC X(57)  VALUE
069500     '235 057089 090       103  Y    CORONARY BYPASS W/O CARDIA'.
069600         05  FILLER   PIC X(57)  VALUE
069700     '236 037952 060       065  Y    CORONARY BYPASS W/O CARDIA'.
069800         05  FILLER   PIC X(57)  VALUE
069900     '237 050843 067       097       MAJOR CARDIOVASC PROCEDURE'.
070000         05  FILLER   PIC X(57)  VALUE
070100     '238 034241 026       037       MAJOR CARDIOVASC PROCEDURE'.
070200         05  FILLER   PIC X(57)  VALUE
070300     '239 047590 106       134  Y    AMPUTATION FOR CIRC SYS DI'.
070400         05  FILLER   PIC X(57)  VALUE
070500     '240 027594 072       088  Y    AMPUTATION FOR CIRC SYS DI'.
070600         05  FILLER   PIC X(57)  VALUE
070700     '241 014111 044       052  Y    AMPUTATION FOR CIRC SYS DI'.
070800         05  FILLER   PIC X(57)  VALUE
070900     '242 037242 058       074  Y    PERMANENT CARDIAC PACEMAKE'.
071000         05  FILLER   PIC X(57)  VALUE
071100     '243 026695 036       045  Y    PERMANENT CARDIAC PACEMAKE'.
071200         05  FILLER   PIC X(57)  VALUE
071300     '244 021555 024       029  Y    PERMANENT CARDIAC PACEMAKE'.
071400         05  FILLER   PIC X(57)  VALUE
071500     '245 046485 034       049       AICD GENERATOR PROCEDURES '.
071600         05  FILLER   PIC X(57)  VALUE
071700     '246 032368 040       054       PERC CARDIOVASC PROC W DRU'.
071800         05  FILLER   PIC X(57)  VALUE
071900     '247 020586 021       025       PERC CARDIOVASC PROC W DRU'.
072000         05  FILLER   PIC X(57)  VALUE
072100     '248 030411 048       064       PERC CARDIOVASC PROC W NON'.
072200         05  FILLER   PIC X(57)  VALUE
072300     '249 018808 024       030       PERC CARDIOVASC PROC W NON'.
072400         05  FILLER   PIC X(57)  VALUE
072500     '250 029885 051       069       PERC CARDIOVASC PROC W/O C'.
072600         05  FILLER   PIC X(57)  VALUE
072700     '251 020399 023       030       PERC CARDIOVASC PROC W/O C'.
072800         05  FILLER   PIC X(57)  VALUE
072900     '252 032646 054       079       OTHER VASCULAR PROCEDURES '.
073000         05  FILLER   PIC X(57)  VALUE
073100     '253 025532 040       055       OTHER VASCULAR PROCEDURES '.
073200         05  FILLER   PIC X(57)  VALUE
073300     '254 017304 022       028       OTHER VASCULAR PROCEDURES '.
073400         05  FILLER   PIC X(57)  VALUE
073500     '255 026051 067       085  Y    UPPER LIMB & TOE AMPUTATIO'.
073600         05  FILLER   PIC X(57)  VALUE
073700     '256 016986 055       066  Y    UPPER LIMB & TOE AMPUTATIO'.
073800         05  FILLER   PIC X(57)  VALUE
073900     '257 010558 032       041  Y    UPPER LIMB & TOE AMPUTATIO'.
074000         05  FILLER   PIC X(57)  VALUE
074100     '258 027613 049       063       CARDIAC PACEMAKER DEVICE R'.
074200         05  FILLER   PIC X(57)  VALUE
074300     '259 019924 027       035       CARDIAC PACEMAKER DEVICE R'.
074400         05  FILLER   PIC X(57)  VALUE
074500     '260 037456 079       106       CARDIAC PACEMAKER REVISION'.
074600         05  FILLER   PIC X(57)  VALUE
074700     '261 018552 035       046       CARDIAC PACEMAKER REVISION'.
074800         05  FILLER   PIC X(57)  VALUE
074900     '262 013978 024       030       CARDIAC PACEMAKER REVISION'.
075000         05  FILLER   PIC X(57)  VALUE
075100     '263 018664 037       056       VEIN LIGATION & STRIPPING '.
075200         05  FILLER   PIC X(57)  VALUE
075300     '264 028292 058       084  Y    OTHER CIRCULATORY SYSTEM O'.
075400         05  FILLER   PIC X(57)  VALUE
075500     '265 028641 028       043       AICD LEAD PROCEDURES      '.
075600         05  FILLER   PIC X(57)  VALUE
075700     '266 089920 084       106  Y Y  ENDOVASCULAR CARDIAC VALVE'.
075800         05  FILLER   PIC X(57)  VALUE
075900     '267 067517 050       058  Y Y  ENDOVASCULAR CARDIAC VALVE'.
076000         05  FILLER   PIC X(57)  VALUE
076100     '280 017289 047       060  Y    ACUTE MYOCARDIAL INFARCTIO'.
076200         05  FILLER   PIC X(57)  VALUE
076300     '281 010247 030       037  Y    ACUTE MYOCARDIAL INFARCTIO'.
076400         05  FILLER   PIC X(57)  VALUE
076500     '282 007562 020       024  Y    ACUTE MYOCARDIAL INFARCTIO'.
076600         05  FILLER   PIC X(57)  VALUE
076700     '283 016753 030       048       ACUTE MYOCARDIAL INFARCTIO'.
076800         05  FILLER   PIC X(57)  VALUE
076900     '284 007703 018       025       ACUTE MYOCARDIAL INFARCTIO'.
077000         05  FILLER   PIC X(57)  VALUE
077100     '285 005065 013       016       ACUTE MYOCARDIAL INFARCTIO'.
077200         05  FILLER   PIC X(57)  VALUE
077300     '286 021240 051       068       CIRCULATORY DISORDERS EXCE'.
077400         05  FILLER   PIC X(57)  VALUE
077500     '287 011290 025       032       CIRCULATORY DISORDERS EXCE'.
077600         05  FILLER   PIC X(57)  VALUE
077700     '288 027138 076       095  Y    ACUTE & SUBACUTE ENDOCARDI'.
077800         05  FILLER   PIC X(57)  VALUE
077900     '289 016991 058       070  Y    ACUTE & SUBACUTE ENDOCARDI'.
078000         05  FILLER   PIC X(57)  VALUE
078100     '290 012476 039       049  Y    ACUTE & SUBACUTE ENDOCARDI'.
078200         05  FILLER   PIC X(57)  VALUE
078300     '291 015097 047       059  Y    HEART FAILURE & SHOCK W MC'.
078400         05  FILLER   PIC X(57)  VALUE
078500     '292 009824 037       045  Y    HEART FAILURE & SHOCK W CC'.
078600         05  FILLER   PIC X(57)  VALUE
078700     '293 006762 026       031  Y    HEART FAILURE & SHOCK W/O '.
078800         05  FILLER   PIC X(57)  VALUE
078900     '294 010480 041       050       DEEP VEIN THROMBOPHLEBITIS'.
079000         05  FILLER   PIC X(57)  VALUE
079100     '295 006926 031       037       DEEP VEIN THROMBOPHLEBITIS'.
079200         05  FILLER   PIC X(57)  VALUE
079300     '296 012347 018       027       CARDIAC ARREST, UNEXPLAINE'.
079400         05  FILLER   PIC X(57)  VALUE
079500     '297 006475 013       016       CARDIAC ARREST, UNEXPLAINE'.
079600         05  FILLER   PIC X(57)  VALUE
079700     '298 004227 011       012       CARDIAC ARREST, UNEXPLAINE'.
079800         05  FILLER   PIC X(57)  VALUE
079900     '299 014094 044       057  Y    PERIPHERAL VASCULAR DISORD'.
080000         05  FILLER   PIC X(57)  VALUE
080100     '300 009770 036       044  Y    PERIPHERAL VASCULAR DISORD'.
080200         05  FILLER   PIC X(57)  VALUE
080300     '301 006776 027       033  Y    PERIPHERAL VASCULAR DISORD'.
080400         05  FILLER   PIC X(57)  VALUE
080500     '302 010311 029       039       ATHEROSCLEROSIS W MCC     '.
080600         05  FILLER   PIC X(57)  VALUE
080700     '303 006101 019       023       ATHEROSCLEROSIS W/O MCC   '.
080800         05  FILLER   PIC X(57)  VALUE
080900     '304 010016 033       042       HYPERTENSION W MCC        '.
081000         05  FILLER   PIC X(57)  VALUE
081100     '305 006272 021       026       HYPERTENSION W/O MCC      '.
081200         05  FILLER   PIC X(57)  VALUE
081300     '306 013687 039       052       CARDIAC CONGENITAL & VALVU'.
081400         05  FILLER   PIC X(57)  VALUE
081500     '307 007698 025       031       CARDIAC CONGENITAL & VALVU'.
081600         05  FILLER   PIC X(57)  VALUE
081700     '308 012107 038       049       CARDIAC ARRHYTHMIA & CONDU'.
081800         05  FILLER   PIC X(57)  VALUE
081900     '309 007865 027       033       CARDIAC ARRHYTHMIA & CONDU'.
082000         05  FILLER   PIC X(57)  VALUE
082100     '310 005493 019       023       CARDIAC ARRHYTHMIA & CONDU'.
082200         05  FILLER   PIC X(57)  VALUE
082300     '311 005662 018       022       ANGINA PECTORIS           '.
082400         05  FILLER   PIC X(57)  VALUE
082500     '312 007423 024       030       SYNCOPE & COLLAPSE        '.
082600         05  FILLER   PIC X(57)  VALUE
082700     '313 006138 018       021       CHEST PAIN                '.
082800         05  FILLER   PIC X(57)  VALUE
082900     '314 019195 050       067  Y    OTHER CIRCULATORY SYSTEM D'.
083000         05  FILLER   PIC X(57)  VALUE
083100     '315 009613 030       039  Y    OTHER CIRCULATORY SYSTEM D'.
083200         05  FILLER   PIC X(57)  VALUE
083300     '316 006210 020       024  Y    OTHER CIRCULATORY SYSTEM D'.
083400         05  FILLER   PIC X(57)  VALUE
083500     '326 053847 112       145  Y    STOMACH, ESOPHAGEAL & DUOD'.
083600         05  FILLER   PIC X(57)  VALUE
083700     '327 026532 060       078  Y    STOMACH, ESOPHAGEAL & DUOD'.
083800         05  FILLER   PIC X(57)  VALUE
083900     '328 014949 026       034  Y    STOMACH, ESOPHAGEAL & DUOD'.
084000         05  FILLER   PIC X(57)  VALUE
084100     '329 050776 117       144  Y    MAJOR SMALL & LARGE BOWEL '.
084200         05  FILLER   PIC X(57)  VALUE
084300     '330 025491 071       084  Y    MAJOR SMALL & LARGE BOWEL '.
084400         05  FILLER   PIC X(57)  VALUE
084500     '331 016580 043       048  Y    MAJOR SMALL & LARGE BOWEL '.
084600         05  FILLER   PIC X(57)  VALUE
084700     '332 047048 105       128  Y    RECTAL RESECTION W MCC    '.
084800         05  FILLER   PIC X(57)  VALUE
084900     '333 024728 063       073  Y    RECTAL RESECTION W CC     '.
085000         05  FILLER   PIC X(57)  VALUE
085100     '334 016032 036       042  Y    RECTAL RESECTION W/O CC/MC'.
085200         05  FILLER   PIC X(57)  VALUE
085300     '335 042881 109       132  Y    PERITONEAL ADHESIOLYSIS W '.
085400         05  FILLER   PIC X(57)  VALUE
085500     '336 023539 069       083  Y    PERITONEAL ADHESIOLYSIS W '.
085600         05  FILLER   PIC X(57)  VALUE
085700     '337 015596 041       050  Y    PERITONEAL ADHESIOLYSIS W/'.
085800         05  FILLER   PIC X(57)  VALUE
085900     '338 030701 076       092       APPENDECTOMY W COMPLICATED'.
086000         05  FILLER   PIC X(57)  VALUE
086100     '339 017340 050       059       APPENDECTOMY W COMPLICATED'.
086200         05  FILLER   PIC X(57)  VALUE
086300     '340 012137 029       035       APPENDECTOMY W COMPLICATED'.
086400         05  FILLER   PIC X(57)  VALUE
086500     '341 022862 047       064       APPENDECTOMY W/O COMPLICAT'.
086600         05  FILLER   PIC X(57)  VALUE
086700     '342 013112 027       035       APPENDECTOMY W/O COMPLICAT'.
086800         05  FILLER   PIC X(57)  VALUE
086900     '343 009404 016       019       APPENDECTOMY W/O COMPLICAT'.
087000         05  FILLER   PIC X(57)  VALUE
087100     '344 033079 087       112       MINOR SMALL & LARGE BOWEL '.
087200         05  FILLER   PIC X(57)  VALUE
087300     '345 017107 054       064       MINOR SMALL & LARGE BOWEL '.
087400         05  FILLER   PIC X(57)  VALUE
087500     '346 011991 038       043       MINOR SMALL & LARGE BOWEL '.
087600         05  FILLER   PIC X(57)  VALUE
087700     '347 026226 064       087       ANAL & STOMAL PROCEDURES W'.
087800         05  FILLER   PIC X(57)  VALUE
087900     '348 013825 040       051       ANAL & STOMAL PROCEDURES W'.
088000         05  FILLER   PIC X(57)  VALUE
088100     '349 009078 025       030       ANAL & STOMAL PROCEDURES W'.
088200         05  FILLER   PIC X(57)  VALUE
088300     '350 024665 057       076       INGUINAL & FEMORAL HERNIA '.
088400         05  FILLER   PIC X(57)  VALUE
088500     '351 014024 035       044       INGUINAL & FEMORAL HERNIA '.
088600         05  FILLER   PIC X(57)  VALUE
088700     '352 009288 021       025       INGUINAL & FEMORAL HERNIA '.
088800         05  FILLER   PIC X(57)  VALUE
088900     '353 029077 064       083       HERNIA PROCEDURES EXCEPT I'.
089000         05  FILLER   PIC X(57)  VALUE
089100     '354 016915 041       050       HERNIA PROCEDURES EXCEPT I'.
089200         05  FILLER   PIC X(57)  VALUE
089300     '355 012521 026       032       HERNIA PROCEDURES EXCEPT I'.
089400         05  FILLER   PIC X(57)  VALUE
089500     '356 038573 084       113  Y    OTHER DIGESTIVE SYSTEM O.R'.
089600         05  FILLER   PIC X(57)  VALUE
089700     '357 021072 052       067  Y    OTHER DIGESTIVE SYSTEM O.R'.
089800         05  FILLER   PIC X(57)  VALUE
089900     '358 013737 031       039  Y    OTHER DIGESTIVE SYSTEM O.R'.
090000         05  FILLER   PIC X(57)  VALUE
090100     '368 018641 049       064       MAJOR ESOPHAGEAL DISORDERS'.
090200         05  FILLER   PIC X(57)  VALUE
090300     '369 010703 034       041       MAJOR ESOPHAGEAL DISORDERS'.
090400         05  FILLER   PIC X(57)  VALUE
090500     '370 007390 024       029       MAJOR ESOPHAGEAL DISORDERS'.
090600         05  FILLER   PIC X(57)  VALUE
090700     '371 018633 061       078  Y    MAJOR GASTROINTESTINAL DIS'.
090800         05  FILLER   PIC X(57)  VALUE
090900     '372 011343 046       056  Y    MAJOR GASTROINTESTINAL DIS'.
091000         05  FILLER   PIC X(57)  VALUE
091100     '373 008013 035       041  Y    MAJOR GASTROINTESTINAL DIS'.
091200         05  FILLER   PIC X(57)  VALUE
091300     '374 020182 060       079  Y    DIGESTIVE MALIGNANCY W MCC'.
091400         05  FILLER   PIC X(57)  VALUE
091500     '375 012429 042       053  Y    DIGESTIVE MALIGNANCY W CC '.
091600         05  FILLER   PIC X(57)  VALUE
091700     '376 009021 029       036  Y    DIGESTIVE MALIGNANCY W/O C'.
091800         05  FILLER   PIC X(57)  VALUE
091900     '377 017775 048       061  Y    G.I. HEMORRHAGE W MCC     '.
092000         05  FILLER   PIC X(57)  VALUE
092100     '378 010021 033       039  Y    G.I. HEMORRHAGE W CC      '.
092200         05  FILLER   PIC X(57)  VALUE
092300     '379 006776 023       027  Y    G.I. HEMORRHAGE W/O CC/MCC'.
092400         05  FILLER   PIC X(57)  VALUE
092500     '380 019265 054       070  Y    COMPLICATED PEPTIC ULCER W'.
092600         05  FILLER   PIC X(57)  VALUE
092700     '381 010875 036       044  Y    COMPLICATED PEPTIC ULCER W'.
092800         05  FILLER   PIC X(57)  VALUE
092900     '382 007591 027       032  Y    COMPLICATED PEPTIC ULCER W'.
093000         05  FILLER   PIC X(57)  VALUE
093100     '383 013215 042       053       UNCOMPLICATED PEPTIC ULCER'.
093200         05  FILLER   PIC X(57)  VALUE
093300     '384 008510 029       034       UNCOMPLICATED PEPTIC ULCER'.
093400         05  FILLER   PIC X(57)  VALUE
093500     '385 017649 059       078       INFLAMMATORY BOWEL DISEASE'.
093600         05  FILLER   PIC X(57)  VALUE
093700     '386 010040 039       049       INFLAMMATORY BOWEL DISEASE'.
093800         05  FILLER   PIC X(57)  VALUE
093900     '387 007449 030       036       INFLAMMATORY BOWEL DISEASE'.
094000         05  FILLER   PIC X(57)  VALUE
094100     '388 016100 053       069  Y    G.I. OBSTRUCTION W MCC    '.
094200         05  FILLER   PIC X(57)  VALUE
094300     '389 008717 036       044  Y    G.I. OBSTRUCTION W CC     '.
094400         05  FILLER   PIC X(57)  VALUE
094500     '390 006034 027       031  Y    G.I. OBSTRUCTION W/O CC/MC'.
094600         05  FILLER   PIC X(57)  VALUE
094700     '391 011976 038       051       ESOPHAGITIS, GASTROENT & M'.
094800         05  FILLER   PIC X(57)  VALUE
094900     '392 007388 028       035       ESOPHAGITIS, GASTROENT & M'.
095000         05  FILLER   PIC X(57)  VALUE
095100     '393 016893 047       066       OTHER DIGESTIVE SYSTEM DIA'.
095200         05  FILLER   PIC X(57)  VALUE
095300     '394 009448 034       043       OTHER DIGESTIVE SYSTEM DIA'.
095400         05  FILLER   PIC X(57)  VALUE
095500     '395 006574 024       030       OTHER DIGESTIVE SYSTEM DIA'.
095600         05  FILLER   PIC X(57)  VALUE
095700     '405 055387 108       144  Y    PANCREAS, LIVER & SHUNT PR'.
095800         05  FILLER   PIC X(57)  VALUE
095900     '406 028067 060       075  Y    PANCREAS, LIVER & SHUNT PR'.
096000         05  FILLER   PIC X(57)  VALUE
096100     '407 019472 040       048  Y    PANCREAS, LIVER & SHUNT PR'.
096200         05  FILLER   PIC X(57)  VALUE
096300     '408 038967 100       123       BILIARY TRACT PROC EXCEPT '.
096400         05  FILLER   PIC X(57)  VALUE
096500     '409 022218 063       075       BILIARY TRACT PROC EXCEPT '.
096600         05  FILLER   PIC X(57)  VALUE
096700     '410 016206 045       052       BILIARY TRACT PROC EXCEPT '.
096800         05  FILLER   PIC X(57)  VALUE
096900     '411 036261 095       117       CHOLECYSTECTOMY W C.D.E. W'.
097000         05  FILLER   PIC X(57)  VALUE
097100     '412 024166 063       074       CHOLECYSTECTOMY W C.D.E. W'.
097200         05  FILLER   PIC X(57)  VALUE
097300     '413 017708 042       051       CHOLECYSTECTOMY W C.D.E. W'.
097400         05  FILLER   PIC X(57)  VALUE
097500     '414 035545 087       106  Y    CHOLECYSTECTOMY EXCEPT BY '.
097600         05  FILLER   PIC X(57)  VALUE
097700     '415 020267 056       065  Y    CHOLECYSTECTOMY EXCEPT BY '.
097800         05  FILLER   PIC X(57)  VALUE
097900     '416 013465 036       042  Y    CHOLECYSTECTOMY EXCEPT BY '.
098000         05  FILLER   PIC X(57)  VALUE
098100     '417 024353 059       074       LAPAROSCOPIC CHOLECYSTECTO'.
098200         05  FILLER   PIC X(57)  VALUE
098300     '418 016600 040       048       LAPAROSCOPIC CHOLECYSTECTO'.
098400         05  FILLER   PIC X(57)  VALUE
098500     '419 012316 026       030       LAPAROSCOPIC CHOLECYSTECTO'.
098600         05  FILLER   PIC X(57)  VALUE
098700     '420 034621 081       114       HEPATOBILIARY DIAGNOSTIC P'.
098800         05  FILLER   PIC X(57)  VALUE
098900     '421 017699 042       056       HEPATOBILIARY DIAGNOSTIC P'.
099000         05  FILLER   PIC X(57)  VALUE
099100     '422 012352 027       033       HEPATOBILIARY DIAGNOSTIC P'.
099200         05  FILLER   PIC X(57)  VALUE
099300     '423 041961 098       132       OTHER HEPATOBILIARY OR PAN'.
099400         05  FILLER   PIC X(57)  VALUE
099500     '424 022993 062       079       OTHER HEPATOBILIARY OR PAN'.
099600         05  FILLER   PIC X(57)  VALUE
099700     '425 013793 037       044       OTHER HEPATOBILIARY OR PAN'.
099800         05  FILLER   PIC X(57)  VALUE
099900     '432 016710 047       062       CIRRHOSIS & ALCOHOLIC HEPA'.
100000         05  FILLER   PIC X(57)  VALUE
100100     '433 009173 033       041       CIRRHOSIS & ALCOHOLIC HEPA'.
100200         05  FILLER   PIC X(57)  VALUE
100300     '434 006229 024       029       CIRRHOSIS & ALCOHOLIC HEPA'.
100400         05  FILLER   PIC X(57)  VALUE
100500     '435 017524 052       068       MALIGNANCY OF HEPATOBILIAR'.
100600         05  FILLER   PIC X(57)  VALUE
100700     '436 011640 039       049       MALIGNANCY OF HEPATOBILIAR'.
100800         05  FILLER   PIC X(57)  VALUE
100900     '437 008971 027       035       MALIGNANCY OF HEPATOBILIAR'.
101000         05  FILLER   PIC X(57)  VALUE
101100     '438 017023 051       068       DISORDERS OF PANCREAS EXCE'.
101200         05  FILLER   PIC X(57)  VALUE
101300     '439 009071 036       044       DISORDERS OF PANCREAS EXCE'.
101400         05  FILLER   PIC X(57)  VALUE
101500     '440 006423 027       032       DISORDERS OF PANCREAS EXCE'.
101600         05  FILLER   PIC X(57)  VALUE
101700     '441 018835 050       068  Y    DISORDERS OF LIVER EXCEPT '.
101800         05  FILLER   PIC X(57)  VALUE
101900     '442 009266 033       042  Y    DISORDERS OF LIVER EXCEPT '.
102000         05  FILLER   PIC X(57)  VALUE
102100     '443 006512 025       031  Y    DISORDERS OF LIVER EXCEPT '.
102200         05  FILLER   PIC X(57)  VALUE
102300     '444 016212 047       061       DISORDERS OF THE BILIARY T'.
102400         05  FILLER   PIC X(57)  VALUE
102500     '445 010654 034       042       DISORDERS OF THE BILIARY T'.
102600         05  FILLER   PIC X(57)  VALUE
102700     '446 007569 024       029       DISORDERS OF THE BILIARY T'.
102800         05  FILLER   PIC X(57)  VALUE
102900     '453 111637 095       117       COMBINED ANTERIOR/POSTERIO'.
103000         05  FILLER   PIC X(57)  VALUE
103100     '454 080184 049       058       COMBINED ANTERIOR/POSTERIO'.
103200         05  FILLER   PIC X(57)  VALUE
103300     '455 062503 031       035       COMBINED ANTERIOR/POSTERIO'.
103400         05  FILLER   PIC X(57)  VALUE
103500     '456 094039 099       120       SPINAL FUS EXC CERV W SPIN'.
103600         05  FILLER   PIC X(57)  VALUE
103700     '457 069074 055       065       SPINAL FUS EXC CERV W SPIN'.
103800         05  FILLER   PIC X(57)  VALUE
103900     '458 052637 034       038       SPINAL FUS EXC CERV W SPIN'.
104000         05  FILLER   PIC X(57)  VALUE
104100     '459 066686 068       085  Y    SPINAL FUSION EXCEPT CERVI'.
104200         05  FILLER   PIC X(57)  VALUE
104300     '460 039998 030       035  Y    SPINAL FUSION EXCEPT CERVI'.
104400         05  FILLER   PIC X(57)  VALUE
104500     '461 050202 063       076       BILATERAL OR MULTIPLE MAJO'.
104600         05  FILLER   PIC X(57)  VALUE
104700     '462 034905 034       037       BILATERAL OR MULTIPLE MAJO'.
104800         05  FILLER   PIC X(57)  VALUE
104900     '463 053345 107       142  Y    WND DEBRID & SKN GRFT EXC '.
105000         05  FILLER   PIC X(57)  VALUE
105100     '464 030085 063       078  Y    WND DEBRID & SKN GRFT EXC '.
105200         05  FILLER   PIC X(57)  VALUE
105300     '465 019463 039       048  Y    WND DEBRID & SKN GRFT EXC '.
105400         05  FILLER   PIC X(57)  VALUE
105500     '466 051513 067       082  Y    REVISION OF HIP OR KNEE RE'.
105600         05  FILLER   PIC X(57)  VALUE
105700     '467 034231 038       043  Y    REVISION OF HIP OR KNEE RE'.
105800         05  FILLER   PIC X(57)  VALUE
105900     '468 027652 029       031  Y    REVISION OF HIP OR KNEE RE'.
106000         05  FILLER   PIC X(57)  VALUE
106100     '469 033905 061       072  Y    MAJOR JOINT REPLACEMENT OR'.
106200         05  FILLER   PIC X(57)  VALUE
106300     '470 021137 030       032  Y    MAJOR JOINT REPLACEMENT OR'.
106400         05  FILLER   PIC X(57)  VALUE
106500     '471 048737 063       087       CERVICAL SPINAL FUSION W M'.
106600         05  FILLER   PIC X(57)  VALUE
106700     '472 029166 024       034       CERVICAL SPINAL FUSION W C'.
106800         05  FILLER   PIC X(57)  VALUE
106900     '473 022655 015       018       CERVICAL SPINAL FUSION W/O'.
107000         05  FILLER   PIC X(57)  VALUE
107100     '474 035943 086       109  Y    AMPUTATION FOR MUSCULOSKEL'.
107200         05  FILLER   PIC X(57)  VALUE
107300     '475 020504 058       072  Y    AMPUTATION FOR MUSCULOSKEL'.
107400         05  FILLER   PIC X(57)  VALUE
107500     '476 011187 031       039  Y    AMPUTATION FOR MUSCULOSKEL'.
107600         05  FILLER   PIC X(57)  VALUE
107700     '477 031638 085       104  Y Y  BIOPSIES OF MUSCULOSKELETA'.
107800         05  FILLER   PIC X(57)  VALUE
107900     '478 022441 055       067  Y Y  BIOPSIES OF MUSCULOSKELETA'.
108000         05  FILLER   PIC X(57)  VALUE
108100     '479 017312 034       042  Y Y  BIOPSIES OF MUSCULOSKELETA'.
108200         05  FILLER   PIC X(57)  VALUE
108300     '480 030052 069       080  Y Y  HIP & FEMUR PROCEDURES EXC'.
108400         05  FILLER   PIC X(57)  VALUE
108500     '481 019776 047       051  Y Y  HIP & FEMUR PROCEDURES EXC'.
108600         05  FILLER   PIC X(57)  VALUE
108700     '482 016243 038       041  Y Y  HIP & FEMUR PROCEDURES EXC'.
108800         05  FILLER   PIC X(57)  VALUE
108900     '483 024205 020       024       MAJOR JOINT/LIMB REATTACHM'.
109000         05  FILLER   PIC X(57)  VALUE
109100     '485 030949 080       095       KNEE PROCEDURES W PDX OF I'.
109200         05  FILLER   PIC X(57)  VALUE
109300     '486 020656 055       063       KNEE PROCEDURES W PDX OF I'.
109400         05  FILLER   PIC X(57)  VALUE
109500     '487 015630 040       047       KNEE PROCEDURES W PDX OF I'.
109600         05  FILLER   PIC X(57)  VALUE
109700     '488 017225 035       042  Y    KNEE PROCEDURES W/O PDX OF'.
109800         05  FILLER   PIC X(57)  VALUE
109900     '489 013186 024       027  Y    KNEE PROCEDURES W/O PDX OF'.
110000         05  FILLER   PIC X(57)  VALUE
110100     '492 031873 065       080  Y Y  LOWER EXTREM & HUMER PROC '.
110200         05  FILLER   PIC X(57)  VALUE
110300     '493 020354 040       047  Y Y  LOWER EXTREM & HUMER PROC '.
110400         05  FILLER   PIC X(57)  VALUE
110500     '494 015397 027       032  Y Y  LOWER EXTREM & HUMER PROC '.
110600         05  FILLER   PIC X(57)  VALUE
110700     '495 030476 073       096  Y Y  LOCAL EXCISION & REMOVAL I'.
110800         05  FILLER   PIC X(57)  VALUE
110900     '496 017289 041       051  Y Y  LOCAL EXCISION & REMOVAL I'.
111000         05  FILLER   PIC X(57)  VALUE
111100     '497 012230 021       027  Y Y  LOCAL EXCISION & REMOVAL I'.
111200         05  FILLER   PIC X(57)  VALUE
111300     '498 021416 055       072       LOCAL EXCISION & REMOVAL I'.
111400         05  FILLER   PIC X(57)  VALUE
111500     '499 010753 023       029       LOCAL EXCISION & REMOVAL I'.
111600         05  FILLER   PIC X(57)  VALUE
111700     '500 032420 077       102  Y Y  SOFT TISSUE PROCEDURES W M'.
111800         05  FILLER   PIC X(57)  VALUE
111900     '501 016474 044       056  Y Y  SOFT TISSUE PROCEDURES W C'.
112000         05  FILLER   PIC X(57)  VALUE
112100     '502 011597 025       030  Y Y  SOFT TISSUE PROCEDURES W/O'.
112200         05  FILLER   PIC X(57)  VALUE
112300     '503 023338 069       085       FOOT PROCEDURES W MCC     '.
112400         05  FILLER   PIC X(57)  VALUE
112500     '504 015691 050       060       FOOT PROCEDURES W CC      '.
112600         05  FILLER   PIC X(57)  VALUE
112700     '505 012474 029       035       FOOT PROCEDURES W/O CC/MCC'.
112800         05  FILLER   PIC X(57)  VALUE
112900     '506 012881 034       043       MAJOR THUMB OR JOINT PROCE'.
113000         05  FILLER   PIC X(57)  VALUE
113100     '507 019154 043       052       MAJOR SHOULDER OR ELBOW JO'.
113200         05  FILLER   PIC X(57)  VALUE
113300     '508 015198 021       026       MAJOR SHOULDER OR ELBOW JO'.
113400         05  FILLER   PIC X(57)  VALUE
113500     '509 015494 036       045       ARTHROSCOPY               '.
113600         05  FILLER   PIC X(57)  VALUE
113700     '510 022857 048       058  Y    SHOULDER,ELBOW OR FOREARM '.
113800         05  FILLER   PIC X(57)  VALUE
113900     '511 016509 033       039  Y    SHOULDER,ELBOW OR FOREARM '.
114000         05  FILLER   PIC X(57)  VALUE
114100     '512 012963 020       024  Y    SHOULDER,ELBOW OR FOREARM '.
114200         05  FILLER   PIC X(57)  VALUE
114300     '513 014462 036       048       HAND OR WRIST PROC, EXCEPT'.
114400         05  FILLER   PIC X(57)  VALUE
114500     '514 008996 022       027       HAND OR WRIST PROC, EXCEPT'.
114600         05  FILLER   PIC X(57)  VALUE
114700     '515 032235 072       092  Y Y  OTHER MUSCULOSKELET SYS & '.
114800         05  FILLER   PIC X(57)  VALUE
114900     '516 020434 044       054  Y Y  OTHER MUSCULOSKELET SYS & '.
115000         05  FILLER   PIC X(57)  VALUE
115100     '517 017251 027       033  Y Y  OTHER MUSCULOSKELET SYS & '.
115200         05  FILLER   PIC X(57)  VALUE
115300     '518 030628 044       066  Y Y  BACK & NECK PROC EXC SPINA'.
115400         05  FILLER   PIC X(57)  VALUE
115500     '519 016468 031       040  Y Y  BACK & NECK PROC EXC SPINA'.
115600         05  FILLER   PIC X(57)  VALUE
115700     '520 011396 019       022  Y Y  BACK & NECK PROC EXC SPINA'.
115800         05  FILLER   PIC X(57)  VALUE
115900     '533 014495 044       057  Y    FRACTURES OF FEMUR W MCC  '.
116000         05  FILLER   PIC X(57)  VALUE
116100     '534 007594 029       035  Y    FRACTURES OF FEMUR W/O MCC'.
116200         05  FILLER   PIC X(57)  VALUE
116300     '535 012410 041       052  Y    FRACTURES OF HIP & PELVIS '.
116400         05  FILLER   PIC X(57)  VALUE
116500     '536 007201 030       035  Y    FRACTURES OF HIP & PELVIS '.
116600         05  FILLER   PIC X(57)  VALUE
116700     '537 008975 033       041       SPRAINS, STRAINS, & DISLOC'.
116800         05  FILLER   PIC X(57)  VALUE
116900     '538 006917 026       031       SPRAINS, STRAINS, & DISLOC'.
117000         05  FILLER   PIC X(57)  VALUE
117100     '539 018276 061       081  Y    OSTEOMYELITIS W MCC       '.
117200         05  FILLER   PIC X(57)  VALUE
117300     '540 012967 047       059  Y    OSTEOMYELITIS W CC        '.
117400         05  FILLER   PIC X(57)  VALUE
117500     '541 009218 035       045  Y    OSTEOMYELITIS W/O CC/MCC  '.
117600         05  FILLER   PIC X(57)  VALUE
117700     '542 019472 060       078  Y    PATHOLOGICAL FRACTURES & M'.
117800         05  FILLER   PIC X(57)  VALUE
117900     '543 011227 041       051  Y    PATHOLOGICAL FRACTURES & M'.
118000         05  FILLER   PIC X(57)  VALUE
118100     '544 007936 031       037  Y    PATHOLOGICAL FRACTURES & M'.
118200         05  FILLER   PIC X(57)  VALUE
118300     '545 025341 061       085  Y    CONNECTIVE TISSUE DISORDER'.
118400         05  FILLER   PIC X(57)  VALUE
118500     '546 011711 039       050  Y    CONNECTIVE TISSUE DISORDER'.
118600         05  FILLER   PIC X(57)  VALUE
118700     '547 007985 028       035  Y    CONNECTIVE TISSUE DISORDER'.
118800         05  FILLER   PIC X(57)  VALUE
118900     '548 019123 061       078       SEPTIC ARTHRITIS W MCC    '.
119000         05  FILLER   PIC X(57)  VALUE
119100     '549 011514 044       055       SEPTIC ARTHRITIS W CC     '.
119200         05  FILLER   PIC X(57)  VALUE
119300     '550 008390 032       039       SEPTIC ARTHRITIS W/O CC/MC'.
119400         05  FILLER   PIC X(57)  VALUE
119500     '551 015556 048       062  Y    MEDICAL BACK PROBLEMS W MC'.
119600         05  FILLER   PIC X(57)  VALUE
119700     '552 008698 032       038  Y    MEDICAL BACK PROBLEMS W/O '.
119800         05  FILLER   PIC X(57)  VALUE
119900     '553 012187 042       054       BONE DISEASES & ARTHROPATH'.
120000         05  FILLER   PIC X(57)  VALUE
120100     '554 007274 029       035       BONE DISEASES & ARTHROPATH'.
120200         05  FILLER   PIC X(57)  VALUE
120300     '555 012636 039       051       SIGNS & SYMPTOMS OF MUSCUL'.
120400         05  FILLER   PIC X(57)  VALUE
120500     '556 007183 026       032       SIGNS & SYMPTOMS OF MUSCUL'.
120600         05  FILLER   PIC X(57)  VALUE
120700     '557 014269 050       062  Y    TENDONITIS, MYOSITIS & BUR'.
120800         05  FILLER   PIC X(57)  VALUE
120900     '558 008522 034       040  Y    TENDONITIS, MYOSITIS & BUR'.
121000         05  FILLER   PIC X(57)  VALUE
121100     '559 018555 050       068  Y    AFTERCARE, MUSCULOSKELETAL'.
121200         05  FILLER   PIC X(57)  VALUE
121300     '560 010756 035       044  Y    AFTERCARE, MUSCULOSKELETAL'.
121400         05  FILLER   PIC X(57)  VALUE
121500     '561 006688 021       025  Y    AFTERCARE, MUSCULOSKELETAL'.
121600         05  FILLER   PIC X(57)  VALUE
121700     '562 013706 043       055  Y    FX, SPRN, STRN & DISL EXCE'.
121800         05  FILLER   PIC X(57)  VALUE
121900     '563 007756 030       035  Y    FX, SPRN, STRN & DISL EXCE'.
122000         05  FILLER   PIC X(57)  VALUE
122100     '564 015036 048       062       OTHER MUSCULOSKELETAL SYS '.
122200         05  FILLER   PIC X(57)  VALUE
122300     '565 009398 035       044       OTHER MUSCULOSKELETAL SYS '.
122400         05  FILLER   PIC X(57)  VALUE
122500     '566 006871 025       031       OTHER MUSCULOSKELETAL SYS '.
122600         05  FILLER   PIC X(57)  VALUE
122700     '570 023952 072       093  Y    SKIN DEBRIDEMENT W MCC    '.
122800         05  FILLER   PIC X(57)  VALUE
122900     '571 014664 052       063  Y    SKIN DEBRIDEMENT W CC     '.
123000         05  FILLER   PIC X(57)  VALUE
123100     '572 009919 037       044  Y    SKIN DEBRIDEMENT W/O CC/MC'.
123200         05  FILLER   PIC X(57)  VALUE
123300     '573 037074 087       129  Y    SKIN GRAFT FOR SKIN ULCER '.
123400         05  FILLER   PIC X(57)  VALUE
123500     '574 026298 071       093  Y    SKIN GRAFT FOR SKIN ULCER '.
123600         05  FILLER   PIC X(57)  VALUE
123700     '575 014926 045       056  Y    SKIN GRAFT FOR SKIN ULCER '.
123800         05  FILLER   PIC X(57)  VALUE
123900     '576 041423 081       116       SKIN GRAFT EXC FOR SKIN UL'.
124000         05  FILLER   PIC X(57)  VALUE
124100     '577 019812 040       056       SKIN GRAFT EXC FOR SKIN UL'.
124200         05  FILLER   PIC X(57)  VALUE
124300     '578 013162 026       035       SKIN GRAFT EXC FOR SKIN UL'.
124400         05  FILLER   PIC X(57)  VALUE
124500     '579 027263 071       092  Y    OTHER SKIN, SUBCUT TISS & '.
124600         05  FILLER   PIC X(57)  VALUE
124700     '580 015727 041       054  Y    OTHER SKIN, SUBCUT TISS & '.
124800         05  FILLER   PIC X(57)  VALUE
124900     '581 011338 022       028  Y    OTHER SKIN, SUBCUT TISS & '.
125000         05  FILLER   PIC X(57)  VALUE
125100     '582 013003 022       029       MASTECTOMY FOR MALIGNANCY '.
125200         05  FILLER   PIC X(57)  VALUE
125300     '583 010932 017       019       MASTECTOMY FOR MALIGNANCY '.
125400         05  FILLER   PIC X(57)  VALUE
125500     '584 017682 039       052       BREAST BIOPSY, LOCAL EXCIS'.
125600         05  FILLER   PIC X(57)  VALUE
125700     '585 013752 021       025       BREAST BIOPSY, LOCAL EXCIS'.
125800         05  FILLER   PIC X(57)  VALUE
125900     '592 014249 051       066  Y    SKIN ULCERS W MCC         '.
126000         05  FILLER   PIC X(57)  VALUE
126100     '593 010196 043       052  Y    SKIN ULCERS W CC          '.
126200         05  FILLER   PIC X(57)  VALUE
126300     '594 007124 031       039  Y    SKIN ULCERS W/O CC/MCC    '.
126400         05  FILLER   PIC X(57)  VALUE
126500     '595 019629 055       075       MAJOR SKIN DISORDERS W MCC'.
126600         05  FILLER   PIC X(57)  VALUE
126700     '596 009527 036       046       MAJOR SKIN DISORDERS W/O M'.
126800         05  FILLER   PIC X(57)  VALUE
126900     '597 016758 054       071       MALIGNANT BREAST DISORDERS'.
127000         05  FILLER   PIC X(57)  VALUE
127100     '598 011235 038       052       MALIGNANT BREAST DISORDERS'.
127200         05  FILLER   PIC X(57)  VALUE
127300     '599 007259 024       031       MALIGNANT BREAST DISORDERS'.
127400         05  FILLER   PIC X(57)  VALUE
127500     '600 009803 038       047       NON-MALIGNANT BREAST DISOR'.
127600         05  FILLER   PIC X(57)  VALUE
127700     '601 006314 027       033       NON-MALIGNANT BREAST DISOR'.
127800         05  FILLER   PIC X(57)  VALUE
127900     '602 014557 050       062  Y    CELLULITIS W MCC          '.
128000         05  FILLER   PIC X(57)  VALUE
128100     '603 008447 035       042  Y    CELLULITIS W/O MCC        '.
128200         05  FILLER   PIC X(57)  VALUE
128300     '604 012624 039       051       TRAUMA TO THE SKIN, SUBCUT'.
128400         05  FILLER   PIC X(57)  VALUE
128500     '605 007664 026       032       TRAUMA TO THE SKIN, SUBCUT'.
128600         05  FILLER   PIC X(57)  VALUE
128700     '606 013664 042       058       MINOR SKIN DISORDERS W MCC'.
128800         05  FILLER   PIC X(57)  VALUE
128900     '607 007296 028       036       MINOR SKIN DISORDERS W/O M'.
129000         05  FILLER   PIC X(57)  VALUE
129100     '614 024642 041       056       ADRENAL & PITUITARY PROCED'.
129200         05  FILLER   PIC X(57)  VALUE
129300     '615 014243 022       026       ADRENAL & PITUITARY PROCED'.
129400         05  FILLER   PIC X(57)  VALUE
129500     '616 041611 107       131  Y    AMPUTAT OF LOWER LIMB FOR '.
129600         05  FILLER   PIC X(57)  VALUE
129700     '617 019956 061       072  Y    AMPUTAT OF LOWER LIMB FOR '.
129800         05  FILLER   PIC X(57)  VALUE
129900     '618 013512 042       050  Y    AMPUTAT OF LOWER LIMB FOR '.
130000         05  FILLER   PIC X(57)  VALUE
130100     '619 032890 042       065       O.R. PROCEDURES FOR OBESIT'.
130200         05  FILLER   PIC X(57)  VALUE
130300     '620 018470 026       031       O.R. PROCEDURES FOR OBESIT'.
130400         05  FILLER   PIC X(57)  VALUE
130500     '621 015434 018       020       O.R. PROCEDURES FOR OBESIT'.
130600         05  FILLER   PIC X(57)  VALUE
130700     '622 038047 092       126  Y    SKIN GRAFTS & WOUND DEBRID'.
130800         05  FILLER   PIC X(57)  VALUE
130900     '623 018308 057       069  Y    SKIN GRAFTS & WOUND DEBRID'.
131000         05  FILLER   PIC X(57)  VALUE
131100     '624 011314 036       044  Y    SKIN GRAFTS & WOUND DEBRID'.
131200         05  FILLER   PIC X(57)  VALUE
131300     '625 024896 046       071       THYROID, PARATHYROID & THY'.
131400         05  FILLER   PIC X(57)  VALUE
131500     '626 013080 021       031       THYROID, PARATHYROID & THY'.
131600         05  FILLER   PIC X(57)  VALUE
131700     '627 008663 013       015       THYROID, PARATHYROID & THY'.
131800         05  FILLER   PIC X(57)  VALUE
131900     '628 032935 067       094  Y    OTHER ENDOCRINE, NUTRIT & '.
132000         05  FILLER   PIC X(57)  VALUE
132100     '629 022471 062       075  Y    OTHER ENDOCRINE, NUTRIT & '.
132200         05  FILLER   PIC X(57)  VALUE
132300     '630 014305 032       042  Y    OTHER ENDOCRINE, NUTRIT & '.
132400         05  FILLER   PIC X(57)  VALUE
132500     '637 013944 042       055  Y    DIABETES W MCC            '.
132600         05  FILLER   PIC X(57)  VALUE
132700     '638 008261 030       037  Y    DIABETES W CC             '.
132800         05  FILLER   PIC X(57)  VALUE
132900     '639 006068 022       027  Y    DIABETES W/O CC/MCC       '.
133000         05  FILLER   PIC X(57)  VALUE
133100     '640 011044 033       045  Y    MISC DISORDERS OF NUTRITIO'.
133200         05  FILLER   PIC X(57)  VALUE
133300     '641 007051 027       034  Y    MISC DISORDERS OF NUTRITIO'.
133400         05  FILLER   PIC X(57)  VALUE
133500     '642 011429 033       046       INBORN AND OTHER DISORDERS'.
133600         05  FILLER   PIC X(57)  VALUE
133700     '643 016460 054       068  Y    ENDOCRINE DISORDERS W MCC '.
133800         05  FILLER   PIC X(57)  VALUE
133900     '644 010199 038       047  Y    ENDOCRINE DISORDERS W CC  '.
134000         05  FILLER   PIC X(57)  VALUE
134100     '645 007180 028       034  Y    ENDOCRINE DISORDERS W/O CC'.
134200         05  FILLER   PIC X(57)  VALUE
134300     '652 031502 057       066       KIDNEY TRANSPLANT         '.
134400         05  FILLER   PIC X(57)  VALUE
134500     '653 057958 122       151  Y    MAJOR BLADDER PROCEDURES W'.
134600         05  FILLER   PIC X(57)  VALUE
134700     '654 030973 077       087  Y    MAJOR BLADDER PROCEDURES W'.
134800         05  FILLER   PIC X(57)  VALUE
134900     '655 022590 049       055  Y    MAJOR BLADDER PROCEDURES W'.
135000         05  FILLER   PIC X(57)  VALUE
135100     '656 034517 069       090       KIDNEY & URETER PROCEDURES'.
135200         05  FILLER   PIC X(57)  VALUE
135300     '657 020111 044       052       KIDNEY & URETER PROCEDURES'.
135400         05  FILLER   PIC X(57)  VALUE
135500     '658 015299 027       030       KIDNEY & URETER PROCEDURES'.
135600         05  FILLER   PIC X(57)  VALUE
135700     '659 033813 075       100  Y    KIDNEY & URETER PROCEDURES'.
135800         05  FILLER   PIC X(57)  VALUE
135900     '660 018888 042       055  Y    KIDNEY & URETER PROCEDURES'.
136000         05  FILLER   PIC X(57)  VALUE
136100     '661 013494 023       027  Y    KIDNEY & URETER PROCEDURES'.
136200         05  FILLER   PIC X(57)  VALUE
136300     '662 030042 078       103       MINOR BLADDER PROCEDURES W'.
136400         05  FILLER   PIC X(57)  VALUE
136500     '663 015285 039       052       MINOR BLADDER PROCEDURES W'.
136600         05  FILLER   PIC X(57)  VALUE
136700     '664 012406 019       024       MINOR BLADDER PROCEDURES W'.
136800         05  FILLER   PIC X(57)  VALUE
136900     '665 031585 091       117       PROSTATECTOMY W MCC       '.
137000         05  FILLER   PIC X(57)  VALUE
137100     '666 017512 047       063       PROSTATECTOMY W CC        '.
137200         05  FILLER   PIC X(57)  VALUE
137300     '667 009690 022       028       PROSTATECTOMY W/O CC/MCC  '.
137400         05  FILLER   PIC X(57)  VALUE
137500     '668 024989 065       086       TRANSURETHRAL PROCEDURES W'.
137600         05  FILLER   PIC X(57)  VALUE
137700     '669 012662 030       040       TRANSURETHRAL PROCEDURES W'.
137800         05  FILLER   PIC X(57)  VALUE
137900     '670 008957 020       025       TRANSURETHRAL PROCEDURES W'.
138000         05  FILLER   PIC X(57)  VALUE
138100     '671 016170 041       057       URETHRAL PROCEDURES W CC/M'.
138200         05  FILLER   PIC X(57)  VALUE
138300     '672 008496 018       022       URETHRAL PROCEDURES W/O CC'.
138400         05  FILLER   PIC X(57)  VALUE
138500     '673 035023 074       106       OTHER KIDNEY & URINARY TRA'.
138600         05  FILLER   PIC X(57)  VALUE
138700     '674 022600 053       070       OTHER KIDNEY & URINARY TRA'.
138800         05  FILLER   PIC X(57)  VALUE
138900     '675 014443 022       029       OTHER KIDNEY & URINARY TRA'.
139000         05  FILLER   PIC X(57)  VALUE
139100     '682 015194 046       061  Y    RENAL FAILURE W MCC       '.
139200         05  FILLER   PIC X(57)  VALUE
139300     '683 009512 036       044  Y    RENAL FAILURE W CC        '.
139400         05  FILLER   PIC X(57)  VALUE
139500     '684 006085 024       029  Y    RENAL FAILURE W/O CC/MCC  '.
139600         05  FILLER   PIC X(57)  VALUE
139700     '685 010025 027       037       ADMIT FOR RENAL DIALYSIS  '.
139800         05  FILLER   PIC X(57)  VALUE
139900     '686 017637 053       071       KIDNEY & URINARY TRACT NEO'.
140000         05  FILLER   PIC X(57)  VALUE
140100     '687 010054 036       046       KIDNEY & URINARY TRACT NEO'.
140200         05  FILLER   PIC X(57)  VALUE
140300     '688 006911 021       027       KIDNEY & URINARY TRACT NEO'.
140400         05  FILLER   PIC X(57)  VALUE
140500     '689 011172 042       052  Y    KIDNEY & URINARY TRACT INF'.
140600         05  FILLER   PIC X(57)  VALUE
140700     '690 007794 032       038  Y    KIDNEY & URINARY TRACT INF'.
140800         05  FILLER   PIC X(57)  VALUE
140900     '691 016238 029       038       URINARY STONES W ESW LITHO'.
141000         05  FILLER   PIC X(57)  VALUE
141100     '692 011286 018       022       URINARY STONES W ESW LITHO'.
141200         05  FILLER   PIC X(57)  VALUE
141300     '693 013433 039       051       URINARY STONES W/O ESW LIT'.
141400         05  FILLER   PIC X(57)  VALUE
141500     '694 006859 019       024       URINARY STONES W/O ESW LIT'.
141600         05  FILLER   PIC X(57)  VALUE
141700     '695 012450 041       053       KIDNEY & URINARY TRACT SIG'.
141800         05  FILLER   PIC X(57)  VALUE
141900     '696 006619 025       031       KIDNEY & URINARY TRACT SIG'.
142000         05  FILLER   PIC X(57)  VALUE
142100     '697 009229 026       034       URETHRAL STRICTURE        '.
142200         05  FILLER   PIC X(57)  VALUE
142300     '698 015625 051       064  Y    OTHER KIDNEY & URINARY TRA'.
142400         05  FILLER   PIC X(57)  VALUE
142500     '699 010170 035       044  Y    OTHER KIDNEY & URINARY TRA'.
142600         05  FILLER   PIC X(57)  VALUE
142700     '700 007110 026       032  Y    OTHER KIDNEY & URINARY TRA'.
142800         05  FILLER   PIC X(57)  VALUE
142900     '707 018155 029       039       MAJOR MALE PELVIC PROCEDUR'.
143000         05  FILLER   PIC X(57)  VALUE
143100     '708 013262 014       016       MAJOR MALE PELVIC PROCEDUR'.
143200         05  FILLER   PIC X(57)  VALUE
143300     '709 021341 043       070       PENIS PROCEDURES W CC/MCC '.
143400         05  FILLER   PIC X(57)  VALUE
143500     '710 012949 017       021       PENIS PROCEDURES W/O CC/MC'.
143600         05  FILLER   PIC X(57)  VALUE
143700     '711 022547 058       081       TESTES PROCEDURES W CC/MCC'.
143800         05  FILLER   PIC X(57)  VALUE
143900     '712 010632 026       037       TESTES PROCEDURES W/O CC/M'.
144000         05  FILLER   PIC X(57)  VALUE
144100     '713 014828 035       049       TRANSURETHRAL PROSTATECTOM'.
144200         05  FILLER   PIC X(57)  VALUE
144300     '714 007933 018       021       TRANSURETHRAL PROSTATECTOM'.
144400         05  FILLER   PIC X(57)  VALUE
144500     '715 020051 048       066       OTHER MALE REPRODUCTIVE SY'.
144600         05  FILLER   PIC X(57)  VALUE
144700     '716 011857 015       018       OTHER MALE REPRODUCTIVE SY'.
144800         05  FILLER   PIC X(57)  VALUE
144900     '717 017717 046       065       OTHER MALE REPRODUCTIVE SY'.
145000         05  FILLER   PIC X(57)  VALUE
145100     '718 010099 024       030       OTHER MALE REPRODUCTIVE SY'.
145200         05  FILLER   PIC X(57)  VALUE
145300     '722 017569 056       073       MALIGNANCY, MALE REPRODUCT'.
145400         05  FILLER   PIC X(57)  VALUE
145500     '723 010635 038       049       MALIGNANCY, MALE REPRODUCT'.
145600         05  FILLER   PIC X(57)  VALUE
145700     '724 006412 023       030       MALIGNANCY, MALE REPRODUCT'.
145800         05  FILLER   PIC X(57)  VALUE
145900     '725 011790 043       056       BENIGN PROSTATIC HYPERTROP'.
146000         05  FILLER   PIC X(57)  VALUE
146100     '726 007029 027       033       BENIGN PROSTATIC HYPERTROP'.
146200         05  FILLER   PIC X(57)  VALUE
146300     '727 014195 049       062       INFLAMMATION OF THE MALE R'.
146400         05  FILLER   PIC X(57)  VALUE
146500     '728 008006 032       039       INFLAMMATION OF THE MALE R'.
146600         05  FILLER   PIC X(57)  VALUE
146700     '729 010390 034       045       OTHER MALE REPRODUCTIVE SY'.
146800         05  FILLER   PIC X(57)  VALUE
146900     '730 006660 023       030       OTHER MALE REPRODUCTIVE SY'.
147000         05  FILLER   PIC X(57)  VALUE
147100     '734 025704 046       066       PELVIC EVISCERATION, RAD H'.
147200         05  FILLER   PIC X(57)  VALUE
147300     '735 012265 019       023       PELVIC EVISCERATION, RAD H'.
147400         05  FILLER   PIC X(57)  VALUE
147500     '736 044341 102       127       UTERINE & ADNEXA PROC FOR '.
147600         05  FILLER   PIC X(57)  VALUE
147700     '737 020198 052       061       UTERINE & ADNEXA PROC FOR '.
147800         05  FILLER   PIC X(57)  VALUE
147900     '738 012746 029       034       UTERINE & ADNEXA PROC FOR '.
148000         05  FILLER   PIC X(57)  VALUE
148100     '739 033133 067       093       UTERINE,ADNEXA PROC FOR NO'.
148200         05  FILLER   PIC X(57)  VALUE
148300     '740 016069 032       041       UTERINE,ADNEXA PROC FOR NO'.
148400         05  FILLER   PIC X(57)  VALUE
148500     '741 011846 018       021       UTERINE,ADNEXA PROC FOR NO'.
148600         05  FILLER   PIC X(57)  VALUE
148700     '742 015436 031       041       UTERINE & ADNEXA PROC FOR '.
148800         05  FILLER   PIC X(57)  VALUE
148900     '743 009954 018       020       UTERINE & ADNEXA PROC FOR '.
149000         05  FILLER   PIC X(57)  VALUE
149100     '744 017484 043       060       D&C, CONIZATION, LAPAROSCO'.
149200         05  FILLER   PIC X(57)  VALUE
149300     '745 009553 020       024       D&C, CONIZATION, LAPAROSCO'.
149400         05  FILLER   PIC X(57)  VALUE
149500     '746 014219 033       047       VAGINA, CERVIX & VULVA PRO'.
149600         05  FILLER   PIC X(57)  VALUE
149700     '747 008892 016       019       VAGINA, CERVIX & VULVA PRO'.
149800         05  FILLER   PIC X(57)  VALUE
149900     '748 010845 016       020       FEMALE REPRODUCTIVE SYSTEM'.
150000         05  FILLER   PIC X(57)  VALUE
150100     '749 025541 061       083       OTHER FEMALE REPRODUCTIVE '.
150200         05  FILLER   PIC X(57)  VALUE
150300     '750 011904 023       028       OTHER FEMALE REPRODUCTIVE '.
150400         05  FILLER   PIC X(57)  VALUE
150500     '754 019626 059       083       MALIGNANCY, FEMALE REPRODU'.
150600         05  FILLER   PIC X(57)  VALUE
150700     '755 011066 037       049       MALIGNANCY, FEMALE REPRODU'.
150800         05  FILLER   PIC X(57)  VALUE
150900     '756 006652 022       030       MALIGNANCY, FEMALE REPRODU'.
151000         05  FILLER   PIC X(57)  VALUE
151100     '757 015397 057       072       INFECTIONS, FEMALE REPRODU'.
151200         05  FILLER   PIC X(57)  VALUE
151300     '758 010518 043       053       INFECTIONS, FEMALE REPRODU'.
151400         05  FILLER   PIC X(57)  VALUE
151500     '759 006931 031       038       INFECTIONS, FEMALE REPRODU'.
151600         05  FILLER   PIC X(57)  VALUE
151700     '760 008399 027       036       MENSTRUAL & OTHER FEMALE R'.
151800         05  FILLER   PIC X(57)  VALUE
151900     '761 004988 018       022       MENSTRUAL & OTHER FEMALE R'.
152000         05  FILLER   PIC X(57)  VALUE
152100     '765 010924 038       047       CESAREAN SECTION W CC/MCC '.
152200         05  FILLER   PIC X(57)  VALUE
152300     '766 007562 029       031       CESAREAN SECTION W/O CC/MC'.
152400         05  FILLER   PIC X(57)  VALUE
152500     '767 008513 024       029       VAGINAL DELIVERY W STERILI'.
152600         05  FILLER   PIC X(57)  VALUE
152700     '768 011184 047       058       VAGINAL DELIVERY W O.R. PR'.
152800         05  FILLER   PIC X(57)  VALUE
152900     '769 018930 036       058       POSTPARTUM & POST ABORTION'.
153000         05  FILLER   PIC X(57)  VALUE
153100     '770 008029 016       022       ABORTION W D&C, ASPIRATION'.
153200         05  FILLER   PIC X(57)  VALUE
153300     '774 007168 026       031       VAGINAL DELIVERY W COMPLIC'.
153400         05  FILLER   PIC X(57)  VALUE
153500     '775 005643 021       023       VAGINAL DELIVERY W/O COMPL'.
153600         05  FILLER   PIC X(57)  VALUE
153700     '776 008117 027       036       POSTPARTUM & POST ABORTION'.
153800         05  FILLER   PIC X(57)  VALUE
153900     '777 010145 018       022       ECTOPIC PREGNANCY         '.
154000         05  FILLER   PIC X(57)  VALUE
154100     '778 005638 021       033       THREATENED ABORTION       '.
154200         05  FILLER   PIC X(57)  VALUE
154300     '779 006389 015       020       ABORTION W/O D&C          '.
154400         05  FILLER   PIC X(57)  VALUE
154500     '780 002880 012       014       FALSE LABOR               '.
154600         05  FILLER   PIC X(57)  VALUE
154700     '781 007546 027       040       OTHER ANTEPARTUM DIAGNOSES'.
154800         05  FILLER   PIC X(57)  VALUE
154900     '782 004057 017       023       OTHER ANTEPARTUM DIAGNOSES'.
155000         05  FILLER   PIC X(57)  VALUE
155100     '789 015547 018       018       NEONATES, DIED OR TRANSFER'.
155200         05  FILLER   PIC X(57)  VALUE
155300     '790 051268 179       179       EXTREME IMMATURITY OR RESP'.
155400         05  FILLER   PIC X(57)  VALUE
155500     '791 035015 133       133       PREMATURITY W MAJOR PROBLE'.
155600         05  FILLER   PIC X(57)  VALUE
155700     '792 021127 086       086       PREMATURITY W/O MAJOR PROB'.
155800         05  FILLER   PIC X(57)  VALUE
155900     '793 035968 047       047       FULL TERM NEONATE W MAJOR '.
156000         05  FILLER   PIC X(57)  VALUE
156100     '794 012731 034       034       NEONATE W OTHER SIGNIFICAN'.
156200         05  FILLER   PIC X(57)  VALUE
156300     '795 001724 031       031       NORMAL NEWBORN            '.
156400         05  FILLER   PIC X(57)  VALUE
156500     '799 050131 095       122       SPLENECTOMY W MCC         '.
156600         05  FILLER   PIC X(57)  VALUE
156700     '800 026403 056       071       SPLENECTOMY W CC          '.
156800         05  FILLER   PIC X(57)  VALUE
156900     '801 015477 029       035       SPLENECTOMY W/O CC/MCC    '.
157000         05  FILLER   PIC X(57)  VALUE
157100     '802 033601 078       106       OTHER O.R. PROC OF THE BLO'.
157200         05  FILLER   PIC X(57)  VALUE
157300     '803 018440 045       060       OTHER O.R. PROC OF THE BLO'.
157400         05  FILLER   PIC X(57)  VALUE
157500     '804 012265 025       032       OTHER O.R. PROC OF THE BLO'.
157600         05  FILLER   PIC X(57)  VALUE
157700     '808 022260 061       080       MAJOR HEMATOL/IMMUN DIAG E'.
157800         05  FILLER   PIC X(57)  VALUE
157900     '809 012037 038       048       MAJOR HEMATOL/IMMUN DIAG E'.
158000         05  FILLER   PIC X(57)  VALUE
158100     '810 008409 026       033       MAJOR HEMATOL/IMMUN DIAG E'.
158200         05  FILLER   PIC X(57)  VALUE
158300     '811 012829 036       049       RED BLOOD CELL DISORDERS W'.
158400         05  FILLER   PIC X(57)  VALUE
158500     '812 008162 026       034       RED BLOOD CELL DISORDERS W'.
158600         05  FILLER   PIC X(57)  VALUE
158700     '813 016534 036       050       COAGULATION DISORDERS     '.
158800         05  FILLER   PIC X(57)  VALUE
158900     '814 017048 050       069       RETICULOENDOTHELIAL & IMMU'.
159000         05  FILLER   PIC X(57)  VALUE
159100     '815 009948 034       043       RETICULOENDOTHELIAL & IMMU'.
159200         05  FILLER   PIC X(57)  VALUE
159300     '816 006882 024       029       RETICULOENDOTHELIAL & IMMU'.
159400         05  FILLER   PIC X(57)  VALUE
159500     '820 055226 118       156       LYMPHOMA & LEUKEMIA W MAJO'.
159600         05  FILLER   PIC X(57)  VALUE
159700     '821 023064 046       064       LYMPHOMA & LEUKEMIA W MAJO'.
159800         05  FILLER   PIC X(57)  VALUE
159900     '822 012805 022       028       LYMPHOMA & LEUKEMIA W MAJO'.
160000         05  FILLER   PIC X(57)  VALUE
160100     '823 044622 115       147       LYMPHOMA & NON-ACUTE LEUKE'.
160200         05  FILLER   PIC X(57)  VALUE
160300     '824 022951 060       078       LYMPHOMA & NON-ACUTE LEUKE'.
160400         05  FILLER   PIC X(57)  VALUE
160500     '825 013803 030       040       LYMPHOMA & NON-ACUTE LEUKE'.
160600         05  FILLER   PIC X(57)  VALUE
160700     '826 050900 105       139       MYELOPROLIF DISORD OR POOR'.
160800         05  FILLER   PIC X(57)  VALUE
160900     '827 023214 052       067       MYELOPROLIF DISORD OR POOR'.
161000         05  FILLER   PIC X(57)  VALUE
161100     '828 015321 028       035       MYELOPROLIF DISORD OR POOR'.
161200         05  FILLER   PIC X(57)  VALUE
161300     '829 034231 070       106       MYELOPROLIF DISORD OR POOR'.
161400         05  FILLER   PIC X(57)  VALUE
161500     '830 012523 024       031       MYELOPROLIF DISORD OR POOR'.
161600         05  FILLER   PIC X(57)  VALUE
161700     '834 052735 102       166       ACUTE LEUKEMIA W/O MAJOR O'.
161800         05  FILLER   PIC X(57)  VALUE
161900     '835 021042 047       076       ACUTE LEUKEMIA W/O MAJOR O'.
162000         05  FILLER   PIC X(57)  VALUE
162100     '836 011693 028       040       ACUTE LEUKEMIA W/O MAJOR O'.
162200         05  FILLER   PIC X(57)  VALUE
162300     '837 064631 165       224       CHEMO W ACUTE LEUKEMIA AS '.
162400         05  FILLER   PIC X(57)  VALUE
162500     '838 027923 069       099       CHEMO W ACUTE LEUKEMIA AS '.
162600         05  FILLER   PIC X(57)  VALUE
162700     '839 012525 049       057       CHEMO W ACUTE LEUKEMIA AS '.
162800         05  FILLER   PIC X(57)  VALUE
162900     '840 031058 077       106  Y    LYMPHOMA & NON-ACUTE LEUKE'.
163000         05  FILLER   PIC X(57)  VALUE
163100     '841 016226 047       062  Y    LYMPHOMA & NON-ACUTE LEUKE'.
163200         05  FILLER   PIC X(57)  VALUE
163300     '842 010777 030       039  Y    LYMPHOMA & NON-ACUTE LEUKE'.
163400         05  FILLER   PIC X(57)  VALUE
163500     '843 017902 055       074       OTHER MYELOPROLIF DIS OR P'.
163600         05  FILLER   PIC X(57)  VALUE
163700     '844 012058 041       054       OTHER MYELOPROLIF DIS OR P'.
163800         05  FILLER   PIC X(57)  VALUE
163900     '845 008551 030       039       OTHER MYELOPROLIF DIS OR P'.
164000         05  FILLER   PIC X(57)  VALUE
164100     '846 023264 058       080       CHEMOTHERAPY W/O ACUTE LEU'.
164200         05  FILLER   PIC X(57)  VALUE
164300     '847 011569 031       037       CHEMOTHERAPY W/O ACUTE LEU'.
164400         05  FILLER   PIC X(57)  VALUE
164500     '848 008454 025       030       CHEMOTHERAPY W/O ACUTE LEU'.
164600         05  FILLER   PIC X(57)  VALUE
164700     '849 014657 046       059       RADIOTHERAPY              '.
164800         05  FILLER   PIC X(57)  VALUE
164900     '853 052068 108       139  Y    INFECTIOUS & PARASITIC DIS'.
165000         05  FILLER   PIC X(57)  VALUE
165100     '854 023877 067       081  Y    INFECTIOUS & PARASITIC DIS'.
165200         05  FILLER   PIC X(57)  VALUE
165300     '855 017057 034       048  Y    INFECTIOUS & PARASITIC DIS'.
165400         05  FILLER   PIC X(57)  VALUE
165500     '856 048177 100       134  Y    POSTOPERATIVE OR POST-TRAU'.
165600         05  FILLER   PIC X(57)  VALUE
165700     '857 020500 057       070  Y    POSTOPERATIVE OR POST-TRAU'.
165800         05  FILLER   PIC X(57)  VALUE
165900     '858 013390 038       047  Y    POSTOPERATIVE OR POST-TRAU'.
166000         05  FILLER   PIC X(57)  VALUE
166100     '862 018506 055       072  Y    POSTOPERATIVE & POST-TRAUM'.
166200         05  FILLER   PIC X(57)  VALUE
166300     '863 009836 037       045  Y    POSTOPERATIVE & POST-TRAUM'.
166400         05  FILLER   PIC X(57)  VALUE
166500     '864 008419 029       036       FEVER                     '.
166600         05  FILLER   PIC X(57)  VALUE
166700     '865 015131 043       059       VIRAL ILLNESS W MCC       '.
166800         05  FILLER   PIC X(57)  VALUE
166900     '866 007425 028       034       VIRAL ILLNESS W/O MCC     '.
167000         05  FILLER   PIC X(57)  VALUE
167100     '867 027245 070       095  Y    OTHER INFECTIOUS & PARASIT'.
167200         05  FILLER   PIC X(57)  VALUE
167300     '868 010897 039       049  Y    OTHER INFECTIOUS & PARASIT'.
167400         05  FILLER   PIC X(57)  VALUE
167500     '869 006877 027       033  Y    OTHER INFECTIOUS & PARASIT'.
167600         05  FILLER   PIC X(57)  VALUE
167700     '870 058698 126       147  Y    SEPTICEMIA OR SEVERE SEPSI'.
167800         05  FILLER   PIC X(57)  VALUE
167900     '871 018072 051       066  Y    SEPTICEMIA OR SEVERE SEPSI'.
168000         05  FILLER   PIC X(57)  VALUE
168100     '872 010528 040       047  Y    SEPTICEMIA OR SEVERE SEPSI'.
168200         05  FILLER   PIC X(57)  VALUE
168300     '876 033533 074       147       O.R. PROCEDURE W PRINCIPAL'.
168400         05  FILLER   PIC X(57)  VALUE
168500     '880 006704 023       031       ACUTE ADJUSTMENT REACTION '.
168600         05  FILLER   PIC X(57)  VALUE
168700     '881 006464 033       044       DEPRESSIVE NEUROSES       '.
168800         05  FILLER   PIC X(57)  VALUE
168900     '882 006935 033       045       NEUROSES EXCEPT DEPRESSIVE'.
169000         05  FILLER   PIC X(57)  VALUE
169100     '883 013062 043       078       DISORDERS OF PERSONALITY &'.
169200         05  FILLER   PIC X(57)  VALUE
169300     '884 010783 041       059  Y    ORGANIC DISTURBANCES & MEN'.
169400         05  FILLER   PIC X(57)  VALUE
169500     '885 010217 054       074       PSYCHOSES                 '.
169600         05  FILLER   PIC X(57)  VALUE
169700     '886 008288 039       062       BEHAVIORAL & DEVELOPMENTAL'.
169800         05  FILLER   PIC X(57)  VALUE
169900     '887 009329 030       045       OTHER MENTAL DISORDER DIAG'.
170000         05  FILLER   PIC X(57)  VALUE
170100     '894 004450 021       030       ALCOHOL/DRUG ABUSE OR DEPE'.
170200         05  FILLER   PIC X(57)  VALUE
170300     '895 012152 096       123       ALCOHOL/DRUG ABUSE OR DEPE'.
170400         05  FILLER   PIC X(57)  VALUE
170500     '896 015244 048       065  Y    ALCOHOL/DRUG ABUSE OR DEPE'.
170600         05  FILLER   PIC X(57)  VALUE
170700     '897 006905 032       040  Y    ALCOHOL/DRUG ABUSE OR DEPE'.
170800         05  FILLER   PIC X(57)  VALUE
170900     '901 039929 090       132       WOUND DEBRIDEMENTS FOR INJ'.
171000         05  FILLER   PIC X(57)  VALUE
171100     '902 017433 051       070       WOUND DEBRIDEMENTS FOR INJ'.
171200         05  FILLER   PIC X(57)  VALUE
171300     '903 011280 033       044       WOUND DEBRIDEMENTS FOR INJ'.
171400         05  FILLER   PIC X(57)  VALUE
171500     '904 033637 073       107       SKIN GRAFTS FOR INJURIES W'.
171600         05  FILLER   PIC X(57)  VALUE
171700     '905 013889 036       046       SKIN GRAFTS FOR INJURIES W'.
171800         05  FILLER   PIC X(57)  VALUE
171900     '906 011789 023       033       HAND PROCEDURES FOR INJURI'.
172000         05  FILLER   PIC X(57)  VALUE
172100     '907 037873 074       102  Y    OTHER O.R. PROCEDURES FOR '.
172200         05  FILLER   PIC X(57)  VALUE
172300     '908 019575 043       057  Y    OTHER O.R. PROCEDURES FOR '.
172400         05  FILLER   PIC X(57)  VALUE
172500     '909 012556 026       033  Y    OTHER O.R. PROCEDURES FOR '.
172600         05  FILLER   PIC X(57)  VALUE
172700     '913 011410 034       047       TRAUMATIC INJURY W MCC    '.
172800         05  FILLER   PIC X(57)  VALUE
172900     '914 007009 024       030       TRAUMATIC INJURY W/O MCC  '.
173000         05  FILLER   PIC X(57)  VALUE
173100     '915 015381 037       050       ALLERGIC REACTIONS W MCC  '.
173200         05  FILLER   PIC X(57)  VALUE
173300     '916 005137 017       021       ALLERGIC REACTIONS W/O MCC'.
173400         05  FILLER   PIC X(57)  VALUE
173500     '917 014051 035       048  Y    POISONING & TOXIC EFFECTS '.
173600         05  FILLER   PIC X(57)  VALUE
173700     '918 006412 021       028  Y    POISONING & TOXIC EFFECTS '.
173800         05  FILLER   PIC X(57)  VALUE
173900     '919 016750 044       060       COMPLICATIONS OF TREATMENT'.
174000         05  FILLER   PIC X(57)  VALUE
174100     '920 009850 030       040       COMPLICATIONS OF TREATMENT'.
174200         05  FILLER   PIC X(57)  VALUE
174300     '921 006602 022       028       COMPLICATIONS OF TREATMENT'.
174400         05  FILLER   PIC X(57)  VALUE
174500     '922 014953 039       057       OTHER INJURY, POISONING & '.
174600         05  FILLER   PIC X(57)  VALUE
174700     '923 007348 023       033       OTHER INJURY, POISONING & '.
174800         05  FILLER   PIC X(57)  VALUE
174900     '927 155499 229       289       EXTENSIVE BURNS OR FULL TH'.
175000         05  FILLER   PIC X(57)  VALUE
175100     '928 053820 111       150       FULL THICKNESS BURN W SKIN'.
175200         05  FILLER   PIC X(57)  VALUE
175300     '929 023344 057       073       FULL THICKNESS BURN W SKIN'.
175400         05  FILLER   PIC X(57)  VALUE
175500     '933 027557 024       056       EXTENSIVE BURNS OR FULL TH'.
175600         05  FILLER   PIC X(57)  VALUE
175700     '934 015748 041       058       FULL THICKNESS BURN W/O SK'.
175800         05  FILLER   PIC X(57)  VALUE
175900     '935 014717 033       050       NON-EXTENSIVE BURNS       '.
176000         05  FILLER   PIC X(57)  VALUE
176100     '939 027647 062       089       O.R. PROC W DIAGNOSES OF O'.
176200         05  FILLER   PIC X(57)  VALUE
176300     '940 018274 037       053       O.R. PROC W DIAGNOSES OF O'.
176400         05  FILLER   PIC X(57)  VALUE
176500     '941 013531 022       029       O.R. PROC W DIAGNOSES OF O'.
176600         05  FILLER   PIC X(57)  VALUE
176700     '945 012709 086       104  Y    REHABILITATION W CC/MCC   '.
176800         05  FILLER   PIC X(57)  VALUE
176900     '946 010662 066       076  Y    REHABILITATION W/O CC/MCC '.
177000         05  FILLER   PIC X(57)  VALUE
177100     '947 011368 036       048  Y    SIGNS & SYMPTOMS W MCC    '.
177200         05  FILLER   PIC X(57)  VALUE
177300     '948 007131 026       033  Y    SIGNS & SYMPTOMS W/O MCC  '.
177400         05  FILLER   PIC X(57)  VALUE
177500     '949 010525 031       045       AFTERCARE W CC/MCC        '.
177600         05  FILLER   PIC X(57)  VALUE
177700     '950 005508 024       033       AFTERCARE W/O CC/MCC      '.
177800         05  FILLER   PIC X(57)  VALUE
177900     '951 009188 025       054       OTHER FACTORS INFLUENCING '.
178000         05  FILLER   PIC X(57)  VALUE
178100     '955 055727 080       116       CRANIOTOMY FOR MULTIPLE SI'.
178200         05  FILLER   PIC X(57)  VALUE
178300     '956 036692 066       080  Y    LIMB REATTACHMENT, HIP & F'.
178400         05  FILLER   PIC X(57)  VALUE
178500     '957 068453 099       140       OTHER O.R. PROCEDURES FOR '.
178600         05  FILLER   PIC X(57)  VALUE
178700     '958 038602 072       088       OTHER O.R. PROCEDURES FOR '.
178800         05  FILLER   PIC X(57)  VALUE
178900     '959 025447 046       057       OTHER O.R. PROCEDURES FOR '.
179000         05  FILLER   PIC X(57)  VALUE
179100     '963 027071 055       082       OTHER MULTIPLE SIGNIFICANT'.
179200         05  FILLER   PIC X(57)  VALUE
179300     '964 014769 042       052       OTHER MULTIPLE SIGNIFICANT'.
179400         05  FILLER   PIC X(57)  VALUE
179500     '965 009418 029       036       OTHER MULTIPLE SIGNIFICANT'.
179600         05  FILLER   PIC X(57)  VALUE
179700     '969 060815 123       170       HIV W EXTENSIVE O.R. PROCE'.
179800         05  FILLER   PIC X(57)  VALUE
179900     '970 022085 055       072       HIV W EXTENSIVE O.R. PROCE'.
180000         05  FILLER   PIC X(57)  VALUE
180100     '974 026849 067       093       HIV W MAJOR RELATED CONDIT'.
180200         05  FILLER   PIC X(57)  VALUE
180300     '975 013047 045       058       HIV W MAJOR RELATED CONDIT'.
180400         05  FILLER   PIC X(57)  VALUE
180500     '976 008774 032       039       HIV W MAJOR RELATED CONDIT'.
180600         05  FILLER   PIC X(57)  VALUE
180700     '977 011305 035       047       HIV W OR W/O OTHER RELATED'.
180800         05  FILLER   PIC X(57)  VALUE
180900     '981 049968 100       131  Y    EXTENSIVE O.R. PROCEDURE U'.
181000         05  FILLER   PIC X(57)  VALUE
181100     '982 028150 058       074  Y    EXTENSIVE O.R. PROCEDURE U'.
181200         05  FILLER   PIC X(57)  VALUE
181300     '983 018039 028       037  Y    EXTENSIVE O.R. PROCEDURE U'.
181400         05  FILLER   PIC X(57)  VALUE
181500     '984 034344 096       130       PROSTATIC O.R. PROCEDURE U'.
181600         05  FILLER   PIC X(57)  VALUE
181700     '985 018509 051       069       PROSTATIC O.R. PROCEDURE U'.
181800         05  FILLER   PIC X(57)  VALUE
181900     '986 010453 025       034       PROSTATIC O.R. PROCEDURE U'.
182000         05  FILLER   PIC X(57)  VALUE
182100     '987 033008 084       111  Y    NON-EXTENSIVE O.R. PROC UN'.
182200         05  FILLER   PIC X(57)  VALUE
182300     '988 017643 048       064  Y    NON-EXTENSIVE O.R. PROC UN'.
182400         05  FILLER   PIC X(57)  VALUE
182500     '989 010454 023       031  Y    NON-EXTENSIVE O.R. PROC UN'.
182600         05  FILLER   PIC X(57)  VALUE
182700     '998 000000 000       000       PRINCIPAL DIAGNOSIS INVALI'.
182800         05  FILLER   PIC X(57)  VALUE
182900     '999 000000 000       000       UNGROUPABLE               '.
183000     02  WK-DRG-DATA2 REDEFINES WK-DRG-DATA.
183100         05  DRG-TAB OCCURS 753
183200                     ASCENDING KEY IS WK-DRG-DRGX
183300                     INDEXED BY DRG-IDX.
183400             10  DRG-DATA-TAB.
183500               15  WK-DRG-DRGX               PIC X(03).
183600               15  FILLER1                   PIC X(01).
183700               15  DRG-WEIGHT                PIC 9(02)V9(04).
183800               15  FILLER2                   PIC X(01).
183900               15  DRG-GMALOS                PIC 9(02)V9(01).
184000               15  FILLER3                   PIC X(05).
184100               15  DRG-LOW                   PIC X(01).
184200               15  FILLER5                   PIC X(01).
184300               15  DRG-ARITH-ALOS            PIC 9(02)V9(01).
184400               15  FILLER6                   PIC X(02).
184500               15  DRG-PAC                   PIC X(01).
184600               15  FILLER7                   PIC X(01).
184700               15  DRG-SPPAC                 PIC X(01).
184800               15  FILLER8                   PIC X(02).
184900               15  DRG-DESC                  PIC X(26).
185000*****YEARCHANGE 2015.0 ** NOT USED 2015 *******************
185100** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
185200** FOR FY 2011 ON
185300***************************************************************
185400
185500 01  PPS-SSRFBN-TABLE.
185600     02  WK-SSRFBN-DATA.
185700         05  FILLER   PIC X(58)  VALUE
185800     '01  099835  01 ALABAMA                                   '.
185900         05  FILLER   PIC X(58)  VALUE
186000     '02  099835  02 ALASKA                                    '.
186100         05  FILLER   PIC X(58)  VALUE
186200     '03  099835  03 ARIZONA                                   '.
186300         05  FILLER   PIC X(58)  VALUE
186400     '04  099835  04 ARKANSAS                                  '.
186500         05  FILLER   PIC X(58)  VALUE
186600     '05  099317  05 CALIFORNIA                                '.
186700          05  FILLER   PIC X(58)  VALUE
186800     '06  099413  06 COLORADO                                  '.
186900         05  FILLER   PIC X(58)  VALUE
187000     '07  098016  07 CONNECTICUT                               '.
187100         05  FILLER   PIC X(58)  VALUE
187200     '08  099835  08 DELAWARE                                  '.
187300         05  FILLER   PIC X(58)  VALUE
187400     '09  099835  09 DISTRICT OF CO                            '.
187500         05  FILLER   PIC X(58)  VALUE
187600     '10  099756  10 FLORIDA                                   '.
187700         05  FILLER   PIC X(58)  VALUE
187800     '11  099835  11 GEORGIA                                   '.
187900         05  FILLER   PIC X(58)  VALUE
188000     '12  099835  12 HAWAII                                    '.
188100         05  FILLER   PIC X(58)  VALUE
188200     '13  099835  13 IDAHO                                     '.
188300         05  FILLER   PIC X(58)  VALUE
188400     '14  099835  14 ILLINOIS                                  '.
188500         05  FILLER   PIC X(58)  VALUE
188600     '15  099813  15 INDIANA                                   '.
188700         05  FILLER   PIC X(58)  VALUE
188800     '16  099783  16 IOWA                                      '.
188900         05  FILLER   PIC X(58)  VALUE
189000     '17  099827  17 KANSAS                                    '.
189100         05  FILLER   PIC X(58)  VALUE
189200     '18  099835  18 KENTUCKY                                  '.
189300         05  FILLER   PIC X(58)  VALUE
189400     '19  099834  19 LOUISIANA                                 '.
189500         05  FILLER   PIC X(58)  VALUE
189600     '20  099835  20 MAINE                                     '.
189700         05  FILLER   PIC X(58)  VALUE
189800     '21  100000  21 MARYLAND                                  '.
189900         05  FILLER   PIC X(58)  VALUE
190000     '22  099834  22 MASSACHUSETTS                             '.
190100         05  FILLER   PIC X(58)  VALUE
190200     '23  099833  23 MICHIGAN                                  '.
190300         05  FILLER   PIC X(58)  VALUE
190400     '24  099835  24 MINNESOTA                                 '.
190500         05  FILLER   PIC X(58)  VALUE
190600     '25  099834  25 MISSISSIPPI                               '.
190700         05  FILLER   PIC X(58)  VALUE
190800     '26  099835  26 MISSOURI                                  '.
190900         05  FILLER   PIC X(58)  VALUE
191000     '27  099835  27 MONTANA                                   '.
191100         05  FILLER   PIC X(58)  VALUE
191200     '28  099835  28 NEBRASKA                                  '.
191300         05  FILLER   PIC X(58)  VALUE
191400     '29  099835  29 NEVADA                                    '.
191500         05  FILLER   PIC X(58)  VALUE
191600     '30  099699  30 NEW HAMPSHIRE                             '.
191700         05  FILLER   PIC X(58)  VALUE
191800     '31  098587  31 NEW JERSEY                                '.
191900         05  FILLER   PIC X(58)  VALUE
192000     '32  099577  32 NEW MEXICO                                '.
192100         05  FILLER   PIC X(58)  VALUE
192200     '33  099835  33 NEW YORK                                  '.
192300         05  FILLER   PIC X(58)  VALUE
192400     '34  099834  34 NORTH CAROLINA                            '.
192500         05  FILLER   PIC X(58)  VALUE
192600     '35  099833  35 NORTH DAKOTA                              '.
192700         05  FILLER   PIC X(58)  VALUE
192800     '36  099784  36 OHIO                                      '.
192900         05  FILLER   PIC X(58)  VALUE
193000     '37  099835  37 OKLAHOMA                                  '.
193100         05  FILLER   PIC X(58)  VALUE
193200     '38  099708  38 OREGON                                    '.
193300         05  FILLER   PIC X(58)  VALUE
193400     '39  099834  39 PENNSYLVANIA                              '.
193500         05  FILLER   PIC X(58)  VALUE
193600     '40  099835  40 PUERTO RICO                               '.
193700         05  FILLER   PIC X(58)  VALUE
193800     '41  099835  41 RHODE ISLAND                              '.
193900         05  FILLER   PIC X(58)  VALUE
194000     '42  099779  42 SOUTH CAROLINA                            '.
194100         05  FILLER   PIC X(58)  VALUE
194200     '43  099834  43 SOUTH DAKOTA                              '.
194300         05  FILLER   PIC X(58)  VALUE
194400     '44  099690  44 TENNESSEE                                 '.
194500         05  FILLER   PIC X(58)  VALUE
194600     '45  099832  45 TEXAS                                     '.
194700         05  FILLER   PIC X(58)  VALUE
194800     '46  099835  46 UTAH                                      '.
194900         05  FILLER   PIC X(58)  VALUE
195000     '47  099835  47 VERMONT                                   '.
195100         05  FILLER   PIC X(58)  VALUE
195200     '48  100000  48 VIRGIN ISLANDS                            '.
195300         05  FILLER   PIC X(58)  VALUE
195400     '49  099835  49 VIRGINIA                                  '.
195500         05  FILLER   PIC X(58)  VALUE
195600     '50  099792  50 WASHINGTON                                '.
195700         05  FILLER   PIC X(58)  VALUE
195800     '51  099712  51 WEST VIRGINIA                             '.
195900         05  FILLER   PIC X(58)  VALUE
196000     '52  099816  52 WISCONSIN                                 '.
196100         05  FILLER   PIC X(58)  VALUE
196200     '53  099835  53 WYOMING                                   '.
196300         05  FILLER   PIC X(58)  VALUE
196400     '55  099317  55 CALIFORNIA                                '.
196500         05  FILLER   PIC X(58)  VALUE
196600     '56  100000  56 CANADA                                    '.
196700         05  FILLER   PIC X(58)  VALUE
196800     '59  100000  59 MEXICO                                    '.
196900         05  FILLER   PIC X(58)  VALUE
197000     '64  100000  64 AMERICAN SAMOA                            '.
197100         05  FILLER   PIC X(58)  VALUE
197200     '65  100000  65 GUAM                                      '.
197300         05  FILLER   PIC X(58)  VALUE
197400     '66  100000  66 MARIANAS ISLANDS                          '.
197500         05  FILLER   PIC X(58)  VALUE
197600     '67  099832  67 TEXAS                                     '.
197700         05  FILLER   PIC X(58)  VALUE
197800     '68  099756  68 FLORIDA                                   '.
197900         05  FILLER   PIC X(58)  VALUE
198000     '69  099756  69 FLORIDA                                   '.
198100         05  FILLER   PIC X(58)  VALUE
198200     '70  099827  70 KANSAS                                    '.
198300         05  FILLER   PIC X(58)  VALUE
198400     '71  099834  71 LOUISIANA                                 '.
198500         05  FILLER   PIC X(58)  VALUE
198600     '72  099784  72 OHIO                                      '.
198700         05  FILLER   PIC X(58)  VALUE
198800     '73  099834  73 PENNSYLVANIA                              '.
198900         05  FILLER   PIC X(58)  VALUE
199000     '74  099832  74 TEXAS                                     '.
199100         05  FILLER   PIC X(58)  VALUE
199200     '75  099317  75 CALIFORNIA                                '.
199300         05  FILLER   PIC X(58)  VALUE
199400     '76  099783  76 IOWA                                      '.
199500         05  FILLER   PIC X(58)  VALUE
199600     '77  099835  77 MINNESOTA                                 '.
199700         05  FILLER   PIC X(58)  VALUE
199800     '78  099835  78 ILLINOIS                                  '.
199900         05  FILLER   PIC X(58)  VALUE
200000     '80  100000  80 MARYLAND                                  '.
200100     02  WK-SSRFBN-DATA2 REDEFINES WK-SSRFBN-DATA.
200200       05  SSRFBN-TAB OCCURS 72 ASCENDING KEY IS WK-SSRFBN-STATE
200300                               INDEXED BY SSRFBN-IDX.
200400           10  WK-SSRFBN-REASON-ALL.
200500              15 WK-SSRFBN-STATE  PIC 99.
200600              15 FILLER           PIC XX.
200700              15 WK-SSRFBN-RATE   PIC 9(1)V9(5).
200800              15 FILLER           PIC XX.
200900              15 WK-SSRFBN-CODE2  PIC 99.
201000              15 FILLER           PIC XX.
201100              15 WK-SSRFBN-STNAM  PIC X(20).
201200              15 WK-SSRFBN-REST   PIC X(22).
201300
201400***********************************************************
201500*****YEARCHANGE 2015.0 ************************************
201600***********************************************************
201700***  LOW VOLUME TABLE IS  APPLICABLE FOR 2015
201800***********************************************************
201900
202000 01  LOWVOL-PROV-TABLE.
202100     05 LOWVOL-PROV-DISCHG-DATA.
202200         10  FILLER      PIC X(13) VALUE '010007   0678'.
202300         10  FILLER      PIC X(13) VALUE '010008   0309'.
202400         10  FILLER      PIC X(13) VALUE '010018   0037'.
202500         10  FILLER      PIC X(13) VALUE '010021   0766'.
202600         10  FILLER      PIC X(13) VALUE '010022   0526'.
202700         10  FILLER      PIC X(13) VALUE '010025   1339'.
202800         10  FILLER      PIC X(13) VALUE '010027   0024'.
202900         10  FILLER      PIC X(13) VALUE '010032   0396'.
203000         10  FILLER      PIC X(13) VALUE '010034   0854'.
203100         10  FILLER      PIC X(13) VALUE '010036   1491'.
203200         10  FILLER      PIC X(13) VALUE '010043   0016'.
203300         10  FILLER      PIC X(13) VALUE '010044   0489'.
203400         10  FILLER      PIC X(13) VALUE '010045   0782'.
203500         10  FILLER      PIC X(13) VALUE '010047   0426'.
203600         10  FILLER      PIC X(13) VALUE '010049   1429'.
203700         10  FILLER      PIC X(13) VALUE '010050   0565'.
203800         10  FILLER      PIC X(13) VALUE '010051   0243'.
203900         10  FILLER      PIC X(13) VALUE '010052   0464'.
204000         10  FILLER      PIC X(13) VALUE '010054   0942'.
204100         10  FILLER      PIC X(13) VALUE '010058   0172'.
204200         10  FILLER      PIC X(13) VALUE '010059   0560'.
204300         10  FILLER      PIC X(13) VALUE '010062   0662'.
204400         10  FILLER      PIC X(13) VALUE '010066   0092'.
204500         10  FILLER      PIC X(13) VALUE '010069   0654'.
204600         10  FILLER      PIC X(13) VALUE '010073   0789'.
204700         10  FILLER      PIC X(13) VALUE '010086   1069'.
204800         10  FILLER      PIC X(13) VALUE '010087   1573'.
204900         10  FILLER      PIC X(13) VALUE '010091   0439'.
205000         10  FILLER      PIC X(13) VALUE '010095   0184'.
205100         10  FILLER      PIC X(13) VALUE '010097   0445'.
205200         10  FILLER      PIC X(13) VALUE '010099   0852'.
205300         10  FILLER      PIC X(13) VALUE '010101   1242'.
205400         10  FILLER      PIC X(13) VALUE '010102   0116'.
205500         10  FILLER      PIC X(13) VALUE '010108   1186'.
205600         10  FILLER      PIC X(13) VALUE '010109   0447'.
205700         10  FILLER      PIC X(13) VALUE '010110   0348'.
205800         10  FILLER      PIC X(13) VALUE '010112   1242'.
205900         10  FILLER      PIC X(13) VALUE '010120   0541'.
206000         10  FILLER      PIC X(13) VALUE '010125   0925'.
206100         10  FILLER      PIC X(13) VALUE '010126   0750'.
206200         10  FILLER      PIC X(13) VALUE '010128   0261'.
206300         10  FILLER      PIC X(13) VALUE '010129   0786'.
206400         10  FILLER      PIC X(13) VALUE '010130   1430'.
206500         10  FILLER      PIC X(13) VALUE '010137   0007'.
206600         10  FILLER      PIC X(13) VALUE '010138   0215'.
206700         10  FILLER      PIC X(13) VALUE '010146   0722'.
206800         10  FILLER      PIC X(13) VALUE '010148   1077'.
206900         10  FILLER      PIC X(13) VALUE '010150   0661'.
207000         10  FILLER      PIC X(13) VALUE '010152   0047'.
207100         10  FILLER      PIC X(13) VALUE '010157   0956'.
207200         10  FILLER      PIC X(13) VALUE '010158   1178'.
207300         10  FILLER      PIC X(13) VALUE '010168   1428'.
207400         10  FILLER      PIC X(13) VALUE '010169   0869'.
207500         10  FILLER      PIC X(13) VALUE '020006   1567'.
207600         10  FILLER      PIC X(13) VALUE '020008   0474'.
207700         10  FILLER      PIC X(13) VALUE '020012   1286'.
207800         10  FILLER      PIC X(13) VALUE '020018   0200'.
207900         10  FILLER      PIC X(13) VALUE '020024   0807'.
208000         10  FILLER      PIC X(13) VALUE '020026   1594'.
208100         10  FILLER      PIC X(13) VALUE '020027   0190'.
208200         10  FILLER      PIC X(13) VALUE '030001   1539'.
208300         10  FILLER      PIC X(13) VALUE '030022   1339'.
208400         10  FILLER      PIC X(13) VALUE '030033   1370'.
208500         10  FILLER      PIC X(13) VALUE '030062   1355'.
208600         10  FILLER      PIC X(13) VALUE '030067   0349'.
208700         10  FILLER      PIC X(13) VALUE '030068   0405'.
208800         10  FILLER      PIC X(13) VALUE '030071   0560'.
208900         10  FILLER      PIC X(13) VALUE '030073   0584'.
209000         10  FILLER      PIC X(13) VALUE '030074   0032'.
209100         10  FILLER      PIC X(13) VALUE '030077   0021'.
209200         10  FILLER      PIC X(13) VALUE '030078   0224'.
209300         10  FILLER      PIC X(13) VALUE '030084   0457'.
209400         10  FILLER      PIC X(13) VALUE '030100   0075'.
209500         10  FILLER      PIC X(13) VALUE '030107   0346'.
209600         10  FILLER      PIC X(13) VALUE '030108   0250'.
209700         10  FILLER      PIC X(13) VALUE '030112   0355'.
209800         10  FILLER      PIC X(13) VALUE '030113   0189'.
209900         10  FILLER      PIC X(13) VALUE '030117   1472'.
210000         10  FILLER      PIC X(13) VALUE '030118   1213'.
210100         10  FILLER      PIC X(13) VALUE '030120   0238'.
210200         10  FILLER      PIC X(13) VALUE '030126   0541'.
210300         10  FILLER      PIC X(13) VALUE '030130   0570'.
210400         10  FILLER      PIC X(13) VALUE '030131   1442'.
210500         10  FILLER      PIC X(13) VALUE '030132   0217'.
210600         10  FILLER      PIC X(13) VALUE '030134   0031'.
210700         10  FILLER      PIC X(13) VALUE '040001   0944'.
210800         10  FILLER      PIC X(13) VALUE '040002   0862'.
210900         10  FILLER      PIC X(13) VALUE '040011   1123'.
211000         10  FILLER      PIC X(13) VALUE '040015   0705'.
211100         10  FILLER      PIC X(13) VALUE '040018   0987'.
211200         10  FILLER      PIC X(13) VALUE '040019   0694'.
211300         10  FILLER      PIC X(13) VALUE '040042   1476'.
211400         10  FILLER      PIC X(13) VALUE '040047   0477'.
211500         10  FILLER      PIC X(13) VALUE '040050   0922'.
211600         10  FILLER      PIC X(13) VALUE '040051   1027'.
211700         10  FILLER      PIC X(13) VALUE '040067   0629'.
211800         10  FILLER      PIC X(13) VALUE '040069   0650'.
211900         10  FILLER      PIC X(13) VALUE '040072   0893'.
212000         10  FILLER      PIC X(13) VALUE '040074   0535'.
212100         10  FILLER      PIC X(13) VALUE '040076   1083'.
212200         10  FILLER      PIC X(13) VALUE '040080   0812'.
212300         10  FILLER      PIC X(13) VALUE '040085   0858'.
212400         10  FILLER      PIC X(13) VALUE '040137   0968'.
212500         10  FILLER      PIC X(13) VALUE '040152   0393'.
212600         10  FILLER      PIC X(13) VALUE '040153   0721'.
212700         10  FILLER      PIC X(13) VALUE '050008   1280'.
212800         10  FILLER      PIC X(13) VALUE '050014   1307'.
212900         10  FILLER      PIC X(13) VALUE '050016   0342'.
213000         10  FILLER      PIC X(13) VALUE '050018   1358'.
213100         10  FILLER      PIC X(13) VALUE '050028   0584'.
213200         10  FILLER      PIC X(13) VALUE '050040   0844'.
213300         10  FILLER      PIC X(13) VALUE '050042   1300'.
213400         10  FILLER      PIC X(13) VALUE '050046   0395'.
213500         10  FILLER      PIC X(13) VALUE '050054   1593'.
213600         10  FILLER      PIC X(13) VALUE '050055   1208'.
213700         10  FILLER      PIC X(13) VALUE '050067   0501'.
213800         10  FILLER      PIC X(13) VALUE '050089   1318'.
213900         10  FILLER      PIC X(13) VALUE '050090   0690'.
214000         10  FILLER      PIC X(13) VALUE '050091   1166'.
214100         10  FILLER      PIC X(13) VALUE '050096   0045'.
214200         10  FILLER      PIC X(13) VALUE '050110   0907'.
214300         10  FILLER      PIC X(13) VALUE '050111   1001'.
214400         10  FILLER      PIC X(13) VALUE '050113   0512'.
214500         10  FILLER      PIC X(13) VALUE '050127   1159'.
214600         10  FILLER      PIC X(13) VALUE '050131   1041'.
214700         10  FILLER      PIC X(13) VALUE '050136   1132'.
214800         10  FILLER      PIC X(13) VALUE '050158   1119'.
214900         10  FILLER      PIC X(13) VALUE '050159   1482'.
215000         10  FILLER      PIC X(13) VALUE '050167   0914'.
215100         10  FILLER      PIC X(13) VALUE '050189   0279'.
215200         10  FILLER      PIC X(13) VALUE '050192   0301'.
215300         10  FILLER      PIC X(13) VALUE '050194   1492'.
215400         10  FILLER      PIC X(13) VALUE '050196   0003'.
215500         10  FILLER      PIC X(13) VALUE '050205   0631'.
215600         10  FILLER      PIC X(13) VALUE '050211   1397'.
215700         10  FILLER      PIC X(13) VALUE '050234   1291'.
215800         10  FILLER      PIC X(13) VALUE '050248   0986'.
215900         10  FILLER      PIC X(13) VALUE '050257   0998'.
216000         10  FILLER      PIC X(13) VALUE '050276   0967'.
216100         10  FILLER      PIC X(13) VALUE '050279   1221'.
216200         10  FILLER      PIC X(13) VALUE '050296   0813'.
216300         10  FILLER      PIC X(13) VALUE '050298   0873'.
216400         10  FILLER      PIC X(13) VALUE '050313   1402'.
216500         10  FILLER      PIC X(13) VALUE '050315   0615'.
216600         10  FILLER      PIC X(13) VALUE '050320   1282'.
216700         10  FILLER      PIC X(13) VALUE '050342   1578'.
216800         10  FILLER      PIC X(13) VALUE '050349   0046'.
216900         10  FILLER      PIC X(13) VALUE '050352   0755'.
217000         10  FILLER      PIC X(13) VALUE '050357   0673'.
217100         10  FILLER      PIC X(13) VALUE '050359   1335'.
217200         10  FILLER      PIC X(13) VALUE '050376   1540'.
217300         10  FILLER      PIC X(13) VALUE '050378   1125'.
217400         10  FILLER      PIC X(13) VALUE '050385   0592'.
217500         10  FILLER      PIC X(13) VALUE '050397   0122'.
217600         10  FILLER      PIC X(13) VALUE '050407   0638'.
217700         10  FILLER      PIC X(13) VALUE '050417   1193'.
217800         10  FILLER      PIC X(13) VALUE '050423   0326'.
217900         10  FILLER      PIC X(13) VALUE '050434   0270'.
218000         10  FILLER      PIC X(13) VALUE '050435   0887'.
218100         10  FILLER      PIC X(13) VALUE '050448   0007'.
218200         10  FILLER      PIC X(13) VALUE '050517   1492'.
218300         10  FILLER      PIC X(13) VALUE '050528   0262'.
218400         10  FILLER      PIC X(13) VALUE '050531   0381'.
218500         10  FILLER      PIC X(13) VALUE '050537   1121'.
218600         10  FILLER      PIC X(13) VALUE '050543   0246'.
218700         10  FILLER      PIC X(13) VALUE '050545   0046'.
218800         10  FILLER      PIC X(13) VALUE '050546   0051'.
218900         10  FILLER      PIC X(13) VALUE '050547   0082'.
219000         10  FILLER      PIC X(13) VALUE '050548   0052'.
219100         10  FILLER      PIC X(13) VALUE '050552   0097'.
219200         10  FILLER      PIC X(13) VALUE '050568   1359'.
219300         10  FILLER      PIC X(13) VALUE '050575   1446'.
219400         10  FILLER      PIC X(13) VALUE '050608   0892'.
219500         10  FILLER      PIC X(13) VALUE '050618   0050'.
219600         10  FILLER      PIC X(13) VALUE '050641   0795'.
219700         10  FILLER      PIC X(13) VALUE '050644   0691'.
219800         10  FILLER      PIC X(13) VALUE '050668   0060'.
219900         10  FILLER      PIC X(13) VALUE '050688   1290'.
220000         10  FILLER      PIC X(13) VALUE '050697   0079'.
220100         10  FILLER      PIC X(13) VALUE '050708   0953'.
220200         10  FILLER      PIC X(13) VALUE '050714   0168'.
220300         10  FILLER      PIC X(13) VALUE '050717   0211'.
220400         10  FILLER      PIC X(13) VALUE '050726   0301'.
220500         10  FILLER      PIC X(13) VALUE '050727   1467'.
220600         10  FILLER      PIC X(13) VALUE '050732   1489'.
220700         10  FILLER      PIC X(13) VALUE '050736   0881'.
220800         10  FILLER      PIC X(13) VALUE '050738   0648'.
220900         10  FILLER      PIC X(13) VALUE '050744   0445'.
221000         10  FILLER      PIC X(13) VALUE '050745   0611'.
221100         10  FILLER      PIC X(13) VALUE '050747   0618'.
221200         10  FILLER      PIC X(13) VALUE '050749   0053'.
221300         10  FILLER      PIC X(13) VALUE '050751   0022'.
221400         10  FILLER      PIC X(13) VALUE '050754   0056'.
221500         10  FILLER      PIC X(13) VALUE '050758   1055'.
221600         10  FILLER      PIC X(13) VALUE '050765   1287'.
221700         10  FILLER      PIC X(13) VALUE '050766   0272'.
221800         10  FILLER      PIC X(13) VALUE '050768   0332'.
221900         10  FILLER      PIC X(13) VALUE '050771   1094'.
222000         10  FILLER      PIC X(13) VALUE '050773   1029'.
222100         10  FILLER      PIC X(13) VALUE '050774   0005'.
222200         10  FILLER      PIC X(13) VALUE '060004   0955'.
222300         10  FILLER      PIC X(13) VALUE '060006   1198'.
222400         10  FILLER      PIC X(13) VALUE '060008   0609'.
222500         10  FILLER      PIC X(13) VALUE '060016   0724'.
222600         10  FILLER      PIC X(13) VALUE '060036   0646'.
222700         10  FILLER      PIC X(13) VALUE '060043   0044'.
222800         10  FILLER      PIC X(13) VALUE '060044   0529'.
222900         10  FILLER      PIC X(13) VALUE '060049   0448'.
223000         10  FILLER      PIC X(13) VALUE '060054   0780'.
223100         10  FILLER      PIC X(13) VALUE '060071   0924'.
223200         10  FILLER      PIC X(13) VALUE '060075   0742'.
223300         10  FILLER      PIC X(13) VALUE '060076   0680'.
223400         10  FILLER      PIC X(13) VALUE '060096   0386'.
223500         10  FILLER      PIC X(13) VALUE '060103   0847'.
223600         10  FILLER      PIC X(13) VALUE '060107   0004'.
223700         10  FILLER      PIC X(13) VALUE '060117   0269'.
223800         10  FILLER      PIC X(13) VALUE '060118   0179'.
223900         10  FILLER      PIC X(13) VALUE '060124   1039'.
224000         10  FILLER      PIC X(13) VALUE '060125   0045'.
224100         10  FILLER      PIC X(13) VALUE '070004   1327'.
224200         10  FILLER      PIC X(13) VALUE '070008   1462'.
224300         10  FILLER      PIC X(13) VALUE '070015   0980'.
224400         10  FILLER      PIC X(13) VALUE '070019   1520'.
224500         10  FILLER      PIC X(13) VALUE '070038   0008'.
224600         10  FILLER      PIC X(13) VALUE '070039   0424'.
224700         10  FILLER      PIC X(13) VALUE '070040   0128'.
224800         10  FILLER      PIC X(13) VALUE '090008   1421'.
224900         10  FILLER      PIC X(13) VALUE '100048   0354'.
225000         10  FILLER      PIC X(13) VALUE '100054   1180'.
225100         10  FILLER      PIC X(13) VALUE '100081   0582'.
225200         10  FILLER      PIC X(13) VALUE '100106   0486'.
225300         10  FILLER      PIC X(13) VALUE '100130   0513'.
225400         10  FILLER      PIC X(13) VALUE '100134   0100'.
225500         10  FILLER      PIC X(13) VALUE '100139   0187'.
225600         10  FILLER      PIC X(13) VALUE '100140   1303'.
225700         10  FILLER      PIC X(13) VALUE '100142   1584'.
225800         10  FILLER      PIC X(13) VALUE '100150   1597'.
225900         10  FILLER      PIC X(13) VALUE '100175   0956'.
226000         10  FILLER      PIC X(13) VALUE '100239   1550'.
226100         10  FILLER      PIC X(13) VALUE '100240   0027'.
226200         10  FILLER      PIC X(13) VALUE '100277   0118'.
226300         10  FILLER      PIC X(13) VALUE '100313   0290'.
226400         10  FILLER      PIC X(13) VALUE '100319   1447'.
226500         10  FILLER      PIC X(13) VALUE '100320   0027'.
226600         10  FILLER      PIC X(13) VALUE '110004   1144'.
226700         10  FILLER      PIC X(13) VALUE '110015   1008'.
226800         10  FILLER      PIC X(13) VALUE '110026   0601'.
226900         10  FILLER      PIC X(13) VALUE '110027   0761'.
227000         10  FILLER      PIC X(13) VALUE '110032   1016'.
227100         10  FILLER      PIC X(13) VALUE '110040   0576'.
227200         10  FILLER      PIC X(13) VALUE '110041   1009'.
227300         10  FILLER      PIC X(13) VALUE '110042   1185'.
227400         10  FILLER      PIC X(13) VALUE '110044   1263'.
227500         10  FILLER      PIC X(13) VALUE '110045   1024'.
227600         10  FILLER      PIC X(13) VALUE '110050   0274'.
227700         10  FILLER      PIC X(13) VALUE '110051   0849'.
227800         10  FILLER      PIC X(13) VALUE '110071   0589'.
227900         10  FILLER      PIC X(13) VALUE '110073   0701'.
228000         10  FILLER      PIC X(13) VALUE '110086   0575'.
228100         10  FILLER      PIC X(13) VALUE '110092   0706'.
228200         10  FILLER      PIC X(13) VALUE '110100   0442'.
228300         10  FILLER      PIC X(13) VALUE '110101   0335'.
228400         10  FILLER      PIC X(13) VALUE '110104   1517'.
228500         10  FILLER      PIC X(13) VALUE '110109   0742'.
228600         10  FILLER      PIC X(13) VALUE '110111   0207'.
228700         10  FILLER      PIC X(13) VALUE '110112   0111'.
228800         10  FILLER      PIC X(13) VALUE '110113   0157'.
228900         10  FILLER      PIC X(13) VALUE '110121   0531'.
229000         10  FILLER      PIC X(13) VALUE '110124   1549'.
229100         10  FILLER      PIC X(13) VALUE '110130   0228'.
229200         10  FILLER      PIC X(13) VALUE '110132   0632'.
229300         10  FILLER      PIC X(13) VALUE '110135   0566'.
229400         10  FILLER      PIC X(13) VALUE '110142   0472'.
229500         10  FILLER      PIC X(13) VALUE '110146   0541'.
229600         10  FILLER      PIC X(13) VALUE '110153   0928'.
229700         10  FILLER      PIC X(13) VALUE '110183   0752'.
229800         10  FILLER      PIC X(13) VALUE '110186   0648'.
229900         10  FILLER      PIC X(13) VALUE '110187   0574'.
230000         10  FILLER      PIC X(13) VALUE '110189   0835'.
230100         10  FILLER      PIC X(13) VALUE '110190   0240'.
230200         10  FILLER      PIC X(13) VALUE '110194   0594'.
230300         10  FILLER      PIC X(13) VALUE '110200   0973'.
230400         10  FILLER      PIC X(13) VALUE '110201   1225'.
230500         10  FILLER      PIC X(13) VALUE '110203   0002'.
230600         10  FILLER      PIC X(13) VALUE '110205   0510'.
230700         10  FILLER      PIC X(13) VALUE '110219   0565'.
230800         10  FILLER      PIC X(13) VALUE '110225   1568'.
230900         10  FILLER      PIC X(13) VALUE '110233   0045'.
231000         10  FILLER      PIC X(13) VALUE '120014   1327'.
231100         10  FILLER      PIC X(13) VALUE '120019   0945'.
231200         10  FILLER      PIC X(13) VALUE '120028   0536'.
231300         10  FILLER      PIC X(13) VALUE '130025   0602'.
231400         10  FILLER      PIC X(13) VALUE '130063   0089'.
231500         10  FILLER      PIC X(13) VALUE '130065   0463'.
231600         10  FILLER      PIC X(13) VALUE '130066   0247'.
231700         10  FILLER      PIC X(13) VALUE '130067   0002'.
231800         10  FILLER      PIC X(13) VALUE '140001   1317'.
231900         10  FILLER      PIC X(13) VALUE '140019   0348'.
232000         10  FILLER      PIC X(13) VALUE '140026   1166'.
232100         10  FILLER      PIC X(13) VALUE '140059   0749'.
232200         10  FILLER      PIC X(13) VALUE '140068   1098'.
232300         10  FILLER      PIC X(13) VALUE '140077   0590'.
232400         10  FILLER      PIC X(13) VALUE '140083   1452'.
232500         10  FILLER      PIC X(13) VALUE '140089   0985'.
232600         10  FILLER      PIC X(13) VALUE '140095   1147'.
232700         10  FILLER      PIC X(13) VALUE '140100   0277'.
232800         10  FILLER      PIC X(13) VALUE '140110   1306'.
232900         10  FILLER      PIC X(13) VALUE '140137   0417'.
233000         10  FILLER      PIC X(13) VALUE '140143   1200'.
233100         10  FILLER      PIC X(13) VALUE '140145   0578'.
233200         10  FILLER      PIC X(13) VALUE '140147   1055'.
233300         10  FILLER      PIC X(13) VALUE '140151   1077'.
233400         10  FILLER      PIC X(13) VALUE '140161   0714'.
233500         10  FILLER      PIC X(13) VALUE '140167   0610'.
233600         10  FILLER      PIC X(13) VALUE '140210   0779'.
233700         10  FILLER      PIC X(13) VALUE '140234   1399'.
233800         10  FILLER      PIC X(13) VALUE '140294   0853'.
233900         10  FILLER      PIC X(13) VALUE '140300   0200'.
234000         10  FILLER      PIC X(13) VALUE '150001   1171'.
234100         10  FILLER      PIC X(13) VALUE '150022   0767'.
234200         10  FILLER      PIC X(13) VALUE '150030   1158'.
234300         10  FILLER      PIC X(13) VALUE '150038   0625'.
234400         10  FILLER      PIC X(13) VALUE '150045   0937'.
234500         10  FILLER      PIC X(13) VALUE '150061   1039'.
234600         10  FILLER      PIC X(13) VALUE '150064   0857'.
234700         10  FILLER      PIC X(13) VALUE '150065   1479'.
234800         10  FILLER      PIC X(13) VALUE '150072   0873'.
234900         10  FILLER      PIC X(13) VALUE '150075   1180'.
235000         10  FILLER      PIC X(13) VALUE '150076   1123'.
235100         10  FILLER      PIC X(13) VALUE '150091   0966'.
235200         10  FILLER      PIC X(13) VALUE '150097   1489'.
235300         10  FILLER      PIC X(13) VALUE '150101   0768'.
235400         10  FILLER      PIC X(13) VALUE '150102   0422'.
235500         10  FILLER      PIC X(13) VALUE '150104   1009'.
235600         10  FILLER      PIC X(13) VALUE '150129   0519'.
235700         10  FILLER      PIC X(13) VALUE '150146   0980'.
235800         10  FILLER      PIC X(13) VALUE '150149   0044'.
235900         10  FILLER      PIC X(13) VALUE '150150   1023'.
236000         10  FILLER      PIC X(13) VALUE '150160   1146'.
236100         10  FILLER      PIC X(13) VALUE '150163   0268'.
236200         10  FILLER      PIC X(13) VALUE '150164   0713'.
236300         10  FILLER      PIC X(13) VALUE '150165   0453'.
236400         10  FILLER      PIC X(13) VALUE '150166   0265'.
236500         10  FILLER      PIC X(13) VALUE '150167   1085'.
236600         10  FILLER      PIC X(13) VALUE '150168   1446'.
236700         10  FILLER      PIC X(13) VALUE '150172   0062'.
236800         10  FILLER      PIC X(13) VALUE '150175   1095'.
236900         10  FILLER      PIC X(13) VALUE '150176   0681'.
237000         10  FILLER      PIC X(13) VALUE '150177   0166'.
237100         10  FILLER      PIC X(13) VALUE '150179   0374'.
237200         10  FILLER      PIC X(13) VALUE '150180   0476'.
237300         10  FILLER      PIC X(13) VALUE '150181   0116'.
237400         10  FILLER      PIC X(13) VALUE '150182   0009'.
237500         10  FILLER      PIC X(13) VALUE '160001   1170'.
237600         10  FILLER      PIC X(13) VALUE '160005   0793'.
237700         10  FILLER      PIC X(13) VALUE '160008   0858'.
237800         10  FILLER      PIC X(13) VALUE '160013   0777'.
237900         10  FILLER      PIC X(13) VALUE '160032   0873'.
238000         10  FILLER      PIC X(13) VALUE '160040   0672'.
238100         10  FILLER      PIC X(13) VALUE '160101   0399'.
238200         10  FILLER      PIC X(13) VALUE '160104   1583'.
238300         10  FILLER      PIC X(13) VALUE '160112   1095'.
238400         10  FILLER      PIC X(13) VALUE '160122   0718'.
238500         10  FILLER      PIC X(13) VALUE '160124   0481'.
238600         10  FILLER      PIC X(13) VALUE '160147   0656'.
238700         10  FILLER      PIC X(13) VALUE '170001   1035'.
238800         10  FILLER      PIC X(13) VALUE '170009   0666'.
238900         10  FILLER      PIC X(13) VALUE '170010   0558'.
239000         10  FILLER      PIC X(13) VALUE '170014   0710'.
239100         10  FILLER      PIC X(13) VALUE '170017   0771'.
239200         10  FILLER      PIC X(13) VALUE '170023   1164'.
239300         10  FILLER      PIC X(13) VALUE '170027   0665'.
239400         10  FILLER      PIC X(13) VALUE '170039   0193'.
239500         10  FILLER      PIC X(13) VALUE '170058   0835'.
239600         10  FILLER      PIC X(13) VALUE '170068   0488'.
239700         10  FILLER      PIC X(13) VALUE '170074   0488'.
239800         10  FILLER      PIC X(13) VALUE '170075   0139'.
239900         10  FILLER      PIC X(13) VALUE '170094   0486'.
240000         10  FILLER      PIC X(13) VALUE '170103   1251'.
240100         10  FILLER      PIC X(13) VALUE '170105   0508'.
240200         10  FILLER      PIC X(13) VALUE '170109   0258'.
240300         10  FILLER      PIC X(13) VALUE '170110   0114'.
240400         10  FILLER      PIC X(13) VALUE '170120   1288'.
240500         10  FILLER      PIC X(13) VALUE '170133   0583'.
240600         10  FILLER      PIC X(13) VALUE '170145   1107'.
240700         10  FILLER      PIC X(13) VALUE '170150   0454'.
240800         10  FILLER      PIC X(13) VALUE '170166   0243'.
240900         10  FILLER      PIC X(13) VALUE '170175   0750'.
241000         10  FILLER      PIC X(13) VALUE '170183   0592'.
241100         10  FILLER      PIC X(13) VALUE '170186   1135'.
241200         10  FILLER      PIC X(13) VALUE '170187   0366'.
241300         10  FILLER      PIC X(13) VALUE '170188   0336'.
241400         10  FILLER      PIC X(13) VALUE '170190   0098'.
241500         10  FILLER      PIC X(13) VALUE '170191   0773'.
241600         10  FILLER      PIC X(13) VALUE '170194   0089'.
241700         10  FILLER      PIC X(13) VALUE '170196   0790'.
241800         10  FILLER      PIC X(13) VALUE '170198   0103'.
241900         10  FILLER      PIC X(13) VALUE '170199   0071'.
242000         10  FILLER      PIC X(13) VALUE '170200   0938'.
242100         10  FILLER      PIC X(13) VALUE '170203   0068'.
242200         10  FILLER      PIC X(13) VALUE '180004   0904'.
242300         10  FILLER      PIC X(13) VALUE '180016   1088'.
242400         10  FILLER      PIC X(13) VALUE '180019   1465'.
242500         10  FILLER      PIC X(13) VALUE '180020   1136'.
242600         10  FILLER      PIC X(13) VALUE '180021   1316'.
242700         10  FILLER      PIC X(13) VALUE '180024   0715'.
242800         10  FILLER      PIC X(13) VALUE '180025   1236'.
242900         10  FILLER      PIC X(13) VALUE '180043   1127'.
243000         10  FILLER      PIC X(13) VALUE '180046   0415'.
243100         10  FILLER      PIC X(13) VALUE '180049   1471'.
243200         10  FILLER      PIC X(13) VALUE '180053   0683'.
243300         10  FILLER      PIC X(13) VALUE '180064   0925'.
243400         10  FILLER      PIC X(13) VALUE '180066   0828'.
243500         10  FILLER      PIC X(13) VALUE '180069   1363'.
243600         10  FILLER      PIC X(13) VALUE '180070   1451'.
243700         10  FILLER      PIC X(13) VALUE '180078   1034'.
243800         10  FILLER      PIC X(13) VALUE '180079   0869'.
243900         10  FILLER      PIC X(13) VALUE '180092   1163'.
244000         10  FILLER      PIC X(13) VALUE '180095   0570'.
244100         10  FILLER      PIC X(13) VALUE '180101   0865'.
244200         10  FILLER      PIC X(13) VALUE '180105   1126'.
244300         10  FILLER      PIC X(13) VALUE '180106   0833'.
244400         10  FILLER      PIC X(13) VALUE '180115   0537'.
244500         10  FILLER      PIC X(13) VALUE '180117   0509'.
244600         10  FILLER      PIC X(13) VALUE '180128   1145'.
244700         10  FILLER      PIC X(13) VALUE '180138   1159'.
244800         10  FILLER      PIC X(13) VALUE '180139   1128'.
244900         10  FILLER      PIC X(13) VALUE '180149   0393'.
245000         10  FILLER      PIC X(13) VALUE '190001   0674'.
245100         10  FILLER      PIC X(13) VALUE '190003   0972'.
245200         10  FILLER      PIC X(13) VALUE '190005   0989'.
245300         10  FILLER      PIC X(13) VALUE '190006   0243'.
245400         10  FILLER      PIC X(13) VALUE '190007   1013'.
245500         10  FILLER      PIC X(13) VALUE '190009   0151'.
245600         10  FILLER      PIC X(13) VALUE '190011   0411'.
245700         10  FILLER      PIC X(13) VALUE '190014   1245'.
245800         10  FILLER      PIC X(13) VALUE '190025   0546'.
245900         10  FILLER      PIC X(13) VALUE '190034   0598'.
246000         10  FILLER      PIC X(13) VALUE '190044   1268'.
246100         10  FILLER      PIC X(13) VALUE '190050   0959'.
246200         10  FILLER      PIC X(13) VALUE '190079   0597'.
246300         10  FILLER      PIC X(13) VALUE '190081   0692'.
246400         10  FILLER      PIC X(13) VALUE '190088   0626'.
246500         10  FILLER      PIC X(13) VALUE '190090   0529'.
246600         10  FILLER      PIC X(13) VALUE '190099   0766'.
246700         10  FILLER      PIC X(13) VALUE '190106   0449'.
246800         10  FILLER      PIC X(13) VALUE '190114   0855'.
246900         10  FILLER      PIC X(13) VALUE '190116   0788'.
247000         10  FILLER      PIC X(13) VALUE '190118   0489'.
247100         10  FILLER      PIC X(13) VALUE '190122   0095'.
247200         10  FILLER      PIC X(13) VALUE '190128   0141'.
247300         10  FILLER      PIC X(13) VALUE '190133   0070'.
247400         10  FILLER      PIC X(13) VALUE '190135   0724'.
247500         10  FILLER      PIC X(13) VALUE '190140   0584'.
247600         10  FILLER      PIC X(13) VALUE '190145   0328'.
247700         10  FILLER      PIC X(13) VALUE '190151   0326'.
247800         10  FILLER      PIC X(13) VALUE '190161   0070'.
247900         10  FILLER      PIC X(13) VALUE '190175   0884'.
248000         10  FILLER      PIC X(13) VALUE '190183   0624'.
248100         10  FILLER      PIC X(13) VALUE '190184   0255'.
248200         10  FILLER      PIC X(13) VALUE '190190   0307'.
248300         10  FILLER      PIC X(13) VALUE '190199   0011'.
248400         10  FILLER      PIC X(13) VALUE '190201   0344'.
248500         10  FILLER      PIC X(13) VALUE '190208   0343'.
248600         10  FILLER      PIC X(13) VALUE '190218   0411'.
248700         10  FILLER      PIC X(13) VALUE '190241   0068'.
248800         10  FILLER      PIC X(13) VALUE '190242   1346'.
248900         10  FILLER      PIC X(13) VALUE '190245   0052'.
249000         10  FILLER      PIC X(13) VALUE '190246   0337'.
249100         10  FILLER      PIC X(13) VALUE '190251   0046'.
249200         10  FILLER      PIC X(13) VALUE '190255   0002'.
249300         10  FILLER      PIC X(13) VALUE '190256   0022'.
249400         10  FILLER      PIC X(13) VALUE '190257   0170'.
249500         10  FILLER      PIC X(13) VALUE '190259   0276'.
249600         10  FILLER      PIC X(13) VALUE '190261   0020'.
249700         10  FILLER      PIC X(13) VALUE '190263   0884'.
249800         10  FILLER      PIC X(13) VALUE '190266   0279'.
249900         10  FILLER      PIC X(13) VALUE '190267   0063'.
250000         10  FILLER      PIC X(13) VALUE '190268   0021'.
250100         10  FILLER      PIC X(13) VALUE '190270   0258'.
250200         10  FILLER      PIC X(13) VALUE '190273   0001'.
250300         10  FILLER      PIC X(13) VALUE '190278   0500'.
250400         10  FILLER      PIC X(13) VALUE '190297   0204'.
250500         10  FILLER      PIC X(13) VALUE '190298   0578'.
250600         10  FILLER      PIC X(13) VALUE '190300   0011'.
250700         10  FILLER      PIC X(13) VALUE '190303   0241'.
250800         10  FILLER      PIC X(13) VALUE '190304   0006'.
250900         10  FILLER      PIC X(13) VALUE '190307   0004'.
251000         10  FILLER      PIC X(13) VALUE '190308   0346'.
251100         10  FILLER      PIC X(13) VALUE '190310   0024'.
251200         10  FILLER      PIC X(13) VALUE '200002   1104'.
251300         10  FILLER      PIC X(13) VALUE '200018   1250'.
251400         10  FILLER      PIC X(13) VALUE '200025   0500'.
251500         10  FILLER      PIC X(13) VALUE '200031   1096'.
251600         10  FILLER      PIC X(13) VALUE '200037   1249'.
251700         10  FILLER      PIC X(13) VALUE '200040   1286'.
251800         10  FILLER      PIC X(13) VALUE '200041   0672'.
251900         10  FILLER      PIC X(13) VALUE '200050   1338'.
252000         10  FILLER      PIC X(13) VALUE '200052   0623'.
252100         10  FILLER      PIC X(13) VALUE '210007   1318'.
252200         10  FILLER      PIC X(13) VALUE '210013   1473'.
252300         10  FILLER      PIC X(13) VALUE '210017   0941'.
252400         10  FILLER      PIC X(13) VALUE '210030   1499'.
252500         10  FILLER      PIC X(13) VALUE '210045   0235'.
252600         10  FILLER      PIC X(13) VALUE '210054   1328'.
252700         10  FILLER      PIC X(13) VALUE '210060   1162'.
252800         10  FILLER      PIC X(13) VALUE '210064   0281'.
252900         10  FILLER      PIC X(13) VALUE '220030   1518'.
253000         10  FILLER      PIC X(13) VALUE '220050   0755'.
253100         10  FILLER      PIC X(13) VALUE '220051   1187'.
253200         10  FILLER      PIC X(13) VALUE '220058   0467'.
253300         10  FILLER      PIC X(13) VALUE '220075   0493'.
253400         10  FILLER      PIC X(13) VALUE '220083   1393'.
253500         10  FILLER      PIC X(13) VALUE '220098   1044'.
253600         10  FILLER      PIC X(13) VALUE '220177   0138'.
253700         10  FILLER      PIC X(13) VALUE '230003   1066'.
253800         10  FILLER      PIC X(13) VALUE '230013   0688'.
253900         10  FILLER      PIC X(13) VALUE '230015   0715'.
254000         10  FILLER      PIC X(13) VALUE '230035   1469'.
254100         10  FILLER      PIC X(13) VALUE '230037   1381'.
254200         10  FILLER      PIC X(13) VALUE '230040   1325'.
254300         10  FILLER      PIC X(13) VALUE '230071   0592'.
254400         10  FILLER      PIC X(13) VALUE '230078   0397'.
254500         10  FILLER      PIC X(13) VALUE '230085   0515'.
254600         10  FILLER      PIC X(13) VALUE '230093   0995'.
254700         10  FILLER      PIC X(13) VALUE '230095   1508'.
254800         10  FILLER      PIC X(13) VALUE '230096   0831'.
254900         10  FILLER      PIC X(13) VALUE '230100   0799'.
255000         10  FILLER      PIC X(13) VALUE '230106   1281'.
255100         10  FILLER      PIC X(13) VALUE '230108   0714'.
255200         10  FILLER      PIC X(13) VALUE '230110   1177'.
255300         10  FILLER      PIC X(13) VALUE '230118   0868'.
255400         10  FILLER      PIC X(13) VALUE '230121   1572'.
255500         10  FILLER      PIC X(13) VALUE '230133   0959'.
255600         10  FILLER      PIC X(13) VALUE '230144   0175'.
255700         10  FILLER      PIC X(13) VALUE '230174   0852'.
255800         10  FILLER      PIC X(13) VALUE '230180   0893'.
255900         10  FILLER      PIC X(13) VALUE '230208   0720'.
256000         10  FILLER      PIC X(13) VALUE '230239   1591'.
256100         10  FILLER      PIC X(13) VALUE '230241   0940'.
256200         10  FILLER      PIC X(13) VALUE '230259   1366'.
256300         10  FILLER      PIC X(13) VALUE '230264   0063'.
256400         10  FILLER      PIC X(13) VALUE '230275   0109'.
256500         10  FILLER      PIC X(13) VALUE '230279   0064'.
256600         10  FILLER      PIC X(13) VALUE '230297   1506'.
256700         10  FILLER      PIC X(13) VALUE '230301   0342'.
256800         10  FILLER      PIC X(13) VALUE '240006   0447'.
256900         10  FILLER      PIC X(13) VALUE '240014   0592'.
257000         10  FILLER      PIC X(13) VALUE '240018   0911'.
257100         10  FILLER      PIC X(13) VALUE '240019   1112'.
257200         10  FILLER      PIC X(13) VALUE '240020   1296'.
257300         10  FILLER      PIC X(13) VALUE '240022   0494'.
257400         10  FILLER      PIC X(13) VALUE '240040   1377'.
257500         10  FILLER      PIC X(13) VALUE '240043   1435'.
257600         10  FILLER      PIC X(13) VALUE '240044   1324'.
257700         10  FILLER      PIC X(13) VALUE '240050   1527'.
257800         10  FILLER      PIC X(13) VALUE '240052   1196'.
257900         10  FILLER      PIC X(13) VALUE '240059   0719'.
258000         10  FILLER      PIC X(13) VALUE '240064   1038'.
258100         10  FILLER      PIC X(13) VALUE '240066   1502'.
258200         10  FILLER      PIC X(13) VALUE '240069   1062'.
258300         10  FILLER      PIC X(13) VALUE '240071   0759'.
258400         10  FILLER      PIC X(13) VALUE '240076   0955'.
258500         10  FILLER      PIC X(13) VALUE '240084   0828'.
258600         10  FILLER      PIC X(13) VALUE '240088   1544'.
258700         10  FILLER      PIC X(13) VALUE '240101   1091'.
258800         10  FILLER      PIC X(13) VALUE '240117   1127'.
258900         10  FILLER      PIC X(13) VALUE '240141   0714'.
259000         10  FILLER      PIC X(13) VALUE '240166   0983'.
259100         10  FILLER      PIC X(13) VALUE '240187   0724'.
259200         10  FILLER      PIC X(13) VALUE '240196   0080'.
259300         10  FILLER      PIC X(13) VALUE '240206   0108'.
259400         10  FILLER      PIC X(13) VALUE '250002   0483'.
259500         10  FILLER      PIC X(13) VALUE '250006   1255'.
259600         10  FILLER      PIC X(13) VALUE '250010   0416'.
259700         10  FILLER      PIC X(13) VALUE '250012   0234'.
259800         10  FILLER      PIC X(13) VALUE '250015   1344'.
259900         10  FILLER      PIC X(13) VALUE '250017   0292'.
260000         10  FILLER      PIC X(13) VALUE '250018   0005'.
260100         10  FILLER      PIC X(13) VALUE '250020   0929'.
260200         10  FILLER      PIC X(13) VALUE '250025   1275'.
260300         10  FILLER      PIC X(13) VALUE '250027   0286'.
260400         10  FILLER      PIC X(13) VALUE '250036   0687'.
260500         10  FILLER      PIC X(13) VALUE '250038   0688'.
260600         10  FILLER      PIC X(13) VALUE '250043   0669'.
260700         10  FILLER      PIC X(13) VALUE '250044   0719'.
260800         10  FILLER      PIC X(13) VALUE '250049   0566'.
260900         10  FILLER      PIC X(13) VALUE '250050   0943'.
261000         10  FILLER      PIC X(13) VALUE '250051   0026'.
261100         10  FILLER      PIC X(13) VALUE '250057   1277'.
261200         10  FILLER      PIC X(13) VALUE '250059   0748'.
261300         10  FILLER      PIC X(13) VALUE '250060   0062'.
261400         10  FILLER      PIC X(13) VALUE '250061   0217'.
261500         10  FILLER      PIC X(13) VALUE '250067   0931'.
261600         10  FILLER      PIC X(13) VALUE '250077   0957'.
261700         10  FILLER      PIC X(13) VALUE '250079   0212'.
261800         10  FILLER      PIC X(13) VALUE '250081   0010'.
261900         10  FILLER      PIC X(13) VALUE '250084   1185'.
262000         10  FILLER      PIC X(13) VALUE '250085   0616'.
262100         10  FILLER      PIC X(13) VALUE '250093   1488'.
262200         10  FILLER      PIC X(13) VALUE '250095   0392'.
262300         10  FILLER      PIC X(13) VALUE '250096   1560'.
262400         10  FILLER      PIC X(13) VALUE '250117   1028'.
262500         10  FILLER      PIC X(13) VALUE '250124   0627'.
262600         10  FILLER      PIC X(13) VALUE '250126   0405'.
262700         10  FILLER      PIC X(13) VALUE '250127   0015'.
262800         10  FILLER      PIC X(13) VALUE '250128   1290'.
262900         10  FILLER      PIC X(13) VALUE '250134   0041'.
263000         10  FILLER      PIC X(13) VALUE '250136   0024'.
263100         10  FILLER      PIC X(13) VALUE '250138   1568'.
263200         10  FILLER      PIC X(13) VALUE '250151   0199'.
263300         10  FILLER      PIC X(13) VALUE '250152   0001'.
263400         10  FILLER      PIC X(13) VALUE '250162   0836'.
263500         10  FILLER      PIC X(13) VALUE '260004   0146'.
263600         10  FILLER      PIC X(13) VALUE '260015   1164'.
263700         10  FILLER      PIC X(13) VALUE '260022   1465'.
263800         10  FILLER      PIC X(13) VALUE '260024   0813'.
263900         10  FILLER      PIC X(13) VALUE '260034   0472'.
264000         10  FILLER      PIC X(13) VALUE '260050   0282'.
264100         10  FILLER      PIC X(13) VALUE '260057   0954'.
264200         10  FILLER      PIC X(13) VALUE '260059   1533'.
264300         10  FILLER      PIC X(13) VALUE '260061   0379'.
264400         10  FILLER      PIC X(13) VALUE '260064   1332'.
264500         10  FILLER      PIC X(13) VALUE '260070   0752'.
264600         10  FILLER      PIC X(13) VALUE '260074   1057'.
264700         10  FILLER      PIC X(13) VALUE '260080   0163'.
264800         10  FILLER      PIC X(13) VALUE '260097   1197'.
264900         10  FILLER      PIC X(13) VALUE '260102   0932'.
265000         10  FILLER      PIC X(13) VALUE '260116   1198'.
265100         10  FILLER      PIC X(13) VALUE '260142   0954'.
265200         10  FILLER      PIC X(13) VALUE '260147   0161'.
265300         10  FILLER      PIC X(13) VALUE '260160   0587'.
265400         10  FILLER      PIC X(13) VALUE '260162   1247'.
265500         10  FILLER      PIC X(13) VALUE '260175   1375'.
265600         10  FILLER      PIC X(13) VALUE '260195   1509'.
265700         10  FILLER      PIC X(13) VALUE '260207   0414'.
265800         10  FILLER      PIC X(13) VALUE '260209   0230'.
265900         10  FILLER      PIC X(13) VALUE '260211   0016'.
266000         10  FILLER      PIC X(13) VALUE '260214   1257'.
266100         10  FILLER      PIC X(13) VALUE '260219   1194'.
266200         10  FILLER      PIC X(13) VALUE '260227   0145'.
266300         10  FILLER      PIC X(13) VALUE '260228   0594'.
266400         10  FILLER      PIC X(13) VALUE '260229   0008'.
266500         10  FILLER      PIC X(13) VALUE '270032   0448'.
266600         10  FILLER      PIC X(13) VALUE '270074   0114'.
266700         10  FILLER      PIC X(13) VALUE '270086   0249'.
266800         10  FILLER      PIC X(13) VALUE '270087   0262'.
266900         10  FILLER      PIC X(13) VALUE '280032   1536'.
267000         10  FILLER      PIC X(13) VALUE '280105   1064'.
267100         10  FILLER      PIC X(13) VALUE '280111   1019'.
267200         10  FILLER      PIC X(13) VALUE '280119   0013'.
267300         10  FILLER      PIC X(13) VALUE '280127   0436'.
267400         10  FILLER      PIC X(13) VALUE '280128   1464'.
267500         10  FILLER      PIC X(13) VALUE '280129   0594'.
267600         10  FILLER      PIC X(13) VALUE '280131   0288'.
267700         10  FILLER      PIC X(13) VALUE '280132   1550'.
267800         10  FILLER      PIC X(13) VALUE '280133   0317'.
267900         10  FILLER      PIC X(13) VALUE '290002   0097'.
268000         10  FILLER      PIC X(13) VALUE '290006   0854'.
268100         10  FILLER      PIC X(13) VALUE '290008   0849'.
268200         10  FILLER      PIC X(13) VALUE '290020   0024'.
268300         10  FILLER      PIC X(13) VALUE '290042   0034'.
268400         10  FILLER      PIC X(13) VALUE '290051   0389'.
268500         10  FILLER      PIC X(13) VALUE '310058   0749'.
268600         10  FILLER      PIC X(13) VALUE '310118   0998'.
268700         10  FILLER      PIC X(13) VALUE '310130   0356'.
268800         10  FILLER      PIC X(13) VALUE '320003   0930'.
268900         10  FILLER      PIC X(13) VALUE '320004   1375'.
269000         10  FILLER      PIC X(13) VALUE '320011   0895'.
269100         10  FILLER      PIC X(13) VALUE '320013   0672'.
269200         10  FILLER      PIC X(13) VALUE '320016   0994'.
269300         10  FILLER      PIC X(13) VALUE '320017   1292'.
269400         10  FILLER      PIC X(13) VALUE '320030   0480'.
269500         10  FILLER      PIC X(13) VALUE '320033   0480'.
269600         10  FILLER      PIC X(13) VALUE '320038   1112'.
269700         10  FILLER      PIC X(13) VALUE '320057   0038'.
269800         10  FILLER      PIC X(13) VALUE '320058   0022'.
269900         10  FILLER      PIC X(13) VALUE '320059   0558'.
270000         10  FILLER      PIC X(13) VALUE '320060   0121'.
270100         10  FILLER      PIC X(13) VALUE '320061   0844'.
270200         10  FILLER      PIC X(13) VALUE '320062   0130'.
270300         10  FILLER      PIC X(13) VALUE '320063   1341'.
270400         10  FILLER      PIC X(13) VALUE '320065   0887'.
270500         10  FILLER      PIC X(13) VALUE '320067   0104'.
270600         10  FILLER      PIC X(13) VALUE '320070   0078'.
270700         10  FILLER      PIC X(13) VALUE '320074   1154'.
270800         10  FILLER      PIC X(13) VALUE '320084   0381'.
270900         10  FILLER      PIC X(13) VALUE '320086   0742'.
271000         10  FILLER      PIC X(13) VALUE '320089   0554'.
271100         10  FILLER      PIC X(13) VALUE '330008   0532'.
271200         10  FILLER      PIC X(13) VALUE '330033   0936'.
271300         10  FILLER      PIC X(13) VALUE '330037   0598'.
271400         10  FILLER      PIC X(13) VALUE '330053   0678'.
271500         10  FILLER      PIC X(13) VALUE '330079   1099'.
271600         10  FILLER      PIC X(13) VALUE '330084   1130'.
271700         10  FILLER      PIC X(13) VALUE '330086   1262'.
271800         10  FILLER      PIC X(13) VALUE '330088   1009'.
271900         10  FILLER      PIC X(13) VALUE '330096   0759'.
272000         10  FILLER      PIC X(13) VALUE '330100   0056'.
272100         10  FILLER      PIC X(13) VALUE '330111   0538'.
272200         10  FILLER      PIC X(13) VALUE '330115   1298'.
272300         10  FILLER      PIC X(13) VALUE '330132   0623'.
272400         10  FILLER      PIC X(13) VALUE '330144   0341'.
272500         10  FILLER      PIC X(13) VALUE '330151   0811'.
272600         10  FILLER      PIC X(13) VALUE '330166   0044'.
272700         10  FILLER      PIC X(13) VALUE '330177   0221'.
272800         10  FILLER      PIC X(13) VALUE '330205   1118'.
272900         10  FILLER      PIC X(13) VALUE '330211   1200'.
273000         10  FILLER      PIC X(13) VALUE '330213   0702'.
273100         10  FILLER      PIC X(13) VALUE '330223   1150'.
273200         10  FILLER      PIC X(13) VALUE '330224   0959'.
273300         10  FILLER      PIC X(13) VALUE '330225   0144'.
273400         10  FILLER      PIC X(13) VALUE '330229   1293'.
273500         10  FILLER      PIC X(13) VALUE '330238   0879'.
273600         10  FILLER      PIC X(13) VALUE '330249   0927'.
273700         10  FILLER      PIC X(13) VALUE '330263   0345'.
273800         10  FILLER      PIC X(13) VALUE '330265   1133'.
273900         10  FILLER      PIC X(13) VALUE '330268   0365'.
274000         10  FILLER      PIC X(13) VALUE '330316   0638'.
274100         10  FILLER      PIC X(13) VALUE '330385   1223'.
274200         10  FILLER      PIC X(13) VALUE '330403   0019'.
274300         10  FILLER      PIC X(13) VALUE '330404   0665'.
274400         10  FILLER      PIC X(13) VALUE '330405   0506'.
274500         10  FILLER      PIC X(13) VALUE '330406   0658'.
274600         10  FILLER      PIC X(13) VALUE '330409   0018'.
274700         10  FILLER      PIC X(13) VALUE '340011   1031'.
274800         10  FILLER      PIC X(13) VALUE '340016   1576'.
274900         10  FILLER      PIC X(13) VALUE '340036   0826'.
275000         10  FILLER      PIC X(13) VALUE '340037   1049'.
275100         10  FILLER      PIC X(13) VALUE '340049   0616'.
275200         10  FILLER      PIC X(13) VALUE '340055   0186'.
275300         10  FILLER      PIC X(13) VALUE '340084   0244'.
275400         10  FILLER      PIC X(13) VALUE '340085   1482'.
275500         10  FILLER      PIC X(13) VALUE '340087   1184'.
275600         10  FILLER      PIC X(13) VALUE '340097   1599'.
275700         10  FILLER      PIC X(13) VALUE '340106   1306'.
275800         10  FILLER      PIC X(13) VALUE '340120   1076'.
275900         10  FILLER      PIC X(13) VALUE '340127   1006'.
276000         10  FILLER      PIC X(13) VALUE '340133   1112'.
276100         10  FILLER      PIC X(13) VALUE '340144   1587'.
276200         10  FILLER      PIC X(13) VALUE '340148   0369'.
276300         10  FILLER      PIC X(13) VALUE '340156   0120'.
276400         10  FILLER      PIC X(13) VALUE '340159   1000'.
276500         10  FILLER      PIC X(13) VALUE '340160   1227'.
276600         10  FILLER      PIC X(13) VALUE '340168   0193'.
276700         10  FILLER      PIC X(13) VALUE '340186   1573'.
276800         10  FILLER      PIC X(13) VALUE '350063   0127'.
276900         10  FILLER      PIC X(13) VALUE '360002   1304'.
277000         10  FILLER      PIC X(13) VALUE '360013   0912'.
277100         10  FILLER      PIC X(13) VALUE '360014   1191'.
277200         10  FILLER      PIC X(13) VALUE '360029   1562'.
277300         10  FILLER      PIC X(13) VALUE '360032   1081'.
277400         10  FILLER      PIC X(13) VALUE '360040   1379'.
277500         10  FILLER      PIC X(13) VALUE '360044   1290'.
277600         10  FILLER      PIC X(13) VALUE '360046   1138'.
277700         10  FILLER      PIC X(13) VALUE '360058   0784'.
277800         10  FILLER      PIC X(13) VALUE '360071   0693'.
277900         10  FILLER      PIC X(13) VALUE '360089   0947'.
278000         10  FILLER      PIC X(13) VALUE '360092   0835'.
278100         10  FILLER      PIC X(13) VALUE '360107   0550'.
278200         10  FILLER      PIC X(13) VALUE '360109   1310'.
278300         10  FILLER      PIC X(13) VALUE '360116   0517'.
278400         10  FILLER      PIC X(13) VALUE '360121   1224'.
278500         10  FILLER      PIC X(13) VALUE '360148   0310'.
278600         10  FILLER      PIC X(13) VALUE '360153   0280'.
278700         10  FILLER      PIC X(13) VALUE '360156   1076'.
278800         10  FILLER      PIC X(13) VALUE '360170   1392'.
278900         10  FILLER      PIC X(13) VALUE '360189   0557'.
279000         10  FILLER      PIC X(13) VALUE '360195   1364'.
279100         10  FILLER      PIC X(13) VALUE '360197   0781'.
279200         10  FILLER      PIC X(13) VALUE '360245   0162'.
279300         10  FILLER      PIC X(13) VALUE '360247   0412'.
279400         10  FILLER      PIC X(13) VALUE '360261   0044'.
279500         10  FILLER      PIC X(13) VALUE '360263   0456'.
279600         10  FILLER      PIC X(13) VALUE '360270   0924'.
279700         10  FILLER      PIC X(13) VALUE '360271   0028'.
279800         10  FILLER      PIC X(13) VALUE '360274   0127'.
279900         10  FILLER      PIC X(13) VALUE '360347   0019'.
280000         10  FILLER      PIC X(13) VALUE '360350   0046'.
280100         10  FILLER      PIC X(13) VALUE '360352   0250'.
280200         10  FILLER      PIC X(13) VALUE '360355   0238'.
280300         10  FILLER      PIC X(13) VALUE '360358   0005'.
280400         10  FILLER      PIC X(13) VALUE '360361   0036'.
280500         10  FILLER      PIC X(13) VALUE '360362   0081'.
280600         10  FILLER      PIC X(13) VALUE '370002   0627'.
280700         10  FILLER      PIC X(13) VALUE '370004   1107'.
280800         10  FILLER      PIC X(13) VALUE '370006   1460'.
280900         10  FILLER      PIC X(13) VALUE '370007   0132'.
281000         10  FILLER      PIC X(13) VALUE '370011   0324'.
281100         10  FILLER      PIC X(13) VALUE '370015   0445'.
281200         10  FILLER      PIC X(13) VALUE '370019   0647'.
281300         10  FILLER      PIC X(13) VALUE '370020   1306'.
281400         10  FILLER      PIC X(13) VALUE '370022   1547'.
281500         10  FILLER      PIC X(13) VALUE '370029   0589'.
281600         10  FILLER      PIC X(13) VALUE '370030   0497'.
281700         10  FILLER      PIC X(13) VALUE '370036   0243'.
281800         10  FILLER      PIC X(13) VALUE '370039   1237'.
281900         10  FILLER      PIC X(13) VALUE '370040   0844'.
282000         10  FILLER      PIC X(13) VALUE '370041   0183'.
282100         10  FILLER      PIC X(13) VALUE '370048   0637'.
282200         10  FILLER      PIC X(13) VALUE '370051   0271'.
282300         10  FILLER      PIC X(13) VALUE '370054   0815'.
282400         10  FILLER      PIC X(13) VALUE '370057   0468'.
282500         10  FILLER      PIC X(13) VALUE '370065   0767'.
282600         10  FILLER      PIC X(13) VALUE '370072   0241'.
282700         10  FILLER      PIC X(13) VALUE '370080   0136'.
282800         10  FILLER      PIC X(13) VALUE '370083   0398'.
282900         10  FILLER      PIC X(13) VALUE '370097   1206'.
283000         10  FILLER      PIC X(13) VALUE '370099   0756'.
283100         10  FILLER      PIC X(13) VALUE '370100   1013'.
283200         10  FILLER      PIC X(13) VALUE '370103   0218'.
283300         10  FILLER      PIC X(13) VALUE '370112   0276'.
283400         10  FILLER      PIC X(13) VALUE '370113   1467'.
283500         10  FILLER      PIC X(13) VALUE '370138   0224'.
283600         10  FILLER      PIC X(13) VALUE '370139   0233'.
283700         10  FILLER      PIC X(13) VALUE '370153   0609'.
283800         10  FILLER      PIC X(13) VALUE '370156   0344'.
283900         10  FILLER      PIC X(13) VALUE '370158   0554'.
284000         10  FILLER      PIC X(13) VALUE '370166   0831'.
284100         10  FILLER      PIC X(13) VALUE '370169   0076'.
284200         10  FILLER      PIC X(13) VALUE '370170   0062'.
284300         10  FILLER      PIC X(13) VALUE '370171   0349'.
284400         10  FILLER      PIC X(13) VALUE '370172   0214'.
284500         10  FILLER      PIC X(13) VALUE '370173   0134'.
284600         10  FILLER      PIC X(13) VALUE '370178   0658'.
284700         10  FILLER      PIC X(13) VALUE '370180   0398'.
284800         10  FILLER      PIC X(13) VALUE '370183   0317'.
284900         10  FILLER      PIC X(13) VALUE '370190   0217'.
285000         10  FILLER      PIC X(13) VALUE '370192   0093'.
285100         10  FILLER      PIC X(13) VALUE '370199   0004'.
285200         10  FILLER      PIC X(13) VALUE '370201   0120'.
285300         10  FILLER      PIC X(13) VALUE '370203   0679'.
285400         10  FILLER      PIC X(13) VALUE '370206   0332'.
285500         10  FILLER      PIC X(13) VALUE '370210   1292'.
285600         10  FILLER      PIC X(13) VALUE '370211   1042'.
285700         10  FILLER      PIC X(13) VALUE '370212   0242'.
285800         10  FILLER      PIC X(13) VALUE '370214   0031'.
285900         10  FILLER      PIC X(13) VALUE '370216   0611'.
286000         10  FILLER      PIC X(13) VALUE '370220   0051'.
286100         10  FILLER      PIC X(13) VALUE '370225   0065'.
286200         10  FILLER      PIC X(13) VALUE '370227   0653'.
286300         10  FILLER      PIC X(13) VALUE '370228   0465'.
286400         10  FILLER      PIC X(13) VALUE '370229   0453'.
286500         10  FILLER      PIC X(13) VALUE '370233   0005'.
286600         10  FILLER      PIC X(13) VALUE '370235   1337'.
286700         10  FILLER      PIC X(13) VALUE '370236   0570'.
286800         10  FILLER      PIC X(13) VALUE '380001   1151'.
286900         10  FILLER      PIC X(13) VALUE '380005   0512'.
287000         10  FILLER      PIC X(13) VALUE '380022   1558'.
287100         10  FILLER      PIC X(13) VALUE '380029   0577'.
287200         10  FILLER      PIC X(13) VALUE '380033   0680'.
287300         10  FILLER      PIC X(13) VALUE '380037   1099'.
287400         10  FILLER      PIC X(13) VALUE '380040   0976'.
287500         10  FILLER      PIC X(13) VALUE '380052   1126'.
287600         10  FILLER      PIC X(13) VALUE '380056   0421'.
287700         10  FILLER      PIC X(13) VALUE '390003   0565'.
287800         10  FILLER      PIC X(13) VALUE '390008   1037'.
287900         10  FILLER      PIC X(13) VALUE '390019   1005'.
288000         10  FILLER      PIC X(13) VALUE '390025   0055'.
288100         10  FILLER      PIC X(13) VALUE '390035   1467'.
288200         10  FILLER      PIC X(13) VALUE '390043   1271'.
288300         10  FILLER      PIC X(13) VALUE '390052   1477'.
288400         10  FILLER      PIC X(13) VALUE '390056   0980'.
288500         10  FILLER      PIC X(13) VALUE '390062   0957'.
288600         10  FILLER      PIC X(13) VALUE '390068   1081'.
288700         10  FILLER      PIC X(13) VALUE '390070   1370'.
288800         10  FILLER      PIC X(13) VALUE '390071   0740'.
288900         10  FILLER      PIC X(13) VALUE '390072   1346'.
289000         10  FILLER      PIC X(13) VALUE '390084   0760'.
289100         10  FILLER      PIC X(13) VALUE '390093   1127'.
289200         10  FILLER      PIC X(13) VALUE '390104   0493'.
289300         10  FILLER      PIC X(13) VALUE '390112   0899'.
289400         10  FILLER      PIC X(13) VALUE '390117   1155'.
289500         10  FILLER      PIC X(13) VALUE '390118   1229'.
289600         10  FILLER      PIC X(13) VALUE '390122   0767'.
289700         10  FILLER      PIC X(13) VALUE '390130   0377'.
289800         10  FILLER      PIC X(13) VALUE '390132   1481'.
289900         10  FILLER      PIC X(13) VALUE '390138   1472'.
290000         10  FILLER      PIC X(13) VALUE '390146   1314'.
290100         10  FILLER      PIC X(13) VALUE '390150   1016'.
290200         10  FILLER      PIC X(13) VALUE '390183   1336'.
290300         10  FILLER      PIC X(13) VALUE '390184   0578'.
290400         10  FILLER      PIC X(13) VALUE '390192   0690'.
290500         10  FILLER      PIC X(13) VALUE '390198   1276'.
290600         10  FILLER      PIC X(13) VALUE '390199   0903'.
290700         10  FILLER      PIC X(13) VALUE '390236   0614'.
290800         10  FILLER      PIC X(13) VALUE '390266   1059'.
290900         10  FILLER      PIC X(13) VALUE '390272   0314'.
291000         10  FILLER      PIC X(13) VALUE '390278   0499'.
291100         10  FILLER      PIC X(13) VALUE '390302   0008'.
291200         10  FILLER      PIC X(13) VALUE '390307   0047'.
291300         10  FILLER      PIC X(13) VALUE '390312   0301'.
291400         10  FILLER      PIC X(13) VALUE '390314   0473'.
291500         10  FILLER      PIC X(13) VALUE '390316   0247'.
291600         10  FILLER      PIC X(13) VALUE '390318   0172'.
291700         10  FILLER      PIC X(13) VALUE '390321   0255'.
291800         10  FILLER      PIC X(13) VALUE '390322   0318'.
291900         10  FILLER      PIC X(13) VALUE '390323   0250'.
292000         10  FILLER      PIC X(13) VALUE '390324   0122'.
292100         10  FILLER      PIC X(13) VALUE '390325   0528'.
292200         10  FILLER      PIC X(13) VALUE '390327   0262'.
292300         10  FILLER      PIC X(13) VALUE '410010   0584'.
292400         10  FILLER      PIC X(13) VALUE '410013   1558'.
292500         10  FILLER      PIC X(13) VALUE '420005   1232'.
292600         10  FILLER      PIC X(13) VALUE '420011   0495'.
292700         10  FILLER      PIC X(13) VALUE '420016   0270'.
292800         10  FILLER      PIC X(13) VALUE '420019   0939'.
292900         10  FILLER      PIC X(13) VALUE '420037   0971'.
293000         10  FILLER      PIC X(13) VALUE '420039   1309'.
293100         10  FILLER      PIC X(13) VALUE '420043   1239'.
293200         10  FILLER      PIC X(13) VALUE '420053   0756'.
293300         10  FILLER      PIC X(13) VALUE '420054   0613'.
293400         10  FILLER      PIC X(13) VALUE '420055   1430'.
293500         10  FILLER      PIC X(13) VALUE '420057   0113'.
293600         10  FILLER      PIC X(13) VALUE '420062   0923'.
293700         10  FILLER      PIC X(13) VALUE '420066   0365'.
293800         10  FILLER      PIC X(13) VALUE '420069   0983'.
293900         10  FILLER      PIC X(13) VALUE '420072   0445'.
294000         10  FILLER      PIC X(13) VALUE '420101   1183'.
294100         10  FILLER      PIC X(13) VALUE '420102   0545'.
294200         10  FILLER      PIC X(13) VALUE '420103   0995'.
294300         10  FILLER      PIC X(13) VALUE '420104   0584'.
294400         10  FILLER      PIC X(13) VALUE '430008   0591'.
294500         10  FILLER      PIC X(13) VALUE '430012   1509'.
294600         10  FILLER      PIC X(13) VALUE '430013   1114'.
294700         10  FILLER      PIC X(13) VALUE '430015   0563'.
294800         10  FILLER      PIC X(13) VALUE '430048   0630'.
294900         10  FILLER      PIC X(13) VALUE '430081   0159'.
295000         10  FILLER      PIC X(13) VALUE '430082   0002'.
295100         10  FILLER      PIC X(13) VALUE '430083   0018'.
295200         10  FILLER      PIC X(13) VALUE '430084   0134'.
295300         10  FILLER      PIC X(13) VALUE '430089   0536'.
295400         10  FILLER      PIC X(13) VALUE '430090   0657'.
295500         10  FILLER      PIC X(13) VALUE '430091   0675'.
295600         10  FILLER      PIC X(13) VALUE '430092   0186'.
295700         10  FILLER      PIC X(13) VALUE '430093   0014'.
295800         10  FILLER      PIC X(13) VALUE '430094   0027'.
295900         10  FILLER      PIC X(13) VALUE '430095   1443'.
296000         10  FILLER      PIC X(13) VALUE '430096   0102'.
296100         10  FILLER      PIC X(13) VALUE '430097   0749'.
296200         10  FILLER      PIC X(13) VALUE '440001   0804'.
296300         10  FILLER      PIC X(13) VALUE '440007   0674'.
296400         10  FILLER      PIC X(13) VALUE '440008   0425'.
296500         10  FILLER      PIC X(13) VALUE '440010   0397'.
296600         10  FILLER      PIC X(13) VALUE '440016   0358'.
296700         10  FILLER      PIC X(13) VALUE '440020   0775'.
296800         10  FILLER      PIC X(13) VALUE '440031   1150'.
296900         10  FILLER      PIC X(13) VALUE '440032   0719'.
297000         10  FILLER      PIC X(13) VALUE '440033   1582'.
297100         10  FILLER      PIC X(13) VALUE '440040   0339'.
297200         10  FILLER      PIC X(13) VALUE '440047   0145'.
297300         10  FILLER      PIC X(13) VALUE '440050   0886'.
297400         10  FILLER      PIC X(13) VALUE '440051   0618'.
297500         10  FILLER      PIC X(13) VALUE '440054   0755'.
297600         10  FILLER      PIC X(13) VALUE '440056   1551'.
297700         10  FILLER      PIC X(13) VALUE '440057   0887'.
297800         10  FILLER      PIC X(13) VALUE '440060   0159'.
297900         10  FILLER      PIC X(13) VALUE '440061   0942'.
298000         10  FILLER      PIC X(13) VALUE '440064   0745'.
298100         10  FILLER      PIC X(13) VALUE '440067   1423'.
298200         10  FILLER      PIC X(13) VALUE '440068   1246'.
298300         10  FILLER      PIC X(13) VALUE '440070   0433'.
298400         10  FILLER      PIC X(13) VALUE '440083   1292'.
298500         10  FILLER      PIC X(13) VALUE '440084   1336'.
298600         10  FILLER      PIC X(13) VALUE '440102   0783'.
298700         10  FILLER      PIC X(13) VALUE '440109   0801'.
298800         10  FILLER      PIC X(13) VALUE '440110   1185'.
298900         10  FILLER      PIC X(13) VALUE '440111   0505'.
299000         10  FILLER      PIC X(13) VALUE '440115   0151'.
299100         10  FILLER      PIC X(13) VALUE '440130   1139'.
299200         10  FILLER      PIC X(13) VALUE '440131   0490'.
299300         10  FILLER      PIC X(13) VALUE '440137   1244'.
299400         10  FILLER      PIC X(13) VALUE '440141   0300'.
299500         10  FILLER      PIC X(13) VALUE '440148   0709'.
299600         10  FILLER      PIC X(13) VALUE '440152   1343'.
299700         10  FILLER      PIC X(13) VALUE '440153   1534'.
299800         10  FILLER      PIC X(13) VALUE '440159   0514'.
299900         10  FILLER      PIC X(13) VALUE '440168   0106'.
300000         10  FILLER      PIC X(13) VALUE '440174   0216'.
300100         10  FILLER      PIC X(13) VALUE '440175   1086'.
300200         10  FILLER      PIC X(13) VALUE '440180   0712'.
300300         10  FILLER      PIC X(13) VALUE '440181   0142'.
300400         10  FILLER      PIC X(13) VALUE '440182   0576'.
300500         10  FILLER      PIC X(13) VALUE '440187   1592'.
300600         10  FILLER      PIC X(13) VALUE '440192   0750'.
300700         10  FILLER      PIC X(13) VALUE '440200   0343'.
300800         10  FILLER      PIC X(13) VALUE '440218   0531'.
300900         10  FILLER      PIC X(13) VALUE '440231   0019'.
301000         10  FILLER      PIC X(13) VALUE '440232   0061'.
301100         10  FILLER      PIC X(13) VALUE '450005   0787'.
301200         10  FILLER      PIC X(13) VALUE '450052   0254'.
301300         10  FILLER      PIC X(13) VALUE '450055   0553'.
301400         10  FILLER      PIC X(13) VALUE '450073   0237'.
301500         10  FILLER      PIC X(13) VALUE '450078   0204'.
301600         10  FILLER      PIC X(13) VALUE '450080   0863'.
301700         10  FILLER      PIC X(13) VALUE '450082   0920'.
301800         10  FILLER      PIC X(13) VALUE '450085   0468'.
301900         10  FILLER      PIC X(13) VALUE '450090   0603'.
302000         10  FILLER      PIC X(13) VALUE '450099   0784'.
302100         10  FILLER      PIC X(13) VALUE '450108   0521'.
302200         10  FILLER      PIC X(13) VALUE '450143   0255'.
302300         10  FILLER      PIC X(13) VALUE '450144   0149'.
302400         10  FILLER      PIC X(13) VALUE '450154   1097'.
302500         10  FILLER      PIC X(13) VALUE '450155   0200'.
302600         10  FILLER      PIC X(13) VALUE '450162   0464'.
302700         10  FILLER      PIC X(13) VALUE '450165   0815'.
302800         10  FILLER      PIC X(13) VALUE '450177   0844'.
302900         10  FILLER      PIC X(13) VALUE '450178   0595'.
303000         10  FILLER      PIC X(13) VALUE '450187   0711'.
303100         10  FILLER      PIC X(13) VALUE '450188   0474'.
303200         10  FILLER      PIC X(13) VALUE '450192   0715'.
303300         10  FILLER      PIC X(13) VALUE '450194   0578'.
303400         10  FILLER      PIC X(13) VALUE '450210   0443'.
303500         10  FILLER      PIC X(13) VALUE '450214   0421'.
303600         10  FILLER      PIC X(13) VALUE '450219   0307'.
303700         10  FILLER      PIC X(13) VALUE '450221   0263'.
303800         10  FILLER      PIC X(13) VALUE '450235   0399'.
303900         10  FILLER      PIC X(13) VALUE '450236   1497'.
304000         10  FILLER      PIC X(13) VALUE '450241   0099'.
304100         10  FILLER      PIC X(13) VALUE '450243   0094'.
304200         10  FILLER      PIC X(13) VALUE '450253   0142'.
304300         10  FILLER      PIC X(13) VALUE '450270   0422'.
304400         10  FILLER      PIC X(13) VALUE '450283   0219'.
304500         10  FILLER      PIC X(13) VALUE '450292   1157'.
304600         10  FILLER      PIC X(13) VALUE '450293   0096'.
304700         10  FILLER      PIC X(13) VALUE '450296   0392'.
304800         10  FILLER      PIC X(13) VALUE '450306   0171'.
304900         10  FILLER      PIC X(13) VALUE '450348   0256'.
305000         10  FILLER      PIC X(13) VALUE '450351   0950'.
305100         10  FILLER      PIC X(13) VALUE '450369   0227'.
305200         10  FILLER      PIC X(13) VALUE '450370   0786'.
305300         10  FILLER      PIC X(13) VALUE '450373   0327'.
305400         10  FILLER      PIC X(13) VALUE '450379   0926'.
305500         10  FILLER      PIC X(13) VALUE '450395   1408'.
305600         10  FILLER      PIC X(13) VALUE '450399   0278'.
305700         10  FILLER      PIC X(13) VALUE '450400   0473'.
305800         10  FILLER      PIC X(13) VALUE '450411   0424'.
305900         10  FILLER      PIC X(13) VALUE '450419   0973'.
306000         10  FILLER      PIC X(13) VALUE '450422   0358'.
306100         10  FILLER      PIC X(13) VALUE '450446   0021'.
306200         10  FILLER      PIC X(13) VALUE '450451   0383'.
306300         10  FILLER      PIC X(13) VALUE '450460   0470'.
306400         10  FILLER      PIC X(13) VALUE '450465   0822'.
306500         10  FILLER      PIC X(13) VALUE '450475   0829'.
306600         10  FILLER      PIC X(13) VALUE '450488   0118'.
306700         10  FILLER      PIC X(13) VALUE '450489   0132'.
306800         10  FILLER      PIC X(13) VALUE '450497   0404'.
306900         10  FILLER      PIC X(13) VALUE '450498   0222'.
307000         10  FILLER      PIC X(13) VALUE '450539   0834'.
307100         10  FILLER      PIC X(13) VALUE '450565   0879'.
307200         10  FILLER      PIC X(13) VALUE '450573   0798'.
307300         10  FILLER      PIC X(13) VALUE '450578   0074'.
307400         10  FILLER      PIC X(13) VALUE '450580   0693'.
307500         10  FILLER      PIC X(13) VALUE '450584   0229'.
307600         10  FILLER      PIC X(13) VALUE '450586   0234'.
307700         10  FILLER      PIC X(13) VALUE '450591   0563'.
307800         10  FILLER      PIC X(13) VALUE '450596   1437'.
307900         10  FILLER      PIC X(13) VALUE '450597   0599'.
308000         10  FILLER      PIC X(13) VALUE '450604   1511'.
308100         10  FILLER      PIC X(13) VALUE '450605   0432'.
308200         10  FILLER      PIC X(13) VALUE '450615   0174'.
308300         10  FILLER      PIC X(13) VALUE '450620   0293'.
308400         10  FILLER      PIC X(13) VALUE '450641   0346'.
308500         10  FILLER      PIC X(13) VALUE '450653   1127'.
308600         10  FILLER      PIC X(13) VALUE '450654   0647'.
308700         10  FILLER      PIC X(13) VALUE '450658   0349'.
308800         10  FILLER      PIC X(13) VALUE '450661   1304'.
308900         10  FILLER      PIC X(13) VALUE '450674   0144'.
309000         10  FILLER      PIC X(13) VALUE '450683   0167'.
309100         10  FILLER      PIC X(13) VALUE '450690   0957'.
309200         10  FILLER      PIC X(13) VALUE '450694   0252'.
309300         10  FILLER      PIC X(13) VALUE '450698   0131'.
309400         10  FILLER      PIC X(13) VALUE '450746   0071'.
309500         10  FILLER      PIC X(13) VALUE '450749   0341'.
309600         10  FILLER      PIC X(13) VALUE '450754   0775'.
309700         10  FILLER      PIC X(13) VALUE '450755   0303'.
309800         10  FILLER      PIC X(13) VALUE '450770   0228'.
309900         10  FILLER      PIC X(13) VALUE '450774   0278'.
310000         10  FILLER      PIC X(13) VALUE '450780   0323'.
310100         10  FILLER      PIC X(13) VALUE '450795   0378'.
310200         10  FILLER      PIC X(13) VALUE '450796   0043'.
310300         10  FILLER      PIC X(13) VALUE '450797   0004'.
310400         10  FILLER      PIC X(13) VALUE '450803   0936'.
310500         10  FILLER      PIC X(13) VALUE '450804   1220'.
310600         10  FILLER      PIC X(13) VALUE '450808   0095'.
310700         10  FILLER      PIC X(13) VALUE '450813   0139'.
310800         10  FILLER      PIC X(13) VALUE '450822   1486'.
310900         10  FILLER      PIC X(13) VALUE '450825   0256'.
311000         10  FILLER      PIC X(13) VALUE '450827   0526'.
311100         10  FILLER      PIC X(13) VALUE '450828   1419'.
311200         10  FILLER      PIC X(13) VALUE '450831   0022'.
311300         10  FILLER      PIC X(13) VALUE '450832   1105'.
311400         10  FILLER      PIC X(13) VALUE '450833   0694'.
311500         10  FILLER      PIC X(13) VALUE '450834   0095'.
311600         10  FILLER      PIC X(13) VALUE '450839   0316'.
311700         10  FILLER      PIC X(13) VALUE '450840   1219'.
311800         10  FILLER      PIC X(13) VALUE '450841   0002'.
311900         10  FILLER      PIC X(13) VALUE '450845   0263'.
312000         10  FILLER      PIC X(13) VALUE '450851   1267'.
312100         10  FILLER      PIC X(13) VALUE '450853   0593'.
312200         10  FILLER      PIC X(13) VALUE '450856   0407'.
312300         10  FILLER      PIC X(13) VALUE '450860   0100'.
312400         10  FILLER      PIC X(13) VALUE '450864   0971'.
312500         10  FILLER      PIC X(13) VALUE '450865   0046'.
312600         10  FILLER      PIC X(13) VALUE '450867   1556'.
312700         10  FILLER      PIC X(13) VALUE '450871   0293'.
312800         10  FILLER      PIC X(13) VALUE '450872   0421'.
312900         10  FILLER      PIC X(13) VALUE '450874   0124'.
313000         10  FILLER      PIC X(13) VALUE '450875   0571'.
313100         10  FILLER      PIC X(13) VALUE '450877   0305'.
313200         10  FILLER      PIC X(13) VALUE '450880   0519'.
313300         10  FILLER      PIC X(13) VALUE '450883   0075'.
313400         10  FILLER      PIC X(13) VALUE '450884   0294'.
313500         10  FILLER      PIC X(13) VALUE '450885   1593'.
313600         10  FILLER      PIC X(13) VALUE '450886   0008'.
313700         10  FILLER      PIC X(13) VALUE '450888   0368'.
313800         10  FILLER      PIC X(13) VALUE '450889   0074'.
313900         10  FILLER      PIC X(13) VALUE '450891   0113'.
314000         10  FILLER      PIC X(13) VALUE '450893   0036'.
314100         10  FILLER      PIC X(13) VALUE '450894   0220'.
314200         10  FILLER      PIC X(13) VALUE '460003   1441'.
314300         10  FILLER      PIC X(13) VALUE '460007   1018'.
314400         10  FILLER      PIC X(13) VALUE '460011   0744'.
314500         10  FILLER      PIC X(13) VALUE '460013   1260'.
314600         10  FILLER      PIC X(13) VALUE '460014   0669'.
314700         10  FILLER      PIC X(13) VALUE '460015   1562'.
314800         10  FILLER      PIC X(13) VALUE '460017   0369'.
314900         10  FILLER      PIC X(13) VALUE '460019   0351'.
315000         10  FILLER      PIC X(13) VALUE '460023   1566'.
315100         10  FILLER      PIC X(13) VALUE '460026   0385'.
315200         10  FILLER      PIC X(13) VALUE '460030   0383'.
315300         10  FILLER      PIC X(13) VALUE '460033   0146'.
315400         10  FILLER      PIC X(13) VALUE '460035   0095'.
315500         10  FILLER      PIC X(13) VALUE '460039   0155'.
315600         10  FILLER      PIC X(13) VALUE '460043   0015'.
315700         10  FILLER      PIC X(13) VALUE '460044   1143'.
315800         10  FILLER      PIC X(13) VALUE '460049   0850'.
315900         10  FILLER      PIC X(13) VALUE '460052   1084'.
316000         10  FILLER      PIC X(13) VALUE '460054   0292'.
316100         10  FILLER      PIC X(13) VALUE '460057   0448'.
316200         10  FILLER      PIC X(13) VALUE '460058   0664'.
316300         10  FILLER      PIC X(13) VALUE '460059   0004'.
316400         10  FILLER      PIC X(13) VALUE '470001   1525'.
316500         10  FILLER      PIC X(13) VALUE '470011   0797'.
316600         10  FILLER      PIC X(13) VALUE '470024   1198'.
316700         10  FILLER      PIC X(13) VALUE '490002   1126'.
316800         10  FILLER      PIC X(13) VALUE '490012   0755'.
316900         10  FILLER      PIC X(13) VALUE '490033   1141'.
317000         10  FILLER      PIC X(13) VALUE '490038   0992'.
317100         10  FILLER      PIC X(13) VALUE '490084   1183'.
317200         10  FILLER      PIC X(13) VALUE '490088   0970'.
317300         10  FILLER      PIC X(13) VALUE '490089   1099'.
317400         10  FILLER      PIC X(13) VALUE '490092   1108'.
317500         10  FILLER      PIC X(13) VALUE '490094   0900'.
317600         10  FILLER      PIC X(13) VALUE '490097   1156'.
317700         10  FILLER      PIC X(13) VALUE '490104   0002'.
317800         10  FILLER      PIC X(13) VALUE '490105   0007'.
317900         10  FILLER      PIC X(13) VALUE '490106   0002'.
318000         10  FILLER      PIC X(13) VALUE '490109   0036'.
318100         10  FILLER      PIC X(13) VALUE '490111   1177'.
318200         10  FILLER      PIC X(13) VALUE '490114   1406'.
318300         10  FILLER      PIC X(13) VALUE '490117   0447'.
318400         10  FILLER      PIC X(13) VALUE '490123   0931'.
318500         10  FILLER      PIC X(13) VALUE '490127   0630'.
318600         10  FILLER      PIC X(13) VALUE '490134   0012'.
318700         10  FILLER      PIC X(13) VALUE '490135   0132'.
318800         10  FILLER      PIC X(13) VALUE '490140   1246'.
318900         10  FILLER      PIC X(13) VALUE '490143   0253'.
319000         10  FILLER      PIC X(13) VALUE '500033   0978'.
319100         10  FILLER      PIC X(13) VALUE '500037   0546'.
319200         10  FILLER      PIC X(13) VALUE '500049   0615'.
319300         10  FILLER      PIC X(13) VALUE '500052   0001'.
319400         10  FILLER      PIC X(13) VALUE '500060   0725'.
319500         10  FILLER      PIC X(13) VALUE '500084   0563'.
319600         10  FILLER      PIC X(13) VALUE '500148   0248'.
319700         10  FILLER      PIC X(13) VALUE '500153   0015'.
319800         10  FILLER      PIC X(13) VALUE '510012   1207'.
319900         10  FILLER      PIC X(13) VALUE '510013   1305'.
320000         10  FILLER      PIC X(13) VALUE '510018   0001'.
320100         10  FILLER      PIC X(13) VALUE '510038   1296'.
320200         10  FILLER      PIC X(13) VALUE '510053   0554'.
320300         10  FILLER      PIC X(13) VALUE '510072   0393'.
320400         10  FILLER      PIC X(13) VALUE '510077   0885'.
320500         10  FILLER      PIC X(13) VALUE '510082   0824'.
320600         10  FILLER      PIC X(13) VALUE '510085   1424'.
320700         10  FILLER      PIC X(13) VALUE '510086   0309'.
320800         10  FILLER      PIC X(13) VALUE '520011   1182'.
320900         10  FILLER      PIC X(13) VALUE '520017   1085'.
321000         10  FILLER      PIC X(13) VALUE '520019   1183'.
321100         10  FILLER      PIC X(13) VALUE '520028   1354'.
321200         10  FILLER      PIC X(13) VALUE '520034   1062'.
321300         10  FILLER      PIC X(13) VALUE '520038   1186'.
321400         10  FILLER      PIC X(13) VALUE '520041   0952'.
321500         10  FILLER      PIC X(13) VALUE '520057   0990'.
321600         10  FILLER      PIC X(13) VALUE '520063   1269'.
321700         10  FILLER      PIC X(13) VALUE '520071   1219'.
321800         10  FILLER      PIC X(13) VALUE '520076   0903'.
321900         10  FILLER      PIC X(13) VALUE '520091   1340'.
322000         10  FILLER      PIC X(13) VALUE '520095   0788'.
322100         10  FILLER      PIC X(13) VALUE '520102   1570'.
322200         10  FILLER      PIC X(13) VALUE '520109   0652'.
322300         10  FILLER      PIC X(13) VALUE '520116   0901'.
322400         10  FILLER      PIC X(13) VALUE '520194   0483'.
322500         10  FILLER      PIC X(13) VALUE '520196   0172'.
322600         10  FILLER      PIC X(13) VALUE '520198   1392'.
322700         10  FILLER      PIC X(13) VALUE '520204   1156'.
322800         10  FILLER      PIC X(13) VALUE '520205   0691'.
322900         10  FILLER      PIC X(13) VALUE '520206   1273'.
323000         10  FILLER      PIC X(13) VALUE '530002   0721'.
323100         10  FILLER      PIC X(13) VALUE '530006   0917'.
323200         10  FILLER      PIC X(13) VALUE '530008   0615'.
323300         10  FILLER      PIC X(13) VALUE '530010   0609'.
323400         10  FILLER      PIC X(13) VALUE '530011   0600'.
323500         10  FILLER      PIC X(13) VALUE '530015   0626'.
323600         10  FILLER      PIC X(13) VALUE '530025   0689'.
323700         10  FILLER      PIC X(13) VALUE '530032   0357'.
323800         10  FILLER      PIC X(13) VALUE '530033   0451'.
323900         10  FILLER      PIC X(13) VALUE '670002   0592'.
324000         10  FILLER      PIC X(13) VALUE '670004   0729'.
324100         10  FILLER      PIC X(13) VALUE '670005   0071'.
324200         10  FILLER      PIC X(13) VALUE '670006   0444'.
324300         10  FILLER      PIC X(13) VALUE '670008   0226'.
324400         10  FILLER      PIC X(13) VALUE '670012   0776'.
324500         10  FILLER      PIC X(13) VALUE '670018   0034'.
324600         10  FILLER      PIC X(13) VALUE '670019   1194'.
324700         10  FILLER      PIC X(13) VALUE '670021   0003'.
324800         10  FILLER      PIC X(13) VALUE '670029   0083'.
324900         10  FILLER      PIC X(13) VALUE '670043   1385'.
325000         10  FILLER      PIC X(13) VALUE '670046   0116'.
325100         10  FILLER      PIC X(13) VALUE '670049   0378'.
325200         10  FILLER      PIC X(13) VALUE '670050   0197'.
325300         10  FILLER      PIC X(13) VALUE '670052   0136'.
325400         10  FILLER      PIC X(13) VALUE '670053   1594'.
325500         10  FILLER      PIC X(13) VALUE '670054   0168'.
325600         10  FILLER      PIC X(13) VALUE '670058   0022'.
325700         10  FILLER      PIC X(13) VALUE '670059   0398'.
325800         10  FILLER      PIC X(13) VALUE '670061   0508'.
325900         10  FILLER      PIC X(13) VALUE '670062   0007'.
326000         10  FILLER      PIC X(13) VALUE '670064   0009'.
326100         10  FILLER      PIC X(13) VALUE '670066   0017'.
326200         10  FILLER      PIC X(13) VALUE '670067   0570'.
326300         10  FILLER      PIC X(13) VALUE '670068   1367'.
326400         10  FILLER      PIC X(13) VALUE '670069   0173'.
326500         10  FILLER      PIC X(13) VALUE '670071   0856'.
326600         10  FILLER      PIC X(13) VALUE '670072   0029'.
326700         10  FILLER      PIC X(13) VALUE '670073   0632'.
326800         10  FILLER      PIC X(13) VALUE '670075   1376'.
326900         10  FILLER      PIC X(13) VALUE '670076   0118'.
327000         10  FILLER      PIC X(13) VALUE '670078   0126'.
327100         10  FILLER      PIC X(13) VALUE '670079   0760'.
327200         10  FILLER      PIC X(13) VALUE '670080   1241'.
327300         10  FILLER      PIC X(13) VALUE '670081   0001'.
327400         10  FILLER      PIC X(13) VALUE '670083   0108'.
327500         10  FILLER      PIC X(13) VALUE '670085   0599'.
327600         10  FILLER      PIC X(13) VALUE '670087   0004'.
327700         10  FILLER      PIC X(13) VALUE '670088   0046'.
327800         10  FILLER      PIC X(13) VALUE '670089   0011'.
327900     05  WK-LOWVOL-DATA2 REDEFINES LOWVOL-PROV-DISCHG-DATA.
328000        10  LOWVOL-TAB OCCURS 1257
328100                        ASCENDING KEY IS WK-LOWVOL-PROV
328200                        INDEXED BY LOWVOL-IDX.
328300           15  WK-LOWVOL-COUNT-ALL.
328400              20  WK-LOWVOL-PROV           PIC X(6).
328500              20  FILLER                   PIC XXX.
328600              20  WK-LOWVOL-PROV-DISCHG    PIC 9999.
328700
328800*****YEARCHANGE 2015.0 ************************************
328900
329000***********************************************************
329100*****YEARCHANGE 2015.0 ************************************
329200***********************************************************
329300***  PROVIDER ADJUSTMENT TABLE FOR UNCOMPENSATED CARE UCC
329400***  WAS CHANGED TO DATA COMING FROM THE PROVIDER FILE
329500***********************************************************
329600
329700*
329800*
329900
330000 01  MES-ADD-PROV                   PIC X(53) VALUE SPACES.
330100 01  MES-CHG-PROV                   PIC X(53) VALUE SPACES.
330200 01  MES-PPS-PROV                   PIC X(06).
330300 01  MES-PPS-STATE                  PIC X(02).
330400 01  MES-INTRO                      PIC X(53) VALUE SPACES.
330500 01  MES-TOT-PAY                    PIC 9(07)V9(02) VALUE 0.
330600 01  MES-SSRFBN.
330700     05 MES-SSRFBN-STATE PIC 99.
330800     05 FILLER           PIC XX.
330900     05 MES-SSRFBN-RATE  PIC 9(1)V9(5).
331000     05 FILLER           PIC XX.
331100     05 MES-SSRFBN-CODE2 PIC 99.
331200     05 FILLER           PIC XX.
331300     05 MES-SSRFBN-STNAM PIC X(20).
331400     05 MES-SSRFBN-REST  PIC X(22).
331500
331600 01 WK-HLDDRG-DATA.
331700     05  HLDDRG-DATA.
331800         10  HLDDRG-DRGX               PIC X(03).
331900         10  FILLER1                   PIC X(01).
332000         10  HLDDRG-WEIGHT             PIC 9(02)V9(04).
332100         10  FILLER2                   PIC X(01).
332200         10  HLDDRG-GMALOS             PIC 9(02)V9(01).
332300         10  FILLER3                   PIC X(05).
332400         10  HLDDRG-LOW                PIC X(01).
332500         10  FILLER5                   PIC X(01).
332600         10  HLDDRG-ARITH-ALOS         PIC 9(02)V9(01).
332700         10  FILLER6                   PIC X(02).
332800         10  HLDDRG-PAC                PIC X(01).
332900         10  FILLER7                   PIC X(01).
333000         10  HLDDRG-SPPAC              PIC X(01).
333100         10  FILLER8                   PIC X(02).
333200         10  HLDDRG-DESC               PIC X(26).
333300
333400
333500 01 WK-HLDDRG-DATA2.
333600     05  HLDDRG-DATA2.
333700         10  HLDDRG-DRGX2               PIC X(03).
333800         10  FILLER21                   PIC X(01).
333900         10  HLDDRG-WEIGHT2             PIC 9(02)V9(04).
334000         10  FILLER22                   PIC X(01).
334100         10  HLDDRG-GMALOS2             PIC 9(02)V9(01).
334200         10  FILLER23                   PIC X(05).
334300         10  HLDDRG-LOW2                PIC X(01).
334400         10  FILLER25                   PIC X(01).
334500         10  HLDDRG-ARITH-ALOS2         PIC 9(02)V9(01).
334600         10  FILLER26                   PIC X(02).
334700         10  HLDDRG-TRANS-FLAGS.
334800                   88  D-DRG-POSTACUTE-50-50
334900                   VALUE 'Y Y'.
335000                   88  D-DRG-POSTACUTE-PERDIEM
335100                   VALUE 'Y  '.
335200             15  HLDDRG-PAC2            PIC X(01).
335300             15  FILLER27               PIC X(01).
335400             15  HLDDRG-SPPAC2          PIC X(01).
335500         10  FILLER28                   PIC X(02).
335600         10  HLDDRG-DESC2               PIC X(26).
335700         10  HLDDRG-VALID               PIC X(01).
335800
335900
336000 01  MES-LOWVOL.
336100     05  MES-LOWVOL-PROV             PIC X(6).
336200     05  FILLER                      PIC XXX.
336300     05  MESWK-LOWVOL-PROV-DISCHG    PIC 9999.
336400
336500
336600 01  WK-UNCOMP-CARE.
336700     05  WK-UNCOMP-CARE-PROV         PIC X(6).
336800     05  FILLER                      PIC X.
336900     05  WK-UNCOMP-CARE-AMOUNT       PIC 9(06)V9(02).
337000
337100
337200*01  HOLD-AREA.
337300*    02  HOLD-PPS-COMPONENTS.
337400*        05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
337500*        05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
337600*
337700*        05  H-OPER-HSP-PART              PIC 9(06)V9(09).
337800*        05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
337900*
338000*        05  H-OPER-FSP-PART              PIC 9(06)V9(09).
338100*        05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
338200*        05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
338300*
338400*        05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
338500*        05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
338600*        05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
338700*
338800*        05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
338900*        05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
339000*
339100*        05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
339200*        05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
339300*
339400*        05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
339500*        05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
339600*
339700*        05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
339800*        05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
339900*        05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
340000*        05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
340100*        05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
340200*        05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
340300*        05  H-CAPI-COLA                  PIC 9(01)V9(03).
340400*        05  H-CAPI-SCH                   PIC 9(05)V9(02).
340500*        05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
340600*        05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
340700*        05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
340800*        05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
340900*        05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
341000*        05  H-CAPI-GAF                   PIC 9(05)V9(04).
341100*        05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
341200*        05  H-BLEND-GAF                  PIC 9(05)V9(04).
341300*        05  H-WAGE-INDEX                 PIC 9(02)V9(04).
341400*        05  H-COV-DAYS                   PIC 9(3).
341500*        05  H-PERDIEM-DAYS               PIC 9(3).
341600*        05  H-REG-DAYS                   PIC 9(3).
341700*        05  H-LTR-DAYS                   PIC 9(3).
341800*        05  H-DSCHG-FRCTN                PIC 9(3)V9999.
341900*        05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
342000*        05  H-ALOS                       PIC 9(02)V9(01).
342100*        05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
342200*        05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
342300*        05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
342400*        05  H-CST-THRESH                 PIC 9(05)V9(02).
342500*        05  H-OPER-BASE                  PIC 9(05)V9(02).
342600*        05  H-CAPI-BASE                  PIC 9(05)V9(02).
342700*        05  H-OPER-BILL-STDZ-COSTS       PIC 9(07)V9(02).
342800*        05  H-CAPI-BILL-STDZ-COSTS       PIC 9(07)V9(02).
342900*        05  H-OPER-STDZ-COST-OUTLIER     PIC 9(07)V9(09).
343000*        05  H-CAPI-STDZ-COST-OUTLIER     PIC 9(07)V9(09).
343100*        05  H-OPER-STDZ-DOLLAR-THRESHOLD PIC 9(07)V9(09).
343200*        05  H-CAPI-STDZ-DOLLAR-THRESHOLD PIC 9(07)V9(02).
343300*        05  H-STANDARD-ALLOWED-AMOUNT    PIC 9(07)V9(02).
343400*        05  H-EHR-SUBS                   PIC 9(05)V9(02).
343500*        05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
343600*        05  H-BUDG-NUTR01                PIC 9(01)V9(06).
343700*        05  H-BUDG-NUTR02                PIC 9(01)V9(06).
343800*        05  H-BUDG-NUTR03                PIC 9(01)V9(06).
343900*        05  H-BUDG-NUTR04                PIC 9(01)V9(06).
344000*        05  H-BUDG-NUTR05                PIC 9(01)V9(06).
344100*        05  H-BUDG-NUTR06                PIC 9(01)V9(06).
344200*        05  H-BUDG-NUTR07                PIC 9(01)V9(06).
344300*        05  H-BUDG-NUTR08                PIC 9(01)V9(06).
344400*        05  H-BUDG-NUTR09                PIC 9(01)V9(06).
344500*        05  H-BUDG-NUTR10                PIC 9(01)V9(06).
344600*        05  H-BUDG-NUTR109               PIC 9(01)V9(06).
344700*        05  H-BUDG-NUTR113               PIC 9(01)V9(06).
344800*        05  H-BUDG-NUTR120               PIC 9(01)V9(06).
344900*        05  H-BUDG-NUTR130               PIC 9(01)V9(06).
345000*        05  H-BUDG-NUTR140               PIC 9(01)V9(06).
345100*        05  H-BUDG-NUTR150               PIC 9(01)V9(06).
345200*        05  H-BUDG-NUTR100               PIC 9(01)V9(06).
345300*        05  H-CASE-MIX-ADJ               PIC 9(01)V9(04).
345400*        05  H-SHORT-STAY-ADJ             PIC 9(01)V9(04).
345500*        05  H-UPDATE-01                  PIC 9(01)V9(04).
345600*        05  H-UPDATE-02                  PIC 9(01)V9(04).
345700*        05  H-UPDATE-03                  PIC 9(01)V9(04).
345800*        05  H-UPDATE-04                  PIC 9(01)V9(04).
345900*        05  H-UPDATE-05                  PIC 9(01)V9(04).
346000*        05  H-UPDATE-06                  PIC 9(01)V9(04).
346100*        05  H-UPDATE-07                  PIC 9(01)V9(04).
346200*        05  H-UPDATE-08                  PIC 9(01)V9(04).
346300*        05  H-UPDATE-09                  PIC 9(01)V9(04).
346400*        05  H-UPDATE-10                  PIC 9(01)V9(04).
346500*        05  H-UPDATE-109                 PIC 9(01)V9(04).
346600*        05  H-UPDATE-113                 PIC 9(01)V9(04).
346700*        05  H-UPDATE-120                 PIC 9(01)V9(04).
346800*        05  H-UPDATE-130                 PIC 9(01)V9(04).
346900*        05  H-UPDATE-140                 PIC 9(01)V9(05).
347000*        05  H-UPDATE-150                 PIC 9(01)V9(06).
347100*        05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
347200*        05  H-HSP-UPDATE94               PIC 9(01)V9(04).
347300*        05  H-HSP-UPDATE95               PIC 9(01)V9(04).
347400*        05  H-HSP-UPDATE96               PIC 9(01)V9(04).
347500*        05  H-HSP-UPDATE97               PIC 9(01)V9(04).
347600*        05  H-HSP-UPDATE98               PIC 9(01)V9(04).
347700*        05  H-HSP-UPDATE99               PIC 9(01)V9(04).
347800*        05  H-HSP-UPDATE00               PIC 9(01)V9(04).
347900*        05  H-HSP-UPDATE01               PIC 9(01)V9(04).
348000*        05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
348100*        05  H-FEDERAL-RATE               PIC 9(04)V9(02).
348200*        05  H-LABOR-PCT                  PIC 9(01)V9(04).
348300*        05  H-NONLABOR-PCT               PIC 9(01)V9(04).
348400*        05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
348500*        05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
348600*        05  H-HSP-RATE                   PIC 9(08)V9(09).
348700*        05  H-FSP-RATE                   PIC 9(08)V9(09).
348800*        05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
348900*        05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
349000*        05  H-WK-OPER-DSH                PIC 9(01)V9(04).
349100*        05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
349200*        05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
349300*        05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
349400*        05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
349500*        05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
349600*        05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
349700*        05  H-NEW-TECH-ADDON-CAP         PIC S9(07)V99.
349800*        05  H-NEW-TECH-ADDON-CAPDIF      PIC S9(07)V99.
349900*        05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
350000*        05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
350100*        05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.
350200*        05  H-NEW-TECH-ADDON-HRTIMP-STOP PIC S9(07)V99.
350300*        05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.
350400*        05  H-NEW-TECH-ADDON-SPIRAT-STOP PIC S9(07)V99.
350500*        05  H-NEW-TECH-ADDON-SPIRAT      PIC S9(07)V99.
350600*        05  H-NEW-TECH-ADDON-AUTOLITT-STOP PIC S9(07)V99.
350700*        05  H-NEW-TECH-ADDON-AUTOLITT    PIC S9(07)V99.
350800*        05  H-NEW-TECH-ADDON-DIFICID-STOP PIC S9(07)V99.
350900*        05  H-NEW-TECH-ADDON-DIFICID     PIC S9(07)V99.
351000*        05  H-NEW-TECH-ADDON-ZENITH-STOP PIC S9(07)V99.
351100*        05  H-NEW-TECH-ADDON-ZENITH      PIC S9(07)V99.
351200*        05  H-NEW-TECH-ADDON-VORAXAZE-STOP PIC S9(07)V99.
351300*        05  H-NEW-TECH-ADDON-VORAXAZE    PIC S9(07)V99.
351400*        05  H-NEW-TECH-ADDON-ARGUS-STOP  PIC S9(07)V99.
351500*        05  H-NEW-TECH-ADDON-ARGUS       PIC S9(07)V99.
351600*        05  H-NEW-TECH-ADDON-KCENTRA-STOP  PIC S9(07)V99.
351700*        05  H-NEW-TECH-ADDON-KCENTRA     PIC S9(07)V99.
351800*        05  H-NEW-TECH-ADDON-ZILVER-STOP  PIC S9(07)V99.
351900*        05  H-NEW-TECH-ADDON-ZILVER      PIC S9(07)V99.
352000*        05  H-NEW-TECH-ADDON-CARDIO-STOP  PIC S9(07)V99.
352100*        05  H-NEW-TECH-ADDON-CARDIO      PIC S9(07)V99.
352200*        05  H-NEW-TECH-ADDON-MITRACLP-STOP PIC S9(07)V99.
352300*        05  H-NEW-TECH-ADDON-MITRACLP    PIC S9(07)V99.
352400*        05  H-NEW-TECH-ADDON-RNSSYS-STOP PIC S9(07)V99.
352500*        05  H-NEW-TECH-ADDON-RNSSYS      PIC S9(07)V99.
352600*        05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).
352700*        05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).
352800*        05  H-READMIS-ADJUST-AMT         PIC S9(07)V99.
352900*        05  H-VAL-BASED-PURCH-ADJUST-AMT PIC S9(07)V99.
353000*        05  H-BUNDLE-ADJUST-AMT          PIC S9(07)V99.
353100*
353200*        05  H-LESSER-NEURO-1             PIC S9(07)V99.
353300*        05  H-LESSER-NEURO-2             PIC S9(07)V99.
353400*
353500*        05  H-LESSER-GRAFT-1             PIC S9(07)V99.
353600*        05  H-LESSER-GRAFT-2             PIC S9(07)V99.
353700*
353800*        05  H-LESSER-X-STOP-1            PIC S9(07)V99.
353900*        05  H-LESSER-X-STOP-2            PIC S9(07)V99.
354000*
354100*        05  H-LESSER-HRTIMP-STOP-1       PIC S9(07)V99.
354200*        05  H-LESSER-HRTIMP-STOP-2       PIC S9(07)V99.
354300*
354400*        05  H-LESSER-SPIRAT-STOP-1       PIC S9(07)V99.
354500*        05  H-LESSER-SPIRAT-STOP-2       PIC S9(07)V99.
354600*
354700*        05  H-LESSER-AUTOLITT-STOP-1     PIC S9(07)V99.
354800*        05  H-LESSER-AUTOLITT-STOP-2     PIC S9(07)V99.
354900*
355000*        05  H-LESSER-DIFICID-STOP-1      PIC S9(07)V99.
355100*        05  H-LESSER-DIFICID-STOP-2      PIC S9(07)V99.
355200*
355300*        05  H-LESSER-ZENITH-STOP-1       PIC S9(07)V99.
355400*        05  H-LESSER-ZENITH-STOP-2       PIC S9(07)V99.
355500*
355600*        05  H-LESSER-VORAXAZE-STOP-1     PIC S9(07)V99.
355700*        05  H-LESSER-VORAXAZE-STOP-2     PIC S9(07)V99.
355800*
355900*        05  H-LESSER-ARGUS-STOP-1        PIC S9(07)V99.
356000*        05  H-LESSER-ARGUS-STOP-2        PIC S9(07)V99.
356100*
356200*        05  H-LESSER-KCENTRA-STOP-1      PIC S9(07)V99.
356300*        05  H-LESSER-KCENTRA-STOP-2      PIC S9(07)V99.
356400*
356500*        05  H-LESSER-ZILVER-STOP-1       PIC S9(07)V99.
356600*        05  H-LESSER-ZILVER-STOP-2       PIC S9(07)V99.
356700*        05  H-LESSER-CARDIO-STOP-1       PIC S9(07)V99.
356800*        05  H-LESSER-CARDIO-STOP-2       PIC S9(07)V99.
356900*        05  H-LESSER-MITRACLP-STOP-1     PIC S9(07)V99.
357000*        05  H-LESSER-MITRACLP-STOP-2     PIC S9(07)V99.
357100*        05  H-LESSER-RNSSYS-STOP-1       PIC S9(07)V99.
357200*        05  H-LESSER-RNSSYS-STOP-2       PIC S9(07)V99.
357300*
357400*        05  H-LESSER-VAL-BASED-PUR-STOP-1 PIC S9(07)V99.
357500*        05  H-LESSER-VAL-BASED-PUR-STOP-2 PIC S9(07)V99.
357600*
357700*        05  H-CSTMED-NEURO               PIC S9(07)V99.
357800*        05  H-CSTMED-GRAFT               PIC S9(07)V99.
357900*        05  H-CSTMED-X-STOP              PIC S9(07)V99.
358000*        05  H-CSTMED-HRTIMP-STOP         PIC S9(07)V99.
358100*        05  H-CSTMED-SPIRAT-STOP         PIC S9(07)V99.
358200*        05  H-CSTMED-AUTOLITT-STOP       PIC S9(07)V99.
358300*        05  H-CSTMED-DIFICID-STOP        PIC S9(07)V99.
358400*        05  H-CSTMED-ZENITH-STOP         PIC S9(07)V99.
358500*        05  H-CSTMED-VORAXAZE-STOP       PIC S9(07)V99.
358600*        05  H-CSTMED-ARGUS-STOP          PIC S9(07)V99.
358700*        05  H-CSTMED-KCENTRA-STOP        PIC S9(07)V99.
358800*        05  H-CSTMED-ZILVER-STOP         PIC S9(07)V99.
358900*        05  H-CSTMED-CARDIO-STOP         PIC S9(07)V99.
359000*        05  H-CSTMED-MITRACLP-STOP       PIC S9(07)V99.
359100*        05  H-CSTMED-RNSSYS-STOP         PIC S9(07)V99.
359200*
359300*
359400*    02  HOLD-ADDITIONAL-VARIABLES.
359500*        05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
359600*        05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
359700*        05  H-NAT-PCT                    PIC 9(01)V9(02).
359800*        05  H-REG-PCT                    PIC 9(01)V9(02).
359900*        05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
360000*        05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
360100*        05  H-DRG-WT                     PIC 9(02)V9(04).
360200*        05  H-NAT-LABOR                  PIC 9(05)V9(02).
360300*        05  H-NAT-NONLABOR               PIC 9(05)V9(02).
360400*        05  H-REG-LABOR                  PIC 9(05)V9(02).
360500*        05  H-REG-NONLABOR               PIC 9(05)V9(02).
360600*        05  H-OPER-COLA                  PIC 9(01)V9(03).
360700*        05  H-INTERN-RATIO               PIC 9(01)V9(04).
360800*        05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
360900*        05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
361000*        05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
361100*
361200*    02  HOLD-CAPITAL-VARIABLES.
361300*        05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
361400*        05  H-CAPI-HSP                   PIC 9(07)V9(02).
361500*        05  H-CAPI-FSP                   PIC 9(07)V9(02).
361600*        05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
361700*        05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
361800*        05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
361900*        05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
362000*        05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
362100*
362200*    02  HOLD-CAPITAL2-VARIABLES.
362300*        05  H-CAPI2-PAY-CODE             PIC X(1).
362400*        05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
362500*        05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
362600*    02  HOLD-OTHER-VARIABLES.
362700*        05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
362800*        05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
362900*        05  H-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
363000*        05  H-VAL-BASED-PURCH-PARTIPNT   PIC X.
363100*        05  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
363200*        05  H-HOSP-READMISSION-REDU      PIC X.
363300*        05  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
363400*        05  H-OPERATNG-DATA.
363500*            10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
363600*            10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
363700*            10  H-OPER-HSP-AMT              PIC 9(08)V99.
363800*    02  HOLD-PC-OTH-VARIABLES.
363900*        05  H-OPER-DSH                   PIC 9(01)V9(04).
364000*        05  H-CAPI-DSH                   PIC 9(01)V9(04).
364100*        05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
364200*        05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
364300*        05  H-ARITH-ALOS                 PIC 9(02)V9(01).
364400*        05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
364500*        05  H-TRANSFER-ADJ               PIC 9(01)V9(04).
364600*        05  H-PC-HMO-FLAG                PIC X(01).
364700*        05  H-PC-COT-FLAG                PIC X(01).
364800*        05  H-OPER-HSP-PART2             PIC 9(07)V9(02).
364900*        05  H-BUNDLE-ADJUST-PAY          PIC S9(07)V99.
365000*    02  H-ADDITIONAL-PAY-INFO-DATA.
365100*        05 H-UNCOMP-CARE-AMOUNT          PIC S9(07)V9(02).
365200*        05 H-BUNDLE-ADJUST-AMT           PIC S9(07)V9(02).
365300*        05 H-VAL-BASED-PURCH-ADJUST-AMT  PIC S9(07)V9(02).
365400*        05 H-READMIS-ADJUST-AMT          PIC S9(07)V9(02).
365500*    02  H-ADDITIONAL-PAY-INFO-DATA2.
365600*        05  H-HAC-PROG-REDUC-IND         PIC X.
365700*        05  H-EHR-PROG-REDUC-IND         PIC X.
365800*        05  H-EHR-ADJUST-AMT             PIC S9(07)V9(02).
365900*        05  H-STNDRD-VALUE               PIC S9(07)V9(02).
366000*        05  H-HAC-PAYMENT-AMT            PIC S9(07)V9(02).
366100*        05  H-FLX7-PAYMENT               PIC S9(07)V9(02).
366200*    02 H-FILLER                          PIC X(0906).
366300
366400 01  HLD-PPS-DATA.
366500         10  HLD-PPS-RTC                PIC 9(02).
366600         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
366700         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
366800         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
366900         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
367000         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
367100         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
367200         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
367300         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
367400         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
367500         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
367600         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
367700         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
367800         10  HLD-PPS-CALC-VERS          PIC X(05).
367900
368000 LINKAGE SECTION.
368100***************************************************************
368200*                 * * * * * * * * *                           *
368300*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
368400*    IN HOW TO PAY THE BILL.                                  *
368500*                         *****                               *
368600*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
368700*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
368800*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
368900*                 OUTLIER COMPUTATION.                        *
369000*                         *****                               *
369100*         REVIEW-CODE:                                        *
369200*            00 = PAY-WITH-OUTLIER.                           *
369300*                 WILL CALCULATE THE STANDARD PAYMENT.        *
369400*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
369500*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
369600*            03 = PAY-PERDIEM-DAYS.                           *
369700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
369800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
369900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
370000*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
370100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
370200*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
370300*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
370400*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
370500*                 BILL EXCEED THE COST THRESHOLD.             *
370600*            06 = PAY-XFER-NO-COST                            *
370700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
370800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
370900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
371000*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
371100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
371200*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
371300*                 CALCULATE ANY COST OUTLIER PORTION          *
371400*                 OF THE PAYMENT.                             *
371500*            07 = PAY-WITHOUT-COST.                           *
371600*                 WILL CALCULATE THE STANDARD PAYMENT         *
371700*                 WITHOUT COST PORTION.                       *
371800*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
371900*                 50-50> NOW USES Y INDICATORS ON DRGS
372000*                        SEE TABLE 5 FROM ANNUAL IPPS FINAL
372100*                        RULE
372200* =======================================================
372300* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
372400* =======================================================
372500*
372600*
372700*     FULL PERDIEM >   NOW USES Y INDICATORS ON DRGS
372800*                      SEE TABLE 5 FROM ANNUAL IPPS FINAL
372900*                      RULE
373000*
373100*                               POST-ACUTE TRANSFERS          *
373200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
373300*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
373400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
373500*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
373600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
373700*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
373800*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
373900*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
374000*                 BILL EXCEED THE COST THRESHOLD.             *
374100*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
374200*                 POST-ACUTE TRANSFERS                        *
374300*                 50-50> NOW USES Y INDICATORS ON DRGS
374400*                        SEE TABLE 5 FROM ANNUAL IPPS FINAL
374500*                        RULE
374600* =======================================================
374700* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
374800* =======================================================
374900*
375000*     FULL PERDIEM >  NOW USES Y INDICATORS ON DRGS
375100*                     SEE TABLE 5
375200*
375300*
375400*                               POST-ACUTE TRANSFERS          *
375500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
375600*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
375700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
375800*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
375900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
376000*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
376100*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
376200*                 PAYMENT.                                    *
376300***************************************************************
376400
376500**************************************************************
376600*      MILLINNIUM COMPATIBLE                                 *
376700*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
376800*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
376900*      IN THE NEW FORMAT                                     *
377000**************************************************************
377100 01  BILL-NEW-DATA.
377200         10  B-NPI10.
377300             15  B-NPI8             PIC X(08).
377400             15  B-NPI-FILLER       PIC X(02).
377500         10  B-PROVIDER-NO          PIC X(06).
377600         10  B-REVIEW-CODE          PIC 9(02).
377700             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
377800             88  PAY-WITH-OUTLIER     VALUE 00 07.
377900             88  PAY-PERDIEM-DAYS     VALUE 03.
378000             88  PAY-XFER-NO-COST     VALUE 06.
378100             88  PAY-WITHOUT-COST     VALUE 07.
378200             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
378300             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
378400         10  B-DRG                  PIC 9(03).
378500
378600             88  B-DRG-SPIRATN-DRG
378700                   VALUE 163 164 165.
378800
378900             88  B-DRG-SPIRATN-DRG11
379000                   VALUE 199 200 201.
379100
379200
379300             88  B-DRG-AUTOLITT-DRG
379400                   VALUE 25 26 27.
379500
379600* =======================================================
379700* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
379800* =======================================================
379900*
380000*            88  B-DRG-POSTACUTE-PERDIEM
380100*                         VALUE  NOW USES Y INDICATORS ON DRGS
380200*                         SEE TABLE 5
380300*                         D-DRG-POSTACUTE-PERDIEM
380400
380500         10  B-LOS                  PIC 9(03).
380600         10  B-COVERED-DAYS         PIC 9(03).
380700         10  B-LTR-DAYS             PIC 9(02).
380800         10  B-DISCHARGE-DATE.
380900             15  B-DISCHG-CC        PIC 9(02).
381000             15  B-DISCHG-YY        PIC 9(02).
381100             15  B-DISCHG-MM        PIC 9(02).
381200             15  B-DISCHG-DD        PIC 9(02).
381300         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
381400         10  B-PRIN-PROC-CODE       PIC X(07).
381500         10  B-OTHER-PROC-CODE1     PIC X(07).
381600         10  B-OTHER-PROC-CODE2     PIC X(07).
381700         10  B-OTHER-PROC-CODE3     PIC X(07).
381800         10  B-OTHER-PROC-CODE4     PIC X(07).
381900         10  B-OTHER-PROC-CODE5     PIC X(07).
382000         10  B-OTHER-PROC-CODE6     PIC X(07).
382100         10  B-OTHER-PROC-CODE7     PIC X(07).
382200         10  B-OTHER-PROC-CODE8     PIC X(07).
382300         10  B-OTHER-PROC-CODE9     PIC X(07).
382400         10  B-OTHER-PROC-CODE10    PIC X(07).
382500         10  B-OTHER-PROC-CODE11    PIC X(07).
382600         10  B-OTHER-PROC-CODE12    PIC X(07).
382700         10  B-OTHER-PROC-CODE13    PIC X(07).
382800         10  B-OTHER-PROC-CODE14    PIC X(07).
382900         10  B-OTHER-PROC-CODE15    PIC X(07).
383000         10  B-OTHER-PROC-CODE16    PIC X(07).
383100         10  B-OTHER-PROC-CODE17    PIC X(07).
383200         10  B-OTHER-PROC-CODE18    PIC X(07).
383300         10  B-OTHER-PROC-CODE19    PIC X(07).
383400         10  B-OTHER-PROC-CODE20    PIC X(07).
383500         10  B-OTHER-PROC-CODE21    PIC X(07).
383600         10  B-OTHER-PROC-CODE22    PIC X(07).
383700         10  B-OTHER-PROC-CODE23    PIC X(07).
383800         10  B-OTHER-PROC-CODE24    PIC X(07).
383900         10  B-OTHER-DIAG-CODE1     PIC X(07).
384000             88  B-DIAG-ISLET-DIAG1
384100                   VALUE 'V707   '.
384200             88  B-DIAG-AUTOLITT-DIAG
384300                   VALUE '1910   ' '1911   ' '1912   ' '1913  '
384400                         '1914   ' '1915   ' '1916   ' '1917  '
384500                         '1918   ' '1919   ' 'C710   ' 'C711  '
384600                         'C712   ' 'C713   ' 'C714   ' 'C715  '
384700                         'C716   ' 'C717   ' 'C718   ' 'C719  '.
384800             88  B-DIAG-KCENTRA-DIAG1
384900                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
385000                         '2864   ' '2865   ' '2867   ' '28652 '
385100                         '28653  ' '28659  '.
385200         10  B-OTHER-DIAG-CODE2     PIC X(07).
385300             88  B-DIAG-ISLET-DIAG2
385400                   VALUE 'V707   '.
385500             88  B-DIAG-KCENTRA-DIAG2
385600                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
385700                         '2864   ' '2865   ' '2867   ' '28652 '
385800                         '28653  ' '28659  '.
385900         10  B-OTHER-DIAG-CODE3     PIC X(07).
386000             88  B-DIAG-ISLET-DIAG3
386100                   VALUE 'V707   '.
386200             88  B-DIAG-KCENTRA-DIAG3
386300                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
386400                         '2864   ' '2865   ' '2867   ' '28652 '
386500                         '28653  ' '28659  '.
386600         10  B-OTHER-DIAG-CODE4     PIC X(07).
386700             88  B-DIAG-ISLET-DIAG4
386800                   VALUE 'V707   '.
386900             88  B-DIAG-KCENTRA-DIAG4
387000                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
387100                         '2864   ' '2865   ' '2867   ' '28652 '
387200                         '28653  ' '28659  '.
387300         10  B-OTHER-DIAG-CODE5     PIC X(07).
387400             88  B-DIAG-ISLET-DIAG5
387500                   VALUE 'V707   '.
387600             88  B-DIAG-KCENTRA-DIAG5
387700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
387800                         '2864   ' '2865   ' '2867   ' '28652 '
387900                         '28653  ' '28659  '.
388000         10  B-OTHER-DIAG-CODE6     PIC X(07).
388100             88  B-DIAG-ISLET-DIAG6
388200                   VALUE 'V707   '.
388300             88  B-DIAG-KCENTRA-DIAG6
388400                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
388500                         '2864   ' '2865   ' '2867   ' '28652 '
388600                         '28653  ' '28659  '.
388700         10  B-OTHER-DIAG-CODE7     PIC X(07).
388800             88  B-DIAG-ISLET-DIAG7
388900                   VALUE 'V707   '.
389000             88  B-DIAG-KCENTRA-DIAG7
389100                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
389200                         '2864   ' '2865   ' '2867   ' '28652 '
389300                         '28653  ' '28659  '.
389400         10  B-OTHER-DIAG-CODE8     PIC X(07).
389500             88  B-DIAG-ISLET-DIAG8
389600                   VALUE 'V707   '.
389700             88  B-DIAG-KCENTRA-DIAG8
389800                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
389900                         '2864   ' '2865   ' '2867   ' '28652 '
390000                         '28653  ' '28659  '.
390100         10  B-OTHER-DIAG-CODE9     PIC X(07).
390200             88  B-DIAG-ISLET-DIAG9
390300                   VALUE 'V707   '.
390400             88  B-DIAG-KCENTRA-DIAG9
390500                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
390600                         '2864   ' '2865   ' '2867   ' '28652 '
390700                         '28653  ' '28659  '.
390800         10  B-OTHER-DIAG-CODE10    PIC X(07).
390900             88  B-DIAG-ISLET-DIAG10
391000                   VALUE 'V707   '.
391100             88  B-DIAG-KCENTRA-DIAG10
391200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
391300                         '2864   ' '2865   ' '2867   ' '28652 '
391400                         '28653  ' '28659  '.
391500         10  B-OTHER-DIAG-CODE11    PIC X(07).
391600             88  B-DIAG-ISLET-DIAG11
391700                   VALUE 'V707   '.
391800             88  B-DIAG-KCENTRA-DIAG11
391900                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
392000                         '2864   ' '2865   ' '2867   ' '28652 '
392100                         '28653  ' '28659  '.
392200         10  B-OTHER-DIAG-CODE12    PIC X(07).
392300             88  B-DIAG-ISLET-DIAG12
392400                   VALUE 'V707   '.
392500             88  B-DIAG-KCENTRA-DIAG12
392600                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
392700                         '2864   ' '2865   ' '2867   ' '28652 '
392800                         '28653  ' '28659  '.
392900         10  B-OTHER-DIAG-CODE13    PIC X(07).
393000             88  B-DIAG-ISLET-DIAG13
393100                   VALUE 'V707   '.
393200             88  B-DIAG-KCENTRA-DIAG13
393300                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
393400                         '2864   ' '2865   ' '2867   ' '28652 '
393500                         '28653  ' '28659  '.
393600         10  B-OTHER-DIAG-CODE14    PIC X(07).
393700             88  B-DIAG-ISLET-DIAG14
393800                   VALUE 'V707   '.
393900             88  B-DIAG-KCENTRA-DIAG14
394000                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
394100                         '2864   ' '2865   ' '2867   ' '28652 '
394200                         '28653  ' '28659  '.
394300         10  B-OTHER-DIAG-CODE15    PIC X(07).
394400             88  B-DIAG-ISLET-DIAG15
394500                   VALUE 'V707   '.
394600             88  B-DIAG-KCENTRA-DIAG15
394700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
394800                         '2864   ' '2865   ' '2867   ' '28652 '
394900                         '28653  ' '28659  '.
395000         10  B-OTHER-DIAG-CODE16    PIC X(07).
395100             88  B-DIAG-ISLET-DIAG16
395200                   VALUE 'V707   '.
395300             88  B-DIAG-KCENTRA-DIAG16
395400                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
395500                         '2864   ' '2865   ' '2867   ' '28652 '
395600                         '28653  ' '28659  '.
395700         10  B-OTHER-DIAG-CODE17    PIC X(07).
395800             88  B-DIAG-ISLET-DIAG17
395900                   VALUE 'V707   '.
396000             88  B-DIAG-KCENTRA-DIAG17
396100                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
396200                         '2864   ' '2865   ' '2867   ' '28652 '
396300                         '28653  ' '28659  '.
396400         10  B-OTHER-DIAG-CODE18    PIC X(07).
396500             88  B-DIAG-ISLET-DIAG18
396600                   VALUE 'V707   '.
396700             88  B-DIAG-KCENTRA-DIAG18
396800                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
396900                         '2864   ' '2865   ' '2867   ' '28652 '
397000                         '28653  ' '28659  '.
397100         10  B-OTHER-DIAG-CODE19    PIC X(07).
397200             88  B-DIAG-ISLET-DIAG19
397300                   VALUE 'V707   '.
397400             88  B-DIAG-KCENTRA-DIAG19
397500                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
397600                         '2864   ' '2865   ' '2867   ' '28652 '
397700                         '28653  ' '28659  '.
397800         10  B-OTHER-DIAG-CODE20    PIC X(07).
397900             88  B-DIAG-ISLET-DIAG20
398000                   VALUE 'V707   '.
398100             88  B-DIAG-KCENTRA-DIAG20
398200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
398300                         '2864   ' '2865   ' '2867   ' '28652 '
398400                         '28653  ' '28659  '.
398500         10  B-OTHER-DIAG-CODE21    PIC X(07).
398600             88  B-DIAG-ISLET-DIAG21
398700                   VALUE 'V707   '.
398800             88  B-DIAG-KCENTRA-DIAG21
398900                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
399000                         '2864   ' '2865   ' '2867   ' '28652 '
399100                         '28653  ' '28659  '.
399200         10  B-OTHER-DIAG-CODE22    PIC X(07).
399300             88  B-DIAG-ISLET-DIAG22
399400                   VALUE 'V707   '.
399500             88  B-DIAG-KCENTRA-DIAG22
399600                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
399700                         '2864   ' '2865   ' '2867   ' '28652 '
399800                         '28653  ' '28659  '.
399900         10  B-OTHER-DIAG-CODE23    PIC X(07).
400000             88  B-DIAG-ISLET-DIAG23
400100                   VALUE 'V707   '.
400200             88  B-DIAG-KCENTRA-DIAG23
400300                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
400400                         '2864   ' '2865   ' '2867   ' '28652 '
400500                         '28653  ' '28659  '.
400600         10  B-OTHER-DIAG-CODE24    PIC X(07).
400700             88  B-DIAG-ISLET-DIAG24
400800                   VALUE 'V707   '.
400900             88  B-DIAG-KCENTRA-DIAG24
401000                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
401100                         '2864   ' '2865   ' '2867   ' '28652 '
401200                         '28653  ' '28659  '.
401300         10  B-OTHER-DIAG-CODE25    PIC X(07).
401400             88  B-DIAG-ISLET-DIAG25
401500                   VALUE 'V707   '.
401600             88  B-DIAG-KCENTRA-DIAG25
401700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
401800                         '2864   ' '2865   ' '2867   ' '28652 '
401900                         '28653  ' '28659  '.
402000         10  B-DEMO-DATA.
402100             15  B-DEMO-CODE1           PIC X(02).
402200             15  B-DEMO-CODE2           PIC X(02).
402300             15  B-DEMO-CODE3           PIC X(02).
402400             15  B-DEMO-CODE4           PIC X(02).
402500         10  B-NDC-DATA.
402600             15  B-NDC-NUMBER           PIC X(11).
402700               88  B-NDC-DIFICID-NDC
402800                   VALUE '52015008001'.
402900         10  FILLER                     PIC X(73).
403000
403100
403200***************************************************************
403300*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
403400*    AND PASSED BACK TO THE CALLING PROGRAM                   *
403500*            RETURN CODE VALUES (PPS-RTC)                     *
403600*                                                             *
403700*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
403800*                                                             *
403900*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
404000*                                                             *
404100*           30,00 = PAID NORMAL DRG PAYMENT                   *
404200*                                                             *
404300*              01 = PAID AS A DAY-OUTLIER.                    *
404400*                   NOTE:                                     *
404500*                     DAY-OUTLIER NO LONGER BEING PAID        *
404600*                         AS OF 10/01/97                      *
404700*                                                             *
404800*              02 = PAID AS A COST-OUTLIER.                   *
404900*                                                             *
405000*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
405100*                   AND INCLUDING THE FULL DRG.               *
405200*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
405300*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
405400*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
405500*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
405600*                   AND INCLUDING THE FULL DRG. PROVIDER      *
405700*                   REFUSED COST OUTLIER.                     *
405800*           40,10 = POST-ACUTE TRANSFER                       *
405900*                   SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE
406000*
406100* =======================================================
406200* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
406300* =======================================================
406400*
406500*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
406600*                       THE FOLLOWING DRG'S                   *
406700*                   DRG =  VALUE  NOW USES Y INDICATORS ON DRGS
406800*                       SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE
406900*                          D-DRG-POSTACUTE-PERDIEM
407000*
407100*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
407200*                    PERDIEM DAYS = OR > GM  ALOS             *
407300*              16 = PAID AS A COST-OUTLIER WITH               *
407400*                    PERDIEM DAYS = OR > GM  ALOS             *
407500*                                                             *
407600*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
407700*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
407800*              52 = INVALID CBSA# IN PROVIDER FILE            *
407900*                   OR INVALID WAGE INDEX                     *
408000*                                      OR                     *
408100*                   INVALID PROVIDER TYPES ON PROVIDER FILE   *
408200*              53 = WAIVER STATE - NOT CALCULATED BY PPS OR   *
408300*                   OR                                         *
408400*                   INVALID STATE CODE IN COMBINATION WITH     *
408500*                   HAC FLAG                                  *
408600*              54 = INVALID DRG                               *
408700*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
408800*                                      OR                     *
408900*                   DISCHARGE DATE < CBSA EFF START DATE      *
409000*                   FOR PPS                                   *
409100*                                      OR                     *
409200*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
409300*                   DISCHARGE DATE                            *
409400*              56 = INVALID LENGTH OF STAY                    *
409500*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
409600*                                        NOT 11)              *
409700*              58 = TOTAL CHARGES NOT NUMERIC                 *
409800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
409900*                   OR BILL-LTR-DAYS > 60                     *
410000*              62 = INVALID NUMBER OF COVERED DAYS            *
410100*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER        *
410200*                   SPECIFIC FILE FOR CAPITAL                  *
410300*                   OR                                         *
410400*                   INVALID READMISSION FLAG IN PSF FILE       *
410500*                   OR                                         *
410600*                   BLANK READMISSION FLAG IN PSF FILE         *
410700*                   OR                                         *
410800*                   READMISSION ADJUSTMENT IS INVALID OR       *
410900*                   OUT OF RANGE IN PSF FILE                   *
411000*                   OR                                         *
411100*                   BLANK READMISSION ADJUSTMENT IN PSF FILE   *
411200*                   OR                                         *
411300*                   INVALID STATE CODE IN COMBINATION WITH     *
411400*                   READMISSION FLAG IN PSF FILE               *
411500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      **
411600*                   OR COST OUTLIER THRESHOLD CALUCULATION    **
411700*              68 = INVALID VALUE BASED PURCHASE FLAG IN PSF   *
411800*                   FILE                                       *
411900*                   OR                                         *
412000*                   BLANK VALUE BASED PURCHASE FLAG IN PSF FILE*
412100*                   OR                                         *
412200*                   VALUE BASED PURCHASE ADJUSTMEMT IS INVALID *
412300*                   OR OUT OF RANGE IN PSF FILE                *
412400*                   INDICATOR                                  *
412500*                   OR                                         *
412600*                   BLANK VALUE BASED PURCHASE ADJUSTMEMT IN   *
412700*                   PSF FILE                                   *
412800*                   OR                                         *
412900*                   INVALID COMBINATION OF HOSPITAL QUALITY    *
413000*                   INDICATOR                                  *
413100*                   AND VALUE BASED PURCHASE FLAG IN PSF FILE  *
413200*                   OR                                         *
413300*                   INVALID STATE CODE IN COMBINATION WITH VALUE
413400*                   BASED PURCHASE FLAG IN PSF FILE            *
413500*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
413600***************************************************************
413700 01  PPS-DATA.
413800         10  PPS-RTC                PIC 9(02).
413900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
414000         10  PPS-OUTLIER-DAYS       PIC 9(03).
414100         10  PPS-AVG-LOS            PIC 9(02)V9(01).
414200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
414300         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
414400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
414500         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
414600         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
414700         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
414800         10  PPS-REG-DAYS-USED      PIC 9(03).
414900         10  PPS-LTR-DAYS-USED      PIC 9(02).
415000         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
415100         10  PPS-CALC-VERS          PIC X(05).
415200
415300*****************************************************************
415400*            THESE ARE THE VERSIONS OF THE PPCAL
415500*           PROGRAMS THAT WILL BE PASSED BACK----
415600*          ASSOCIATED WITH THE BILL BEING PROCESSED
415700*****************************************************************
415800 01  PRICER-OPT-VERS-SW.
415900     02  PRICER-OPTION-SW          PIC X(01).
416000         88  ALL-TABLES-PASSED          VALUE 'A'.
416100         88  PROV-RECORD-PASSED         VALUE 'P'.
416200         88  ADDITIONAL-VARIABLES       VALUE 'M'.
416300         88  PC-PRICER                  VALUE 'C'.
416400     02  PPS-VERSIONS.
416500         10  PPDRV-VERSION         PIC X(05).
416600
416700*****************************************************************
416800*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
416900*          ASSOCIATED WITH THE BILL BEING PROCESSED
417000*****************************************************************
417100 01  PPS-ADDITIONAL-VARIABLES.
417200     05  PPS-HSP-PCT                PIC 9(01)V9(02).
417300     05  PPS-FSP-PCT                PIC 9(01)V9(02).
417400     05  PPS-NAT-PCT                PIC 9(01)V9(02).
417500     05  PPS-REG-PCT                PIC 9(01)V9(02).
417600     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
417700     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
417800     05  PPS-DRG-WT                 PIC 9(02)V9(04).
417900     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
418000     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
418100     05  PPS-REG-LABOR              PIC 9(05)V9(02).
418200     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
418300     05  PPS-OPER-COLA              PIC 9(01)V9(03).
418400     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
418500     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
418600     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
418700     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
418800     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
418900     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
419000     05  PPS-CAPITAL-VARIABLES.
419100         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
419200         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
419300         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
419400         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
419500         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
419600         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
419700         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
419800         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
419900     05  PPS-CAPITAL2-VARIABLES.
420000         10  PPS-CAPI2-PAY-CODE             PIC X(1).
420100         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
420200         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
420300
420400     05  PPS-OTHER-VARIABLES.
420500         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
420600         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
420700         10  PPS-ISLET-ISOL-PAY-ADD-ON      PIC 9(07)V9(02).
420800         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
420900         10  PPS-VAL-BASED-PURCH-PARTIPNT   PIC X.
421000         10  PPS-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
421100         10  PPS-HOSP-READMISSION-REDU      PIC X.
421200         10  PPS-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
421300         10  PPS-OPERATNG-DATA.
421400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
421500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
421600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
421700
421800     05  PPS-PC-OTH-VARIABLES.
421900         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
422000         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
422100         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
422200         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
422300         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
422400         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
422500         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(04).
422600         10  PPS-PC-HMO-FLAG                PIC X(01).
422700         10  PPS-PC-COT-FLAG                PIC X(01).
422800         10  PPS-OPER-HSP-PART2             PIC 9(07)V9(02).
422900         10  PPS-BUNDLE-ADJUST-PAY          PIC S9(07)V99.
423000
423100     05  PPS-ADDITIONAL-PAY-INFO-DATA.
423200         10 PPS-UNCOMP-CARE-AMOUNT          PIC S9(07)V9(02).
423300         10 PPS-BUNDLE-ADJUST-AMT           PIC S9(07)V9(02).
423400         10 PPS-VAL-BASED-PURCH-ADJUST-AMT  PIC S9(07)V9(02).
423500         10 PPS-READMIS-ADJUST-AMT          PIC S9(07)V9(02).
423600     05  PPS-ADDITIONAL-PAY-INFO-DATA2.
423700         10  PPS-HAC-PROG-REDUC-IND      PIC X.
423800         10  PPS-EHR-PROG-REDUC-IND      PIC X.
423900         10  PPS-EHR-ADJUST-AMT          PIC S9(07)V9(02).
424000         10  PPS-STNDRD-VALUE            PIC S9(07)V9(02).
424100         10  PPS-HAC-PAYMENT-AMT         PIC S9(07)V9(02).
424200         10  PPS-FLX7-PAYMENT            PIC S9(07)V9(02).
424300     05 PPS-FILLER                       PIC X(0906).
424400
424500 01  PROV-NEW-HOLD.
424600     02  PROV-NEWREC-HOLD1.
424700         05  P-NEW-NPI10.
424800             10  P-NEW-NPI8             PIC X(08).
424900             10  P-NEW-NPI-FILLER       PIC X(02).
425000         05  P-NEW-PROVIDER-NO.
425100             88  P-NEW-DSH-ADJ-PROVIDERS
425200                             VALUE '180049' '190044' '190144'
425300                                   '190191' '330047' '340085'
425400                                   '370016' '370149' '420043'.
425500             10  P-NEW-STATE            PIC 9(02).
425600                 88  P-VBP-INVALID-STATE
425700                             VALUE 21 80 40.
425800                 88  P-READ-INVALID-STATE
425900                             VALUE 40.
426000                 88  P-HAC-INVALID-STATE
426100                             VALUE 40.
426200             10  FILLER                 PIC X(04).
426300         05  P-NEW-DATE-DATA.
426400             10  P-NEW-EFF-DATE.
426500                 15  P-NEW-EFF-DT-CC    PIC 9(02).
426600                 15  P-NEW-EFF-DT-YY    PIC 9(02).
426700                 15  P-NEW-EFF-DT-MM    PIC 9(02).
426800                 15  P-NEW-EFF-DT-DD    PIC 9(02).
426900             10  P-NEW-FY-BEGIN-DATE.
427000                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
427100                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
427200                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
427300                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
427400             10  P-NEW-REPORT-DATE.
427500                 15  P-NEW-REPORT-DT-CC PIC 9(02).
427600                 15  P-NEW-REPORT-DT-YY PIC 9(02).
427700                 15  P-NEW-REPORT-DT-MM PIC 9(02).
427800                 15  P-NEW-REPORT-DT-DD PIC 9(02).
427900             10  P-NEW-TERMINATION-DATE.
428000                 15  P-NEW-TERM-DT-CC   PIC 9(02).
428100                 15  P-NEW-TERM-DT-YY   PIC 9(02).
428200                 15  P-NEW-TERM-DT-MM   PIC 9(02).
428300                 15  P-NEW-TERM-DT-DD   PIC 9(02).
428400         05  P-NEW-WAIVER-CODE          PIC X(01).
428500             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
428600         05  P-NEW-INTER-NO             PIC 9(05).
428700         05  P-NEW-PROVIDER-TYPE        PIC X(02).
428800             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
428900             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
429000                                                  '15' '17'
429100                                                  '22'.
429200             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
429300             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
429400             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
429500             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
429600             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
429700             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
429800             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
429900             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
430000             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
430100             88  P-N-EACH                   VALUE '21' '22'.
430200             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
430300             88  P-N-NHCMQ-II-SNF           VALUE '32'.
430400             88  P-N-NHCMQ-III-SNF          VALUE '33'.
430500             88  P-N-INVALID-PROV-TYPES     VALUE '14' '15'.
430600         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
430700             88  P-N-NEW-ENGLAND            VALUE  1.
430800             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
430900             88  P-N-SOUTH-ATLANTIC         VALUE  3.
431000             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
431100             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
431200             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
431300             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
431400             88  P-N-MOUNTAIN               VALUE  8.
431500             88  P-N-PACIFIC                VALUE  9.
431600         05  P-NEW-CURRENT-DIV   REDEFINES
431700                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
431800             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
431900         05  P-NEW-MSA-DATA.
432000             10  P-NEW-CHG-CODE-INDEX       PIC X.
432100             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
432200             10  P-NEW-GEO-LOC-MSA9   REDEFINES
432300                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
432400             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
432500             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
432600             10  P-NEW-STAND-AMT-LOC-MSA9
432700       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
432800                 15  P-NEW-RURAL-1ST.
432900                     20  P-NEW-STAND-RURAL  PIC XX.
433000                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
433100                 15  P-NEW-RURAL-2ND        PIC XX.
433200         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
433300                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
433400                 88  P-NEW-SCH-YR82       VALUE   '82'.
433500                 88  P-NEW-SCH-YR87       VALUE   '87'.
433600         05  P-NEW-LUGAR                    PIC X.
433700         05  P-NEW-TEMP-RELIEF-IND          PIC X.
433800         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
433900         05  FILLER                         PIC X(05).
434000     02  PROV-NEWREC-HOLD2.
434100         05  P-NEW-VARIABLES.
434200             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
434300             10  P-NEW-COLA              PIC  9(01)V9(03).
434400             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
434500             10  P-NEW-BED-SIZE          PIC  9(05).
434600             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
434700             10  P-NEW-CMI               PIC  9(01)V9(04).
434800             10  P-NEW-SSI-RATIO         PIC  V9(04).
434900             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
435000             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
435100             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
435200             10  P-NEW-DSH-PERCENT       PIC  V9(04).
435300             10  P-NEW-FYE-DATE          PIC  X(08).
435400         05  P-NEW-CBSA-DATA.
435500             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
435600             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
435700             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
435800             10  P-NEW-CBSA-GEO-RURAL REDEFINES
435900                 P-NEW-CBSA-GEO-LOC.
436000                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
436100                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
436200                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
436300
436400             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
436500             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
436600             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
436700     02  PROV-NEWREC-HOLD3.
436800         05  P-NEW-PASS-AMT-DATA.
436900             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
437000             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
437100             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
437200             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
437300         05  P-NEW-CAPI-DATA.
437400             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
437500             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
437600             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
437700             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
437800             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
437900             15  P-NEW-CAPI-NEW-HOSP       PIC X.
438000             15  P-NEW-CAPI-IME            PIC 9V9999.
438100             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
438200         05  P-HVBP-HRR-DATA.
438300             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
438400             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
438500             15  P-HOSP-READMISSION-REDU    PIC X.
438600             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
438700         05  P-MODEL1-BUNDLE-DATA.
438800             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
438900             15  P-HAC-REDUC-IND            PIC X.
439000             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
439100             15  P-EHR-REDUC-IND            PIC X.
439200         05  FILLER                         PIC X(09).
439300
439400*****************************************************************
439500 01  WAGE-NEW-CBSA-INDEX-RECORD.
439600     05  W-CBSA                        PIC X(5).
439700     05  W-CBSA-SIZE                   PIC X.
439800         88  LARGE-URBAN       VALUE 'L'.
439900         88  OTHER-URBAN       VALUE 'O'.
440000         88  ALL-RURAL         VALUE 'R'.
440100     05  W-CBSA-EFF-DATE               PIC X(8).
440200     05  FILLER                        PIC X.
440300     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
440400     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
440500
440600*******************************************************
440700*    HOLD VARIABLES POPULATED IN PPCAL___***          *
440800*******************************************************
440900 COPY PPHOLDAR.
441000
441100******************************************************************
441200 PROCEDURE DIVISION  USING BILL-NEW-DATA
441300                           PPS-DATA
441400                           PRICER-OPT-VERS-SW
441500                           PPS-ADDITIONAL-VARIABLES
441600                           PROV-NEW-HOLD
441700                           WAGE-NEW-CBSA-INDEX-RECORD
441800                           PPHOLDAR-HOLD-AREA.
441900
442000***************************************************************
442100*    PROCESSING:                                              *
442200*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
442300*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
442400*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
442500*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
442600*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
442700*           GOBACK.                                           *
442800*        D. ASSEMBLE PRICING COMPONENTS.                      *
442900*        E. CALCULATE THE PRICE.                              *
443000***************************************************************
443100
443200     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
443300     MOVE ZEROES TO WK-UNCOMP-CARE-AMOUNT.
443400     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT.
443500     MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT.
443600     MOVE ZEROES TO H-READMIS-ADJUST-AMT.
443700     MOVE 'N' TO TEMP-RELIEF-FLAG.
443800     MOVE 'N' TO OUTLIER-RECON-FLAG.
443900     MOVE ZEROES TO WK-HAC-AMOUNT.
444000     MOVE ZEROES TO WK-HAC-TOTAL-PAYMENT.
444100     MOVE ZEROES TO H-NEW-TECH-PAY-ADD-ON.
444200     MOVE ZEROES TO PPS-NEW-TECH-PAY-ADD-ON.
444300
444400     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
444500
444600     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
444700     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
444800     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
444900     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
445000     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
445100     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
445200     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
445300     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
445400     MOVE H-ADDITIONAL-PAY-INFO-DATA TO
445500                            PPS-ADDITIONAL-PAY-INFO-DATA.
445600     MOVE H-ADDITIONAL-PAY-INFO-DATA2 TO
445700                            PPS-ADDITIONAL-PAY-INFO-DATA2.
445800
445900
446000     COMPUTE PPS-OPER-HSP-PART2 ROUNDED =  1 *  H-HSP-RATE.
446100     MOVE    WK-UNCOMP-CARE-AMOUNT TO PPS-UNCOMP-CARE-AMOUNT.
446200     MOVE    H-BUNDLE-ADJUST-AMT TO PPS-BUNDLE-ADJUST-AMT.
446300     MOVE    H-VAL-BASED-PURCH-ADJUST-AMT TO
446400                           PPS-VAL-BASED-PURCH-ADJUST-AMT.
446500     MOVE    H-READMIS-ADJUST-AMT TO PPS-READMIS-ADJUST-AMT.
446600     MOVE    P-MODEL1-BUNDLE-DISPRCNT TO
446700                               PPS-MODEL1-BUNDLE-DISPRCNT.
446800
446900     MOVE P-HAC-REDUC-IND  TO  PPS-HAC-PROG-REDUC-IND.
447000     MOVE P-EHR-REDUC-IND  TO  PPS-EHR-PROG-REDUC-IND.
447100     MOVE H-EHR-ADJUST-AMT TO  PPS-EHR-ADJUST-AMT.
447200*    MOVE H-STNDRD-VALUE   TO  PPS-STNDRD-VALUE.
447300     MOVE H-STANDARD-ALLOWED-AMOUNT  TO  PPS-STNDRD-VALUE.
447400     MOVE WK-HAC-AMOUNT  TO   PPS-HAC-PAYMENT-AMT.
447500     MOVE 0     TO    PPS-FLX7-PAYMENT.
447600
447700     IF (PPS-RTC = '00' OR '03' OR '10' OR
447800                   '12' OR '14')
447900        MOVE 'Y' TO OUTLIER-RECON-FLAG
448000        MOVE PPS-DATA TO HLD-PPS-DATA
448100        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
448200        MOVE HLD-PPS-DATA TO PPS-DATA.
448300
448400     IF  PPS-RTC < 50
448500         IF  P-NEW-WAIVER-STATE
448600             MOVE 53 TO PPS-RTC
448700             MOVE ALL '0' TO PPS-OPER-HSP-PART
448800                             PPS-OPER-FSP-PART
448900                             PPS-OPER-OUTLIER-PART
449000                             PPS-OUTLIER-DAYS
449100                             PPS-REG-DAYS-USED
449200                             PPS-LTR-DAYS-USED
449300                             PPS-TOTAL-PAYMENT
449400                             WK-HAC-TOTAL-PAYMENT
449500                             PPS-OPER-DSH-ADJ
449600                             PPS-OPER-IME-ADJ
449700                             H-DSCHG-FRCTN
449800                             H-DRG-WT-FRCTN
449900                             HOLD-ADDITIONAL-VARIABLES
450000                             HOLD-CAPITAL-VARIABLES
450100                             HOLD-CAPITAL2-VARIABLES
450200                             HOLD-OTHER-VARIABLES
450300                             HOLD-PC-OTH-VARIABLES
450400                             H-ADDITIONAL-PAY-INFO-DATA
450500                             H-ADDITIONAL-PAY-INFO-DATA2.
450600
450700     GOBACK.
450800
450900 0200-MAINLINE-CONTROL.
451000
451100     MOVE 'N' TO HMO-TAG.
451200
451300     IF PPS-PC-HMO-FLAG = 'Y' OR
451400               HMO-FLAG = 'Y'
451500        MOVE 'Y' TO HMO-TAG.
451600
451700     IF P-NEW-STATE NOT = 40
451800        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
451900
452000     MOVE ALL '0' TO PPS-DATA
452100                     H-OPER-DSH-SCH
452200                     H-OPER-DSH-RRC
452300                     HOLD-PPS-COMPONENTS
452400                     HOLD-PPS-COMPONENTS
452500                     HOLD-ADDITIONAL-VARIABLES
452600                     HOLD-CAPITAL-VARIABLES
452700                     HOLD-CAPITAL2-VARIABLES
452800                     HOLD-OTHER-VARIABLES
452900                     HOLD-PC-OTH-VARIABLES
453000                     H-ADDITIONAL-PAY-INFO-DATA
453100                     H-ADDITIONAL-PAY-INFO-DATA2
453200                     H-EHR-SUBSAV-QUANT
453300                     H-EHR-SUBSAV-LV
453400                     H-EHR-SUBSAV-QUANT-INCLV
453500                     H-EHR-RESTORE-FULL-QUANT
453600                     H-OPER-BILL-STDZ-COSTS
453700                     H-CAPI-BILL-STDZ-COSTS
453800                     H-OPER-STDZ-COST-OUTLIER
453900                     H-CAPI-STDZ-COST-OUTLIER
454000                     H-OPER-STDZ-DOLLAR-THRESHOLD
454100                     H-CAPI-STDZ-DOLLAR-THRESHOLD
454200                     WK-LOW-VOL-ADDON
454300                     WK-HAC-AMOUNT
454400                     WK-HAC-TOTAL-PAYMENT.
454500
454600     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
454700        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
454800
454900     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
455000        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
455100
455200     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
455300        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
455400
455500     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
455600        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
455700
455800     IF P-HOSP-HRR-ADJUSTMT     NOT NUMERIC
455900        MOVE 0 TO P-HOSP-HRR-ADJUSTMT.
456000
456100     IF P-VAL-BASED-PURCH-ADJUST NOT NUMERIC
456200        MOVE 0 TO P-VAL-BASED-PURCH-ADJUST.
456300
456400     IF P-MODEL1-BUNDLE-DISPRCNT NOT NUMERIC
456500        MOVE 0 TO P-MODEL1-BUNDLE-DISPRCNT.
456600
456700
456800     PERFORM 1000-EDIT-THE-BILL-INFO.
456900
457000     IF  PPS-RTC = 00
457100         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
457200         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
457300
457400     IF OUTLIER-RECON-FLAG = 'Y'
457500        MOVE 'N' TO OUTLIER-RECON-FLAG
457600        GO TO 0200-EXIT.
457700
457800     IF PPS-RTC = 00
457900        IF H-PERDIEM-DAYS = H-ALOS OR
458000           H-PERDIEM-DAYS > H-ALOS
458100           MOVE 14 TO PPS-RTC.
458200
458300     IF PPS-RTC = 02
458400        IF H-PERDIEM-DAYS = H-ALOS OR
458500           H-PERDIEM-DAYS > H-ALOS
458600           MOVE 16 TO PPS-RTC.
458700
458800 0200-EXIT.   EXIT.
458900
459000 1000-EDIT-THE-BILL-INFO.
459100
459200     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
459300     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
459400
459500**   IF  PPS-RTC = 00
459600*        IF  P-NEW-WAIVER-STATE
459700*            MOVE 53 TO PPS-RTC.
459800
459900     IF  PPS-RTC = 00
460000         IF   HLDDRG-VALID = 'I'
460100             MOVE 54 TO PPS-RTC.
460200
460300     IF  PPS-RTC = 00
460400            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
460500                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
460600                MOVE 55 TO PPS-RTC.
460700
460800     IF  PPS-RTC = 00
460900         IF P-NEW-TERMINATION-DATE > 00000000
461000            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
461100                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
461200                  MOVE 55 TO PPS-RTC.
461300
461400     IF  PPS-RTC = 00
461500         IF  B-LOS NOT NUMERIC
461600             MOVE 56 TO PPS-RTC
461700         ELSE
461800         IF  B-LOS = 0
461900             IF B-REVIEW-CODE NOT = 00 AND
462000                              NOT = 03 AND
462100                              NOT = 06 AND
462200                              NOT = 07 AND
462300                              NOT = 09 AND
462400                              NOT = 11
462500             MOVE 56 TO PPS-RTC.
462600
462700     IF  PPS-RTC = 00
462800         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
462900             MOVE 61 TO PPS-RTC
463000         ELSE
463100             MOVE B-LTR-DAYS TO H-LTR-DAYS.
463200
463300     IF  PPS-RTC = 00
463400         IF  B-COVERED-DAYS NOT NUMERIC
463500             MOVE 62 TO PPS-RTC
463600         ELSE
463700         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
463800             MOVE 62 TO PPS-RTC
463900         ELSE
464000             MOVE B-COVERED-DAYS TO H-COV-DAYS.
464100
464200     IF  PPS-RTC = 00
464300         IF  H-LTR-DAYS  > H-COV-DAYS
464400             MOVE 62 TO PPS-RTC
464500         ELSE
464600             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
464700
464800     IF  PPS-RTC = 00
464900         IF  NOT VALID-REVIEW-CODE
465000             MOVE 57 TO PPS-RTC.
465100
465200     IF  PPS-RTC = 00
465300         IF  B-CHARGES-CLAIMED NOT NUMERIC
465400             MOVE 58 TO PPS-RTC.
465500
465600     IF PPS-RTC = 00
465700           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
465800                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'B' AND
465900                                            NOT = 'C'
466000                 MOVE 65 TO PPS-RTC.
466100*
466200*    IF PPS-RTC = 00 AND
466300*       B-DISCHARGE-DATE > 20150331 AND
466400*       P-N-INVALID-PROV-TYPES
466500*                MOVE 52 TO PPS-RTC.
466600
466700 2000-ASSEMBLE-PPS-VARIABLES.
466800***  GET THE PROVIDER SPECIFIC VARIABLES.
466900***  GET THE PROVIDER SPECIFIC VARIABLES.
467000
467100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
467200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
467300
467400     IF  (P-NEW-STATE = 02 OR 12)
467500         MOVE P-NEW-COLA TO H-OPER-COLA
467600     ELSE
467700         MOVE 1.000  TO H-OPER-COLA.
467800
467900***************************************************************
468000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
468100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
468200
468300     PERFORM 2600-GET-DRG-WEIGHT THRU 2600-EXIT.
468400
468500     PERFORM 4410-UNCOMP-CARE-CODE-RTN THRU 4410-EXIT.
468600
468700     MOVE P-NEW-STATE            TO MES-PPS-STATE.
468800*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
468900** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
469000** FOR FY 2011
469100***************************************************************
469200*    PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
469300*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
469400***************************************************************
469500***  GET THE WAGE-INDEX
469600***  GET THE WAGE-INDEX
469700
469800     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
469900     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
470000     MOVE P-NEW-STATE            TO MES-PPS-STATE.
470100
470200*****YEARCHANGE 2011.0 ** NOT USED 2013 *******************
470300
470400***************************************************************
470500***  GET THE LABOR, NON-LABOR STANDARD RATES
470600
470700     IF  P-NEW-STATE = 40
470800         MOVE 2 TO R2
470900         MOVE 3 TO R4
471000     ELSE
471100         MOVE 1 TO R2
471200         MOVE 1 TO R4.
471300
471400     IF  LARGE-URBAN
471500         MOVE 1 TO R3
471600     ELSE
471700         MOVE 2 TO R3.
471800
471900     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
472000        (P-EHR-REDUC-IND = ' ')           AND
472100        (H-WAGE-INDEX > 01.0000))
472200        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
472300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
472400
472500     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
472600        (P-EHR-REDUC-IND = ' ')               AND
472700         (H-WAGE-INDEX > 01.0000))
472800        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
472900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
473000
473100     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
473200        (P-EHR-REDUC-IND = ' ')            AND
473300         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
473400        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
473500             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
473600
473700     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
473800        (P-EHR-REDUC-IND = ' ')               AND
473900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
474000        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
474100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
474200
474300
474400     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
474500        (P-EHR-REDUC-IND = 'Y')           AND
474600        (H-WAGE-INDEX > 01.0000))
474700        PERFORM 2300-GET-LAB-NONLAB-TB5-RATES
474800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
474900
475000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
475100        (P-EHR-REDUC-IND = 'Y')               AND
475200         (H-WAGE-INDEX > 01.0000))
475300        PERFORM 2300-GET-LAB-NONLAB-TB6-RATES
475400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
475500
475600     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
475700        (P-EHR-REDUC-IND = 'Y')            AND
475800         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
475900        PERFORM 2300-GET-LAB-NONLAB-TB7-RATES
476000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
476100
476200     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
476300        (P-EHR-REDUC-IND = 'Y')               AND
476400         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
476500        PERFORM 2300-GET-LAB-NONLAB-TB8-RATES
476600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
476700
476800     IF P-NEW-STATE = 40
476900        IF (H-PR-WAGE-INDEX > 01.0000)
477000            PERFORM 2300-GET-PR-LAB-TB1-RATES
477100            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
477200
477300     IF P-NEW-STATE = 40
477400        IF (H-PR-WAGE-INDEX < 01.0000 OR
477500            H-PR-WAGE-INDEX = 01.0000)
477600            PERFORM 2300-GET-PR-LAB-TB3-RATES
477700            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
477800*
477900*    IF P-NEW-STATE = 40
478000*       IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
478100*           (H-PR-WAGE-INDEX > 01.0000))
478200*            PERFORM 2300-GET-PR-LAB-TB1-RATES
478300*            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
478400*
478500*    IF P-NEW-STATE = 40
478600*       IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
478700*            (H-PR-WAGE-INDEX > 01.0000))
478800*             PERFORM 2300-GET-PR-LAB-TB2-RATES
478900*                 VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
479000*
479100*    IF P-NEW-STATE = 40
479200*       IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
479300*       (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
479400*         PERFORM 2300-GET-PR-LAB-TB3-RATES
479500*             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
479600*
479700*    IF P-NEW-STATE = 40
479800*       IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
479900*       (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
480000*         PERFORM 2300-GET-PR-LAB-TB4-RATES
480100*             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
480200*
480300***************************************************************
480400***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
480500***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
480600
480700     MOVE 0.00  TO H-OPER-HSP-PCT.
480800     MOVE 1.00  TO H-OPER-FSP-PCT.
480900
481000***************************************************************
481100***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
481200***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
481300
481400      MOVE 1.00 TO H-NAT-PCT.
481500      MOVE 0.00 TO H-REG-PCT.
481600
481700     IF  P-NEW-STATE = 40
481800         MOVE 0.75 TO H-NAT-PCT
481900         MOVE 0.25 TO H-REG-PCT.
482000
482100     IF  P-N-SCH-REBASED-FY90 OR
482200         P-N-EACH OR
482300         P-N-MDH-REBASED-FY90
482400         MOVE 1.00 TO H-OPER-HSP-PCT.
482500
482600 2300-GET-LAB-NONLAB-TB1-RATES.
482700
482800     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
482900         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
483000         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
483100         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
483200         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
483300
483400 2300-GET-LAB-NONLAB-TB2-RATES.
483500
483600     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
483700         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
483800         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
483900         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
484000         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
484100
484200 2300-GET-LAB-NONLAB-TB3-RATES.
484300
484400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
484500         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
484600         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
484700         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
484800         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
484900
485000 2300-GET-LAB-NONLAB-TB4-RATES.
485100
485200     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
485300         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
485400         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
485500         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
485600         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
485700
485800 2300-GET-LAB-NONLAB-TB5-RATES.
485900
486000     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
486100         MOVE TB5-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
486200         MOVE TB5-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
486300         MOVE TB5-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
486400         MOVE TB5-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
486500
486600 2300-GET-LAB-NONLAB-TB6-RATES.
486700
486800     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
486900         MOVE TB6-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
487000         MOVE TB6-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
487100         MOVE TB6-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
487200         MOVE TB6-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
487300
487400 2300-GET-LAB-NONLAB-TB7-RATES.
487500
487600     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
487700         MOVE TB7-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
487800         MOVE TB7-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
487900         MOVE TB7-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
488000         MOVE TB7-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
488100
488200 2300-GET-LAB-NONLAB-TB8-RATES.
488300
488400     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
488500         MOVE TB8-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
488600         MOVE TB8-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
488700         MOVE TB8-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
488800         MOVE TB8-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
488900
489000 2300-GET-PR-LAB-TB1-RATES.
489100
489200     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
489300         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
489400         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
489500
489600 2300-GET-PR-LAB-TB2-RATES.
489700
489800     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
489900         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
490000         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
490100
490200 2300-GET-PR-LAB-TB3-RATES.
490300
490400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
490500         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
490600         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
490700
490800 2300-GET-PR-LAB-TB4-RATES.
490900
491000     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
491100         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
491200         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
491300
491400*
491500 2600-GET-DRG-WEIGHT.
491600
491700     IF  B-DISCHARGE-DATE NOT < WK-DRGX-EFF-DATE
491800     SET DRG-IDX TO 1
491900     SEARCH DRG-TAB VARYING DRG-IDX
492000         AT END
492100           MOVE ' NO DRG CODE    FOUND' TO HLDDRG-DESC
492200           MOVE 'I' TO  HLDDRG-VALID
492300       WHEN WK-DRG-DRGX(DRG-IDX) = B-DRG
492400         MOVE DRG-DATA-TAB(DRG-IDX) TO HLDDRG-DATA.
492500
492600
492700     MOVE HLDDRG-DATA TO WK-HLDDRG-DATA2.
492800     MOVE  HLDDRG-DRGX         TO HLDDRG-DRGX2.
492900     MOVE  HLDDRG-WEIGHT       TO HLDDRG-WEIGHT2
493000                                  H-DRG-WT.
493100     MOVE  HLDDRG-GMALOS       TO HLDDRG-GMALOS2
493200                                  H-ALOS.
493300     MOVE  HLDDRG-LOW          TO HLDDRG-LOW2.
493400     MOVE  HLDDRG-ARITH-ALOS   TO HLDDRG-ARITH-ALOS2
493500                                  H-ARITH-ALOS.
493600     MOVE  HLDDRG-PAC          TO HLDDRG-PAC2.
493700     MOVE  HLDDRG-SPPAC        TO HLDDRG-SPPAC2.
493800     MOVE  HLDDRG-DESC         TO HLDDRG-DESC2.
493900     MOVE  'V'                 TO HLDDRG-VALID.
494000     MOVE ZEROES               TO H-DAYS-CUTOFF.
494100
494200 2600-EXIT.   EXIT.
494300*
494400 3000-CALC-PAYMENT.
494500***************************************************************
494600
494700     PERFORM 3100-CALC-STAY-UTILIZATION.
494800     PERFORM 3300-CALC-OPER-FSP-AMT.
494900     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
495000
495100***********************************************************
495200***  OPERATING IME CALCULATION
495300***  OPERATING IME CALCULATION
495400
495500     COMPUTE H-OPER-IME-TEACH ROUNDED =
495600            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
495700
495800***********************************************************
495900*
496000*    IF P-N-SCH-REBASED-FY90 OR
496100*       P-N-EACH OR
496200*       P-N-MDH-REBASED-FY90
496300*        PERFORM 3450-CALC-ADDITIONAL-HSP.
496400*
496500     MOVE 00                 TO  PPS-RTC.
496600     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
496700     MOVE H-ALOS             TO  PPS-AVG-LOS.
496800     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
496900
497000     MOVE B-LOS TO H-PERDIEM-DAYS.
497100     IF H-PERDIEM-DAYS < 1
497200         MOVE 1 TO H-PERDIEM-DAYS.
497300     ADD 1 TO H-PERDIEM-DAYS.
497400
497500     MOVE 1 TO H-DSCHG-FRCTN.
497600
497700     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
497800
497900     IF (PAY-PERDIEM-DAYS  OR
498000         PAY-XFER-NO-COST) OR
498100        (PAY-XFER-SPEC-DRG AND
498200         D-DRG-POSTACUTE-PERDIEM)
498300       IF H-ALOS > 0
498400         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
498500         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
498600         IF H-DSCHG-FRCTN > 1
498700              MOVE 1 TO H-DSCHG-FRCTN
498800              MOVE 1 TO H-TRANSFER-ADJ
498900         ELSE
499000              COMPUTE H-DRG-WT-FRCTN ROUNDED =
499100                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT
499200         END-IF
499300        END-IF
499400     END-IF.
499500
499600
499700     IF (PAY-XFER-SPEC-DRG AND
499800         D-DRG-POSTACUTE-50-50) AND
499900         H-ALOS > 0
500000         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
500100         COMPUTE H-DSCHG-FRCTN  ROUNDED =
500200                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
500300         IF H-DSCHG-FRCTN > 1
500400              MOVE 1 TO H-DSCHG-FRCTN
500500              MOVE 1 TO H-TRANSFER-ADJ
500600         ELSE
500700              COMPUTE H-DRG-WT-FRCTN ROUNDED =
500800            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
500900
501000
501100***********************************************************
501200***  CAPITAL DSH CALCULATION
501300***  CAPITAL DSH CALCULATION
501400
501500     MOVE 0 TO H-CAPI-DSH.
501600
501700     IF P-NEW-BED-SIZE NOT NUMERIC
501800         MOVE 0 TO P-NEW-BED-SIZE.
501900
502000     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
502100         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
502200                  (.2025 * (P-NEW-SSI-RATIO
502300                          + P-NEW-MEDICAID-RATIO)) - 1.
502400
502500***********************************************************
502600***  CAPITAL IME TEACH CALCULATION
502700***  CAPITAL IME TEACH CALCULATION
502800
502900     MOVE 0 TO H-WK-CAPI-IME-TEACH.
503000
503100     IF P-NEW-CAPI-IME NUMERIC
503200        IF P-NEW-CAPI-IME > 1.5000
503300           MOVE 1.5000 TO P-NEW-CAPI-IME.
503400
503500*****YEARCHANGE 2009.5 ****************************************
503600***
503700***  PER POLICY, WE REMOVED THE .5 MULTIPLER
503800***
503900***********************************************************
504000     IF P-NEW-CAPI-IME NUMERIC
504100        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
504200         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
504300
504400*****YEARCHANGE 2009.5 ****************************************
504500***********************************************************
504600     MOVE 0.00 TO H-DAYOUT-PCT.
504700     MOVE 0.80 TO H-CSTOUT-PCT.
504800
504900*****************************************************************
505000**
505100** BURN DRGS FOR FY14 ARE 927, 928, 929, 933, 934 AND 935.
505200**
505300*****************************************************************
505400
505500     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
505600             MOVE 0.90 TO H-CSTOUT-PCT.
505700
505800*****YEARCHANGE 2015.0 ****************************************
505900***     NATIONAL PERCENTAGE
506000     MOVE 0.6960   TO H-LABOR-PCT.
506100     MOVE 0.3040   TO H-NONLABOR-PCT.
506200
506300*****YEARCHANGE 2015.0 ****************************************
506400***     PUERTO RICO PERCENTAGE
506500     MOVE 0.6320   TO H-PR-LABOR-PCT.
506600     MOVE 0.3680   TO H-PR-NONLABOR-PCT.
506700*****YEARCHANGE 2015.0 ****************************************
506800
506900     IF (H-WAGE-INDEX < 01.0000 OR
507000         H-WAGE-INDEX = 01.0000)
507100        MOVE 0.6200 TO H-LABOR-PCT
507200        MOVE 0.3800 TO H-NONLABOR-PCT.
507300***
507400     IF P-NEW-STATE = 40
507500       IF (H-PR-WAGE-INDEX < 01.0000 OR
507600           H-PR-WAGE-INDEX = 01.0000)
507700          MOVE 0.6200 TO H-PR-LABOR-PCT
507800          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
507900
508000
508100     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
508200             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
508300     ELSE
508400             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
508500
508600     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
508700             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
508800     ELSE
508900             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
509000
509100***********************************************************
509200*****YEARCHANGE 2010.0 ************************************
509300***  CAPITAL PAYMENT METHOD B - YEARCHNG
509400***  CAPITAL PAYMENT METHOD B
509500
509600     IF W-CBSA-SIZE = 'L'
509700        MOVE 1.00 TO H-CAPI-LARG-URBAN
509800     ELSE
509900        MOVE 1.00 TO H-CAPI-LARG-URBAN.
510000
510100     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
510200     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
510300
510400*****YEARCHANGE 2015.1 ************************************
510500     COMPUTE H-FEDERAL-RATE ROUNDED =
510600                                 (0434.97 * H-CAPI-GAF).
510700     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
510800                                 (0209.45 * H-PR-CAPI-GAF).
510900*****YEARCHANGE 2015.1 ************************************
511000
511100     COMPUTE H-CAPI-COLA ROUNDED =
511200                     (.3152 * (H-OPER-COLA - 1) + 1).
511300
511400     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
511500
511600     IF P-NEW-STATE = 40
511700        COMPUTE  H-CAPI-FED-RATE ROUNDED =
511800                 (H-NAT-PCT * H-FEDERAL-RATE) +
511900                 (H-REG-PCT * H-PUERTO-RICO-RATE).
512000***********************************************************
512100***  CAPITAL FSP CALCULATION
512200***  CAPITAL FSP CALCULATION
512300
512400     COMPUTE H-CAPI-FSP-PART ROUNDED =
512500                               H-DRG-WT       *
512600                               H-CAPI-FED-RATE *
512700                               H-CAPI-COLA *
512800                               H-CAPI-LARG-URBAN.
512900
513000***********************************************************
513100***  CAPITAL PAYMENT METHOD A
513200***  CAPITAL PAYMENT METHOD A
513300
513400     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
513500        MOVE 1.00 TO H-CAPI-SCH
513600     ELSE
513700        MOVE 0.85 TO H-CAPI-SCH.
513800
513900***********************************************************
514000***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
514100***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
514200
514300     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
514400                    (P-NEW-CAPI-OLD-HARM-RATE *
514500                    H-CAPI-SCH).
514600
514700***********************************************************
514800        IF PAY-PERDIEM-DAYS
514900            IF  H-PERDIEM-DAYS < H-ALOS
515000                IF  NOT (B-DRG = 789)
515100                    PERFORM 3500-CALC-PERDIEM-AMT
515200                    MOVE 03 TO PPS-RTC.
515300
515400        IF PAY-XFER-SPEC-DRG
515500            IF  H-PERDIEM-DAYS < H-ALOS
515600                IF  NOT (B-DRG = 789)
515700                    PERFORM 3550-CALC-PERDIEM-AMT.
515800
515900        IF  PAY-XFER-NO-COST
516000            MOVE 00 TO PPS-RTC
516100            IF H-PERDIEM-DAYS < H-ALOS
516200               IF  NOT (B-DRG = 789)
516300                   PERFORM 3500-CALC-PERDIEM-AMT
516400                   MOVE 06 TO PPS-RTC.
516500
516600     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
516700
516800     PERFORM 6000-CALC-READMIS-REDU THRU 6000-EXIT.
516900
517000     IF PPS-RTC = 65 OR 67 OR 68
517100               GO TO 3000-CONTINUE.
517200
517300     PERFORM 7000-CALC-VALUE-BASED-PURCH THRU 7000-EXIT.
517400
517500     IF PPS-RTC = 65 OR 67 OR 68
517600               GO TO 3000-CONTINUE.
517700
517800     PERFORM 8000-CALC-BUNDLE-REDU  THRU 8000-EXIT.
517900
518000     IF PPS-RTC = 65 OR 67 OR 68
518100               GO TO 3000-CONTINUE.
518200
518300     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
518400
518500     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
518600
518700     IF PPS-RTC = 65 OR 67 OR 68
518800               GO TO 3000-CONTINUE.
518900
519000        IF PAY-XFER-SPEC-DRG
519100            IF  H-PERDIEM-DAYS < H-ALOS
519200                IF  NOT (B-DRG = 789)
519300                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
519400
519500
519600        IF  PAY-PERDIEM-DAYS
519700            IF  H-OPER-OUTCST-PART > 0
519800                MOVE H-OPER-OUTCST-PART TO
519900                     H-OPER-OUTLIER-PART
520000                MOVE 05 TO PPS-RTC
520100            ELSE
520200            IF  PPS-RTC NOT = 03
520300                MOVE 00 TO PPS-RTC
520400                MOVE 0  TO H-OPER-OUTLIER-PART.
520500
520600        IF  PAY-PERDIEM-DAYS
520700            IF  H-CAPI-OUTCST-PART > 0
520800                MOVE H-CAPI-OUTCST-PART TO
520900                     H-CAPI-OUTLIER-PART
521000                MOVE 05 TO PPS-RTC
521100            ELSE
521200            IF  PPS-RTC NOT = 03
521300                MOVE 0  TO H-CAPI-OUTLIER-PART.
521400
521500
521600     IF P-N-SCH-REBASED-FY90 OR
521700        P-N-EACH OR
521800        P-N-MDH-REBASED-FY90
521900         PERFORM 3450-CALC-ADDITIONAL-HSP.
522000
522100
522200 3000-CONTINUE.
522300
522400***********************************************************
522500***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
522600***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
522700
522800     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
522900
523000***********************************************************
523100
523200     IF  PPS-RTC = 67
523300         MOVE H-OPER-DOLLAR-THRESHOLD TO
523400              WK-H-OPER-DOLLAR-THRESHOLD.
523500
523600     IF  PPS-RTC < 50
523700         PERFORM 3800-CALC-TOT-AMT THRU 3800-EXIT.
523800
523900     IF  PPS-RTC < 50
524000         NEXT SENTENCE
524100     ELSE
524200         MOVE ALL '0' TO PPS-OPER-HSP-PART
524300                         PPS-OPER-FSP-PART
524400                         PPS-OPER-OUTLIER-PART
524500                         PPS-OUTLIER-DAYS
524600                         PPS-REG-DAYS-USED
524700                         PPS-LTR-DAYS-USED
524800                         PPS-TOTAL-PAYMENT
524900                         WK-HAC-TOTAL-PAYMENT
525000                         PPS-OPER-DSH-ADJ
525100                         PPS-OPER-IME-ADJ
525200                         H-DSCHG-FRCTN
525300                         H-DRG-WT-FRCTN
525400                         HOLD-ADDITIONAL-VARIABLES
525500                         HOLD-CAPITAL-VARIABLES
525600                         HOLD-CAPITAL2-VARIABLES
525700                         HOLD-OTHER-VARIABLES
525800                         HOLD-PC-OTH-VARIABLES
525900                        H-ADDITIONAL-PAY-INFO-DATA
526000                        H-ADDITIONAL-PAY-INFO-DATA2.
526100
526200     IF  PPS-RTC = 67
526300         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
526400                 H-OPER-DOLLAR-THRESHOLD.
526500
526600 3000-EXIT.  EXIT.
526700
526800 3100-CALC-STAY-UTILIZATION.
526900
527000     MOVE 0 TO PPS-REG-DAYS-USED.
527100     MOVE 0 TO PPS-LTR-DAYS-USED.
527200
527300     IF H-REG-DAYS > 0
527400        IF H-REG-DAYS > B-LOS
527500           MOVE B-LOS TO PPS-REG-DAYS-USED
527600        ELSE
527700           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
527800     ELSE
527900        IF H-LTR-DAYS > B-LOS
528000           MOVE B-LOS TO PPS-LTR-DAYS-USED
528100        ELSE
528200           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
528300
528400
528500
528600 3300-CALC-OPER-FSP-AMT.
528700***********************************************************
528800***  OPERATING FSP CALCULATION
528900***  OPERATING FSP CALCULATION
529000
529100     COMPUTE H-OPER-FSP-PART ROUNDED =
529200           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
529300            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
529400                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
529500
529600     IF P-NEW-STATE = 40
529700       COMPUTE H-OPER-FSP-PART ROUNDED =
529800           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
529900            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
530000                           +
530100           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
530200            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
530300                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
530400
530500
530600 3500-CALC-PERDIEM-AMT.
530700***********************************************************
530800***  REVIEW CODE = 03 OR 06
530900***  OPERATING PERDIEM-AMT CALCULATION
531000***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
531100
531200        COMPUTE H-OPER-FSP-PART ROUNDED =
531300        H-OPER-FSP-PART * H-TRANSFER-ADJ
531400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
531500
531600***********************************************************
531700***********************************************************
531800***  REVIEW CODE = 03 OR 06
531900***  CAPITAL   PERDIEM-AMT CALCULATION
532000***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
532100
532200        COMPUTE H-CAPI-FSP-PART ROUNDED =
532300        H-CAPI-FSP-PART * H-TRANSFER-ADJ
532400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
532500
532600***********************************************************
532700***  REVIEW CODE = 03 OR 06
532800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
532900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
533000
533100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
533200        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
533300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
533400
533500 3550-CALC-PERDIEM-AMT.
533600***********************************************************
533700***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
533800***  OPERATING PERDIEM-AMT CALCULATION
533900***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
534000
534100     IF (D-DRG-POSTACUTE-50-50)
534200        MOVE 10 TO PPS-RTC
534300        COMPUTE H-OPER-FSP-PART ROUNDED =
534400        H-OPER-FSP-PART * H-DSCHG-FRCTN
534500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
534600
534700     IF (D-DRG-POSTACUTE-PERDIEM)
534800        MOVE 12 TO PPS-RTC
534900        COMPUTE H-OPER-FSP-PART ROUNDED =
535000        H-OPER-FSP-PART *  H-TRANSFER-ADJ
535100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
535200
535300***********************************************************
535400***  CAPITAL PERDIEM-AMT CALCULATION
535500***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
535600
535700     IF (D-DRG-POSTACUTE-50-50)
535800        MOVE 10 TO PPS-RTC
535900        COMPUTE H-CAPI-FSP-PART ROUNDED =
536000        H-CAPI-FSP-PART * H-DSCHG-FRCTN
536100        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
536200
536300     IF (D-DRG-POSTACUTE-PERDIEM)
536400        MOVE 12 TO PPS-RTC
536500        COMPUTE H-CAPI-FSP-PART ROUNDED =
536600        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
536700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
536800
536900***********************************************************
537000***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
537100***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
537200
537300     IF (D-DRG-POSTACUTE-50-50)
537400        MOVE 10 TO PPS-RTC
537500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
537600        H-CAPI-OLD-HARMLESS * H-DSCHG-FRCTN
537700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
537800
537900     IF (D-DRG-POSTACUTE-PERDIEM)
538000        MOVE 12 TO PPS-RTC
538100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
538200        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
538300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
538400
538500 3560-CHECK-RTN-CODE.
538600
538700     IF (D-DRG-POSTACUTE-50-50)
538800        MOVE 10 TO PPS-RTC.
538900     IF (D-DRG-POSTACUTE-PERDIEM)
539000        MOVE 12 TO PPS-RTC.
539100
539200 3560-EXIT.    EXIT.
539300
539400 3600-CALC-OUTLIER.
539500***********************************************************
539600***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
539700***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
539800
539900     IF OUTLIER-RECON-FLAG = 'Y'
540000        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
540100               (H-OPER-CSTCHG-RATIO + .2).
540200
540300     IF H-CAPI-CSTCHG-RATIO > 0 OR
540400       H-OPER-CSTCHG-RATIO > 0
540500        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
540600                H-OPER-CSTCHG-RATIO /
540700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
540800        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
540900                H-CAPI-CSTCHG-RATIO /
541000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
541100     ELSE
541200         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
541300                   H-CAPI-SHARE-DOLL-THRESHOLD.
541400
541500***********************************************************
541600*****YEARCHANGE 2015.0 ************************************
541700***  OUTLIER THRESHOLD AMOUNTS
541800***  OUTLIER THRESHOLD AMOUNTS
541900
542000*****YEARCHANGE 2015.1 ************************************
542100
542200     MOVE 24626.00 TO H-CST-THRESH.
542300
542400*****YEARCHANGE 2015.1 ************************************
542500
542600     IF (B-REVIEW-CODE = '03') AND
542700         H-PERDIEM-DAYS < H-ALOS
542800        COMPUTE H-CST-THRESH ROUNDED =
542900                      (H-CST-THRESH * H-TRANSFER-ADJ)
543000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
543100
543200     IF ((B-REVIEW-CODE = '09') AND
543300         (H-PERDIEM-DAYS < H-ALOS))
543400         IF (D-DRG-POSTACUTE-PERDIEM)
543500            COMPUTE H-CST-THRESH ROUNDED =
543600                      (H-CST-THRESH * H-TRANSFER-ADJ)
543700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
543800
543900     IF ((B-REVIEW-CODE = '09') AND
544000         (H-PERDIEM-DAYS < H-ALOS))
544100         IF (D-DRG-POSTACUTE-50-50)
544200           COMPUTE H-CST-THRESH ROUNDED =
544300          H-CST-THRESH * H-DSCHG-FRCTN
544400                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
544500
544600     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
544700        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
544800         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
544900          H-OPER-SHARE-DOLL-THRESHOLD.
545000
545100     IF P-NEW-STATE = 40
545200        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
545300           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
545400            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
545500             H-OPER-SHARE-DOLL-THRESHOLD
545600        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
545700               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
545800               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
545900
546000***********************************************************
546100***********************************************************
546200
546300     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
546400          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
546500          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
546600
546700
546800     IF P-NEW-STATE = 40
546900        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
547000           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
547100           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
547200        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
547300               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
547400               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
547500
547600***********************************************************
547700******NOW INCLUDES UNCOMPENCATED CARE**********************
547800
547900     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
548000         ((H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH))
548100                       +
548200           ((H-OPER-FSP-PART * H-OPER-DSH) * .25))
548300                       +
548400             H-OPER-DOLLAR-THRESHOLD
548500                       +
548600                WK-UNCOMP-CARE-AMOUNT
548700                       +
548800                 H-NEW-TECH-PAY-ADD-ON
548900                       -
549000                 H-NEW-TECH-ADDON-ISLET.
549100
549200     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
549300      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
549400                       +
549500             H-CAPI-DOLLAR-THRESHOLD.
549600
549700     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
549800         MOVE 0 TO H-CAPI-COST-OUTLIER.
549900
550000
550100***********************************************************
550200***  OPERATING COST CALCULATION
550300***  OPERATING COST CALCULATION
550400
550500     COMPUTE H-OPER-BILL-COSTS ROUNDED =
550600         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
550700         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
550800
550900
551000     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
551100         COMPUTE H-OPER-OUTCST-PART ROUNDED =
551200         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
551300                         H-OPER-COST-OUTLIER).
551400
551500     IF PAY-WITHOUT-COST OR
551600        PAY-XFER-NO-COST OR
551700        PAY-XFER-SPEC-DRG-NO-COST
551800         MOVE 0 TO H-OPER-OUTCST-PART.
551900
552000***********************************************************
552100***  CAPITAL COST CALCULATION
552200***  CAPITAL COST CALCULATION
552300
552400     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
552500             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
552600         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
552700
552800     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
552900         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
553000         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
553100                         H-CAPI-COST-OUTLIER).
553200
553300***********************************************************
553400***  'A' NOT VALID FY 2015 ON
553500
553600*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
553700*      COMPUTE H-CAPI-OUTCST-PART ROUNDED =
553800*             (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
553900
554000     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
554100        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
554200               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
554300
554400     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
554500        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
554600        MOVE 0 TO H-CAPI-OUTCST-PART
554700                  H-OPER-OUTCST-PART.
554800
554900     IF PAY-WITHOUT-COST OR
555000        PAY-XFER-NO-COST OR
555100        PAY-XFER-SPEC-DRG-NO-COST
555200         MOVE 0 TO H-CAPI-OUTCST-PART.
555300
555400***********************************************************
555500***  DETERMINES THE BILL TO BE COST  OUTLIER
555600
555700     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
555800         MOVE 0 TO H-CAPI-OUTDAY-PART
555900                   H-CAPI-OUTCST-PART.
556000
556100     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
556200                 MOVE H-OPER-OUTCST-PART TO
556300                      H-OPER-OUTLIER-PART
556400                 MOVE H-CAPI-OUTCST-PART TO
556500                      H-CAPI-OUTLIER-PART
556600                 MOVE 02 TO PPS-RTC.
556700
556800     IF OUTLIER-RECON-FLAG = 'Y'
556900        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
557000           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
557100           GO TO 3600-EXIT
557200        ELSE
557300           GO TO 3600-EXIT
557400     ELSE
557500        NEXT SENTENCE.
557600
557700
557800***********************************************************
557900***  DETERMINES IF COST OUTLIER
558000***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
558100***         RETURN CODE OF 02
558200
558300     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
558400
558500     IF PPS-RTC = 02
558600       IF H-CAPI-CSTCHG-RATIO > 0 OR
558700          H-OPER-CSTCHG-RATIO > 0
558800             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
558900                     (H-CAPI-COST-OUTLIER  +
559000                      H-OPER-COST-OUTLIER)
559100                             /
559200                    (H-CAPI-CSTCHG-RATIO  +
559300                     H-OPER-CSTCHG-RATIO)
559400             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD
559500       ELSE MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
559600
559700***********************************************************
559800***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
559900***         RETURN CODE OF 67
560000
560100     IF PPS-RTC = 02
560200         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
560300            PPS-PC-COT-FLAG = 'Y'
560400             MOVE 67 TO PPS-RTC.
560500***********************************************************
560600
560700***********************************************************
560800***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
560900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
561000***********************************************************
561100*
561200***********************************************************
561300***  'A' NOT VALID FY 2015 ON
561400*
561500*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
561600*       COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
561700*               H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
561800*        ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
561900
562000     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
562100        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
562200                H-CAPI-OUTLIER-PART.
562300
562400     IF P-NEW-CAPI-PPS-PAY-CODE = 'C' AND
562500        H-CAPI-PAYCDE-PCT1 > 0
562600        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
562700                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
562800         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART
562900     ELSE MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
563000
563100 3600-EXIT.   EXIT.
563200
563300 3450-CALC-ADDITIONAL-HSP.
563400***********************************************************
563500*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
563600*    SOLE COMMUNITY
563700*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
563800*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
563900***********************************************************
564000***         GET THE UPDATING FACTOR
564100***         GET THE UPDATING FACTOR
564200
564300*****YEARCHANGE 2013.0 AND 2014.0******************************
564400     MOVE 0.998431 TO H-BUDG-NUTR130.
564500     MOVE 0.997989 TO H-BUDG-NUTR140.
564600*****YEARCHANGE 2015.1 ****************************************
564700     MOVE 0.998761 TO H-BUDG-NUTR150.
564800*****YEARCHANGE 2015.1 ****************************************
564900
565000*****YEARCHANGE 2013.0 ****************************************
565100        MOVE 1.0180 TO H-UPDATE-130.
565200*****YEARCHANGE 2013.0 ****************************************
565300
565400*****YEARCHANGE 2014.0 ****************************************
565500        MOVE 1.0170 TO H-UPDATE-140.
565600*****YEARCHANGE 2014.0 ****************************************
565700*****YEARCHANGE 2015.0 ****************************************
565800        MOVE 1.02200 TO H-UPDATE-150.
565900*****YEARCHANGE 2015.0 ****************************************
566000
566100*****YEARCHANGE 2015.0 ****************************************
566200     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
566300        P-EHR-REDUC-IND = 'Y'
566400        MOVE 1.01475 TO H-UPDATE-150.
566500*****YEARCHANGE 2015.0 ****************************************
566600*****YEARCHANGE 2015.0 ****************************************
566700     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
566800        P-EHR-REDUC-IND = ' '
566900        MOVE 1.02200 TO H-UPDATE-150.
567000*****YEARCHANGE 2015.0 ****************************************
567100
567200*****YEARCHANGE 2015.0 ****************************************
567300     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
567400        P-EHR-REDUC-IND = 'Y'
567500        MOVE 1.00750 TO H-UPDATE-150.
567600*****YEARCHANGE 2015.0 ****************************************
567700*****YEARCHANGE 2015.0 ****************************************
567800     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
567900        P-EHR-REDUC-IND = ' '
568000        MOVE 1.01475 TO H-UPDATE-150.
568100*****YEARCHANGE 2015.0 ****************************************
568200
568300     IF P-NEW-STATE = 40
568400*****YEARCHANGE 2015.0 ****************************************
568500        MOVE 1.0220 TO H-UPDATE-150.
568600*****YEARCHANGE 2015.0 ****************************************
568700
568800********YEARCHANGE 2015.0 *************************************
568900***         CASE MIX ADJUSTMENT - FOR 2015
569000***         SHORT STAY ADJUSTMENT - FOR 2014
569100     MOVE 0.9480 TO H-CASE-MIX-ADJ.
569200     MOVE 0.9980 TO H-SHORT-STAY-ADJ.
569300
569400     COMPUTE H-UPDATE-FACTOR ROUNDED =
569500                       (H-UPDATE-130 *
569600                        H-UPDATE-140 *
569700                        H-UPDATE-150 *
569800                        H-BUDG-NUTR130 *
569900                        H-BUDG-NUTR140 *
570000                        H-BUDG-NUTR150 *
570100                        H-CASE-MIX-ADJ * H-SHORT-STAY-ADJ).
570200
570300     COMPUTE H-HSP-RATE ROUNDED =
570400         H-FAC-SPEC-RATE * H-UPDATE-FACTOR * H-DRG-WT.
570500***************************************************************
570600*
570700*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
570800*       COMPUTE H-HSP-RATE ROUNDED =
570900*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
571000*    ELSE
571100*       COMPUTE H-HSP-RATE ROUNDED =
571200*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
571300*
571400***************************************************************
571500********YEARCHANGE 2011.0 *************************************
571600***     OUTLIER OFFSETS NO LONGER USED IN HSP COMPARISON
571700***     WE NOW USE THE ACTUAL OPERATING OUTLIER PAYMEMT
571800***     IN THE HSP COMPARRISON
571900
572000********YEARCHANGE 2014.0 *XXXXXX******************************
572100*      THE HSP BUCKET FOR SCH                      ************
572200*      ADDED UNCOMPENSATED CARE TO COMPARRISON FOR 2014 *******
572300***************************************************************
572400     COMPUTE H-FSP-RATE ROUNDED =
572500        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
572600         H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
572700                           *
572800             (1 + H-OPER-IME-TEACH + (H-OPER-DSH * .25))
572900                               +
573000                         H-OPER-OUTLIER-PART
573100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
573200
573300     IF P-NEW-STATE = 40
573400       COMPUTE H-FSP-RATE ROUNDED =
573500         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
573600         H-NAT-NONLABOR * H-OPER-COLA))  * H-DRG-WT-FRCTN)
573700                           *
573800         (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
573900                            H-OPER-OUTLIER-PART
574000                               +
574100        ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
574200         H-REG-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
574300                           *
574400             (1 + H-OPER-IME-TEACH +(H-OPER-DSH * .25))
574500                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
574600
574700****************************************************************
574800****         INCLUDE UNCOMPENSATED CARE PER CLAIM IN HSP
574900*****        CHOICE
575000
575100
575200     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
575300           COMPUTE H-OPER-HSP-PART ROUNDED =
575400             (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT))
575500                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
575600     ELSE
575700         MOVE 0 TO H-OPER-HSP-PART.
575800
575900***************************************************************
576000***  YEARCHANGE TURNING MDH BACK ON ***************************
576100***************************************************************
576200***         GET THE MDH REBASE
576300
576400
576500     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
576600         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
576700           COMPUTE H-OPER-HSP-PART ROUNDED =
576800         (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)) * .75
576900                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
577000
577100***********************************************************
577200 3800-CALC-TOT-AMT.
577300***********************************************************
577400***  CALCULATE TOTALS FOR CAPITAL
577500***  CALCULATE TOTALS FOR CAPITAL
577600
577700     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
577800
577900***********************************************************
578000***  'A' NOT VALID FY 2015 ON
578100*
578200*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
578300*       MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
578400*       MOVE 0.00 TO H-CAPI-HSP-PCT.
578500
578600     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
578700        MOVE 0    TO H-CAPI-OLD-HARMLESS
578800        MOVE 1.00 TO H-CAPI-FSP-PCT
578900        MOVE 0.00 TO H-CAPI-HSP-PCT.
579000
579100     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
579200        MOVE 0    TO H-CAPI-OLD-HARMLESS
579300        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
579400        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
579500
579600     COMPUTE H-CAPI-HSP ROUNDED =
579700         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
579800
579900     COMPUTE H-CAPI-FSP ROUNDED =
580000         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
580100
580200     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
580300
580400     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
580500
580600     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
580700             H-CAPI-FSP
580800              * H-CAPI-DSH.
580900
581000     COMPUTE H-CAPI-IME-ADJ ROUNDED =
581100          H-CAPI-FSP *
581200                 H-WK-CAPI-IME-TEACH.
581300
581400     COMPUTE H-CAPI-OUTLIER ROUNDED =
581500             1.00 * H-CAPI-OUTLIER-PART.
581600
581700     COMPUTE H-CAPI2-B-FSP ROUNDED =
581800             1.00 * H-CAPI2-B-FSP-PART.
581900
582000     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
582100             1.00 * H-CAPI2-B-OUTLIER-PART.
582200***********************************************************
582300***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
582400***        THIS ZEROES OUT ALL CAPITAL DATA
582500
582600     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
582700        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
582800***********************************************************
582900
583000***********************************************************
583100***  CALCULATE FINAL TOTALS FOR OPERATING
583200***  CALCULATE FINAL TOTALS FOR OPERATING
583300
583400     IF (H-CAPI-OUTLIER > 0 AND
583500         PPS-OPER-OUTLIER-PART = 0)
583600            COMPUTE PPS-OPER-OUTLIER-PART =
583700                    PPS-OPER-OUTLIER-PART + .01.
583800
583900***********************************************************
584000***  LOW VOLUME CALCULATION
584100***  LOW VOLUME CALCULATION
584200
584300     MOVE 01.000 TO WK-LOW-VOL25PCT.
584400
584500*
584600***********************************************************
584700***  LOW VOLUME CALCULATION ENDS 3/31/2015
584800
584900*    IF  B-DISCHARGE-DATE < 20150401
585000*        NEXT SENTENCE
585100*    ELSE
585200*        COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0
585300*         IF P-NEW-TEMP-RELIEF-IND = 'Y'
585400*           MOVE 00.250 TO WK-LOW-VOL25PCT
585500*           GO TO LOW-VOL-CALC
585600*         ELSE
585700*           MOVE 01.000 TO WK-LOW-VOL25PCT
585800*           GO TO LOW-VOL-CALC.
585900
586000     IF P-NEW-TEMP-RELIEF-IND = 'Y'
586100     MOVE P-NEW-PROVIDER-NO      TO MES-PPS-PROV
586200     PERFORM 4400-LOWVOL-CODE-RTN THRU 4400-EXIT.
586300
586400*****SET THE LOW-VOLUME DISCHARGE PERCENT
586500**   ADD ON TO 25% FOR DISCHARGES
586600**   FOR FY 2014 USE A FIXED FACTOR OF 0.25
586700
586800*    IF P-NEW-TEMP-RELIEF-IND = 'Y'
586900*           MOVE 00.250 TO WK-LOW-VOL25PCT
587000*           GO TO LOW-VOL-CALC.
587100
587200     IF P-NEW-TEMP-RELIEF-IND = 'Y'
587300     AND MESWK-LOWVOL-PROV-DISCHG <= 200
587400            MOVE 00.250 TO WK-LOW-VOL25PCT
587500            GO TO LOW-VOL-CALC.
587600
587700***  CALCULATE THE LOW VOLUME DISCHARGE PERCENT
587800***  SLIDING SCALE ADD ON FOR
587900
588000     IF P-NEW-TEMP-RELIEF-IND = 'Y'
588100        AND MESWK-LOWVOL-PROV-DISCHG > 200
588200        AND MESWK-LOWVOL-PROV-DISCHG < 1600
588300            COMPUTE  WK-LOW-VOL25PCT ROUNDED =
588400            ((4 / 14) - (MESWK-LOWVOL-PROV-DISCHG / 5600))
588500            GO TO LOW-VOL-CALC
588600     ELSE
588700           MOVE 01.000 TO WK-LOW-VOL25PCT.
588800
588900
589000 LOW-VOL-CALC.
589100
589200     MOVE ZERO TO PPS-OPER-DSH-ADJ.
589300************************************************
589400* FOR FY 2014 WE APPLY AN ADJUSTMENT OF 0.25 TO CALCULATE
589500* EMPERICAL DSH
589600************************************************
589700     IF  H-OPER-DSH NUMERIC
589800         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
589900                     (PPS-OPER-FSP-PART  * H-OPER-DSH) * .25.
590000
590100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
590200                         PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
590300
590400
590500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
590600                           H-OPER-FSP-PART * H-OPER-FSP-PCT.
590700
590800     COMPUTE PPS-OPER-HSP-PART ROUNDED =
590900                           H-OPER-HSP-PART * H-OPER-HSP-PCT.
591000
591100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
591200                         H-OPER-OUTLIER-PART * H-OPER-FSP-PCT.
591300
591400     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
591500                                H-NEW-TECH-PAY-ADD-ON -
591600                                H-NEW-TECH-ADDON-ISLET.
591700
591800     IF  WK-LOW-VOL25PCT < 1.000000
591900     COMPUTE WK-LOW-VOL-ADDON  ROUNDED =
592000              (PPS-OPER-HSP-PART
592100                         +
592200                   PPS-OPER-FSP-PART
592300                         +
592400                 PPS-OPER-OUTLIER-PART
592500                         +
592600                   PPS-OPER-DSH-ADJ
592700                         +
592800                      PPS-OPER-IME-ADJ
592900                           +
593000                    WK-UNCOMP-CARE-AMOUNT
593100                           +
593200                      H-CAPI-HSP
593300                           +
593400                     H-CAPI-FSP
593500                           +
593600                  H-CAPI-EXCEPTIONS
593700                           +
593800                   H-CAPI-OUTLIER
593900                           +
594000                   H-CAPI-DSH-ADJ
594100                           +
594200                   H-CAPI-IME-ADJ
594300                           +
594400                   H-CAPI-OLD-HARM
594500                           +
594600                 PPS-NEW-TECH-PAY-ADD-ON) *  WK-LOW-VOL25PCT
594700     ELSE
594800     COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0.
594900
595000 LOW-VOL-END.
595100
595200     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
595300
595400     IF HMO-TAG  = 'Y'
595500        PERFORM 3850-HMO-IME-ADJ.
595600
595700***********************************************************
595800***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
595900***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
596000
596100     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
596200             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
596300             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
596400             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
596500
596600         PERFORM 9000-CALC-EHR-SAVING   THRU 9000-EXIT.
596700         PERFORM 9010-CALC-STANDARD-CHG THRU 9010-EXIT.
596800
596900
597000***********************************************************
597100***  TOTAL PAYMENT NOW INCLUDES UNCOMPENSATED CARE AMOUNT
597200************************************************
597300* FOR FY 2015 AN ADJUSTMENT OF 0.01 TO CALCULATE
597400* HOSPITAL AQUIRED CONDITION (HAC) PENALTY
597500************************************************
597600
597700     COMPUTE   WK-HAC-TOTAL-PAYMENT ROUNDED =
597800               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
597900               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
598000                      PPS-OPER-IME-ADJ
598100                           +
598200                 PPS-NEW-TECH-PAY-ADD-ON
598300                           +
598400                  WK-UNCOMP-CARE-AMOUNT
598500                           +
598600                  WK-LOW-VOL-ADDON
598700                           +
598800                   H-CAPI-TOTAL-PAY
598900                           +
599000                 H-READMIS-ADJUST-AMT
599100                           +
599200               H-VAL-BASED-PURCH-ADJUST-AMT.
599300
599400************************************************
599500* FOR FY 2015 AN ADJUSTMENT OF 0.01 TO CALCULATE
599600* HOSPITAL AQUIRED CONDITION (HAC) PENALTY
599700* BASED ON INDICATOR FROM THE PPS FILE
599800************************************************
599900     MOVE ZERO TO WK-HAC-AMOUNT.
600000
600100************************************************
600200* HOSPITAL AQUIRED CONDITION (HAC)
600300* BASED ON INDICATOR FROM THE PPS FILE
600400* NOT VALID IN PUERTO RICO
600500************************************************
600600     IF P-NEW-STATE = 40  AND
600700        P-HAC-REDUC-IND = 'Y'
600800           MOVE 53 TO PPS-RTC
600900           GO TO 3800-EXIT.
601000
601100     IF  P-HAC-REDUC-IND = 'Y'
601200         COMPUTE   WK-HAC-AMOUNT     ROUNDED =
601300                   WK-HAC-TOTAL-PAYMENT * -0.01
601400     ELSE
601500         COMPUTE   WK-HAC-AMOUNT     ROUNDED = 0.
601600
601700***********************************************************
601800***  TOTAL PAYMENT NOW INCLUDES HAC PENALTY AMOUNT
601900************************************************
602000     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
602100                 WK-HAC-TOTAL-PAYMENT
602200                           +
602300                 H-WK-PASS-AMT-PLUS-MISC
602400                           +
602500                 H-BUNDLE-ADJUST-AMT
602600                           +
602700                 WK-HAC-AMOUNT
602800                           +
602900                 H-NEW-TECH-ADDON-ISLET.
603000
603100     MOVE     P-VAL-BASED-PURCH-PARTIPNT TO
603200              H-VAL-BASED-PURCH-PARTIPNT.
603300
603400     MOVE     P-VAL-BASED-PURCH-ADJUST   TO
603500              H-VAL-BASED-PURCH-ADJUST.
603600
603700     MOVE     P-HOSP-READMISSION-REDU    TO
603800              H-HOSP-READMISSION-REDU.
603900
604000     MOVE     P-HOSP-HRR-ADJUSTMT        TO
604100              H-HOSP-HRR-ADJUSTMT.
604200
604300 3800-EXIT.   EXIT.
604400
604500 3850-HMO-IME-ADJ.
604600***********************************************************
604700***  HMO CALC FOR PASS-THRU ADDON
604800***  HMO CALC FOR PASS-THRU ADDON
604900
605000     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
605100          (P-NEW-PASS-AMT-PLUS-MISC -
605200          (P-NEW-PASS-AMT-ORGAN-ACQ +
605300           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
605400
605500***********************************************************
605600***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
605700
605800     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
605900                   PPS-OPER-IME-ADJ * .0.
606000
606100***********************************************************
606200
606300
606400 3900A-CALC-OPER-DSH.
606500
606600***  OPERATING DSH CALCULATION
606700***  OPERATING DSH CALCULATION
606800
606900      MOVE 0.0000 TO H-OPER-DSH.
607000
607100      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
607200                                     + P-NEW-MEDICAID-RATIO).
607300
607400***********************************************************
607500**1**    0-99 BEDS
607600***  NOT TO EXCEED 12%
607700
607800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
607900                               AND H-WK-OPER-DSH > .1499
608000                               AND H-WK-OPER-DSH < .2020
608100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
608200                                      * .65 + .025
608300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
608400
608500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
608600                               AND H-WK-OPER-DSH > .2019
608700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
608800                                      * .825 + .0588
608900        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
609000
609100***********************************************************
609200**2**   100 + BEDS
609300***  NO CAP >> CAN EXCEED 12%
609400
609500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
609600                               AND H-WK-OPER-DSH > .1499
609700                               AND H-WK-OPER-DSH < .2020
609800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
609900                                      * .65 + .025.
610000
610100      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
610200                               AND H-WK-OPER-DSH > .2019
610300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
610400                                      * .825 + .0588.
610500
610600***********************************************************
610700**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
610800***  NOT TO EXCEED 12%
610900
611000      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
611100                               AND H-WK-OPER-DSH > .1499
611200                               AND H-WK-OPER-DSH < .2020
611300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
611400                                 * .65 + .025
611500        IF H-OPER-DSH > .1200
611600              MOVE .1200 TO H-OPER-DSH.
611700
611800      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
611900                               AND H-WK-OPER-DSH > .2019
612000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
612100                                 * .825 + .0588
612200        IF H-OPER-DSH > .1200
612300                 MOVE .1200 TO H-OPER-DSH.
612400***********************************************************
612500**4**   OTHER RURAL HOSPITALS 500 BEDS +
612600***  NO CAP >> CAN EXCEED 12%
612700
612800      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
612900                               AND H-WK-OPER-DSH > .1499
613000                               AND H-WK-OPER-DSH < .2020
613100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
613200                                 * .65 + .025.
613300
613400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
613500                               AND H-WK-OPER-DSH > .2019
613600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
613700                                 * .825 + .0588.
613800
613900***********************************************************
614000**7**   RURAL HOSPITALS SCH
614100***  NOT TO EXCEED 12%
614200
614300      IF W-CBSA-SIZE = 'R'
614400         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
614500                               AND H-WK-OPER-DSH > .1499
614600                               AND H-WK-OPER-DSH < .2020
614700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
614800                                 * .65 + .025
614900        IF H-OPER-DSH > .1200
615000                 MOVE .1200 TO H-OPER-DSH.
615100
615200      IF W-CBSA-SIZE = 'R'
615300         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
615400                               AND H-WK-OPER-DSH > .2019
615500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
615600                                 * .825 + .0588
615700        IF H-OPER-DSH > .1200
615800                 MOVE .1200 TO H-OPER-DSH.
615900
616000***********************************************************
616100**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
616200***  RRC OVERRIDES SCH CAP
616300***  NO CAP >> CAN EXCEED 12%
616400
616500         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
616600                                   '17' OR '22')
616700                               AND H-WK-OPER-DSH > .1499
616800                               AND H-WK-OPER-DSH < .2020
616900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
617000                                 * .65 + .025.
617100
617200         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
617300                                   '17' OR '22')
617400                               AND H-WK-OPER-DSH > .2019
617500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
617600                                 * .825 + .0588.
617700
617800      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
617900
618000 3900A-EXIT.   EXIT.
618100
618200 4000-CALC-TECH-ADDON.
618300
618400***********************************************************
618500***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
618600***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
618700
618800     COMPUTE PPS-OPER-HSP-PART ROUNDED =
618900         H-OPER-HSP-PCT * H-OPER-HSP-PART.
619000
619100     COMPUTE PPS-OPER-FSP-PART ROUNDED =
619200         H-OPER-FSP-PCT * H-OPER-FSP-PART.
619300
619400     MOVE ZERO TO PPS-OPER-DSH-ADJ.
619500
619600     IF  H-OPER-DSH NUMERIC
619700             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
619800             (PPS-OPER-FSP-PART
619900              * H-OPER-DSH) * .25.
620000
620100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
620200             PPS-OPER-FSP-PART *
620300             H-OPER-IME-TEACH.
620400
620500     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
620600             PPS-OPER-FSP-PART +
620700             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ +
620800             WK-UNCOMP-CARE-AMOUNT.
620900
621000***********************************************************
621100***********************************************************
621200* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
621300
621400     IF   B-DIAG-ISLET-DIAG1  OR
621500          B-DIAG-ISLET-DIAG2  OR
621600          B-DIAG-ISLET-DIAG3  OR
621700          B-DIAG-ISLET-DIAG4  OR
621800          B-DIAG-ISLET-DIAG5  OR
621900          B-DIAG-ISLET-DIAG6  OR
622000          B-DIAG-ISLET-DIAG7  OR
622100          B-DIAG-ISLET-DIAG8  OR
622200          B-DIAG-ISLET-DIAG9  OR
622300          B-DIAG-ISLET-DIAG10 OR
622400          B-DIAG-ISLET-DIAG11 OR
622500          B-DIAG-ISLET-DIAG12 OR
622600          B-DIAG-ISLET-DIAG13 OR
622700          B-DIAG-ISLET-DIAG14 OR
622800          B-DIAG-ISLET-DIAG15 OR
622900          B-DIAG-ISLET-DIAG16 OR
623000          B-DIAG-ISLET-DIAG17 OR
623100          B-DIAG-ISLET-DIAG18 OR
623200          B-DIAG-ISLET-DIAG19 OR
623300          B-DIAG-ISLET-DIAG20 OR
623400          B-DIAG-ISLET-DIAG21 OR
623500          B-DIAG-ISLET-DIAG22 OR
623600          B-DIAG-ISLET-DIAG23 OR
623700          B-DIAG-ISLET-DIAG24 OR
623800          B-DIAG-ISLET-DIAG25
623900       PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT
624000     ELSE
624100       MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET.
624200
624300*    IF   B-DIAG-AUTOLITT-DIAG AND
624400*         B-DRG-AUTOLITT-DRG
624500*       PERFORM 4500-AUTOLIT-TECH-ADD-ON THRU 4500-EXIT.
624600
624700***********************************************************
624800*  DIFICID DISCONTINUED FOR FY 2015
624900*    IF   B-NDC-DIFICID-NDC
625000*      PERFORM 4600-DIFICID-TECH-ADD-ON THRU 4600-EXIT.
625100
625200     PERFORM 4700-ZENITH-TECH-ADD-ON THRU 4700-EXIT.
625300
625400     PERFORM 4800-VORAXAZE-TECH-ADD-ON THRU 4800-EXIT.
625500
625600     PERFORM 4810-ARGUS-TECH-ADD-ON THRU 4810-EXIT.
625700
625800     IF   B-DIAG-KCENTRA-DIAG1  OR
625900          B-DIAG-KCENTRA-DIAG2  OR
626000          B-DIAG-KCENTRA-DIAG3  OR
626100          B-DIAG-KCENTRA-DIAG4  OR
626200          B-DIAG-KCENTRA-DIAG5  OR
626300          B-DIAG-KCENTRA-DIAG6  OR
626400          B-DIAG-KCENTRA-DIAG7  OR
626500          B-DIAG-KCENTRA-DIAG8  OR
626600          B-DIAG-KCENTRA-DIAG9  OR
626700          B-DIAG-KCENTRA-DIAG10 OR
626800          B-DIAG-KCENTRA-DIAG11 OR
626900          B-DIAG-KCENTRA-DIAG12 OR
627000          B-DIAG-KCENTRA-DIAG13 OR
627100          B-DIAG-KCENTRA-DIAG14 OR
627200          B-DIAG-KCENTRA-DIAG15 OR
627300          B-DIAG-KCENTRA-DIAG16 OR
627400          B-DIAG-KCENTRA-DIAG17 OR
627500          B-DIAG-KCENTRA-DIAG18 OR
627600          B-DIAG-KCENTRA-DIAG19 OR
627700          B-DIAG-KCENTRA-DIAG20 OR
627800          B-DIAG-KCENTRA-DIAG21 OR
627900          B-DIAG-KCENTRA-DIAG22 OR
628000          B-DIAG-KCENTRA-DIAG23 OR
628100          B-DIAG-KCENTRA-DIAG24 OR
628200          B-DIAG-KCENTRA-DIAG25
628300       MOVE ZEROES TO H-NEW-TECH-ADDON-KCENTRA
628400     ELSE
628500       PERFORM 4820-KCENTRA-TECH-ADD-ON THRU 4820-EXIT.
628600
628700     PERFORM 4830-ZILVER-TECH-ADD-ON THRU 4830-EXIT.
628800
628900     PERFORM 5010-CARDIO-MEMES-ADD-ON THRU 5010-EXIT.
629000
629100     PERFORM 5020-MITRA-CLIP-ADD-ON THRU 5020-EXIT.
629200
629300     PERFORM 5030-RNS-SYS-ADD-ON    THRU 5030-EXIT.
629400
629500***********************************************************
629600*  ALL NEW TECH MUST BE CALCULATED BEFORE
629700*  5000-CAP-CALC-TECH-ADD-ON
629800***********************************************************
629900     PERFORM 5000-CAP-CALC-TECH-ADD-ON THRU 5000-EXIT.
630000
630100     COMPUTE H-OPER-BASE-DRG-PAY ROUNDED =
630200             H-OPER-FSP-PART +
630300             H-NEW-TECH-PAY-ADD-ON -
630400             H-NEW-TECH-ADDON-ISLET.
630500
630600*
630700 4000-EXIT.    EXIT.
630800***********************************************************
630900
631000 4100-ISLET-ISOLATION-ADD-ON.
631100***********************************************************
631200***  TECHNICAL TRANSPLANTATION OF CELLS
631300***
631400*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
631500*** ISLETS OF LANGERHAUS) AND
631600*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
631700*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
631800*** TIMES IN ANY OTHER PROC-CODE
631900***********************************************************
632000*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
632100*** V70.7
632200***********************************************************
632300
632400     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
632500               H-TECH-ADDON-ISLET-CNTR2
632600               H-NEW-TECH-ADDON-ISLET.
632700
632800     IF '5285   ' =  B-PRIN-PROC-CODE     OR
632900                     B-OTHER-PROC-CODE1   OR
633000                     B-OTHER-PROC-CODE2   OR
633100                     B-OTHER-PROC-CODE3   OR
633200                     B-OTHER-PROC-CODE4   OR
633300                     B-OTHER-PROC-CODE5   OR
633400                     B-OTHER-PROC-CODE6   OR
633500                     B-OTHER-PROC-CODE7   OR
633600                     B-OTHER-PROC-CODE8   OR
633700                     B-OTHER-PROC-CODE9   OR
633800                     B-OTHER-PROC-CODE10  OR
633900                     B-OTHER-PROC-CODE11  OR
634000                     B-OTHER-PROC-CODE12  OR
634100                     B-OTHER-PROC-CODE13  OR
634200                     B-OTHER-PROC-CODE14  OR
634300                     B-OTHER-PROC-CODE15  OR
634400                     B-OTHER-PROC-CODE16  OR
634500                     B-OTHER-PROC-CODE17  OR
634600                     B-OTHER-PROC-CODE18  OR
634700                     B-OTHER-PROC-CODE19  OR
634800                     B-OTHER-PROC-CODE20  OR
634900                     B-OTHER-PROC-CODE21  OR
635000                     B-OTHER-PROC-CODE22  OR
635100                     B-OTHER-PROC-CODE23  OR
635200                     B-OTHER-PROC-CODE24
635300           NEXT SENTENCE
635400     ELSE
635500           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
635600           GO TO 4100-ADD-TECH-CASES.
635700
635800     IF '5285   ' =  B-PRIN-PROC-CODE
635900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
636000                       H-TECH-ADDON-ISLET-CNTR + 1.
636100
636200     IF '5285   ' =  B-OTHER-PROC-CODE1
636300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
636400                       H-TECH-ADDON-ISLET-CNTR + 1.
636500
636600     IF '5285   ' =  B-OTHER-PROC-CODE2
636700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
636800                       H-TECH-ADDON-ISLET-CNTR + 1.
636900
637000     IF '5285   ' =  B-OTHER-PROC-CODE3
637100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
637200                       H-TECH-ADDON-ISLET-CNTR + 1.
637300
637400     IF '5285   ' =  B-OTHER-PROC-CODE4
637500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
637600                       H-TECH-ADDON-ISLET-CNTR + 1.
637700
637800     IF '5285   ' =  B-OTHER-PROC-CODE5
637900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
638000                       H-TECH-ADDON-ISLET-CNTR + 1.
638100
638200     IF '5285   ' =  B-OTHER-PROC-CODE6
638300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
638400                       H-TECH-ADDON-ISLET-CNTR + 1.
638500
638600     IF '5285   ' =  B-OTHER-PROC-CODE7
638700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
638800                       H-TECH-ADDON-ISLET-CNTR + 1.
638900
639000     IF '5285   ' =  B-OTHER-PROC-CODE8
639100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
639200                       H-TECH-ADDON-ISLET-CNTR + 1.
639300
639400     IF '5285   ' =  B-OTHER-PROC-CODE9
639500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
639600                       H-TECH-ADDON-ISLET-CNTR + 1.
639700
639800     IF '5285   ' =  B-OTHER-PROC-CODE10
639900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
640000                       H-TECH-ADDON-ISLET-CNTR + 1.
640100
640200     IF '5285   ' =  B-OTHER-PROC-CODE11
640300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
640400                       H-TECH-ADDON-ISLET-CNTR + 1.
640500
640600     IF '5285   ' =  B-OTHER-PROC-CODE12
640700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
640800                       H-TECH-ADDON-ISLET-CNTR + 1.
640900
641000     IF '5285   ' =  B-OTHER-PROC-CODE13
641100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
641200                       H-TECH-ADDON-ISLET-CNTR + 1.
641300
641400     IF '5285   ' =  B-OTHER-PROC-CODE14
641500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
641600                       H-TECH-ADDON-ISLET-CNTR + 1.
641700
641800     IF '5285   ' =  B-OTHER-PROC-CODE15
641900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
642000                       H-TECH-ADDON-ISLET-CNTR + 1.
642100
642200     IF '5285   ' =  B-OTHER-PROC-CODE16
642300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
642400                       H-TECH-ADDON-ISLET-CNTR + 1.
642500
642600     IF '5285   ' =  B-OTHER-PROC-CODE17
642700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
642800                       H-TECH-ADDON-ISLET-CNTR + 1.
642900
643000     IF '5285   ' =  B-OTHER-PROC-CODE18
643100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
643200                       H-TECH-ADDON-ISLET-CNTR + 1.
643300
643400     IF '5285   ' =  B-OTHER-PROC-CODE19
643500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
643600                       H-TECH-ADDON-ISLET-CNTR + 1.
643700
643800     IF '5285   ' =  B-OTHER-PROC-CODE20
643900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
644000                       H-TECH-ADDON-ISLET-CNTR + 1.
644100
644200     IF '5285   ' =  B-OTHER-PROC-CODE21
644300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
644400                       H-TECH-ADDON-ISLET-CNTR + 1.
644500
644600     IF '5285   ' =  B-OTHER-PROC-CODE22
644700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
644800                       H-TECH-ADDON-ISLET-CNTR + 1.
644900
645000     IF '5285   ' =  B-OTHER-PROC-CODE23
645100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
645200                       H-TECH-ADDON-ISLET-CNTR + 1.
645300
645400     IF '5285   ' =  B-OTHER-PROC-CODE24
645500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
645600                       H-TECH-ADDON-ISLET-CNTR + 1.
645700
645800     IF  H-TECH-ADDON-ISLET-CNTR = 1
645900     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
646000           GO TO 4100-ADD-TECH-CASES.
646100
646200     IF  H-TECH-ADDON-ISLET-CNTR > 1
646300     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
646400           GO TO 4100-ADD-TECH-CASES.
646500
646600     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
646700
646800
646900 4100-ADD-TECH-CASES.
647000
647100     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
647200             H-NEW-TECH-PAY-ADD-ON +
647300             H-NEW-TECH-ADDON-ISLET.
647400
647500 4100-EXIT.    EXIT.
647600
647700***********************************************************
647800* THIS IS A SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
647900* DISCHARGE COUNTS.
648000***********************************************************
648100 4400-LOWVOL-CODE-RTN.
648200*
648300     SET LOWVOL-IDX TO 1.
648400     SEARCH LOWVOL-TAB VARYING LOWVOL-IDX
648500         AT END
648600           MOVE ' NO LOWVOL PROVIDER FOUND' TO MES-LOWVOL
648700           MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG
648800       WHEN WK-LOWVOL-PROV (LOWVOL-IDX) = MES-PPS-PROV
648900         MOVE WK-LOWVOL-PROV-DISCHG(LOWVOL-IDX)
649000                            TO MESWK-LOWVOL-PROV-DISCHG.
649100
649200*          MOVE ' NO LOWVOL IN 2014       ' TO MES-LOWVOL.
649300*          MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG.
649400
649500 4400-EXIT.   EXIT.
649600
649700***********************************************************
649800*
649900****YEARCHANGE 2015.0**************************************
650000* THIS SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
650100* DISCHARGE COUNTS WAS REPLACED BY A FIELD ON THE PSF PROVIDER
650200* FILE
650300***********************************************************
650400 4410-UNCOMP-CARE-CODE-RTN.
650500
650600*    MOVE P-NEW-PROVIDER-NO  TO MES-PPS-PROV.
650700*
650800*    SET UNCOMP-CARE-IDX TO 1.
650900*    SEARCH UNCOMP-CARE-TAB VARYING UNCOMP-CARE-IDX
651000*        AT END
651100*          MOVE 0 TO  WK-UNCOMP-CARE-AMOUNT
651200*      WHEN TB-UNCOMP-CARE-PROV (UNCOMP-CARE-IDX) = MES-PPS-PROV
651300*        MOVE TB-UNCOMP-CARE-AMOUNT (UNCOMP-CARE-IDX)
651400*                           TO WK-UNCOMP-CARE-AMOUNT.
651500*
651600        COMPUTE WK-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
651700
651800        COMPUTE H-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
651900
652000 4410-EXIT.   EXIT.
652100
652200****YEARCHANGE 2015.0**************************************
652300***********************************************************
652400*
652500*
652600***********************************************************
652700 4500-AUTOLIT-TECH-ADD-ON.
652800***********************************************************
652900***** CASES INVOLVING AUTOLITT PROCESS DECOMPRESSION SYSTEM
653000***********************************************************
653100
653200     MOVE 0 TO H-NEW-TECH-ADDON-AUTOLITT
653300               H-LESSER-AUTOLITT-STOP-1
653400               H-LESSER-AUTOLITT-STOP-2
653500               H-CSTMED-AUTOLITT-STOP.
653600
653700
653800
653900     IF '1761   ' =  B-PRIN-PROC-CODE     OR
654000                     B-OTHER-PROC-CODE1   OR
654100                     B-OTHER-PROC-CODE2   OR
654200                     B-OTHER-PROC-CODE3   OR
654300                     B-OTHER-PROC-CODE4   OR
654400                     B-OTHER-PROC-CODE5   OR
654500                     B-OTHER-PROC-CODE6   OR
654600                     B-OTHER-PROC-CODE7   OR
654700                     B-OTHER-PROC-CODE8   OR
654800                     B-OTHER-PROC-CODE9   OR
654900                     B-OTHER-PROC-CODE10  OR
655000                     B-OTHER-PROC-CODE11  OR
655100                     B-OTHER-PROC-CODE12  OR
655200                     B-OTHER-PROC-CODE13  OR
655300                     B-OTHER-PROC-CODE14  OR
655400                     B-OTHER-PROC-CODE15  OR
655500                     B-OTHER-PROC-CODE16  OR
655600                     B-OTHER-PROC-CODE17  OR
655700                     B-OTHER-PROC-CODE18  OR
655800                     B-OTHER-PROC-CODE19  OR
655900                     B-OTHER-PROC-CODE20  OR
656000                     B-OTHER-PROC-CODE21  OR
656100                     B-OTHER-PROC-CODE22  OR
656200                     B-OTHER-PROC-CODE23  OR
656300                     B-OTHER-PROC-CODE24
656400           GO TO 4500-COMPUTE-AUTOLITT
656500     ELSE
656600           NEXT SENTENCE.
656700
656800           MOVE ZEROES TO H-NEW-TECH-ADDON-AUTOLITT.
656900           GO TO 4500-ADD-TECH-CASES.
657000
657100 4500-COMPUTE-AUTOLITT.
657200
657300     MOVE  5300.00 TO H-CSTMED-AUTOLITT-STOP.
657400
657500     COMPUTE H-LESSER-AUTOLITT-STOP-1 ROUNDED =
657600                  H-CSTMED-AUTOLITT-STOP.
657700
657800     COMPUTE H-LESSER-AUTOLITT-STOP-2 ROUNDED =
657900          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
658000                     H-BASE-DRG-PAYMENT)) * .5.
658100
658200     IF H-LESSER-AUTOLITT-STOP-2 > 0
658300        IF H-LESSER-AUTOLITT-STOP-1 < H-LESSER-AUTOLITT-STOP-2
658400         MOVE H-LESSER-AUTOLITT-STOP-1 TO
658500                                H-NEW-TECH-ADDON-AUTOLITT
658600        ELSE
658700         MOVE H-LESSER-AUTOLITT-STOP-2 TO
658800                                H-NEW-TECH-ADDON-AUTOLITT
658900     ELSE
659000        MOVE ZEROES          TO H-NEW-TECH-ADDON-AUTOLITT.
659100
659200
659300 4500-ADD-TECH-CASES.
659400
659500     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
659600             H-NEW-TECH-PAY-ADD-ON +
659700             H-NEW-TECH-ADDON-AUTOLITT.
659800*
659900 4500-EXIT.    EXIT.
660000
660100
660200 4600-DIFICID-TECH-ADD-ON.
660300***********************************************************
660400***** CASES INVOLVING DIFICID PROCESS DECOMPRESSION SYSTEM
660500***********************************************************
660600***** PER HPAR 8041H TEST WAS CHANGED FR 0845 TO 00845
660700***********************************************************
660800
660900
661000     MOVE 0 TO H-NEW-TECH-ADDON-DIFICID
661100               H-LESSER-DIFICID-STOP-1
661200               H-LESSER-DIFICID-STOP-2
661300               H-CSTMED-DIFICID-STOP.
661400
661500     IF '00845  ' =  B-OTHER-DIAG-CODE1   OR
661600                     B-OTHER-DIAG-CODE2   OR
661700                     B-OTHER-DIAG-CODE3   OR
661800                     B-OTHER-DIAG-CODE4   OR
661900                     B-OTHER-DIAG-CODE5   OR
662000                     B-OTHER-DIAG-CODE6   OR
662100                     B-OTHER-DIAG-CODE7   OR
662200                     B-OTHER-DIAG-CODE8   OR
662300                     B-OTHER-DIAG-CODE9   OR
662400                     B-OTHER-DIAG-CODE10  OR
662500                     B-OTHER-DIAG-CODE11  OR
662600                     B-OTHER-DIAG-CODE12  OR
662700                     B-OTHER-DIAG-CODE13  OR
662800                     B-OTHER-DIAG-CODE14  OR
662900                     B-OTHER-DIAG-CODE15  OR
663000                     B-OTHER-DIAG-CODE16  OR
663100                     B-OTHER-DIAG-CODE17  OR
663200                     B-OTHER-DIAG-CODE18  OR
663300                     B-OTHER-DIAG-CODE19  OR
663400                     B-OTHER-DIAG-CODE20  OR
663500                     B-OTHER-DIAG-CODE21  OR
663600                     B-OTHER-DIAG-CODE22  OR
663700                     B-OTHER-DIAG-CODE23  OR
663800                     B-OTHER-DIAG-CODE24  OR
663900                     B-OTHER-DIAG-CODE25
664000           GO TO 4600-COMPUTE-DIFICID
664100     ELSE
664200           NEXT SENTENCE.
664300
664400           MOVE ZEROES TO H-NEW-TECH-ADDON-DIFICID.
664500           GO TO 4600-ADD-TECH-CASES.
664600
664700 4600-COMPUTE-DIFICID.
664800
664900     MOVE  868.00 TO H-CSTMED-DIFICID-STOP.
665000
665100     COMPUTE H-LESSER-DIFICID-STOP-1 ROUNDED =
665200                  H-CSTMED-DIFICID-STOP.
665300
665400     COMPUTE H-LESSER-DIFICID-STOP-2 ROUNDED =
665500          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
665600                     H-BASE-DRG-PAYMENT)) * .5.
665700
665800     IF H-LESSER-DIFICID-STOP-2 > 0
665900        IF H-LESSER-DIFICID-STOP-1 < H-LESSER-DIFICID-STOP-2
666000         MOVE H-LESSER-DIFICID-STOP-1 TO
666100                                H-NEW-TECH-ADDON-DIFICID
666200        ELSE
666300         MOVE H-LESSER-DIFICID-STOP-2 TO
666400                                H-NEW-TECH-ADDON-DIFICID
666500     ELSE
666600        MOVE ZEROES          TO H-NEW-TECH-ADDON-DIFICID.
666700
666800
666900
667000 4600-ADD-TECH-CASES.
667100
667200     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
667300             H-NEW-TECH-PAY-ADD-ON +
667400             H-NEW-TECH-ADDON-DIFICID.
667500*
667600 4600-EXIT.    EXIT.
667700
667800 4700-ZENITH-TECH-ADD-ON.
667900***********************************************************
668000***** CASES INVOLVING ZENITH PROCESS DECOMPRESSION SYSTEM
668100***********************************************************
668200
668300     MOVE 0 TO H-NEW-TECH-ADDON-ZENITH
668400               H-LESSER-ZENITH-STOP-1
668500               H-LESSER-ZENITH-STOP-2
668600               H-CSTMED-ZENITH-STOP.
668700
668800
668900
669000     IF '3978   ' =  B-PRIN-PROC-CODE     OR
669100                     B-OTHER-PROC-CODE1   OR
669200                     B-OTHER-PROC-CODE2   OR
669300                     B-OTHER-PROC-CODE3   OR
669400                     B-OTHER-PROC-CODE4   OR
669500                     B-OTHER-PROC-CODE5   OR
669600                     B-OTHER-PROC-CODE6   OR
669700                     B-OTHER-PROC-CODE7   OR
669800                     B-OTHER-PROC-CODE8   OR
669900                     B-OTHER-PROC-CODE9   OR
670000                     B-OTHER-PROC-CODE10  OR
670100                     B-OTHER-PROC-CODE11  OR
670200                     B-OTHER-PROC-CODE12  OR
670300                     B-OTHER-PROC-CODE13  OR
670400                     B-OTHER-PROC-CODE14  OR
670500                     B-OTHER-PROC-CODE15  OR
670600                     B-OTHER-PROC-CODE16  OR
670700                     B-OTHER-PROC-CODE17  OR
670800                     B-OTHER-PROC-CODE18  OR
670900                     B-OTHER-PROC-CODE19  OR
671000                     B-OTHER-PROC-CODE20  OR
671100                     B-OTHER-PROC-CODE21  OR
671200                     B-OTHER-PROC-CODE22  OR
671300                     B-OTHER-PROC-CODE23  OR
671400                     B-OTHER-PROC-CODE24
671500           GO TO 4700-COMPUTE-ZENITH
671600     ELSE
671700           NEXT SENTENCE.
671800
671900           MOVE ZEROES TO H-NEW-TECH-ADDON-ZENITH.
672000           GO TO 4700-ADD-TECH-CASES.
672100
672200 4700-COMPUTE-ZENITH.
672300
672400     MOVE  8171.50 TO H-CSTMED-ZENITH-STOP.
672500
672600     COMPUTE H-LESSER-ZENITH-STOP-1 ROUNDED =
672700                  H-CSTMED-ZENITH-STOP.
672800
672900     COMPUTE H-LESSER-ZENITH-STOP-2 ROUNDED =
673000          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
673100                     H-BASE-DRG-PAYMENT)) * .5.
673200
673300     IF H-LESSER-ZENITH-STOP-2 > 0
673400        IF H-LESSER-ZENITH-STOP-1 < H-LESSER-ZENITH-STOP-2
673500         MOVE H-LESSER-ZENITH-STOP-1 TO
673600                                H-NEW-TECH-ADDON-ZENITH
673700        ELSE
673800         MOVE H-LESSER-ZENITH-STOP-2 TO
673900                                H-NEW-TECH-ADDON-ZENITH
674000     ELSE
674100        MOVE ZEROES          TO H-NEW-TECH-ADDON-ZENITH.
674200
674300
674400 4700-ADD-TECH-CASES.
674500
674600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
674700             H-NEW-TECH-PAY-ADD-ON +
674800             H-NEW-TECH-ADDON-ZENITH.
674900*
675000 4700-EXIT.    EXIT.
675100
675200***********************************************************
675300 4800-VORAXAZE-TECH-ADD-ON.
675400***********************************************************
675500***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
675600***********************************************************
675700
675800     MOVE 0 TO H-NEW-TECH-ADDON-VORAXAZE
675900               H-LESSER-VORAXAZE-STOP-1
676000               H-LESSER-VORAXAZE-STOP-2
676100               H-CSTMED-VORAXAZE-STOP.
676200
676300
676400
676500     IF '0095   ' =  B-PRIN-PROC-CODE     OR
676600                     B-OTHER-PROC-CODE1   OR
676700                     B-OTHER-PROC-CODE2   OR
676800                     B-OTHER-PROC-CODE3   OR
676900                     B-OTHER-PROC-CODE4   OR
677000                     B-OTHER-PROC-CODE5   OR
677100                     B-OTHER-PROC-CODE6   OR
677200                     B-OTHER-PROC-CODE7   OR
677300                     B-OTHER-PROC-CODE8   OR
677400                     B-OTHER-PROC-CODE9   OR
677500                     B-OTHER-PROC-CODE10  OR
677600                     B-OTHER-PROC-CODE11  OR
677700                     B-OTHER-PROC-CODE12  OR
677800                     B-OTHER-PROC-CODE13  OR
677900                     B-OTHER-PROC-CODE14  OR
678000                     B-OTHER-PROC-CODE15  OR
678100                     B-OTHER-PROC-CODE16  OR
678200                     B-OTHER-PROC-CODE17  OR
678300                     B-OTHER-PROC-CODE18  OR
678400                     B-OTHER-PROC-CODE19  OR
678500                     B-OTHER-PROC-CODE20  OR
678600                     B-OTHER-PROC-CODE21  OR
678700                     B-OTHER-PROC-CODE22  OR
678800                     B-OTHER-PROC-CODE23  OR
678900                     B-OTHER-PROC-CODE24
679000           GO TO 4800-COMPUTE-VORAXAZE
679100     ELSE
679200           NEXT SENTENCE.
679300
679400           MOVE ZEROES TO H-NEW-TECH-ADDON-VORAXAZE.
679500           GO TO 4800-ADD-TECH-CASES.
679600
679700 4800-COMPUTE-VORAXAZE.
679800
679900     MOVE  47250.00 TO H-CSTMED-VORAXAZE-STOP.
680000
680100     COMPUTE H-LESSER-VORAXAZE-STOP-1 ROUNDED =
680200                  H-CSTMED-VORAXAZE-STOP.
680300
680400     COMPUTE H-LESSER-VORAXAZE-STOP-2 ROUNDED =
680500          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
680600                     H-BASE-DRG-PAYMENT)) * .5.
680700
680800     IF H-LESSER-VORAXAZE-STOP-2 > 0
680900        IF H-LESSER-VORAXAZE-STOP-1 < H-LESSER-VORAXAZE-STOP-2
681000         MOVE H-LESSER-VORAXAZE-STOP-1 TO
681100                                H-NEW-TECH-ADDON-VORAXAZE
681200        ELSE
681300         MOVE H-LESSER-VORAXAZE-STOP-2 TO
681400                                H-NEW-TECH-ADDON-VORAXAZE
681500     ELSE
681600        MOVE ZEROES          TO H-NEW-TECH-ADDON-VORAXAZE.
681700
681800
681900 4800-ADD-TECH-CASES.
682000
682100     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
682200             H-NEW-TECH-PAY-ADD-ON +
682300             H-NEW-TECH-ADDON-VORAXAZE.
682400*
682500 4800-EXIT.    EXIT.
682600
682700***********************************************************
682800 4810-ARGUS-TECH-ADD-ON.
682900***********************************************************
683000***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
683100***********************************************************
683200
683300     MOVE 0 TO H-NEW-TECH-ADDON-ARGUS
683400               H-LESSER-ARGUS-STOP-1
683500               H-LESSER-ARGUS-STOP-2
683600               H-CSTMED-ARGUS-STOP.
683700
683800
683900
684000     IF '1481   ' =  B-PRIN-PROC-CODE     OR
684100                     B-OTHER-PROC-CODE1   OR
684200                     B-OTHER-PROC-CODE2   OR
684300                     B-OTHER-PROC-CODE3   OR
684400                     B-OTHER-PROC-CODE4   OR
684500                     B-OTHER-PROC-CODE5   OR
684600                     B-OTHER-PROC-CODE6   OR
684700                     B-OTHER-PROC-CODE7   OR
684800                     B-OTHER-PROC-CODE8   OR
684900                     B-OTHER-PROC-CODE9   OR
685000                     B-OTHER-PROC-CODE10  OR
685100                     B-OTHER-PROC-CODE11  OR
685200                     B-OTHER-PROC-CODE12  OR
685300                     B-OTHER-PROC-CODE13  OR
685400                     B-OTHER-PROC-CODE14  OR
685500                     B-OTHER-PROC-CODE15  OR
685600                     B-OTHER-PROC-CODE16  OR
685700                     B-OTHER-PROC-CODE17  OR
685800                     B-OTHER-PROC-CODE18  OR
685900                     B-OTHER-PROC-CODE19  OR
686000                     B-OTHER-PROC-CODE20  OR
686100                     B-OTHER-PROC-CODE21  OR
686200                     B-OTHER-PROC-CODE22  OR
686300                     B-OTHER-PROC-CODE23  OR
686400                     B-OTHER-PROC-CODE24
686500           GO TO 4810-COMPUTE-ARGUS
686600     ELSE
686700           NEXT SENTENCE.
686800
686900           MOVE ZEROES TO H-NEW-TECH-ADDON-ARGUS.
687000           GO TO 4810-ADD-TECH-CASES.
687100
687200 4810-COMPUTE-ARGUS.
687300
687400     MOVE  72028.75 TO H-CSTMED-ARGUS-STOP.
687500
687600     COMPUTE H-LESSER-ARGUS-STOP-1 ROUNDED =
687700                  H-CSTMED-ARGUS-STOP.
687800
687900     COMPUTE H-LESSER-ARGUS-STOP-2 ROUNDED =
688000          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
688100                     H-BASE-DRG-PAYMENT)) * .5.
688200
688300     IF H-LESSER-ARGUS-STOP-2 > 0
688400        IF H-LESSER-ARGUS-STOP-1 < H-LESSER-ARGUS-STOP-2
688500         MOVE H-LESSER-ARGUS-STOP-1 TO
688600                                H-NEW-TECH-ADDON-ARGUS
688700        ELSE
688800         MOVE H-LESSER-ARGUS-STOP-2 TO
688900                                H-NEW-TECH-ADDON-ARGUS
689000     ELSE
689100        MOVE ZEROES          TO H-NEW-TECH-ADDON-ARGUS.
689200
689300
689400 4810-ADD-TECH-CASES.
689500
689600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
689700             H-NEW-TECH-PAY-ADD-ON +
689800             H-NEW-TECH-ADDON-ARGUS.
689900*
690000 4810-EXIT.    EXIT.
690100
690200
690300***********************************************************
690400 4820-KCENTRA-TECH-ADD-ON.
690500***********************************************************
690600***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
690700***********************************************************
690800
690900     MOVE 0 TO H-NEW-TECH-ADDON-KCENTRA
691000               H-LESSER-KCENTRA-STOP-1
691100               H-LESSER-KCENTRA-STOP-2
691200               H-CSTMED-KCENTRA-STOP.
691300
691400
691500
691600     IF '0096   ' =  B-PRIN-PROC-CODE     OR
691700                     B-OTHER-PROC-CODE1   OR
691800                     B-OTHER-PROC-CODE2   OR
691900                     B-OTHER-PROC-CODE3   OR
692000                     B-OTHER-PROC-CODE4   OR
692100                     B-OTHER-PROC-CODE5   OR
692200                     B-OTHER-PROC-CODE6   OR
692300                     B-OTHER-PROC-CODE7   OR
692400                     B-OTHER-PROC-CODE8   OR
692500                     B-OTHER-PROC-CODE9   OR
692600                     B-OTHER-PROC-CODE10  OR
692700                     B-OTHER-PROC-CODE11  OR
692800                     B-OTHER-PROC-CODE12  OR
692900                     B-OTHER-PROC-CODE13  OR
693000                     B-OTHER-PROC-CODE14  OR
693100                     B-OTHER-PROC-CODE15  OR
693200                     B-OTHER-PROC-CODE16  OR
693300                     B-OTHER-PROC-CODE17  OR
693400                     B-OTHER-PROC-CODE18  OR
693500                     B-OTHER-PROC-CODE19  OR
693600                     B-OTHER-PROC-CODE20  OR
693700                     B-OTHER-PROC-CODE21  OR
693800                     B-OTHER-PROC-CODE22  OR
693900                     B-OTHER-PROC-CODE23  OR
694000                     B-OTHER-PROC-CODE24
694100           GO TO 4820-COMPUTE-KCENTRA
694200     ELSE
694300           NEXT SENTENCE.
694400
694500           MOVE ZEROES TO H-NEW-TECH-ADDON-KCENTRA.
694600           GO TO 4820-ADD-TECH-CASES.
694700
694800 4820-COMPUTE-KCENTRA.
694900
695000     MOVE  01587.50 TO H-CSTMED-KCENTRA-STOP.
695100
695200     COMPUTE H-LESSER-KCENTRA-STOP-1 ROUNDED =
695300                  H-CSTMED-KCENTRA-STOP.
695400
695500     COMPUTE H-LESSER-KCENTRA-STOP-2 ROUNDED =
695600          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
695700                     H-BASE-DRG-PAYMENT)) * .5.
695800
695900     IF H-LESSER-KCENTRA-STOP-2 > 0
696000        IF H-LESSER-KCENTRA-STOP-1 < H-LESSER-KCENTRA-STOP-2
696100         MOVE H-LESSER-KCENTRA-STOP-1 TO
696200                                H-NEW-TECH-ADDON-KCENTRA
696300        ELSE
696400         MOVE H-LESSER-KCENTRA-STOP-2 TO
696500                                H-NEW-TECH-ADDON-KCENTRA
696600     ELSE
696700        MOVE ZEROES          TO H-NEW-TECH-ADDON-KCENTRA.
696800
696900
697000 4820-ADD-TECH-CASES.
697100
697200     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
697300             H-NEW-TECH-PAY-ADD-ON +
697400             H-NEW-TECH-ADDON-KCENTRA.
697500*
697600 4820-EXIT.    EXIT.
697700
697800
697900***********************************************************
698000 4830-ZILVER-TECH-ADD-ON.
698100***********************************************************
698200***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
698300***********************************************************
698400
698500     MOVE 0 TO H-NEW-TECH-ADDON-ZILVER
698600               H-LESSER-ZILVER-STOP-1
698700               H-LESSER-ZILVER-STOP-2
698800               H-CSTMED-ZILVER-STOP.
698900
699000
699100
699200     IF '0060   ' =  B-PRIN-PROC-CODE     OR
699300                     B-OTHER-PROC-CODE1   OR
699400                     B-OTHER-PROC-CODE2   OR
699500                     B-OTHER-PROC-CODE3   OR
699600                     B-OTHER-PROC-CODE4   OR
699700                     B-OTHER-PROC-CODE5   OR
699800                     B-OTHER-PROC-CODE6   OR
699900                     B-OTHER-PROC-CODE7   OR
700000                     B-OTHER-PROC-CODE8   OR
700100                     B-OTHER-PROC-CODE9   OR
700200                     B-OTHER-PROC-CODE10  OR
700300                     B-OTHER-PROC-CODE11  OR
700400                     B-OTHER-PROC-CODE12  OR
700500                     B-OTHER-PROC-CODE13  OR
700600                     B-OTHER-PROC-CODE14  OR
700700                     B-OTHER-PROC-CODE15  OR
700800                     B-OTHER-PROC-CODE16  OR
700900                     B-OTHER-PROC-CODE17  OR
701000                     B-OTHER-PROC-CODE18  OR
701100                     B-OTHER-PROC-CODE19  OR
701200                     B-OTHER-PROC-CODE20  OR
701300                     B-OTHER-PROC-CODE21  OR
701400                     B-OTHER-PROC-CODE22  OR
701500                     B-OTHER-PROC-CODE23  OR
701600                     B-OTHER-PROC-CODE24
701700           GO TO 4830-COMPUTE-ZILVER
701800     ELSE
701900           NEXT SENTENCE.
702000
702100           MOVE ZEROES TO H-NEW-TECH-ADDON-ZILVER.
702200           GO TO 4830-ADD-TECH-CASES.
702300
702400 4830-COMPUTE-ZILVER.
702500
702600     MOVE  01705.25 TO H-CSTMED-ZILVER-STOP.
702700
702800     COMPUTE H-LESSER-ZILVER-STOP-1 ROUNDED =
702900                  H-CSTMED-ZILVER-STOP.
703000
703100     COMPUTE H-LESSER-ZILVER-STOP-2 ROUNDED =
703200          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
703300                     H-BASE-DRG-PAYMENT)) * .5.
703400
703500     IF H-LESSER-ZILVER-STOP-2 > 0
703600        IF H-LESSER-ZILVER-STOP-1 < H-LESSER-ZILVER-STOP-2
703700         MOVE H-LESSER-ZILVER-STOP-1 TO
703800                                H-NEW-TECH-ADDON-ZILVER
703900        ELSE
704000         MOVE H-LESSER-ZILVER-STOP-2 TO
704100                                H-NEW-TECH-ADDON-ZILVER
704200     ELSE
704300        MOVE ZEROES          TO H-NEW-TECH-ADDON-ZILVER.
704400
704500
704600 4830-ADD-TECH-CASES.
704700
704800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
704900             H-NEW-TECH-PAY-ADD-ON +
705000             H-NEW-TECH-ADDON-ZILVER.
705100*
705200 4830-EXIT.    EXIT.
705300
705400
705500***********************************************************
705600 5000-CAP-CALC-TECH-ADD-ON.
705700***********************************************************
705800***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
705900***********************************************************
706000
706100     MOVE 0 TO H-NEW-TECH-ADDON-CAP.
706200     MOVE 0 TO H-NEW-TECH-ADDON-CAPDIF.
706300
706400     COMPUTE H-OPER-BILL-COSTS ROUNDED =
706500         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
706600         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
706700
706800     COMPUTE H-NEW-TECH-ADDON-CAP ROUNDED =
706900                 (H-BASE-DRG-PAYMENT + H-NEW-TECH-PAY-ADD-ON).
707000
707100     COMPUTE H-NEW-TECH-ADDON-CAPDIF ROUNDED =
707200                 (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
707300
707400     IF (H-NEW-TECH-ADDON-CAP > H-OPER-BILL-COSTS) AND
707500         H-NEW-TECH-ADDON-CAPDIF  > 0
707600        COMPUTE H-NEW-TECH-PAY-ADD-ON  ROUNDED =
707700             (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
707800
707900*
708000 5000-EXIT.    EXIT.
708100
708200***********************************************************
708300 5010-CARDIO-MEMES-ADD-ON.
708400***********************************************************
708500***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
708600***********************************************************
708700
708800     MOVE 0 TO H-NEW-TECH-ADDON-CARDIO
708900               H-LESSER-CARDIO-STOP-1
709000               H-LESSER-CARDIO-STOP-2
709100               H-CSTMED-CARDIO-STOP.
709200
709300
709400
709500     IF '3826   ' =  B-PRIN-PROC-CODE     OR
709600                     B-OTHER-PROC-CODE1   OR
709700                     B-OTHER-PROC-CODE2   OR
709800                     B-OTHER-PROC-CODE3   OR
709900                     B-OTHER-PROC-CODE4   OR
710000                     B-OTHER-PROC-CODE5   OR
710100                     B-OTHER-PROC-CODE6   OR
710200                     B-OTHER-PROC-CODE7   OR
710300                     B-OTHER-PROC-CODE8   OR
710400                     B-OTHER-PROC-CODE9   OR
710500                     B-OTHER-PROC-CODE10  OR
710600                     B-OTHER-PROC-CODE11  OR
710700                     B-OTHER-PROC-CODE12  OR
710800                     B-OTHER-PROC-CODE13  OR
710900                     B-OTHER-PROC-CODE14  OR
711000                     B-OTHER-PROC-CODE15  OR
711100                     B-OTHER-PROC-CODE16  OR
711200                     B-OTHER-PROC-CODE17  OR
711300                     B-OTHER-PROC-CODE18  OR
711400                     B-OTHER-PROC-CODE19  OR
711500                     B-OTHER-PROC-CODE20  OR
711600                     B-OTHER-PROC-CODE21  OR
711700                     B-OTHER-PROC-CODE22  OR
711800                     B-OTHER-PROC-CODE23  OR
711900                     B-OTHER-PROC-CODE24
712000           GO TO 5010-COMPUTE-CARDIO
712100     ELSE
712200           NEXT SENTENCE.
712300
712400           MOVE ZEROES TO H-NEW-TECH-ADDON-CARDIO.
712500           GO TO 5010-ADD-TECH-CASES.
712600
712700 5010-COMPUTE-CARDIO.
712800
712900     MOVE  08875.00 TO H-CSTMED-CARDIO-STOP.
713000
713100     COMPUTE H-LESSER-CARDIO-STOP-1 ROUNDED =
713200                  H-CSTMED-CARDIO-STOP.
713300
713400     COMPUTE H-LESSER-CARDIO-STOP-2 ROUNDED =
713500          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
713600                     H-BASE-DRG-PAYMENT)) * .5.
713700
713800     IF H-LESSER-CARDIO-STOP-2 > 0
713900        IF H-LESSER-CARDIO-STOP-1 < H-LESSER-CARDIO-STOP-2
714000         MOVE H-LESSER-CARDIO-STOP-1 TO
714100                                H-NEW-TECH-ADDON-CARDIO
714200        ELSE
714300         MOVE H-LESSER-CARDIO-STOP-2 TO
714400                                H-NEW-TECH-ADDON-CARDIO
714500     ELSE
714600        MOVE ZEROES          TO H-NEW-TECH-ADDON-CARDIO.
714700
714800
714900 5010-ADD-TECH-CASES.
715000
715100     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
715200             H-NEW-TECH-PAY-ADD-ON +
715300             H-NEW-TECH-ADDON-CARDIO.
715400*
715500*
715600 5010-EXIT.    EXIT.
715700***********************************************************
715800***********************************************************
715900 5020-MITRA-CLIP-ADD-ON.
716000***********************************************************
716100***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
716200***********************************************************
716300
716400     MOVE 0 TO H-NEW-TECH-ADDON-MITRACLP
716500               H-LESSER-MITRACLP-STOP-1
716600               H-LESSER-MITRACLP-STOP-2
716700               H-CSTMED-MITRACLP-STOP.
716800
716900
717000
717100     IF '3597   ' =  B-PRIN-PROC-CODE     OR
717200                     B-OTHER-PROC-CODE1   OR
717300                     B-OTHER-PROC-CODE2   OR
717400                     B-OTHER-PROC-CODE3   OR
717500                     B-OTHER-PROC-CODE4   OR
717600                     B-OTHER-PROC-CODE5   OR
717700                     B-OTHER-PROC-CODE6   OR
717800                     B-OTHER-PROC-CODE7   OR
717900                     B-OTHER-PROC-CODE8   OR
718000                     B-OTHER-PROC-CODE9   OR
718100                     B-OTHER-PROC-CODE10  OR
718200                     B-OTHER-PROC-CODE11  OR
718300                     B-OTHER-PROC-CODE12  OR
718400                     B-OTHER-PROC-CODE13  OR
718500                     B-OTHER-PROC-CODE14  OR
718600                     B-OTHER-PROC-CODE15  OR
718700                     B-OTHER-PROC-CODE16  OR
718800                     B-OTHER-PROC-CODE17  OR
718900                     B-OTHER-PROC-CODE18  OR
719000                     B-OTHER-PROC-CODE19  OR
719100                     B-OTHER-PROC-CODE20  OR
719200                     B-OTHER-PROC-CODE21  OR
719300                     B-OTHER-PROC-CODE22  OR
719400                     B-OTHER-PROC-CODE23  OR
719500                     B-OTHER-PROC-CODE24
719600           GO TO 5020-COMPUTE-MITRACLP
719700     ELSE
719800           NEXT SENTENCE.
719900
720000           MOVE ZEROES TO H-NEW-TECH-ADDON-MITRACLP.
720100           GO TO 5020-ADD-TECH-CASES.
720200
720300 5020-COMPUTE-MITRACLP.
720400
720500     MOVE  15000.00 TO H-CSTMED-MITRACLP-STOP.
720600
720700     COMPUTE H-LESSER-MITRACLP-STOP-1 ROUNDED =
720800                  H-CSTMED-MITRACLP-STOP.
720900
721000     COMPUTE H-LESSER-MITRACLP-STOP-2 ROUNDED =
721100          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
721200                     H-BASE-DRG-PAYMENT)) * .5.
721300
721400     IF H-LESSER-MITRACLP-STOP-2 > 0
721500        IF H-LESSER-MITRACLP-STOP-1 < H-LESSER-MITRACLP-STOP-2
721600         MOVE H-LESSER-MITRACLP-STOP-1 TO
721700                                H-NEW-TECH-ADDON-MITRACLP
721800        ELSE
721900         MOVE H-LESSER-MITRACLP-STOP-2 TO
722000                                H-NEW-TECH-ADDON-MITRACLP
722100     ELSE
722200        MOVE ZEROES          TO H-NEW-TECH-ADDON-MITRACLP.
722300
722400
722500 5020-ADD-TECH-CASES.
722600
722700     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
722800             H-NEW-TECH-PAY-ADD-ON +
722900             H-NEW-TECH-ADDON-MITRACLP.
723000*
723100*
723200 5020-EXIT.    EXIT.
723300
723400***********************************************************
723500***********************************************************
723600 5030-RNS-SYS-ADD-ON.
723700***********************************************************
723800***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
723900***********************************************************
724000
724100     MOVE 0 TO H-NEW-TECH-ADDON-RNSSYS
724200               H-LESSER-RNSSYS-STOP-1
724300               H-LESSER-RNSSYS-STOP-2
724400               H-CSTMED-RNSSYS-STOP.
724500
724600
724700     IF '0120   ' =  B-PRIN-PROC-CODE     OR
724800                     B-OTHER-PROC-CODE1   OR
724900                     B-OTHER-PROC-CODE2   OR
725000                     B-OTHER-PROC-CODE3   OR
725100                     B-OTHER-PROC-CODE4   OR
725200                     B-OTHER-PROC-CODE5   OR
725300                     B-OTHER-PROC-CODE6   OR
725400                     B-OTHER-PROC-CODE7   OR
725500                     B-OTHER-PROC-CODE8   OR
725600                     B-OTHER-PROC-CODE9   OR
725700                     B-OTHER-PROC-CODE10  OR
725800                     B-OTHER-PROC-CODE11  OR
725900                     B-OTHER-PROC-CODE12  OR
726000                     B-OTHER-PROC-CODE13  OR
726100                     B-OTHER-PROC-CODE14  OR
726200                     B-OTHER-PROC-CODE15  OR
726300                     B-OTHER-PROC-CODE16  OR
726400                     B-OTHER-PROC-CODE17  OR
726500                     B-OTHER-PROC-CODE18  OR
726600                     B-OTHER-PROC-CODE19  OR
726700                     B-OTHER-PROC-CODE20  OR
726800                     B-OTHER-PROC-CODE21  OR
726900                     B-OTHER-PROC-CODE22  OR
727000                     B-OTHER-PROC-CODE23  OR
727100                     B-OTHER-PROC-CODE24
727200           NEXT SENTENCE
727300     ELSE
727400           MOVE ZEROES TO H-NEW-TECH-ADDON-RNSSYS
727500           GO TO 5030-ADD-TECH-CASES.
727600
727700
727800     IF '0293   ' =  B-PRIN-PROC-CODE     OR
727900                     B-OTHER-PROC-CODE1   OR
728000                     B-OTHER-PROC-CODE2   OR
728100                     B-OTHER-PROC-CODE3   OR
728200                     B-OTHER-PROC-CODE4   OR
728300                     B-OTHER-PROC-CODE5   OR
728400                     B-OTHER-PROC-CODE6   OR
728500                     B-OTHER-PROC-CODE7   OR
728600                     B-OTHER-PROC-CODE8   OR
728700                     B-OTHER-PROC-CODE9   OR
728800                     B-OTHER-PROC-CODE10  OR
728900                     B-OTHER-PROC-CODE11  OR
729000                     B-OTHER-PROC-CODE12  OR
729100                     B-OTHER-PROC-CODE13  OR
729200                     B-OTHER-PROC-CODE14  OR
729300                     B-OTHER-PROC-CODE15  OR
729400                     B-OTHER-PROC-CODE16  OR
729500                     B-OTHER-PROC-CODE17  OR
729600                     B-OTHER-PROC-CODE18  OR
729700                     B-OTHER-PROC-CODE19  OR
729800                     B-OTHER-PROC-CODE20  OR
729900                     B-OTHER-PROC-CODE21  OR
730000                     B-OTHER-PROC-CODE22  OR
730100                     B-OTHER-PROC-CODE23  OR
730200                     B-OTHER-PROC-CODE24
730300           GO TO 5030-COMPUTE-RNSSYS
730400     ELSE
730500           NEXT SENTENCE.
730600
730700           MOVE ZEROES TO H-NEW-TECH-ADDON-RNSSYS.
730800           GO TO 5030-ADD-TECH-CASES.
730900
731000 5030-COMPUTE-RNSSYS.
731100
731200     MOVE  18475.00 TO H-CSTMED-RNSSYS-STOP.
731300
731400     COMPUTE H-LESSER-RNSSYS-STOP-1 ROUNDED =
731500                  H-CSTMED-RNSSYS-STOP.
731600
731700     COMPUTE H-LESSER-RNSSYS-STOP-2 ROUNDED =
731800          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
731900                     H-BASE-DRG-PAYMENT)) * .5.
732000
732100     IF H-LESSER-RNSSYS-STOP-2 > 0
732200        IF H-LESSER-RNSSYS-STOP-1 < H-LESSER-RNSSYS-STOP-2
732300         MOVE H-LESSER-RNSSYS-STOP-1 TO
732400                                H-NEW-TECH-ADDON-RNSSYS
732500        ELSE
732600         MOVE H-LESSER-RNSSYS-STOP-2 TO
732700                                H-NEW-TECH-ADDON-RNSSYS
732800     ELSE
732900        MOVE ZEROES          TO H-NEW-TECH-ADDON-RNSSYS.
733000
733100
733200 5030-ADD-TECH-CASES.
733300
733400     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
733500             H-NEW-TECH-PAY-ADD-ON +
733600             H-NEW-TECH-ADDON-RNSSYS.
733700*
733800*
733900 5030-EXIT.    EXIT.
734000
734100***********************************************************
734200 6000-CALC-READMIS-REDU.
734300***********************************************************
734400***** CASES INVOLVING READMISN PROCESS ADJUSTMENTS
734500**    FOR FY 2014 THE LOWEST FACTOR CAN BE 0.98 **********
734600***********************************************************
734700
734800     MOVE 0 TO H-READMIS-ADJUST-AMT.
734900
735000     IF P-HOSP-READMISSION-REDU = '1'
735100           GO TO 6000-EDIT-READMISN
735200     ELSE
735300           NEXT SENTENCE.
735400
735500     IF P-HOSP-READMISSION-REDU = '0' AND
735600        P-HOSP-HRR-ADJUSTMT = 0.0000
735700           MOVE ZEROES TO H-READMIS-ADJUST-AMT
735800           GO TO 6000-EXIT.
735900
736000     IF P-HOSP-READMISSION-REDU = '0' AND
736100        P-HOSP-HRR-ADJUSTMT > 0.0000
736200           MOVE 65 TO PPS-RTC
736300           MOVE ZEROES TO H-READMIS-ADJUST-AMT
736400           GO TO 6000-EXIT.
736500
736600
736700     IF P-HOSP-READMISSION-REDU = '2' OR '3' OR '4' OR '5' OR
736800                                  '6' OR '7' OR '8' OR
736900                                  '9' OR ' '
737000           MOVE 65 TO PPS-RTC
737100           MOVE ZEROES TO H-READMIS-ADJUST-AMT
737200           GO TO 6000-EXIT.
737300
737400 6000-EDIT-READMISN.
737500
737600     IF P-HOSP-HRR-ADJUSTMT < 0.9700
737700           MOVE 65 TO PPS-RTC
737800           MOVE ZEROES TO H-READMIS-ADJUST-AMT
737900           GO TO 6000-EXIT.
738000
738100
738200     IF P-HOSP-HRR-ADJUSTMT > 1.0000
738300           MOVE 65 TO PPS-RTC
738400           MOVE ZEROES TO H-READMIS-ADJUST-AMT
738500           GO TO 6000-EXIT.
738600
738700     IF P-READ-INVALID-STATE
738800           MOVE 65 TO PPS-RTC
738900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
739000           GO TO 6000-EXIT.
739100
739200
739300 6000-COMPUTE-READMISN.
739400
739500
739600        COMPUTE H-READMIS-ADJUST-AMT         ROUNDED =
739700              ((P-HOSP-HRR-ADJUSTMT * H-OPER-BASE-DRG-PAY) -
739800                H-OPER-BASE-DRG-PAY).
739900
740000
740100 6000-EXIT.    EXIT.
740200
740300***********************************************************
740400 7000-CALC-VALUE-BASED-PURCH.
740500***********************************************************
740600***** CASES INVOLVING VALUE BASE PURCH ADJUSTMENTS
740700**    FOR FY 2014 THE LOWEST FACTOR CAN BE 0.9875  *******
740800***********************************************************
740900
741000     MOVE 0 TO H-VAL-BASED-PURCH-ADJUST-AMT.
741100
741200     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N' OR 'Y'
741300           NEXT SENTENCE
741400     ELSE
741500           MOVE 68 TO PPS-RTC
741600           GO TO 7000-EXIT.
741700
741800     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N'
741900           GO TO 7000-EXIT.
742000
742100     IF  P-VAL-BASED-PURCH-PARTIPNT = 'Y' AND
742200         P-NEW-CBSA-HOSP-QUAL-IND = '1'
742300           NEXT SENTENCE
742400     ELSE
742500           MOVE 68 TO PPS-RTC
742600           GO TO 7000-EXIT.
742700
742800     IF  P-VBP-INVALID-STATE
742900           MOVE 68 TO PPS-RTC
743000           GO TO 7000-EXIT
743100     ELSE
743200           NEXT SENTENCE.
743300
743400     IF P-VAL-BASED-PURCH-ADJUST < 0.9850000000 OR
743500        P-VAL-BASED-PURCH-ADJUST > 2.0000000000
743600           MOVE 68 TO PPS-RTC
743700           MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT
743800           GO TO 7000-EXIT
743900     ELSE
744000           GO TO 7000-COMPUTE-VAL-BASED-PUR.
744100
744200 7000-COMPUTE-VAL-BASED-PUR.
744300
744400     COMPUTE H-VAL-BASED-PURCH-ADJUST-AMT  ROUNDED =
744500              ((P-VAL-BASED-PURCH-ADJUST *
744600                  H-OPER-BASE-DRG-PAY) -
744700                  H-OPER-BASE-DRG-PAY).
744800*
744900 7000-EXIT.    EXIT.
745000
745100***********************************************************
745200 8000-CALC-BUNDLE-REDU.
745300***********************************************************
745400***** CASES INVOLVING BUNDLE PROCESS ADJUSTMENTS
745500***********************************************************
745600
745700
745800     MOVE 0 TO H-BUNDLE-ADJUST-AMT.
745900     MOVE 0 TO WK-MODEL1-BUNDLE-DISPRCNT.
746000
746100     IF '61' =  B-DEMO-CODE1  OR
746200                B-DEMO-CODE2  OR
746300                B-DEMO-CODE3  OR
746400                B-DEMO-CODE4
746500         NEXT SENTENCE
746600     ELSE
746700         MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
746800           GO TO 8000-EXIT.
746900
747000     IF P-MODEL1-BUNDLE-DISPRCNT > .00
747100           GO TO 8000-COMPUTE-BUNDLE
747200     ELSE
747300           NEXT SENTENCE.
747400
747500     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
747600           GO TO 8000-EXIT.
747700
747800 8000-COMPUTE-BUNDLE.
747900
748000     IF  B-DISCHARGE-DATE < 20140401 AND
748100         P-MODEL1-BUNDLE-DISPRCNT = .01
748200         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
748300          (1 - (P-MODEL1-BUNDLE-DISPRCNT * .5))
748400     ELSE
748500         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
748600          (1 - (P-MODEL1-BUNDLE-DISPRCNT * 1)).
748700
748800        COMPUTE H-BUNDLE-ADJUST-AMT      ROUNDED =
748900              ((WK-MODEL1-BUNDLE-DISPRCNT *
749000                                     H-OPER-BASE-DRG-PAY) -
749100                H-OPER-BASE-DRG-PAY).
749200
749300        COMPUTE H-BUNDLE-ADJUST-AMT ROUNDED = H-BUNDLE-ADJUST-AMT.
749400
749500 8000-EXIT.    EXIT.
749600
749700***********************************************************
749800 9000-CALC-EHR-SAVING.
749900***********************************************************
750000***** CASES INVOLVING EHR SVINGS
750100***********************************************************
750200
750300***********************************************************
750400****YEARCHANGE 2015.0**************************************
750500****
750600     MOVE 1.007144617 TO H-MB-RATIO-EHR-FULL.
750700     MOVE 1.007196030 TO H-MB-RATIO-EHR-QUAL-FULL.
750800     MOVE 0 TO H-EHR-SUBSAV-QUANT.
750900     MOVE 0 TO H-EHR-SUBSAV-LV.
751000     MOVE 0 TO H-EHR-SUBSAV-QUANT-INCLV.
751100     MOVE 0 TO H-EHR-RESTORE-FULL-QUANT.
751200
751300     IF P-EHR-REDUC-IND = 'Y'
751400         NEXT SENTENCE
751500     ELSE
751600         GO TO 9000-EXIT.
751700
751800 9000-COMPUTE-EHR.
751900
752000*
752100* LOGIC TO IMPLEMENT EHR SAVINGS CALCULATION -
752200* ACTUAL EHR REDUCTIONS WILL BE BUILT INTO NEW RATE
752300* TABLES (5,6,7,&8) UP FRONT BUT OESS WANTS TO HAVE THE
752400* AMOUNT OF MONEY THE EHR POLICY 'SAVED' IN ITS OWN FIELD
752500* WHICH INVOLVES RESTORING THE FULL MARKET  BASKET
752600* TO THE PAYMENT TO GET THE 'WOULD'VE PAID' AND THEN
752700* TAKING THE DIFFERENCE BETWEEN ACTUAL PAID AND
752800* WOULD'VE PAID FOR THE SAVINGS.  OUTLIERS ARE TO BE
752900* LEFT OUT AT MOMENT SINCE OUTLIER SHOULD BE LOWER
753000* ON THE FULL RATE THAN IT WINDS UP BEING ON THE
753100* REDUCED RATE - LIKEWISE NEW TECH IS BEING LEFT
753200* OUT.
753300*
753400*
753500* FOR EHR NEED TO EXCLUDE NEW TECH AND OUTLIERS FROM
753600* SAVINGS CALCULATION SO CALCULATE AN OPERATING
753700* PAYMENT SUBTOTAL ON SO CALCULATE AN OPERATING
753800* PAYMENT SUBTOTAL ON EHR PAYMENTS THAT EXCLUDES
753900* OUTLIERS AND NEW TECH FOR CLAIMS WITH AN EHR FLAG
754000*
754100*
754200
754300      COMPUTE H-EHR-SUBSAV-QUANT =
754400           (PPS-OPER-HSP-PART +
754500            PPS-OPER-FSP-PART +
754600            PPS-OPER-DSH-ADJ +
754700            PPS-OPER-IME-ADJ +
754800            H-READMIS-ADJUST-AMT +
754900            H-VAL-BASED-PURCH-ADJUST-AMT +
755000            H-BUNDLE-ADJUST-AMT).
755100
755200*
755300*
755400* NEED TO ENSURE THAT LOW VOLUME, IF APPLICABLE IS
755500* INCLUDED - CAN'T USE PRICER'S LOW VOLUME PAYMENT
755600* AS THAT INCLUDES NEW TECH OUTLIERS AND CAPITAL -
755700* READM VBP AND BUNDLE
755800* DON'T MULTIPLY BY LV ADJUSTMENT SO MAKE A NEW LV AMT
755900* FOR ERH SAVINGS FIELD;
756000*
756100*
756200*
756300
756400      MOVE 0 TO H-EHR-SUBSAV-LV.
756500
756600      IF  WK-LOW-VOL25PCT < 1.000000
756700
756800      COMPUTE H-EHR-SUBSAV-LV =
756900          (PPS-OPER-HSP-PART +
757000           PPS-OPER-FSP-PART +
757100           PPS-OPER-DSH-ADJ +
757200           PPS-OPER-IME-ADJ )  * WK-LOW-VOL25PCT.
757300
757400      COMPUTE H-EHR-SUBSAV-QUANT-INCLV =
757500           H-EHR-SUBSAV-QUANT + H-EHR-SUBSAV-LV.
757600
757700*
757800* H-MB-RATIO-EHR-FULL IS THE RATIO OF THE FULL MARKET
757900* BASKET TO THE REDUCED EHR MB - NEED TO CARRY 2 RATIOS
758000* FOR PROVIDERS FAILING EHR AND FOR PROVIDERS FAILING EHR
758100* AND QUALITY IN COMBINATION.  EHR SAVINGS REQUIRES
758200* BACKING OFF THE LOW UPDATE AND MULTIPLYING ON THE
758300* FULL UPDATE SO USING RATIO OF LOW/FULL AND LOW/QUALHIT
758400* OF .625 ONLY.
758500*
758600
758700       COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
758800       H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-FULL.
758900
759000     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1'
759100        COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
759200          H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-QUAL-FULL.
759300
759400        COMPUTE  H-EHR-ADJUST-AMT ROUNDED =
759500          H-EHR-RESTORE-FULL-QUANT - H-EHR-SUBSAV-QUANT-INCLV.
759600
759700
759800
759900 9000-EXIT.    EXIT.
760000
760100
760200 9010-CALC-STANDARD-CHG.
760300
760400***********************************************************
760500***CM-P3 STANDARDIZED OPERATING COST CALCULATION
760600
760700     IF ((H-LABOR-PCT * H-WAGE-INDEX) +
760800               (H-NONLABOR-PCT * H-OPER-COLA)) > 0
760900        COMPUTE  H-OPER-BILL-STDZ-COSTS ROUNDED =
761000        (B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO) /
761100        ((H-LABOR-PCT * H-WAGE-INDEX) +
761200               (H-NONLABOR-PCT * H-OPER-COLA))
761300     ELSE MOVE 0 TO H-OPER-BILL-STDZ-COSTS.
761400
761500***********************************************************
761600***CM-P3 STANDARDIZED CAPITAL COST CALCULATION
761700
761800     IF (H-CAPI-GAF * H-CAPI-COLA) > 0
761900       COMPUTE  H-CAPI-BILL-STDZ-COSTS ROUNDED =
762000        (B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO) /
762100               (H-CAPI-GAF * H-CAPI-COLA)
762200     ELSE MOVE 0 TO H-CAPI-BILL-STDZ-COSTS.
762300
762400***********************************************************
762500***CM-P3 STANDARDIZED OPERATING TRESHOLD
762600
762700     MOVE 5431.22 TO H-OPER-BASE.
762800
762900     COMPUTE   H-OPER-STDZ-DOLLAR-THRESHOLD ROUNDED =
763000      (H-CST-THRESH * H-OPER-SHARE-DOLL-THRESHOLD)  +
763100                        +
763200           (H-OPER-BASE * H-DRG-WT-FRCTN)
763300                        +
763400              H-NEW-TECH-PAY-ADD-ON.
763500
763600******************************************************
763700***CM-P3 STANDARDIZED CAPITAL TRESHOLD
763800
763900     MOVE 434.26 TO H-CAPI-BASE.
764000
764100     COMPUTE   H-CAPI-STDZ-DOLLAR-THRESHOLD ROUNDED =
764200     (H-CST-THRESH * H-CAPI-SHARE-DOLL-THRESHOLD)
764300                     +
764400     (H-CAPI-BASE * H-DRG-WT-FRCTN).
764500
764600
764700******************************************************
764800***CM-P3 STANDARDIZED OPERATING OUTLIER CALCULATION
764900
765000     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
765100        (H-OPER-STDZ-DOLLAR-THRESHOLD +
765200                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
765300                          AND
765400         H-OPER-BILL-STDZ-COSTS > H-OPER-STDZ-DOLLAR-THRESHOLD
765500
765600       COMPUTE  H-OPER-STDZ-COST-OUTLIER ROUNDED =
765700        (H-CSTOUT-PCT  *
765800        (H-OPER-BILL-STDZ-COSTS - H-OPER-STDZ-DOLLAR-THRESHOLD))
765900
766000     ELSE
766100       MOVE 0 TO H-OPER-STDZ-COST-OUTLIER.
766200
766300******************************************************
766400***CM-P3 STANDARDIZED CAPITAL OUTLIER CALCULATION
766500
766600     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
766700        (H-OPER-STDZ-DOLLAR-THRESHOLD +
766800                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
766900                          AND
767000         H-CAPI-BILL-STDZ-COSTS > H-CAPI-STDZ-DOLLAR-THRESHOLD
767100
767200      COMPUTE  H-CAPI-STDZ-COST-OUTLIER ROUNDED =
767300      (H-CSTOUT-PCT  *
767400      (H-CAPI-BILL-STDZ-COSTS - H-CAPI-STDZ-DOLLAR-THRESHOLD))
767500     ELSE
767600      MOVE 0 TO H-CAPI-STDZ-COST-OUTLIER.
767700
767800*******************************************************
767900***CM-P3 STANDARDIZED ALLOWED AMOUNT CALCULATION
768000
768100      COMPUTE H-STANDARD-ALLOWED-AMOUNT ROUNDED =
768200       (H-OPER-BASE + H-CAPI-BASE)
768300                 *
768400       H-DRG-WT-FRCTN
768500                 +
768600       H-OPER-STDZ-COST-OUTLIER
768700                 +
768800       H-CAPI-STDZ-COST-OUTLIER
768900                 +
769000       H-NEW-TECH-PAY-ADD-ON.
769100
769200 9010-EXIT.    EXIT.
769300
769400***********************************************************
769500******        L A S T   S O U R C E   S T A T E M E N T   *****
