000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL154.
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     'PPCAL154      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C15.4'.
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-AUTOLITT-DIAG
384100                   VALUE '1910   ' '1911   ' '1912   ' '1913  '
384200                         '1914   ' '1915   ' '1916   ' '1917  '
384300                         '1918   ' '1919   ' 'C710   ' 'C711  '
384400                         'C712   ' 'C713   ' 'C714   ' 'C715  '
384500                         'C716   ' 'C717   ' 'C718   ' 'C719  '.
384600             88  B-DIAG-KCENTRA-DIAG1
384700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
384800                         '2864   ' '2865   ' '2867   ' '28652 '
384900                         '28653  ' '28659  '.
385000         10  B-OTHER-DIAG-CODE2     PIC X(07).
385100             88  B-DIAG-KCENTRA-DIAG2
385200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
385300                         '2864   ' '2865   ' '2867   ' '28652 '
385400                         '28653  ' '28659  '.
385500         10  B-OTHER-DIAG-CODE3     PIC X(07).
385600             88  B-DIAG-KCENTRA-DIAG3
385700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
385800                         '2864   ' '2865   ' '2867   ' '28652 '
385900                         '28653  ' '28659  '.
386000         10  B-OTHER-DIAG-CODE4     PIC X(07).
386100             88  B-DIAG-KCENTRA-DIAG4
386200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
386300                         '2864   ' '2865   ' '2867   ' '28652 '
386400                         '28653  ' '28659  '.
386500         10  B-OTHER-DIAG-CODE5     PIC X(07).
386600             88  B-DIAG-KCENTRA-DIAG5
386700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
386800                         '2864   ' '2865   ' '2867   ' '28652 '
386900                         '28653  ' '28659  '.
387000         10  B-OTHER-DIAG-CODE6     PIC X(07).
387100             88  B-DIAG-KCENTRA-DIAG6
387200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
387300                         '2864   ' '2865   ' '2867   ' '28652 '
387400                         '28653  ' '28659  '.
387500         10  B-OTHER-DIAG-CODE7     PIC X(07).
387600             88  B-DIAG-KCENTRA-DIAG7
387700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
387800                         '2864   ' '2865   ' '2867   ' '28652 '
387900                         '28653  ' '28659  '.
388000         10  B-OTHER-DIAG-CODE8     PIC X(07).
388100             88  B-DIAG-KCENTRA-DIAG8
388200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
388300                         '2864   ' '2865   ' '2867   ' '28652 '
388400                         '28653  ' '28659  '.
388500         10  B-OTHER-DIAG-CODE9     PIC X(07).
388600             88  B-DIAG-KCENTRA-DIAG9
388700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
388800                         '2864   ' '2865   ' '2867   ' '28652 '
388900                         '28653  ' '28659  '.
389000         10  B-OTHER-DIAG-CODE10    PIC X(07).
389100             88  B-DIAG-KCENTRA-DIAG10
389200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
389300                         '2864   ' '2865   ' '2867   ' '28652 '
389400                         '28653  ' '28659  '.
389500         10  B-OTHER-DIAG-CODE11    PIC X(07).
389600             88  B-DIAG-KCENTRA-DIAG11
389700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
389800                         '2864   ' '2865   ' '2867   ' '28652 '
389900                         '28653  ' '28659  '.
390000         10  B-OTHER-DIAG-CODE12    PIC X(07).
390100             88  B-DIAG-KCENTRA-DIAG12
390200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
390300                         '2864   ' '2865   ' '2867   ' '28652 '
390400                         '28653  ' '28659  '.
390500         10  B-OTHER-DIAG-CODE13    PIC X(07).
390600             88  B-DIAG-KCENTRA-DIAG13
390700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
390800                         '2864   ' '2865   ' '2867   ' '28652 '
390900                         '28653  ' '28659  '.
391000         10  B-OTHER-DIAG-CODE14    PIC X(07).
391100             88  B-DIAG-KCENTRA-DIAG14
391200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
391300                         '2864   ' '2865   ' '2867   ' '28652 '
391400                         '28653  ' '28659  '.
391500         10  B-OTHER-DIAG-CODE15    PIC X(07).
391600             88  B-DIAG-KCENTRA-DIAG15
391700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
391800                         '2864   ' '2865   ' '2867   ' '28652 '
391900                         '28653  ' '28659  '.
392000         10  B-OTHER-DIAG-CODE16    PIC X(07).
392100             88  B-DIAG-KCENTRA-DIAG16
392200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
392300                         '2864   ' '2865   ' '2867   ' '28652 '
392400                         '28653  ' '28659  '.
392500         10  B-OTHER-DIAG-CODE17    PIC X(07).
392600             88  B-DIAG-KCENTRA-DIAG17
392700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
392800                         '2864   ' '2865   ' '2867   ' '28652 '
392900                         '28653  ' '28659  '.
393000         10  B-OTHER-DIAG-CODE18    PIC X(07).
393100             88  B-DIAG-KCENTRA-DIAG18
393200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
393300                         '2864   ' '2865   ' '2867   ' '28652 '
393400                         '28653  ' '28659  '.
393500         10  B-OTHER-DIAG-CODE19    PIC X(07).
393600             88  B-DIAG-KCENTRA-DIAG19
393700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
393800                         '2864   ' '2865   ' '2867   ' '28652 '
393900                         '28653  ' '28659  '.
394000         10  B-OTHER-DIAG-CODE20    PIC X(07).
394100             88  B-DIAG-KCENTRA-DIAG20
394200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
394300                         '2864   ' '2865   ' '2867   ' '28652 '
394400                         '28653  ' '28659  '.
394500         10  B-OTHER-DIAG-CODE21    PIC X(07).
394600             88  B-DIAG-KCENTRA-DIAG21
394700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
394800                         '2864   ' '2865   ' '2867   ' '28652 '
394900                         '28653  ' '28659  '.
395000         10  B-OTHER-DIAG-CODE22    PIC X(07).
395100             88  B-DIAG-KCENTRA-DIAG22
395200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
395300                         '2864   ' '2865   ' '2867   ' '28652 '
395400                         '28653  ' '28659  '.
395500         10  B-OTHER-DIAG-CODE23    PIC X(07).
395600             88  B-DIAG-KCENTRA-DIAG23
395700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
395800                         '2864   ' '2865   ' '2867   ' '28652 '
395900                         '28653  ' '28659  '.
396000         10  B-OTHER-DIAG-CODE24    PIC X(07).
396100             88  B-DIAG-KCENTRA-DIAG24
396200                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
396300                         '2864   ' '2865   ' '2867   ' '28652 '
396400                         '28653  ' '28659  '.
396500         10  B-OTHER-DIAG-CODE25    PIC X(07).
396600             88  B-DIAG-KCENTRA-DIAG25
396700                   VALUE '2860   ' '2861   ' '2862   ' '2863  '
396800                         '2864   ' '2865   ' '2867   ' '28652 '
396900                         '28653  ' '28659  '.
397000         10  B-DEMO-DATA.
397100             15  B-DEMO-CODE1           PIC X(02).
397200             15  B-DEMO-CODE2           PIC X(02).
397300             15  B-DEMO-CODE3           PIC X(02).
397400             15  B-DEMO-CODE4           PIC X(02).
397500         10  B-NDC-DATA.
397600             15  B-NDC-NUMBER           PIC X(11).
397700               88  B-NDC-DIFICID-NDC
397800                   VALUE '52015008001'.
397900         10  FILLER                     PIC X(73).
398000
398100
398200***************************************************************
398300*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
398400*    AND PASSED BACK TO THE CALLING PROGRAM                   *
398500*            RETURN CODE VALUES (PPS-RTC)                     *
398600*                                                             *
398700*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
398800*                                                             *
398900*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
399000*                                                             *
399100*           30,00 = PAID NORMAL DRG PAYMENT                   *
399200*                                                             *
399300*              01 = PAID AS A DAY-OUTLIER.                    *
399400*                   NOTE:                                     *
399500*                     DAY-OUTLIER NO LONGER BEING PAID        *
399600*                         AS OF 10/01/97                      *
399700*                                                             *
399800*              02 = PAID AS A COST-OUTLIER.                   *
399900*                                                             *
400000*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
400100*                   AND INCLUDING THE FULL DRG.               *
400200*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
400300*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
400400*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
400500*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
400600*                   AND INCLUDING THE FULL DRG. PROVIDER      *
400700*                   REFUSED COST OUTLIER.                     *
400800*           40,10 = POST-ACUTE TRANSFER                       *
400900*                   SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE
401000*
401100* =======================================================
401200* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
401300* =======================================================
401400*
401500*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
401600*                       THE FOLLOWING DRG'S                   *
401700*                   DRG =  VALUE  NOW USES Y INDICATORS ON DRGS
401800*                       SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE
401900*                          D-DRG-POSTACUTE-PERDIEM
402000*
402100*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
402200*                    PERDIEM DAYS = OR > GM  ALOS             *
402300*              16 = PAID AS A COST-OUTLIER WITH               *
402400*                    PERDIEM DAYS = OR > GM  ALOS             *
402500*                                                             *
402600*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
402700*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
402800*              52 = INVALID CBSA# IN PROVIDER FILE            *
402900*                   OR INVALID WAGE INDEX                     *
403000*                                      OR                     *
403100*                   INVALID PROVIDER TYPES ON PROVIDER FILE   *
403200*              53 = WAIVER STATE - NOT CALCULATED BY PPS OR   *
403300*                   OR                                         *
403400*                   INVALID STATE CODE IN COMBINATION WITH     *
403500*                   HAC FLAG                                  *
403600*              54 = INVALID DRG                               *
403700*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
403800*                                      OR                     *
403900*                   DISCHARGE DATE < CBSA EFF START DATE      *
404000*                   FOR PPS                                   *
404100*                                      OR                     *
404200*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
404300*                   DISCHARGE DATE                            *
404400*              56 = INVALID LENGTH OF STAY                    *
404500*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
404600*                                        NOT 11)              *
404700*              58 = TOTAL CHARGES NOT NUMERIC                 *
404800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
404900*                   OR BILL-LTR-DAYS > 60                     *
405000*              62 = INVALID NUMBER OF COVERED DAYS            *
405100*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER        *
405200*                   SPECIFIC FILE FOR CAPITAL                  *
405300*                   OR                                         *
405400*                   INVALID READMISSION FLAG IN PSF FILE       *
405500*                   OR                                         *
405600*                   BLANK READMISSION FLAG IN PSF FILE         *
405700*                   OR                                         *
405800*                   READMISSION ADJUSTMENT IS INVALID OR       *
405900*                   OUT OF RANGE IN PSF FILE                   *
406000*                   OR                                         *
406100*                   BLANK READMISSION ADJUSTMENT IN PSF FILE   *
406200*                   OR                                         *
406300*                   INVALID STATE CODE IN COMBINATION WITH     *
406400*                   READMISSION FLAG IN PSF FILE               *
406500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      **
406600*                   OR COST OUTLIER THRESHOLD CALUCULATION    **
406700*              68 = INVALID VALUE BASED PURCHASE FLAG IN PSF   *
406800*                   FILE                                       *
406900*                   OR                                         *
407000*                   BLANK VALUE BASED PURCHASE FLAG IN PSF FILE*
407100*                   OR                                         *
407200*                   VALUE BASED PURCHASE ADJUSTMEMT IS INVALID *
407300*                   OR OUT OF RANGE IN PSF FILE                *
407400*                   INDICATOR                                  *
407500*                   OR                                         *
407600*                   BLANK VALUE BASED PURCHASE ADJUSTMEMT IN   *
407700*                   PSF FILE                                   *
407800*                   OR                                         *
407900*                   INVALID COMBINATION OF HOSPITAL QUALITY    *
408000*                   INDICATOR                                  *
408100*                   AND VALUE BASED PURCHASE FLAG IN PSF FILE  *
408200*                   OR                                         *
408300*                   INVALID STATE CODE IN COMBINATION WITH VALUE
408400*                   BASED PURCHASE FLAG IN PSF FILE            *
408500*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
408600***************************************************************
408700 01  PPS-DATA.
408800         10  PPS-RTC                PIC 9(02).
408900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
409000         10  PPS-OUTLIER-DAYS       PIC 9(03).
409100         10  PPS-AVG-LOS            PIC 9(02)V9(01).
409200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
409300         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
409400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
409500         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
409600         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
409700         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
409800         10  PPS-REG-DAYS-USED      PIC 9(03).
409900         10  PPS-LTR-DAYS-USED      PIC 9(02).
410000         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
410100         10  PPS-CALC-VERS          PIC X(05).
410200
410300*****************************************************************
410400*            THESE ARE THE VERSIONS OF THE PPCAL
410500*           PROGRAMS THAT WILL BE PASSED BACK----
410600*          ASSOCIATED WITH THE BILL BEING PROCESSED
410700*****************************************************************
410800 01  PRICER-OPT-VERS-SW.
410900     02  PRICER-OPTION-SW          PIC X(01).
411000         88  ALL-TABLES-PASSED          VALUE 'A'.
411100         88  PROV-RECORD-PASSED         VALUE 'P'.
411200         88  ADDITIONAL-VARIABLES       VALUE 'M'.
411300         88  PC-PRICER                  VALUE 'C'.
411400     02  PPS-VERSIONS.
411500         10  PPDRV-VERSION         PIC X(05).
411600
411700*****************************************************************
411800*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
411900*          ASSOCIATED WITH THE BILL BEING PROCESSED
412000*****************************************************************
412100 01  PPS-ADDITIONAL-VARIABLES.
412200     05  PPS-HSP-PCT                PIC 9(01)V9(02).
412300     05  PPS-FSP-PCT                PIC 9(01)V9(02).
412400     05  PPS-NAT-PCT                PIC 9(01)V9(02).
412500     05  PPS-REG-PCT                PIC 9(01)V9(02).
412600     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
412700     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
412800     05  PPS-DRG-WT                 PIC 9(02)V9(04).
412900     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
413000     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
413100     05  PPS-REG-LABOR              PIC 9(05)V9(02).
413200     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
413300     05  PPS-OPER-COLA              PIC 9(01)V9(03).
413400     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
413500     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
413600     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
413700     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
413800     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
413900     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
414000     05  PPS-CAPITAL-VARIABLES.
414100         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
414200         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
414300         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
414400         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
414500         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
414600         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
414700         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
414800         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
414900     05  PPS-CAPITAL2-VARIABLES.
415000         10  PPS-CAPI2-PAY-CODE             PIC X(1).
415100         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
415200         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
415300
415400     05  PPS-OTHER-VARIABLES.
415500         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
415600         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
415700         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
415800         10  PPS-VAL-BASED-PURCH-PARTIPNT   PIC X.
415900         10  PPS-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
416000         10  PPS-HOSP-READMISSION-REDU      PIC X.
416100         10  PPS-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
416200         10  PPS-OPERATNG-DATA.
416300             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
416400             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
416500             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
416600
416700     05  PPS-PC-OTH-VARIABLES.
416800         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
416900         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
417000         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
417100         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
417200         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
417300         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
417400         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(04).
417500         10  PPS-PC-HMO-FLAG                PIC X(01).
417600         10  PPS-PC-COT-FLAG                PIC X(01).
417700         10  PPS-OPER-HSP-PART2             PIC 9(07)V9(02).
417800         10  PPS-BUNDLE-ADJUST-PAY          PIC S9(07)V99.
417900
418000     05  PPS-ADDITIONAL-PAY-INFO-DATA.
418100         10 PPS-UNCOMP-CARE-AMOUNT          PIC S9(07)V9(02).
418200         10 PPS-BUNDLE-ADJUST-AMT           PIC S9(07)V9(02).
418300         10 PPS-VAL-BASED-PURCH-ADJUST-AMT  PIC S9(07)V9(02).
418400         10 PPS-READMIS-ADJUST-AMT          PIC S9(07)V9(02).
418500     05  PPS-ADDITIONAL-PAY-INFO-DATA2.
418600         10  PPS-HAC-PROG-REDUC-IND      PIC X.
418700         10  PPS-EHR-PROG-REDUC-IND      PIC X.
418800         10  PPS-EHR-ADJUST-AMT          PIC S9(07)V9(02).
418900         10  PPS-STNDRD-VALUE            PIC S9(07)V9(02).
419000         10  PPS-HAC-PAYMENT-AMT         PIC S9(07)V9(02).
419100         10  PPS-FLX7-PAYMENT            PIC S9(07)V9(02).
419200     05 PPS-FILLER                       PIC X(0906).
419300
419400 01  PROV-NEW-HOLD.
419500     02  PROV-NEWREC-HOLD1.
419600         05  P-NEW-NPI10.
419700             10  P-NEW-NPI8             PIC X(08).
419800             10  P-NEW-NPI-FILLER       PIC X(02).
419900         05  P-NEW-PROVIDER-NO.
420000             88  P-NEW-DSH-ADJ-PROVIDERS
420100                             VALUE '180049' '190044' '190144'
420200                                   '190191' '330047' '340085'
420300                                   '370016' '370149' '420043'.
420400             10  P-NEW-STATE            PIC 9(02).
420500                 88  P-VBP-INVALID-STATE
420600                             VALUE 21 80 40.
420700                 88  P-READ-INVALID-STATE
420800                             VALUE 40.
420900                 88  P-HAC-INVALID-STATE
421000                             VALUE 40.
421100             10  FILLER                 PIC X(04).
421200         05  P-NEW-DATE-DATA.
421300             10  P-NEW-EFF-DATE.
421400                 15  P-NEW-EFF-DT-CC    PIC 9(02).
421500                 15  P-NEW-EFF-DT-YY    PIC 9(02).
421600                 15  P-NEW-EFF-DT-MM    PIC 9(02).
421700                 15  P-NEW-EFF-DT-DD    PIC 9(02).
421800             10  P-NEW-FY-BEGIN-DATE.
421900                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
422000                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
422100                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
422200                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
422300             10  P-NEW-REPORT-DATE.
422400                 15  P-NEW-REPORT-DT-CC PIC 9(02).
422500                 15  P-NEW-REPORT-DT-YY PIC 9(02).
422600                 15  P-NEW-REPORT-DT-MM PIC 9(02).
422700                 15  P-NEW-REPORT-DT-DD PIC 9(02).
422800             10  P-NEW-TERMINATION-DATE.
422900                 15  P-NEW-TERM-DT-CC   PIC 9(02).
423000                 15  P-NEW-TERM-DT-YY   PIC 9(02).
423100                 15  P-NEW-TERM-DT-MM   PIC 9(02).
423200                 15  P-NEW-TERM-DT-DD   PIC 9(02).
423300         05  P-NEW-WAIVER-CODE          PIC X(01).
423400             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
423500         05  P-NEW-INTER-NO             PIC 9(05).
423600         05  P-NEW-PROVIDER-TYPE        PIC X(02).
423700             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
423800             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
423900                                                  '15' '17'
424000                                                  '22'.
424100             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
424200             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
424300             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
424400             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
424500             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
424600             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
424700             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
424800             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
424900             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
425000             88  P-N-EACH                   VALUE '21' '22'.
425100             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
425200             88  P-N-NHCMQ-II-SNF           VALUE '32'.
425300             88  P-N-NHCMQ-III-SNF          VALUE '33'.
425400             88  P-N-INVALID-PROV-TYPES     VALUE '14' '15'.
425500         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
425600             88  P-N-NEW-ENGLAND            VALUE  1.
425700             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
425800             88  P-N-SOUTH-ATLANTIC         VALUE  3.
425900             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
426000             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
426100             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
426200             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
426300             88  P-N-MOUNTAIN               VALUE  8.
426400             88  P-N-PACIFIC                VALUE  9.
426500         05  P-NEW-CURRENT-DIV   REDEFINES
426600                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
426700             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
426800         05  P-NEW-MSA-DATA.
426900             10  P-NEW-CHG-CODE-INDEX       PIC X.
427000             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
427100             10  P-NEW-GEO-LOC-MSA9   REDEFINES
427200                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
427300             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
427400             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
427500             10  P-NEW-STAND-AMT-LOC-MSA9
427600       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
427700                 15  P-NEW-RURAL-1ST.
427800                     20  P-NEW-STAND-RURAL  PIC XX.
427900                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
428000                 15  P-NEW-RURAL-2ND        PIC XX.
428100         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
428200                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
428300                 88  P-NEW-SCH-YR82       VALUE   '82'.
428400                 88  P-NEW-SCH-YR87       VALUE   '87'.
428500         05  P-NEW-LUGAR                    PIC X.
428600         05  P-NEW-TEMP-RELIEF-IND          PIC X.
428700         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
428800         05  FILLER                         PIC X(05).
428900     02  PROV-NEWREC-HOLD2.
429000         05  P-NEW-VARIABLES.
429100             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
429200             10  P-NEW-COLA              PIC  9(01)V9(03).
429300             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
429400             10  P-NEW-BED-SIZE          PIC  9(05).
429500             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
429600             10  P-NEW-CMI               PIC  9(01)V9(04).
429700             10  P-NEW-SSI-RATIO         PIC  V9(04).
429800             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
429900             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
430000             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
430100             10  P-NEW-DSH-PERCENT       PIC  V9(04).
430200             10  P-NEW-FYE-DATE          PIC  X(08).
430300         05  P-NEW-CBSA-DATA.
430400             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
430500             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
430600             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
430700             10  P-NEW-CBSA-GEO-RURAL REDEFINES
430800                 P-NEW-CBSA-GEO-LOC.
430900                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
431000                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
431100                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
431200
431300             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
431400             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
431500             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
431600     02  PROV-NEWREC-HOLD3.
431700         05  P-NEW-PASS-AMT-DATA.
431800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
431900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
432000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
432100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
432200         05  P-NEW-CAPI-DATA.
432300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
432400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
432500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
432600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
432700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
432800             15  P-NEW-CAPI-NEW-HOSP       PIC X.
432900             15  P-NEW-CAPI-IME            PIC 9V9999.
433000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
433100         05  P-HVBP-HRR-DATA.
433200             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
433300             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
433400             15  P-HOSP-READMISSION-REDU    PIC X.
433500             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
433600         05  P-MODEL1-BUNDLE-DATA.
433700             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
433800             15  P-HAC-REDUC-IND            PIC X.
433900             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
434000             15  P-EHR-REDUC-IND            PIC X.
434100         05  FILLER                         PIC X(09).
434200
434300*****************************************************************
434400 01  WAGE-NEW-CBSA-INDEX-RECORD.
434500     05  W-CBSA                        PIC X(5).
434600     05  W-CBSA-SIZE                   PIC X.
434700         88  LARGE-URBAN       VALUE 'L'.
434800         88  OTHER-URBAN       VALUE 'O'.
434900         88  ALL-RURAL         VALUE 'R'.
435000     05  W-CBSA-EFF-DATE               PIC X(8).
435100     05  FILLER                        PIC X.
435200     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
435300     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
435400
435500*******************************************************
435600*    HOLD VARIABLES POPULATED IN PPCAL___***          *
435700*******************************************************
435800 COPY PPHOLDAR.
435900
436000******************************************************************
436100 PROCEDURE DIVISION  USING BILL-NEW-DATA
436200                           PPS-DATA
436300                           PRICER-OPT-VERS-SW
436400                           PPS-ADDITIONAL-VARIABLES
436500                           PROV-NEW-HOLD
436600                           WAGE-NEW-CBSA-INDEX-RECORD
436700                           PPHOLDAR-HOLD-AREA.
436800
436900***************************************************************
437000*    PROCESSING:                                              *
437100*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
437200*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
437300*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
437400*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
437500*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
437600*           GOBACK.                                           *
437700*        D. ASSEMBLE PRICING COMPONENTS.                      *
437800*        E. CALCULATE THE PRICE.                              *
437900***************************************************************
438000
438100     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
438200     MOVE ZEROES TO WK-UNCOMP-CARE-AMOUNT.
438300     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT.
438400     MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT.
438500     MOVE ZEROES TO H-READMIS-ADJUST-AMT.
438600     MOVE 'N' TO TEMP-RELIEF-FLAG.
438700     MOVE 'N' TO OUTLIER-RECON-FLAG.
438800     MOVE ZEROES TO WK-HAC-AMOUNT.
438900     MOVE ZEROES TO WK-HAC-TOTAL-PAYMENT.
439000     MOVE ZEROES TO H-NEW-TECH-PAY-ADD-ON.
439100     MOVE ZEROES TO PPS-NEW-TECH-PAY-ADD-ON.
439200
439300     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
439400
439500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
439600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
439700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
439800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
439900     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
440000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
440100     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
440200     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
440300     MOVE H-ADDITIONAL-PAY-INFO-DATA TO
440400                            PPS-ADDITIONAL-PAY-INFO-DATA.
440500     MOVE H-ADDITIONAL-PAY-INFO-DATA2 TO
440600                            PPS-ADDITIONAL-PAY-INFO-DATA2.
440700
440800
440900     COMPUTE PPS-OPER-HSP-PART2 ROUNDED =  1 *  H-HSP-RATE.
441000     MOVE    WK-UNCOMP-CARE-AMOUNT TO PPS-UNCOMP-CARE-AMOUNT.
441100     MOVE    H-BUNDLE-ADJUST-AMT TO PPS-BUNDLE-ADJUST-AMT.
441200     MOVE    H-VAL-BASED-PURCH-ADJUST-AMT TO
441300                           PPS-VAL-BASED-PURCH-ADJUST-AMT.
441400     MOVE    H-READMIS-ADJUST-AMT TO PPS-READMIS-ADJUST-AMT.
441500     MOVE    P-MODEL1-BUNDLE-DISPRCNT TO
441600                               PPS-MODEL1-BUNDLE-DISPRCNT.
441700
441800     MOVE P-HAC-REDUC-IND  TO  PPS-HAC-PROG-REDUC-IND.
441900     MOVE P-EHR-REDUC-IND  TO  PPS-EHR-PROG-REDUC-IND.
442000     MOVE H-EHR-ADJUST-AMT TO  PPS-EHR-ADJUST-AMT.
442100*    MOVE H-STNDRD-VALUE   TO  PPS-STNDRD-VALUE.
442200     MOVE H-STANDARD-ALLOWED-AMOUNT  TO  PPS-STNDRD-VALUE.
442300     MOVE WK-HAC-AMOUNT  TO   PPS-HAC-PAYMENT-AMT.
442400     MOVE 0     TO    PPS-FLX7-PAYMENT.
442500
442600     IF (PPS-RTC = '00' OR '03' OR '10' OR
442700                   '12' OR '14')
442800        MOVE 'Y' TO OUTLIER-RECON-FLAG
442900        MOVE PPS-DATA TO HLD-PPS-DATA
443000        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
443100        MOVE HLD-PPS-DATA TO PPS-DATA.
443200
443300     IF  PPS-RTC < 50
443400         IF  P-NEW-WAIVER-STATE
443500             MOVE 53 TO PPS-RTC
443600             MOVE ALL '0' TO PPS-OPER-HSP-PART
443700                             PPS-OPER-FSP-PART
443800                             PPS-OPER-OUTLIER-PART
443900                             PPS-OUTLIER-DAYS
444000                             PPS-REG-DAYS-USED
444100                             PPS-LTR-DAYS-USED
444200                             PPS-TOTAL-PAYMENT
444300                             WK-HAC-TOTAL-PAYMENT
444400                             PPS-OPER-DSH-ADJ
444500                             PPS-OPER-IME-ADJ
444600                             H-DSCHG-FRCTN
444700                             H-DRG-WT-FRCTN
444800                             HOLD-ADDITIONAL-VARIABLES
444900                             HOLD-CAPITAL-VARIABLES
445000                             HOLD-CAPITAL2-VARIABLES
445100                             HOLD-OTHER-VARIABLES
445200                             HOLD-PC-OTH-VARIABLES
445300                             H-ADDITIONAL-PAY-INFO-DATA
445400                             H-ADDITIONAL-PAY-INFO-DATA2.
445500
445600     GOBACK.
445700
445800 0200-MAINLINE-CONTROL.
445900
446000     MOVE 'N' TO HMO-TAG.
446100
446200     IF PPS-PC-HMO-FLAG = 'Y' OR
446300               HMO-FLAG = 'Y'
446400        MOVE 'Y' TO HMO-TAG.
446500
446600     IF P-NEW-STATE NOT = 40
446700        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
446800
446900     MOVE ALL '0' TO PPS-DATA
447000                     H-OPER-DSH-SCH
447100                     H-OPER-DSH-RRC
447200                     HOLD-PPS-COMPONENTS
447300                     HOLD-PPS-COMPONENTS
447400                     HOLD-ADDITIONAL-VARIABLES
447500                     HOLD-CAPITAL-VARIABLES
447600                     HOLD-CAPITAL2-VARIABLES
447700                     HOLD-OTHER-VARIABLES
447800                     HOLD-PC-OTH-VARIABLES
447900                     H-ADDITIONAL-PAY-INFO-DATA
448000                     H-ADDITIONAL-PAY-INFO-DATA2
448100                     H-EHR-SUBSAV-QUANT
448200                     H-EHR-SUBSAV-LV
448300                     H-EHR-SUBSAV-QUANT-INCLV
448400                     H-EHR-RESTORE-FULL-QUANT
448500                     H-OPER-BILL-STDZ-COSTS
448600                     H-CAPI-BILL-STDZ-COSTS
448700                     H-OPER-STDZ-COST-OUTLIER
448800                     H-CAPI-STDZ-COST-OUTLIER
448900                     H-OPER-STDZ-DOLLAR-THRESHOLD
449000                     H-CAPI-STDZ-DOLLAR-THRESHOLD
449100                     WK-LOW-VOL-ADDON
449200                     WK-HAC-AMOUNT
449300                     WK-HAC-TOTAL-PAYMENT.
449400
449500     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
449600        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
449700
449800     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
449900        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
450000
450100     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
450200        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
450300
450400     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
450500        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
450600
450700     IF P-HOSP-HRR-ADJUSTMT     NOT NUMERIC
450800        MOVE 0 TO P-HOSP-HRR-ADJUSTMT.
450900
451000     IF P-VAL-BASED-PURCH-ADJUST NOT NUMERIC
451100        MOVE 0 TO P-VAL-BASED-PURCH-ADJUST.
451200
451300     IF P-MODEL1-BUNDLE-DISPRCNT NOT NUMERIC
451400        MOVE 0 TO P-MODEL1-BUNDLE-DISPRCNT.
451500
451600
451700     PERFORM 1000-EDIT-THE-BILL-INFO.
451800
451900     IF  PPS-RTC = 00
452000         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
452100         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
452200
452300     IF OUTLIER-RECON-FLAG = 'Y'
452400        MOVE 'N' TO OUTLIER-RECON-FLAG
452500        GO TO 0200-EXIT.
452600
452700     IF PPS-RTC = 00
452800        IF H-PERDIEM-DAYS = H-ALOS OR
452900           H-PERDIEM-DAYS > H-ALOS
453000           MOVE 14 TO PPS-RTC.
453100
453200     IF PPS-RTC = 02
453300        IF H-PERDIEM-DAYS = H-ALOS OR
453400           H-PERDIEM-DAYS > H-ALOS
453500           MOVE 16 TO PPS-RTC.
453600
453700 0200-EXIT.   EXIT.
453800
453900 1000-EDIT-THE-BILL-INFO.
454000
454100     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
454200     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
454300
454400**   IF  PPS-RTC = 00
454500*        IF  P-NEW-WAIVER-STATE
454600*            MOVE 53 TO PPS-RTC.
454700
454800     IF  PPS-RTC = 00
454900         IF   HLDDRG-VALID = 'I'
455000             MOVE 54 TO PPS-RTC.
455100
455200     IF  PPS-RTC = 00
455300            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
455400                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
455500                MOVE 55 TO PPS-RTC.
455600
455700     IF  PPS-RTC = 00
455800         IF P-NEW-TERMINATION-DATE > 00000000
455900            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
456000                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
456100                  MOVE 55 TO PPS-RTC.
456200
456300     IF  PPS-RTC = 00
456400         IF  B-LOS NOT NUMERIC
456500             MOVE 56 TO PPS-RTC
456600         ELSE
456700         IF  B-LOS = 0
456800             IF B-REVIEW-CODE NOT = 00 AND
456900                              NOT = 03 AND
457000                              NOT = 06 AND
457100                              NOT = 07 AND
457200                              NOT = 09 AND
457300                              NOT = 11
457400             MOVE 56 TO PPS-RTC.
457500
457600     IF  PPS-RTC = 00
457700         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
457800             MOVE 61 TO PPS-RTC
457900         ELSE
458000             MOVE B-LTR-DAYS TO H-LTR-DAYS.
458100
458200     IF  PPS-RTC = 00
458300         IF  B-COVERED-DAYS NOT NUMERIC
458400             MOVE 62 TO PPS-RTC
458500         ELSE
458600         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
458700             MOVE 62 TO PPS-RTC
458800         ELSE
458900             MOVE B-COVERED-DAYS TO H-COV-DAYS.
459000
459100     IF  PPS-RTC = 00
459200         IF  H-LTR-DAYS  > H-COV-DAYS
459300             MOVE 62 TO PPS-RTC
459400         ELSE
459500             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
459600
459700     IF  PPS-RTC = 00
459800         IF  NOT VALID-REVIEW-CODE
459900             MOVE 57 TO PPS-RTC.
460000
460100     IF  PPS-RTC = 00
460200         IF  B-CHARGES-CLAIMED NOT NUMERIC
460300             MOVE 58 TO PPS-RTC.
460400
460500     IF PPS-RTC = 00
460600           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
460700                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'B' AND
460800                                            NOT = 'C'
460900                 MOVE 65 TO PPS-RTC.
461000*
461100*    IF PPS-RTC = 00 AND
461200*       B-DISCHARGE-DATE > 20150331 AND
461300*       P-N-INVALID-PROV-TYPES
461400*                MOVE 52 TO PPS-RTC.
461500
461600 2000-ASSEMBLE-PPS-VARIABLES.
461700***  GET THE PROVIDER SPECIFIC VARIABLES.
461800***  GET THE PROVIDER SPECIFIC VARIABLES.
461900
462000     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
462100     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
462200
462300     IF  (P-NEW-STATE = 02 OR 12)
462400         MOVE P-NEW-COLA TO H-OPER-COLA
462500     ELSE
462600         MOVE 1.000  TO H-OPER-COLA.
462700
462800***************************************************************
462900***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
463000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
463100
463200     PERFORM 2600-GET-DRG-WEIGHT THRU 2600-EXIT.
463300
463400     PERFORM 4410-UNCOMP-CARE-CODE-RTN THRU 4410-EXIT.
463500
463600     MOVE P-NEW-STATE            TO MES-PPS-STATE.
463700*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
463800** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
463900** FOR FY 2011
464000***************************************************************
464100*    PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
464200*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
464300***************************************************************
464400***  GET THE WAGE-INDEX
464500***  GET THE WAGE-INDEX
464600
464700     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
464800     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
464900     MOVE P-NEW-STATE            TO MES-PPS-STATE.
465000
465100*****YEARCHANGE 2011.0 ** NOT USED 2013 *******************
465200
465300***************************************************************
465400***  GET THE LABOR, NON-LABOR STANDARD RATES
465500
465600     IF  P-NEW-STATE = 40
465700         MOVE 2 TO R2
465800         MOVE 3 TO R4
465900     ELSE
466000         MOVE 1 TO R2
466100         MOVE 1 TO R4.
466200
466300     IF  LARGE-URBAN
466400         MOVE 1 TO R3
466500     ELSE
466600         MOVE 2 TO R3.
466700
466800     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
466900        (P-EHR-REDUC-IND = ' ')           AND
467000        (H-WAGE-INDEX > 01.0000))
467100        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
467200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
467300
467400     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
467500        (P-EHR-REDUC-IND = ' ')               AND
467600         (H-WAGE-INDEX > 01.0000))
467700        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
467800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
467900
468000     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
468100        (P-EHR-REDUC-IND = ' ')            AND
468200         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
468300        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
468400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
468500
468600     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
468700        (P-EHR-REDUC-IND = ' ')               AND
468800         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
468900        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
469000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
469100
469200
469300     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
469400        (P-EHR-REDUC-IND = 'Y')           AND
469500        (H-WAGE-INDEX > 01.0000))
469600        PERFORM 2300-GET-LAB-NONLAB-TB5-RATES
469700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
469800
469900     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
470000        (P-EHR-REDUC-IND = 'Y')               AND
470100         (H-WAGE-INDEX > 01.0000))
470200        PERFORM 2300-GET-LAB-NONLAB-TB6-RATES
470300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
470400
470500     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
470600        (P-EHR-REDUC-IND = 'Y')            AND
470700         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
470800        PERFORM 2300-GET-LAB-NONLAB-TB7-RATES
470900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
471000
471100     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
471200        (P-EHR-REDUC-IND = 'Y')               AND
471300         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
471400        PERFORM 2300-GET-LAB-NONLAB-TB8-RATES
471500             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
471600
471700     IF P-NEW-STATE = 40
471800        IF (H-PR-WAGE-INDEX > 01.0000)
471900            PERFORM 2300-GET-PR-LAB-TB1-RATES
472000            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
472100
472200     IF P-NEW-STATE = 40
472300        IF (H-PR-WAGE-INDEX < 01.0000 OR
472400            H-PR-WAGE-INDEX = 01.0000)
472500            PERFORM 2300-GET-PR-LAB-TB3-RATES
472600            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
472700*
472800*    IF P-NEW-STATE = 40
472900*       IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
473000*           (H-PR-WAGE-INDEX > 01.0000))
473100*            PERFORM 2300-GET-PR-LAB-TB1-RATES
473200*            VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
473300*
473400*    IF P-NEW-STATE = 40
473500*       IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
473600*            (H-PR-WAGE-INDEX > 01.0000))
473700*             PERFORM 2300-GET-PR-LAB-TB2-RATES
473800*                 VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
473900*
474000*    IF P-NEW-STATE = 40
474100*       IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
474200*       (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
474300*         PERFORM 2300-GET-PR-LAB-TB3-RATES
474400*             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
474500*
474600*    IF P-NEW-STATE = 40
474700*       IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
474800*       (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
474900*         PERFORM 2300-GET-PR-LAB-TB4-RATES
475000*             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
475100*
475200***************************************************************
475300***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
475400***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
475500
475600     MOVE 0.00  TO H-OPER-HSP-PCT.
475700     MOVE 1.00  TO H-OPER-FSP-PCT.
475800
475900***************************************************************
476000***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
476100***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
476200
476300      MOVE 1.00 TO H-NAT-PCT.
476400      MOVE 0.00 TO H-REG-PCT.
476500
476600     IF  P-NEW-STATE = 40
476700         MOVE 0.75 TO H-NAT-PCT
476800         MOVE 0.25 TO H-REG-PCT.
476900
477000     IF  P-N-SCH-REBASED-FY90 OR
477100         P-N-EACH OR
477200         P-N-MDH-REBASED-FY90
477300         MOVE 1.00 TO H-OPER-HSP-PCT.
477400
477500 2300-GET-LAB-NONLAB-TB1-RATES.
477600
477700     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
477800         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
477900         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
478000         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
478100         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
478200
478300 2300-GET-LAB-NONLAB-TB2-RATES.
478400
478500     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
478600         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
478700         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
478800         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
478900         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
479000
479100 2300-GET-LAB-NONLAB-TB3-RATES.
479200
479300     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
479400         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
479500         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
479600         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
479700         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
479800
479900 2300-GET-LAB-NONLAB-TB4-RATES.
480000
480100     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
480200         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
480300         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
480400         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
480500         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
480600
480700 2300-GET-LAB-NONLAB-TB5-RATES.
480800
480900     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
481000         MOVE TB5-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
481100         MOVE TB5-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
481200         MOVE TB5-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
481300         MOVE TB5-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
481400
481500 2300-GET-LAB-NONLAB-TB6-RATES.
481600
481700     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
481800         MOVE TB6-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
481900         MOVE TB6-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
482000         MOVE TB6-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
482100         MOVE TB6-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
482200
482300 2300-GET-LAB-NONLAB-TB7-RATES.
482400
482500     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
482600         MOVE TB7-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
482700         MOVE TB7-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
482800         MOVE TB7-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
482900         MOVE TB7-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
483000
483100 2300-GET-LAB-NONLAB-TB8-RATES.
483200
483300     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
483400         MOVE TB8-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
483500         MOVE TB8-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
483600         MOVE TB8-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
483700         MOVE TB8-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
483800
483900 2300-GET-PR-LAB-TB1-RATES.
484000
484100     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
484200         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
484300         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
484400
484500 2300-GET-PR-LAB-TB2-RATES.
484600
484700     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
484800         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
484900         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
485000
485100 2300-GET-PR-LAB-TB3-RATES.
485200
485300     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
485400         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
485500         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
485600
485700 2300-GET-PR-LAB-TB4-RATES.
485800
485900     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
486000         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
486100         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
486200
486300*
486400 2600-GET-DRG-WEIGHT.
486500
486600     IF  B-DISCHARGE-DATE NOT < WK-DRGX-EFF-DATE
486700     SET DRG-IDX TO 1
486800     SEARCH DRG-TAB VARYING DRG-IDX
486900         AT END
487000           MOVE ' NO DRG CODE    FOUND' TO HLDDRG-DESC
487100           MOVE 'I' TO  HLDDRG-VALID
487200       WHEN WK-DRG-DRGX(DRG-IDX) = B-DRG
487300         MOVE DRG-DATA-TAB(DRG-IDX) TO HLDDRG-DATA.
487400
487500
487600     MOVE HLDDRG-DATA TO WK-HLDDRG-DATA2.
487700     MOVE  HLDDRG-DRGX         TO HLDDRG-DRGX2.
487800     MOVE  HLDDRG-WEIGHT       TO HLDDRG-WEIGHT2
487900                                  H-DRG-WT.
488000     MOVE  HLDDRG-GMALOS       TO HLDDRG-GMALOS2
488100                                  H-ALOS.
488200     MOVE  HLDDRG-LOW          TO HLDDRG-LOW2.
488300     MOVE  HLDDRG-ARITH-ALOS   TO HLDDRG-ARITH-ALOS2
488400                                  H-ARITH-ALOS.
488500     MOVE  HLDDRG-PAC          TO HLDDRG-PAC2.
488600     MOVE  HLDDRG-SPPAC        TO HLDDRG-SPPAC2.
488700     MOVE  HLDDRG-DESC         TO HLDDRG-DESC2.
488800     MOVE  'V'                 TO HLDDRG-VALID.
488900     MOVE ZEROES               TO H-DAYS-CUTOFF.
489000
489100 2600-EXIT.   EXIT.
489200*
489300 3000-CALC-PAYMENT.
489400***************************************************************
489500
489600     PERFORM 3100-CALC-STAY-UTILIZATION.
489700     PERFORM 3300-CALC-OPER-FSP-AMT.
489800     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
489900
490000***********************************************************
490100***  OPERATING IME CALCULATION
490200***  OPERATING IME CALCULATION
490300
490400     COMPUTE H-OPER-IME-TEACH ROUNDED =
490500            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
490600
490700***********************************************************
490800*
490900*    IF P-N-SCH-REBASED-FY90 OR
491000*       P-N-EACH OR
491100*       P-N-MDH-REBASED-FY90
491200*        PERFORM 3450-CALC-ADDITIONAL-HSP.
491300*
491400     MOVE 00                 TO  PPS-RTC.
491500     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
491600     MOVE H-ALOS             TO  PPS-AVG-LOS.
491700     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
491800
491900     MOVE B-LOS TO H-PERDIEM-DAYS.
492000     IF H-PERDIEM-DAYS < 1
492100         MOVE 1 TO H-PERDIEM-DAYS.
492200     ADD 1 TO H-PERDIEM-DAYS.
492300
492400     MOVE 1 TO H-DSCHG-FRCTN.
492500
492600     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
492700
492800     IF (PAY-PERDIEM-DAYS  OR
492900         PAY-XFER-NO-COST) OR
493000        (PAY-XFER-SPEC-DRG AND
493100         D-DRG-POSTACUTE-PERDIEM)
493110       IF H-ALOS > 0
493200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
493300         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
493400         IF H-DSCHG-FRCTN > 1
493500              MOVE 1 TO H-DSCHG-FRCTN
493600              MOVE 1 TO H-TRANSFER-ADJ
493700         ELSE
493800              COMPUTE H-DRG-WT-FRCTN ROUNDED =
493900                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT
494000         END-IF
494000        END-IF
494000     END-IF.
494000
494000
494100     IF (PAY-XFER-SPEC-DRG AND
494200         D-DRG-POSTACUTE-50-50) AND
494000         H-ALOS > 0
494300         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
494400         COMPUTE H-DSCHG-FRCTN  ROUNDED =
494500                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
494600         IF H-DSCHG-FRCTN > 1
494700              MOVE 1 TO H-DSCHG-FRCTN
494800              MOVE 1 TO H-TRANSFER-ADJ
494900         ELSE
495000              COMPUTE H-DRG-WT-FRCTN ROUNDED =
495100            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
495200
495300
495400***********************************************************
495500***  CAPITAL DSH CALCULATION
495600***  CAPITAL DSH CALCULATION
495700
495800     MOVE 0 TO H-CAPI-DSH.
495900
496000     IF P-NEW-BED-SIZE NOT NUMERIC
496100         MOVE 0 TO P-NEW-BED-SIZE.
496200
496300     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
496400         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
496500                  (.2025 * (P-NEW-SSI-RATIO
496600                          + P-NEW-MEDICAID-RATIO)) - 1.
496700
496800***********************************************************
496900***  CAPITAL IME TEACH CALCULATION
497000***  CAPITAL IME TEACH CALCULATION
497100
497200     MOVE 0 TO H-WK-CAPI-IME-TEACH.
497300
497400     IF P-NEW-CAPI-IME NUMERIC
497500        IF P-NEW-CAPI-IME > 1.5000
497600           MOVE 1.5000 TO P-NEW-CAPI-IME.
497700
497800*****YEARCHANGE 2009.5 ****************************************
497900***
498000***  PER POLICY, WE REMOVED THE .5 MULTIPLER
498100***
498200***********************************************************
498300     IF P-NEW-CAPI-IME NUMERIC
498400        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
498500         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
498600
498700*****YEARCHANGE 2009.5 ****************************************
498800***********************************************************
498900     MOVE 0.00 TO H-DAYOUT-PCT.
499000     MOVE 0.80 TO H-CSTOUT-PCT.
499100
499200*****************************************************************
499300**
499400** BURN DRGS FOR FY14 ARE 927, 928, 929, 933, 934 AND 935.
499500**
499600*****************************************************************
499700
499800     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
499900             MOVE 0.90 TO H-CSTOUT-PCT.
500000
500100*****YEARCHANGE 2015.0 ****************************************
500200***     NATIONAL PERCENTAGE
500300     MOVE 0.6960   TO H-LABOR-PCT.
500400     MOVE 0.3040   TO H-NONLABOR-PCT.
500500
500600*****YEARCHANGE 2015.0 ****************************************
500700***     PUERTO RICO PERCENTAGE
500800     MOVE 0.6320   TO H-PR-LABOR-PCT.
500900     MOVE 0.3680   TO H-PR-NONLABOR-PCT.
501000*****YEARCHANGE 2015.0 ****************************************
501100
501200     IF (H-WAGE-INDEX < 01.0000 OR
501300         H-WAGE-INDEX = 01.0000)
501400        MOVE 0.6200 TO H-LABOR-PCT
501500        MOVE 0.3800 TO H-NONLABOR-PCT.
501600***
501700     IF P-NEW-STATE = 40
501800       IF (H-PR-WAGE-INDEX < 01.0000 OR
501900           H-PR-WAGE-INDEX = 01.0000)
502000          MOVE 0.6200 TO H-PR-LABOR-PCT
502100          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
502200
502300
502400     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
502500             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
502600     ELSE
502700             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
502800
502900     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
503000             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
503100     ELSE
503200             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
503300
503400***********************************************************
503500*****YEARCHANGE 2010.0 ************************************
503600***  CAPITAL PAYMENT METHOD B - YEARCHNG
503700***  CAPITAL PAYMENT METHOD B
503800
503900     IF W-CBSA-SIZE = 'L'
504000        MOVE 1.00 TO H-CAPI-LARG-URBAN
504100     ELSE
504200        MOVE 1.00 TO H-CAPI-LARG-URBAN.
504300
504400     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
504500     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
504600
504700*****YEARCHANGE 2015.1 ************************************
504800     COMPUTE H-FEDERAL-RATE ROUNDED =
504900                                 (0434.97 * H-CAPI-GAF).
505000     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
505100                                 (0209.45 * H-PR-CAPI-GAF).
505200*****YEARCHANGE 2015.1 ************************************
505300
505400     COMPUTE H-CAPI-COLA ROUNDED =
505500                     (.3152 * (H-OPER-COLA - 1) + 1).
505600
505700     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
505800
505900     IF P-NEW-STATE = 40
506000        COMPUTE  H-CAPI-FED-RATE ROUNDED =
506100                 (H-NAT-PCT * H-FEDERAL-RATE) +
506200                 (H-REG-PCT * H-PUERTO-RICO-RATE).
506300***********************************************************
506400***  CAPITAL FSP CALCULATION
506500***  CAPITAL FSP CALCULATION
506600
506700     COMPUTE H-CAPI-FSP-PART ROUNDED =
506800                               H-DRG-WT       *
506900                               H-CAPI-FED-RATE *
507000                               H-CAPI-COLA *
507100                               H-CAPI-LARG-URBAN.
507200
507300***********************************************************
507400***  CAPITAL PAYMENT METHOD A
507500***  CAPITAL PAYMENT METHOD A
507600
507700     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
507800        MOVE 1.00 TO H-CAPI-SCH
507900     ELSE
508000        MOVE 0.85 TO H-CAPI-SCH.
508100
508200***********************************************************
508300***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
508400***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
508500
508600     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
508700                    (P-NEW-CAPI-OLD-HARM-RATE *
508800                    H-CAPI-SCH).
508900
509000***********************************************************
509100        IF PAY-PERDIEM-DAYS
509200            IF  H-PERDIEM-DAYS < H-ALOS
509300                IF  NOT (B-DRG = 789)
509400                    PERFORM 3500-CALC-PERDIEM-AMT
509500                    MOVE 03 TO PPS-RTC.
509600
509700        IF PAY-XFER-SPEC-DRG
509800            IF  H-PERDIEM-DAYS < H-ALOS
509900                IF  NOT (B-DRG = 789)
510000                    PERFORM 3550-CALC-PERDIEM-AMT.
510100
510200        IF  PAY-XFER-NO-COST
510300            MOVE 00 TO PPS-RTC
510400            IF H-PERDIEM-DAYS < H-ALOS
510500               IF  NOT (B-DRG = 789)
510600                   PERFORM 3500-CALC-PERDIEM-AMT
510700                   MOVE 06 TO PPS-RTC.
510800
510900     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
511000
511100     PERFORM 6000-CALC-READMIS-REDU THRU 6000-EXIT.
511200
511300     IF PPS-RTC = 65 OR 67 OR 68
511400               GO TO 3000-CONTINUE.
511500
511600     PERFORM 7000-CALC-VALUE-BASED-PURCH THRU 7000-EXIT.
511700
511800     IF PPS-RTC = 65 OR 67 OR 68
511900               GO TO 3000-CONTINUE.
512000
512100     PERFORM 8000-CALC-BUNDLE-REDU  THRU 8000-EXIT.
512200
512300     IF PPS-RTC = 65 OR 67 OR 68
512400               GO TO 3000-CONTINUE.
512500
512600     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
512700
512800     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
512900
513000     IF PPS-RTC = 65 OR 67 OR 68
513100               GO TO 3000-CONTINUE.
513200
513300        IF PAY-XFER-SPEC-DRG
513400            IF  H-PERDIEM-DAYS < H-ALOS
513500                IF  NOT (B-DRG = 789)
513600                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
513700
513800
513900        IF  PAY-PERDIEM-DAYS
514000            IF  H-OPER-OUTCST-PART > 0
514100                MOVE H-OPER-OUTCST-PART TO
514200                     H-OPER-OUTLIER-PART
514300                MOVE 05 TO PPS-RTC
514400            ELSE
514500            IF  PPS-RTC NOT = 03
514600                MOVE 00 TO PPS-RTC
514700                MOVE 0  TO H-OPER-OUTLIER-PART.
514800
514900        IF  PAY-PERDIEM-DAYS
515000            IF  H-CAPI-OUTCST-PART > 0
515100                MOVE H-CAPI-OUTCST-PART TO
515200                     H-CAPI-OUTLIER-PART
515300                MOVE 05 TO PPS-RTC
515400            ELSE
515500            IF  PPS-RTC NOT = 03
515600                MOVE 0  TO H-CAPI-OUTLIER-PART.
515700
515800
515900     IF P-N-SCH-REBASED-FY90 OR
516000        P-N-EACH OR
516100        P-N-MDH-REBASED-FY90
516200         PERFORM 3450-CALC-ADDITIONAL-HSP.
516300
516400
516500 3000-CONTINUE.
516600
516700***********************************************************
516800***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
516900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
517000
517100     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
517200
517300***********************************************************
517400
517500     IF  PPS-RTC = 67
517600         MOVE H-OPER-DOLLAR-THRESHOLD TO
517700              WK-H-OPER-DOLLAR-THRESHOLD.
517800
517900     IF  PPS-RTC < 50
518000         PERFORM 3800-CALC-TOT-AMT THRU 3800-EXIT.
518100
518200     IF  PPS-RTC < 50
518300         NEXT SENTENCE
518400     ELSE
518500         MOVE ALL '0' TO PPS-OPER-HSP-PART
518600                         PPS-OPER-FSP-PART
518700                         PPS-OPER-OUTLIER-PART
518800                         PPS-OUTLIER-DAYS
518900                         PPS-REG-DAYS-USED
519000                         PPS-LTR-DAYS-USED
519100                         PPS-TOTAL-PAYMENT
519200                         WK-HAC-TOTAL-PAYMENT
519300                         PPS-OPER-DSH-ADJ
519400                         PPS-OPER-IME-ADJ
519500                         H-DSCHG-FRCTN
519600                         H-DRG-WT-FRCTN
519700                         HOLD-ADDITIONAL-VARIABLES
519800                         HOLD-CAPITAL-VARIABLES
519900                         HOLD-CAPITAL2-VARIABLES
520000                         HOLD-OTHER-VARIABLES
520100                         HOLD-PC-OTH-VARIABLES
520200                        H-ADDITIONAL-PAY-INFO-DATA
520300                        H-ADDITIONAL-PAY-INFO-DATA2.
520400
520500     IF  PPS-RTC = 67
520600         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
520700                 H-OPER-DOLLAR-THRESHOLD.
520800
520900 3000-EXIT.  EXIT.
521000
521100 3100-CALC-STAY-UTILIZATION.
521200
521300     MOVE 0 TO PPS-REG-DAYS-USED.
521400     MOVE 0 TO PPS-LTR-DAYS-USED.
521500
521600     IF H-REG-DAYS > 0
521700        IF H-REG-DAYS > B-LOS
521800           MOVE B-LOS TO PPS-REG-DAYS-USED
521900        ELSE
522000           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
522100     ELSE
522200        IF H-LTR-DAYS > B-LOS
522300           MOVE B-LOS TO PPS-LTR-DAYS-USED
522400        ELSE
522500           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
522600
522700
522800
522900 3300-CALC-OPER-FSP-AMT.
523000***********************************************************
523100***  OPERATING FSP CALCULATION
523200***  OPERATING FSP CALCULATION
523300
523400     COMPUTE H-OPER-FSP-PART ROUNDED =
523500           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
523600            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
523700                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
523800
523900     IF P-NEW-STATE = 40
524000       COMPUTE H-OPER-FSP-PART ROUNDED =
524100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
524200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
524300                           +
524400           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
524500            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
524600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
524700
524800
524900 3500-CALC-PERDIEM-AMT.
525000***********************************************************
525100***  REVIEW CODE = 03 OR 06
525200***  OPERATING PERDIEM-AMT CALCULATION
525300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
525400
525500        COMPUTE H-OPER-FSP-PART ROUNDED =
525600        H-OPER-FSP-PART * H-TRANSFER-ADJ
525700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
525800
525900***********************************************************
526000***********************************************************
526100***  REVIEW CODE = 03 OR 06
526200***  CAPITAL   PERDIEM-AMT CALCULATION
526300***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
526400
526500        COMPUTE H-CAPI-FSP-PART ROUNDED =
526600        H-CAPI-FSP-PART * H-TRANSFER-ADJ
526700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
526800
526900***********************************************************
527000***  REVIEW CODE = 03 OR 06
527100***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
527200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
527300
527400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
527500        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
527600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
527700
527800 3550-CALC-PERDIEM-AMT.
527900***********************************************************
528000***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
528100***  OPERATING PERDIEM-AMT CALCULATION
528200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
528300
528400     IF (D-DRG-POSTACUTE-50-50)
528500        MOVE 10 TO PPS-RTC
528600        COMPUTE H-OPER-FSP-PART ROUNDED =
528700        H-OPER-FSP-PART * H-DSCHG-FRCTN
528800        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
528900
529000     IF (D-DRG-POSTACUTE-PERDIEM)
529100        MOVE 12 TO PPS-RTC
529200        COMPUTE H-OPER-FSP-PART ROUNDED =
529300        H-OPER-FSP-PART *  H-TRANSFER-ADJ
529400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
529500
529600***********************************************************
529700***  CAPITAL PERDIEM-AMT CALCULATION
529800***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
529900
530000     IF (D-DRG-POSTACUTE-50-50)
530100        MOVE 10 TO PPS-RTC
530200        COMPUTE H-CAPI-FSP-PART ROUNDED =
530300        H-CAPI-FSP-PART * H-DSCHG-FRCTN
530400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
530500
530600     IF (D-DRG-POSTACUTE-PERDIEM)
530700        MOVE 12 TO PPS-RTC
530800        COMPUTE H-CAPI-FSP-PART ROUNDED =
530900        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
531000        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
531100
531200***********************************************************
531300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
531400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
531500
531600     IF (D-DRG-POSTACUTE-50-50)
531700        MOVE 10 TO PPS-RTC
531800        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
531900        H-CAPI-OLD-HARMLESS * H-DSCHG-FRCTN
532000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
532100
532200     IF (D-DRG-POSTACUTE-PERDIEM)
532300        MOVE 12 TO PPS-RTC
532400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
532500        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
532600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
532700
532800 3560-CHECK-RTN-CODE.
532900
533000     IF (D-DRG-POSTACUTE-50-50)
533100        MOVE 10 TO PPS-RTC.
533200     IF (D-DRG-POSTACUTE-PERDIEM)
533300        MOVE 12 TO PPS-RTC.
533400
533500 3560-EXIT.    EXIT.
533600
533700 3600-CALC-OUTLIER.
533800***********************************************************
533900***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
534000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
534100
534200     IF OUTLIER-RECON-FLAG = 'Y'
534300        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
534400               (H-OPER-CSTCHG-RATIO + .2).
534500
534600     IF H-CAPI-CSTCHG-RATIO > 0 OR
534700       H-OPER-CSTCHG-RATIO > 0
534800        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
534900                H-OPER-CSTCHG-RATIO /
535000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
535100        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
535200                H-CAPI-CSTCHG-RATIO /
535300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
535400     ELSE
535500         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
535600                   H-CAPI-SHARE-DOLL-THRESHOLD.
535700
535800***********************************************************
535900*****YEARCHANGE 2015.0 ************************************
536000***  OUTLIER THRESHOLD AMOUNTS
536100***  OUTLIER THRESHOLD AMOUNTS
536200
536300*****YEARCHANGE 2015.1 ************************************
536400
536500     MOVE 24626.00 TO H-CST-THRESH.
536600
536700*****YEARCHANGE 2015.1 ************************************
536800
536900     IF (B-REVIEW-CODE = '03') AND
537000         H-PERDIEM-DAYS < H-ALOS
537100        COMPUTE H-CST-THRESH ROUNDED =
537200                      (H-CST-THRESH * H-TRANSFER-ADJ)
537300                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
537400
537500     IF ((B-REVIEW-CODE = '09') AND
537600         (H-PERDIEM-DAYS < H-ALOS))
537700         IF (D-DRG-POSTACUTE-PERDIEM)
537800            COMPUTE H-CST-THRESH ROUNDED =
537900                      (H-CST-THRESH * H-TRANSFER-ADJ)
538000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
538100
538200     IF ((B-REVIEW-CODE = '09') AND
538300         (H-PERDIEM-DAYS < H-ALOS))
538400         IF (D-DRG-POSTACUTE-50-50)
538500           COMPUTE H-CST-THRESH ROUNDED =
538600          H-CST-THRESH * H-DSCHG-FRCTN
538700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
538800
538900     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
539000        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
539100         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
539200          H-OPER-SHARE-DOLL-THRESHOLD.
539300
539400     IF P-NEW-STATE = 40
539500        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
539600           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
539700            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
539800             H-OPER-SHARE-DOLL-THRESHOLD
539900        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
540000               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
540100               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
540200
540300***********************************************************
540400***********************************************************
540500
540600     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
540700          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
540800          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
540900
541000
541100     IF P-NEW-STATE = 40
541200        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
541300           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
541400           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
541500        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
541600               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
541700               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
541800
541900***********************************************************
542000******NOW INCLUDES UNCOMPENCATED CARE**********************
542100
542200     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
542300         ((H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH))
542400                       +
542500           ((H-OPER-FSP-PART * H-OPER-DSH) * .25))
542600                       +
542700             H-OPER-DOLLAR-THRESHOLD
542800                       +
542900                WK-UNCOMP-CARE-AMOUNT
543000                       +
543100                 H-NEW-TECH-PAY-ADD-ON.
543200
543300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
543400      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
543500                       +
543600             H-CAPI-DOLLAR-THRESHOLD.
543700
543800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
543900         MOVE 0 TO H-CAPI-COST-OUTLIER.
544000
544100
544200***********************************************************
544300***  OPERATING COST CALCULATION
544400***  OPERATING COST CALCULATION
544500
544600     COMPUTE H-OPER-BILL-COSTS ROUNDED =
544700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
544800         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
544900
545000
545100     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
545200         COMPUTE H-OPER-OUTCST-PART ROUNDED =
545300         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
545400                         H-OPER-COST-OUTLIER).
545500
545600     IF PAY-WITHOUT-COST OR
545700        PAY-XFER-NO-COST OR
545800        PAY-XFER-SPEC-DRG-NO-COST
545900         MOVE 0 TO H-OPER-OUTCST-PART.
546000
546100***********************************************************
546200***  CAPITAL COST CALCULATION
546300***  CAPITAL COST CALCULATION
546400
546500     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
546600             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
546700         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
546800
546900     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
547000         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
547100         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
547200                         H-CAPI-COST-OUTLIER).
547300
547400***********************************************************
547500***  'A' NOT VALID FY 2015 ON
547600
547700*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
547800*      COMPUTE H-CAPI-OUTCST-PART ROUNDED =
547900*             (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
548000
548100     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
548200        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
548300               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
548400
548500     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
548600        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
548700        MOVE 0 TO H-CAPI-OUTCST-PART
548800                  H-OPER-OUTCST-PART.
548900
549000     IF PAY-WITHOUT-COST OR
549100        PAY-XFER-NO-COST OR
549200        PAY-XFER-SPEC-DRG-NO-COST
549300         MOVE 0 TO H-CAPI-OUTCST-PART.
549400
549500***********************************************************
549600***  DETERMINES THE BILL TO BE COST  OUTLIER
549700
549800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
549900         MOVE 0 TO H-CAPI-OUTDAY-PART
550000                   H-CAPI-OUTCST-PART.
550100
550200     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
550300                 MOVE H-OPER-OUTCST-PART TO
550400                      H-OPER-OUTLIER-PART
550500                 MOVE H-CAPI-OUTCST-PART TO
550600                      H-CAPI-OUTLIER-PART
550700                 MOVE 02 TO PPS-RTC.
550800
550900     IF OUTLIER-RECON-FLAG = 'Y'
551000        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
551100           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
551200           GO TO 3600-EXIT
551300        ELSE
551400           GO TO 3600-EXIT
551500     ELSE
551600        NEXT SENTENCE.
551700
551800
551900***********************************************************
552000***  DETERMINES IF COST OUTLIER
552100***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
552200***         RETURN CODE OF 02
552300
552400     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
552500
552600     IF PPS-RTC = 02
552700       IF H-CAPI-CSTCHG-RATIO > 0 OR
552800          H-OPER-CSTCHG-RATIO > 0
552900             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
553000                     (H-CAPI-COST-OUTLIER  +
553100                      H-OPER-COST-OUTLIER)
553200                             /
553300                    (H-CAPI-CSTCHG-RATIO  +
553400                     H-OPER-CSTCHG-RATIO)
553500             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD
553600       ELSE MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
553700
553800***********************************************************
553900***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
554000***         RETURN CODE OF 67
554100
554200     IF PPS-RTC = 02
554300         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
554400            PPS-PC-COT-FLAG = 'Y'
554500             MOVE 67 TO PPS-RTC.
554600***********************************************************
554700
554800***********************************************************
554900***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
555000***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
555100***********************************************************
555200*
555300***********************************************************
555400***  'A' NOT VALID FY 2015 ON
555500*
555600*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
555700*       COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
555800*               H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
555900*        ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
556000
556100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
556200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
556300                H-CAPI-OUTLIER-PART.
556400
556500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C' AND
556600        H-CAPI-PAYCDE-PCT1 > 0
556700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
556800                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
556900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART
557000     ELSE MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
557100
557200 3600-EXIT.   EXIT.
557300
557400 3450-CALC-ADDITIONAL-HSP.
557500***********************************************************
557600*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
557700*    SOLE COMMUNITY
557800*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
557900*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
558000***********************************************************
558100***         GET THE UPDATING FACTOR
558200***         GET THE UPDATING FACTOR
558300
558400*****YEARCHANGE 2013.0 AND 2014.0******************************
558500     MOVE 0.998431 TO H-BUDG-NUTR130.
558600     MOVE 0.997989 TO H-BUDG-NUTR140.
558700*****YEARCHANGE 2015.1 ****************************************
558800     MOVE 0.998761 TO H-BUDG-NUTR150.
558900*****YEARCHANGE 2015.1 ****************************************
559000
559100*****YEARCHANGE 2013.0 ****************************************
559200        MOVE 1.0180 TO H-UPDATE-130.
559300*****YEARCHANGE 2013.0 ****************************************
559400
559500*****YEARCHANGE 2014.0 ****************************************
559600        MOVE 1.0170 TO H-UPDATE-140.
559700*****YEARCHANGE 2014.0 ****************************************
559800*****YEARCHANGE 2015.0 ****************************************
559900        MOVE 1.02200 TO H-UPDATE-150.
560000*****YEARCHANGE 2015.0 ****************************************
560100
560200*****YEARCHANGE 2015.0 ****************************************
560300     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
560400        P-EHR-REDUC-IND = 'Y'
560500        MOVE 1.01475 TO H-UPDATE-150.
560600*****YEARCHANGE 2015.0 ****************************************
560700*****YEARCHANGE 2015.0 ****************************************
560800     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
560900        P-EHR-REDUC-IND = ' '
561000        MOVE 1.02200 TO H-UPDATE-150.
561100*****YEARCHANGE 2015.0 ****************************************
561200
561300*****YEARCHANGE 2015.0 ****************************************
561400     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
561500        P-EHR-REDUC-IND = 'Y'
561600        MOVE 1.00750 TO H-UPDATE-150.
561700*****YEARCHANGE 2015.0 ****************************************
561800*****YEARCHANGE 2015.0 ****************************************
561900     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
562000        P-EHR-REDUC-IND = ' '
562100        MOVE 1.01475 TO H-UPDATE-150.
562200*****YEARCHANGE 2015.0 ****************************************
562300
562400     IF P-NEW-STATE = 40
562500*****YEARCHANGE 2015.0 ****************************************
562600        MOVE 1.0220 TO H-UPDATE-150.
562700*****YEARCHANGE 2015.0 ****************************************
562800
562900********YEARCHANGE 2015.0 *************************************
563000***         CASE MIX ADJUSTMENT - FOR 2015
563100***         SHORT STAY ADJUSTMENT - FOR 2014
563200     MOVE 0.9480 TO H-CASE-MIX-ADJ.
563300     MOVE 0.9980 TO H-SHORT-STAY-ADJ.
563400
563500     COMPUTE H-UPDATE-FACTOR ROUNDED =
563600                       (H-UPDATE-130 *
563700                        H-UPDATE-140 *
563800                        H-UPDATE-150 *
563900                        H-BUDG-NUTR130 *
564000                        H-BUDG-NUTR140 *
564100                        H-BUDG-NUTR150 *
564200                        H-CASE-MIX-ADJ * H-SHORT-STAY-ADJ).
564300
564400     COMPUTE H-HSP-RATE ROUNDED =
564500         H-FAC-SPEC-RATE * H-UPDATE-FACTOR * H-DRG-WT.
564600***************************************************************
564700*
564800*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
564900*       COMPUTE H-HSP-RATE ROUNDED =
565000*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
565100*    ELSE
565200*       COMPUTE H-HSP-RATE ROUNDED =
565300*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
565400*
565500***************************************************************
565600********YEARCHANGE 2011.0 *************************************
565700***     OUTLIER OFFSETS NO LONGER USED IN HSP COMPARISON
565800***     WE NOW USE THE ACTUAL OPERATING OUTLIER PAYMEMT
565900***     IN THE HSP COMPARRISON
566000
566100********YEARCHANGE 2014.0 *XXXXXX******************************
566200*      THE HSP BUCKET FOR SCH                      ************
566300*      ADDED UNCOMPENSATED CARE TO COMPARRISON FOR 2014 *******
566400***************************************************************
566500     COMPUTE H-FSP-RATE ROUNDED =
566600        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
566700         H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
566800                           *
566900             (1 + H-OPER-IME-TEACH + (H-OPER-DSH * .25))
567000                               +
567100                         H-OPER-OUTLIER-PART
567200                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
567300
567400     IF P-NEW-STATE = 40
567500       COMPUTE H-FSP-RATE ROUNDED =
567600         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
567700         H-NAT-NONLABOR * H-OPER-COLA))  * H-DRG-WT-FRCTN)
567800                           *
567900         (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
568000                            H-OPER-OUTLIER-PART
568100                               +
568200        ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
568300         H-REG-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
568400                           *
568500             (1 + H-OPER-IME-TEACH +(H-OPER-DSH * .25))
568600                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
568700
568800****************************************************************
568900****         INCLUDE UNCOMPENSATED CARE PER CLAIM IN HSP
569000*****        CHOICE
569100
569200
569300     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
569400           COMPUTE H-OPER-HSP-PART ROUNDED =
569500             (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT))
569600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
569700     ELSE
569800         MOVE 0 TO H-OPER-HSP-PART.
569900
570000***************************************************************
570100***  YEARCHANGE TURNING MDH BACK ON ***************************
570200***************************************************************
570300***         GET THE MDH REBASE
570400
570500
570600     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
570700         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
570800           COMPUTE H-OPER-HSP-PART ROUNDED =
570900         (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)) * .75
571000                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
571100
571200***********************************************************
571300 3800-CALC-TOT-AMT.
571400***********************************************************
571500***  CALCULATE TOTALS FOR CAPITAL
571600***  CALCULATE TOTALS FOR CAPITAL
571700
571800     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
571900
572000***********************************************************
572100***  'A' NOT VALID FY 2015 ON
572200*
572300*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
572400*       MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
572500*       MOVE 0.00 TO H-CAPI-HSP-PCT.
572600
572700     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
572800        MOVE 0    TO H-CAPI-OLD-HARMLESS
572900        MOVE 1.00 TO H-CAPI-FSP-PCT
573000        MOVE 0.00 TO H-CAPI-HSP-PCT.
573100
573200     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
573300        MOVE 0    TO H-CAPI-OLD-HARMLESS
573400        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
573500        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
573600
573700     COMPUTE H-CAPI-HSP ROUNDED =
573800         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
573900
574000     COMPUTE H-CAPI-FSP ROUNDED =
574100         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
574200
574300     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
574400
574500     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
574600
574700     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
574800             H-CAPI-FSP
574900              * H-CAPI-DSH.
575000
575100     COMPUTE H-CAPI-IME-ADJ ROUNDED =
575200          H-CAPI-FSP *
575300                 H-WK-CAPI-IME-TEACH.
575400
575500     COMPUTE H-CAPI-OUTLIER ROUNDED =
575600             1.00 * H-CAPI-OUTLIER-PART.
575700
575800     COMPUTE H-CAPI2-B-FSP ROUNDED =
575900             1.00 * H-CAPI2-B-FSP-PART.
576000
576100     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
576200             1.00 * H-CAPI2-B-OUTLIER-PART.
576300***********************************************************
576400***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
576500***        THIS ZEROES OUT ALL CAPITAL DATA
576600
576700     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
576800        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
576900***********************************************************
577000
577100***********************************************************
577200***  CALCULATE FINAL TOTALS FOR OPERATING
577300***  CALCULATE FINAL TOTALS FOR OPERATING
577400
577500     IF (H-CAPI-OUTLIER > 0 AND
577600         PPS-OPER-OUTLIER-PART = 0)
577700            COMPUTE PPS-OPER-OUTLIER-PART =
577800                    PPS-OPER-OUTLIER-PART + .01.
577900
578000***********************************************************
578100***  LOW VOLUME CALCULATION
578200***  LOW VOLUME CALCULATION
578300
578400     MOVE 01.000 TO WK-LOW-VOL25PCT.
578500
578600*
578600***********************************************************
578700***  LOW VOLUME CALCULATION ENDS 3/31/2015
578800
578900*    IF  B-DISCHARGE-DATE < 20150401
579000*        NEXT SENTENCE
579100*    ELSE
579200*        COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0
579300*         IF P-NEW-TEMP-RELIEF-IND = 'Y'
579400*           MOVE 00.250 TO WK-LOW-VOL25PCT
579500*           GO TO LOW-VOL-CALC
579600*         ELSE
579700*           MOVE 01.000 TO WK-LOW-VOL25PCT
579800*           GO TO LOW-VOL-CALC.
579900
580000     IF P-NEW-TEMP-RELIEF-IND = 'Y'
580100     MOVE P-NEW-PROVIDER-NO      TO MES-PPS-PROV
580200     PERFORM 4400-LOWVOL-CODE-RTN THRU 4400-EXIT.
580300
580400*****SET THE LOW-VOLUME DISCHARGE PERCENT
580500**   ADD ON TO 25% FOR DISCHARGES
580600**   FOR FY 2014 USE A FIXED FACTOR OF 0.25
580700
580800*    IF P-NEW-TEMP-RELIEF-IND = 'Y'
580900*           MOVE 00.250 TO WK-LOW-VOL25PCT
581000*           GO TO LOW-VOL-CALC.
581100
581200     IF P-NEW-TEMP-RELIEF-IND = 'Y'
581300     AND MESWK-LOWVOL-PROV-DISCHG < 200
581400            MOVE 00.250 TO WK-LOW-VOL25PCT
581500            GO TO LOW-VOL-CALC.
581600
581700***  CALCULATE THE LOW VOLUME DISCHARGE PERCENT
581800***  SLIDING SCALE ADD ON FOR
581900
582000     IF P-NEW-TEMP-RELIEF-IND = 'Y'
582100        AND MESWK-LOWVOL-PROV-DISCHG > 200
582200        AND MESWK-LOWVOL-PROV-DISCHG < 1600
582300            COMPUTE  WK-LOW-VOL25PCT ROUNDED =
582400            ((4 / 14) - (MESWK-LOWVOL-PROV-DISCHG / 5600))
582500            GO TO LOW-VOL-CALC
582600     ELSE
582700           MOVE 01.000 TO WK-LOW-VOL25PCT.
582800
582900
583000 LOW-VOL-CALC.
583100
583200     MOVE ZERO TO PPS-OPER-DSH-ADJ.
583300************************************************
583400* FOR FY 2014 WE APPLY AN ADJUSTMENT OF 0.25 TO CALCULATE
583500* EMPERICAL DSH
583600************************************************
583700     IF  H-OPER-DSH NUMERIC
583800         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
583900                     (PPS-OPER-FSP-PART  * H-OPER-DSH) * .25.
584000
584100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
584200                         PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
584300
584400
584500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
584600                           H-OPER-FSP-PART * H-OPER-FSP-PCT.
584700
584800     COMPUTE PPS-OPER-HSP-PART ROUNDED =
584900                           H-OPER-HSP-PART * H-OPER-HSP-PCT.
585000
585100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
585200                         H-OPER-OUTLIER-PART * H-OPER-FSP-PCT.
585300
585400     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
585500                                H-NEW-TECH-PAY-ADD-ON.
585600
585700     IF  WK-LOW-VOL25PCT < 1.000000
585800     COMPUTE WK-LOW-VOL-ADDON  ROUNDED =
585900              (PPS-OPER-HSP-PART
586000                         +
586100                   PPS-OPER-FSP-PART
586200                         +
586300                 PPS-OPER-OUTLIER-PART
586400                         +
586500                   PPS-OPER-DSH-ADJ
586600                         +
586700                      PPS-OPER-IME-ADJ
586800                           +
586900                    WK-UNCOMP-CARE-AMOUNT
587000                           +
587100                      H-CAPI-HSP
587200                           +
587300                     H-CAPI-FSP
587400                           +
587500                  H-CAPI-EXCEPTIONS
587600                           +
587700                   H-CAPI-OUTLIER
587800                           +
587900                   H-CAPI-DSH-ADJ
588000                           +
588100                   H-CAPI-IME-ADJ
588200                           +
588300                   H-CAPI-OLD-HARM
588400                           +
588500                 PPS-NEW-TECH-PAY-ADD-ON) *  WK-LOW-VOL25PCT
588600     ELSE
588700     COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0.
588800
588900 LOW-VOL-END.
589000
589100     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
589200
589300     IF HMO-TAG  = 'Y'
589400        PERFORM 3850-HMO-IME-ADJ.
589500
589600***********************************************************
589700***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
589800***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
589900
590000     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
590100             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
590200             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
590300             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
590400
590500         PERFORM 9000-CALC-EHR-SAVING   THRU 9000-EXIT.
590600         PERFORM 9010-CALC-STANDARD-CHG THRU 9010-EXIT.
590700
590800
590900***********************************************************
591000***  TOTAL PAYMENT NOW INCLUDES UNCOMPENSATED CARE AMOUNT
591100************************************************
591200* FOR FY 2015 AN ADJUSTMENT OF 0.01 TO CALCULATE
591300* HOSPITAL AQUIRED CONDITION (HAC) PENALTY
591400************************************************
591500
591600     COMPUTE   WK-HAC-TOTAL-PAYMENT ROUNDED =
591700               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
591800               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
591900                      PPS-OPER-IME-ADJ
592000                           +
592100                 PPS-NEW-TECH-PAY-ADD-ON
592200                           +
592300                  WK-UNCOMP-CARE-AMOUNT
592400                           +
592500                  WK-LOW-VOL-ADDON
592600                           +
592700                   H-CAPI-TOTAL-PAY
592800                           +
592900                 H-READMIS-ADJUST-AMT
593000                           +
593100               H-VAL-BASED-PURCH-ADJUST-AMT.
593200
593300************************************************
593400* FOR FY 2015 AN ADJUSTMENT OF 0.01 TO CALCULATE
593500* HOSPITAL AQUIRED CONDITION (HAC) PENALTY
593600* BASED ON INDICATOR FROM THE PPS FILE
593700************************************************
593800     MOVE ZERO TO WK-HAC-AMOUNT.
593900
594000************************************************
594100* HOSPITAL AQUIRED CONDITION (HAC)
594200* BASED ON INDICATOR FROM THE PPS FILE
594300* NOT VALID IN PUERTO RICO
594400************************************************
594500     IF P-NEW-STATE = 40  AND
594600        P-HAC-REDUC-IND = 'Y'
594700           MOVE 53 TO PPS-RTC
594800           GO TO 3800-EXIT.
594900
595000     IF  P-HAC-REDUC-IND = 'Y'
595100         COMPUTE   WK-HAC-AMOUNT     ROUNDED =
595200                   WK-HAC-TOTAL-PAYMENT * -0.01
595300     ELSE
595400         COMPUTE   WK-HAC-AMOUNT     ROUNDED = 0.
595500
595600***********************************************************
595700***  TOTAL PAYMENT NOW INCLUDES HAC PENALTY AMOUNT
595800************************************************
595900     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
596000                 WK-HAC-TOTAL-PAYMENT
596100                           +
596200                 H-WK-PASS-AMT-PLUS-MISC
596300                           +
596400                 H-BUNDLE-ADJUST-AMT
596500                           +
596600                 WK-HAC-AMOUNT.
596700
596800     MOVE     P-VAL-BASED-PURCH-PARTIPNT TO
596900              H-VAL-BASED-PURCH-PARTIPNT.
597000
597100     MOVE     P-VAL-BASED-PURCH-ADJUST   TO
597200              H-VAL-BASED-PURCH-ADJUST.
597300
597400     MOVE     P-HOSP-READMISSION-REDU    TO
597500              H-HOSP-READMISSION-REDU.
597600
597700     MOVE     P-HOSP-HRR-ADJUSTMT        TO
597800              H-HOSP-HRR-ADJUSTMT.
597900
598000 3800-EXIT.   EXIT.
598100
598200 3850-HMO-IME-ADJ.
598300***********************************************************
598400***  HMO CALC FOR PASS-THRU ADDON
598500***  HMO CALC FOR PASS-THRU ADDON
598600
598700     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
598800          (P-NEW-PASS-AMT-PLUS-MISC -
598900          (P-NEW-PASS-AMT-ORGAN-ACQ +
599000           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
599100
599200***********************************************************
599300***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
599400
599500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
599600                   PPS-OPER-IME-ADJ * .0.
599700
599800***********************************************************
599900
600000
600100 3900A-CALC-OPER-DSH.
600200
600300***  OPERATING DSH CALCULATION
600400***  OPERATING DSH CALCULATION
600500
600600      MOVE 0.0000 TO H-OPER-DSH.
600700
600800      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
600900                                     + P-NEW-MEDICAID-RATIO).
601000
601100***********************************************************
601200**1**    0-99 BEDS
601300***  NOT TO EXCEED 12%
601400
601500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
601600                               AND H-WK-OPER-DSH > .1499
601700                               AND H-WK-OPER-DSH < .2020
601800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
601900                                      * .65 + .025
602000        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
602100
602200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
602300                               AND H-WK-OPER-DSH > .2019
602400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
602500                                      * .825 + .0588
602600        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
602700
602800***********************************************************
602900**2**   100 + BEDS
603000***  NO CAP >> CAN EXCEED 12%
603100
603200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
603300                               AND H-WK-OPER-DSH > .1499
603400                               AND H-WK-OPER-DSH < .2020
603500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
603600                                      * .65 + .025.
603700
603800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
603900                               AND H-WK-OPER-DSH > .2019
604000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
604100                                      * .825 + .0588.
604200
604300***********************************************************
604400**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
604500***  NOT TO EXCEED 12%
604600
604700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
604800                               AND H-WK-OPER-DSH > .1499
604900                               AND H-WK-OPER-DSH < .2020
605000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
605100                                 * .65 + .025
605200        IF H-OPER-DSH > .1200
605300              MOVE .1200 TO H-OPER-DSH.
605400
605500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
605600                               AND H-WK-OPER-DSH > .2019
605700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
605800                                 * .825 + .0588
605900        IF H-OPER-DSH > .1200
606000                 MOVE .1200 TO H-OPER-DSH.
606100***********************************************************
606200**4**   OTHER RURAL HOSPITALS 500 BEDS +
606300***  NO CAP >> CAN EXCEED 12%
606400
606500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
606600                               AND H-WK-OPER-DSH > .1499
606700                               AND H-WK-OPER-DSH < .2020
606800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
606900                                 * .65 + .025.
607000
607100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
607200                               AND H-WK-OPER-DSH > .2019
607300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
607400                                 * .825 + .0588.
607500
607600***********************************************************
607700**7**   RURAL HOSPITALS SCH
607800***  NOT TO EXCEED 12%
607900
608000      IF W-CBSA-SIZE = 'R'
608100         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
608200                               AND H-WK-OPER-DSH > .1499
608300                               AND H-WK-OPER-DSH < .2020
608400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
608500                                 * .65 + .025
608600        IF H-OPER-DSH > .1200
608700                 MOVE .1200 TO H-OPER-DSH.
608800
608900      IF W-CBSA-SIZE = 'R'
609000         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
609100                               AND H-WK-OPER-DSH > .2019
609200         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
609300                                 * .825 + .0588
609400        IF H-OPER-DSH > .1200
609500                 MOVE .1200 TO H-OPER-DSH.
609600
609700***********************************************************
609800**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
609900***  RRC OVERRIDES SCH CAP
610000***  NO CAP >> CAN EXCEED 12%
610100
610200         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
610300                                   '17' OR '22')
610400                               AND H-WK-OPER-DSH > .1499
610500                               AND H-WK-OPER-DSH < .2020
610600         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
610700                                 * .65 + .025.
610800
610900         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
611000                                   '17' OR '22')
611100                               AND H-WK-OPER-DSH > .2019
611200         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
611300                                 * .825 + .0588.
611400
611500      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
611600
611700 3900A-EXIT.   EXIT.
611800
611900 4000-CALC-TECH-ADDON.
612000
612100***********************************************************
612200***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
612300***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
612400
612500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
612600         H-OPER-HSP-PCT * H-OPER-HSP-PART.
612700
612800     COMPUTE PPS-OPER-FSP-PART ROUNDED =
612900         H-OPER-FSP-PCT * H-OPER-FSP-PART.
613000
613100     MOVE ZERO TO PPS-OPER-DSH-ADJ.
613200
613300     IF  H-OPER-DSH NUMERIC
613400             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
613500             (PPS-OPER-FSP-PART
613600              * H-OPER-DSH) * .25.
613700
613800     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
613900             PPS-OPER-FSP-PART *
614000             H-OPER-IME-TEACH.
614100
614200     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
614300             PPS-OPER-FSP-PART +
614400             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ +
614500             WK-UNCOMP-CARE-AMOUNT.
614600
614700***********************************************************
614800***********************************************************
614900* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
615000
615100*    PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
615200*
615300*    IF   B-DIAG-AUTOLITT-DIAG AND
615400*         B-DRG-AUTOLITT-DRG
615500*       PERFORM 4500-AUTOLIT-TECH-ADD-ON THRU 4500-EXIT.
615600
615700***********************************************************
615800*  DIFICID DISCONTINUED FOR FY 2015
615900*    IF   B-NDC-DIFICID-NDC
616000*      PERFORM 4600-DIFICID-TECH-ADD-ON THRU 4600-EXIT.
616100
616200     PERFORM 4700-ZENITH-TECH-ADD-ON THRU 4700-EXIT.
616300
616400     PERFORM 4800-VORAXAZE-TECH-ADD-ON THRU 4800-EXIT.
616500
616600     PERFORM 4810-ARGUS-TECH-ADD-ON THRU 4810-EXIT.
616700
616800     IF   B-DIAG-KCENTRA-DIAG1  OR
616900          B-DIAG-KCENTRA-DIAG2  OR
617000          B-DIAG-KCENTRA-DIAG3  OR
617100          B-DIAG-KCENTRA-DIAG4  OR
617200          B-DIAG-KCENTRA-DIAG5  OR
617300          B-DIAG-KCENTRA-DIAG6  OR
617400          B-DIAG-KCENTRA-DIAG7  OR
617500          B-DIAG-KCENTRA-DIAG8  OR
617600          B-DIAG-KCENTRA-DIAG9  OR
617700          B-DIAG-KCENTRA-DIAG10 OR
617800          B-DIAG-KCENTRA-DIAG11 OR
617900          B-DIAG-KCENTRA-DIAG12 OR
618000          B-DIAG-KCENTRA-DIAG13 OR
618100          B-DIAG-KCENTRA-DIAG14 OR
618200          B-DIAG-KCENTRA-DIAG15 OR
618300          B-DIAG-KCENTRA-DIAG16 OR
618400          B-DIAG-KCENTRA-DIAG17 OR
618500          B-DIAG-KCENTRA-DIAG18 OR
618600          B-DIAG-KCENTRA-DIAG19 OR
618700          B-DIAG-KCENTRA-DIAG20 OR
618800          B-DIAG-KCENTRA-DIAG21 OR
618900          B-DIAG-KCENTRA-DIAG22 OR
619000          B-DIAG-KCENTRA-DIAG23 OR
619100          B-DIAG-KCENTRA-DIAG24 OR
619200          B-DIAG-KCENTRA-DIAG25
619300       MOVE ZEROES TO H-NEW-TECH-ADDON-KCENTRA
619400     ELSE
619500       PERFORM 4820-KCENTRA-TECH-ADD-ON THRU 4820-EXIT.
619600
619700     PERFORM 4830-ZILVER-TECH-ADD-ON THRU 4830-EXIT.
619800
619900     PERFORM 5010-CARDIO-MEMES-ADD-ON THRU 5010-EXIT.
620000
620100     PERFORM 5020-MITRA-CLIP-ADD-ON THRU 5020-EXIT.
620200
620300     PERFORM 5030-RNS-SYS-ADD-ON    THRU 5030-EXIT.
620400
620500***********************************************************
620600*  ALL NEW TECH MUST BE CALCULATED BEFORE
620700*  5000-CAP-CALC-TECH-ADD-ON
620800***********************************************************
620900     PERFORM 5000-CAP-CALC-TECH-ADD-ON THRU 5000-EXIT.
621000
621100     COMPUTE H-OPER-BASE-DRG-PAY ROUNDED =
621200             H-OPER-FSP-PART +
621300             H-NEW-TECH-PAY-ADD-ON.
621400
621500*
621600 4000-EXIT.    EXIT.
621700***********************************************************
621800
621900 4100-ISLET-ISOLATION-ADD-ON.
622000***********************************************************
622100***  TECHNICAL TRANSPLANTATION OF CELLS
622200***
622300*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
622400*** ISLETS OF LANGERHAUS) AND
622500*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
622600*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
622700*** TIMES IN ANY OTHER PROC-CODE
622800***********************************************************
622900*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
623000*** V70.7
623100***********************************************************
623200
623300     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
623400               H-TECH-ADDON-ISLET-CNTR2
623500               H-NEW-TECH-ADDON-ISLET.
623600
623700     IF '5285   ' =  B-PRIN-PROC-CODE     OR
623800                     B-OTHER-PROC-CODE1   OR
623900                     B-OTHER-PROC-CODE2   OR
624000                     B-OTHER-PROC-CODE3   OR
624100                     B-OTHER-PROC-CODE4   OR
624200                     B-OTHER-PROC-CODE5   OR
624300                     B-OTHER-PROC-CODE6   OR
624400                     B-OTHER-PROC-CODE7   OR
624500                     B-OTHER-PROC-CODE8   OR
624600                     B-OTHER-PROC-CODE9   OR
624700                     B-OTHER-PROC-CODE10  OR
624800                     B-OTHER-PROC-CODE11  OR
624900                     B-OTHER-PROC-CODE12  OR
625000                     B-OTHER-PROC-CODE13  OR
625100                     B-OTHER-PROC-CODE14  OR
625200                     B-OTHER-PROC-CODE15  OR
625300                     B-OTHER-PROC-CODE16  OR
625400                     B-OTHER-PROC-CODE17  OR
625500                     B-OTHER-PROC-CODE18  OR
625600                     B-OTHER-PROC-CODE19  OR
625700                     B-OTHER-PROC-CODE20  OR
625800                     B-OTHER-PROC-CODE21  OR
625900                     B-OTHER-PROC-CODE22  OR
626000                     B-OTHER-PROC-CODE23  OR
626100                     B-OTHER-PROC-CODE24
626200           NEXT SENTENCE
626300     ELSE
626400           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
626500           GO TO 4100-ADD-TECH-CASES.
626600
626700     IF '5285   ' =  B-PRIN-PROC-CODE
626800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
626900                       H-TECH-ADDON-ISLET-CNTR + 1.
627000
627100     IF '5285   ' =  B-OTHER-PROC-CODE1
627200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
627300                       H-TECH-ADDON-ISLET-CNTR + 1.
627400
627500     IF '5285   ' =  B-OTHER-PROC-CODE2
627600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
627700                       H-TECH-ADDON-ISLET-CNTR + 1.
627800
627900     IF '5285   ' =  B-OTHER-PROC-CODE3
628000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
628100                       H-TECH-ADDON-ISLET-CNTR + 1.
628200
628300     IF '5285   ' =  B-OTHER-PROC-CODE4
628400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
628500                       H-TECH-ADDON-ISLET-CNTR + 1.
628600
628700
628800     IF '5285   ' =  B-OTHER-PROC-CODE5
628900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
629000                       H-TECH-ADDON-ISLET-CNTR + 1.
629100
629200     IF '5285   ' =  B-OTHER-PROC-CODE6
629300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
629400                       H-TECH-ADDON-ISLET-CNTR + 1.
629500
629600     IF '5285   ' =  B-OTHER-PROC-CODE7
629700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
629800                       H-TECH-ADDON-ISLET-CNTR + 1.
629900
630000     IF '5285   ' =  B-OTHER-PROC-CODE8
630100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
630200                       H-TECH-ADDON-ISLET-CNTR + 1.
630300
630400     IF '5285   ' =  B-OTHER-PROC-CODE9
630500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
630600                       H-TECH-ADDON-ISLET-CNTR + 1.
630700
630800     IF '5285   ' =  B-OTHER-PROC-CODE10
630900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
631000                       H-TECH-ADDON-ISLET-CNTR + 1.
631100
631200     IF '5285   ' =  B-OTHER-PROC-CODE11
631300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
631400                       H-TECH-ADDON-ISLET-CNTR + 1.
631500
631600     IF '5285   ' =  B-OTHER-PROC-CODE12
631700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
631800                       H-TECH-ADDON-ISLET-CNTR + 1.
631900
632000     IF '5285   ' =  B-OTHER-PROC-CODE13
632100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
632200                       H-TECH-ADDON-ISLET-CNTR + 1.
632300
632400     IF '5285   ' =  B-OTHER-PROC-CODE14
632500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
632600                       H-TECH-ADDON-ISLET-CNTR + 1.
632700
632800     IF '5285   ' =  B-OTHER-PROC-CODE15
632900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
633000                       H-TECH-ADDON-ISLET-CNTR + 1.
633100
633200     IF '5285   ' =  B-OTHER-PROC-CODE16
633300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
633400                       H-TECH-ADDON-ISLET-CNTR + 1.
633500
633600     IF '5285   ' =  B-OTHER-PROC-CODE17
633700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
633800                       H-TECH-ADDON-ISLET-CNTR + 1.
633900
634000     IF '5285   ' =  B-OTHER-PROC-CODE18
634100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
634200                       H-TECH-ADDON-ISLET-CNTR + 1.
634300
634400     IF '5285   ' =  B-OTHER-PROC-CODE19
634500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
634600                       H-TECH-ADDON-ISLET-CNTR + 1.
634700
634800     IF '5285   ' =  B-OTHER-PROC-CODE20
634900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
635000                       H-TECH-ADDON-ISLET-CNTR + 1.
635100
635200     IF '5285   ' =  B-OTHER-PROC-CODE21
635300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
635400                       H-TECH-ADDON-ISLET-CNTR + 1.
635500
635600     IF '5285   ' =  B-OTHER-PROC-CODE22
635700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
635800                       H-TECH-ADDON-ISLET-CNTR + 1.
635900
636000     IF '5285   ' =  B-OTHER-PROC-CODE23
636100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
636200                       H-TECH-ADDON-ISLET-CNTR + 1.
636300
636400     IF '5285   ' =  B-OTHER-PROC-CODE24
636500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
636600                       H-TECH-ADDON-ISLET-CNTR + 1.
636700
636800     IF  H-TECH-ADDON-ISLET-CNTR = 1
636900     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
637000           GO TO 4100-ADD-TECH-CASES.
637100
637200     IF  H-TECH-ADDON-ISLET-CNTR > 1
637300     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
637400           GO TO 4100-ADD-TECH-CASES.
637500
637600     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
637700
637800
637900 4100-ADD-TECH-CASES.
638000
638100     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
638200             H-NEW-TECH-PAY-ADD-ON +
638300             H-NEW-TECH-ADDON-ISLET.
638400
638500 4100-EXIT.    EXIT.
638600
638700*
638800*
638900***********************************************************
639000* THIS IS A SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
639100* DISCHARGE COUNTS.
639200***********************************************************
639300 4400-LOWVOL-CODE-RTN.
639400*
639500     SET LOWVOL-IDX TO 1.
639600     SEARCH LOWVOL-TAB VARYING LOWVOL-IDX
639700         AT END
639800           MOVE ' NO LOWVOL PROVIDER FOUND' TO MES-LOWVOL
639900           MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG
640000       WHEN WK-LOWVOL-PROV (LOWVOL-IDX) = MES-PPS-PROV
640100         MOVE WK-LOWVOL-PROV-DISCHG(LOWVOL-IDX)
640200                            TO MESWK-LOWVOL-PROV-DISCHG.
640300
640400*          MOVE ' NO LOWVOL IN 2014       ' TO MES-LOWVOL.
640500*          MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG.
640600
640700 4400-EXIT.   EXIT.
640800
640900***********************************************************
641000*
641100****YEARCHANGE 2015.0**************************************
641200* THIS SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
641300* DISCHARGE COUNTS WAS REPLACED BY A FIELD ON THE PSF PROVIDER
641400* FILE
641500***********************************************************
641600 4410-UNCOMP-CARE-CODE-RTN.
641700
641800*    MOVE P-NEW-PROVIDER-NO  TO MES-PPS-PROV.
641900*
642000*    SET UNCOMP-CARE-IDX TO 1.
642100*    SEARCH UNCOMP-CARE-TAB VARYING UNCOMP-CARE-IDX
642200*        AT END
642300*          MOVE 0 TO  WK-UNCOMP-CARE-AMOUNT
642400*      WHEN TB-UNCOMP-CARE-PROV (UNCOMP-CARE-IDX) = MES-PPS-PROV
642500*        MOVE TB-UNCOMP-CARE-AMOUNT (UNCOMP-CARE-IDX)
642600*                           TO WK-UNCOMP-CARE-AMOUNT.
642700*
642800        COMPUTE WK-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
642900
643000        COMPUTE H-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
643100
643200 4410-EXIT.   EXIT.
643300
643400****YEARCHANGE 2015.0**************************************
643500***********************************************************
643600*
643700*
643800***********************************************************
643900 4500-AUTOLIT-TECH-ADD-ON.
644000***********************************************************
644100***** CASES INVOLVING AUTOLITT PROCESS DECOMPRESSION SYSTEM
644200***********************************************************
644300
644400     MOVE 0 TO H-NEW-TECH-ADDON-AUTOLITT
644500               H-LESSER-AUTOLITT-STOP-1
644600               H-LESSER-AUTOLITT-STOP-2
644700               H-CSTMED-AUTOLITT-STOP.
644800
644900
645000
645100     IF '1761   ' =  B-PRIN-PROC-CODE     OR
645200                     B-OTHER-PROC-CODE1   OR
645300                     B-OTHER-PROC-CODE2   OR
645400                     B-OTHER-PROC-CODE3   OR
645500                     B-OTHER-PROC-CODE4   OR
645600                     B-OTHER-PROC-CODE5   OR
645700                     B-OTHER-PROC-CODE6   OR
645800                     B-OTHER-PROC-CODE7   OR
645900                     B-OTHER-PROC-CODE8   OR
646000                     B-OTHER-PROC-CODE9   OR
646100                     B-OTHER-PROC-CODE10  OR
646200                     B-OTHER-PROC-CODE11  OR
646300                     B-OTHER-PROC-CODE12  OR
646400                     B-OTHER-PROC-CODE13  OR
646500                     B-OTHER-PROC-CODE14  OR
646600                     B-OTHER-PROC-CODE15  OR
646700                     B-OTHER-PROC-CODE16  OR
646800                     B-OTHER-PROC-CODE17  OR
646900                     B-OTHER-PROC-CODE18  OR
647000                     B-OTHER-PROC-CODE19  OR
647100                     B-OTHER-PROC-CODE20  OR
647200                     B-OTHER-PROC-CODE21  OR
647300                     B-OTHER-PROC-CODE22  OR
647400                     B-OTHER-PROC-CODE23  OR
647500                     B-OTHER-PROC-CODE24
647600           GO TO 4500-COMPUTE-AUTOLITT
647700     ELSE
647800           NEXT SENTENCE.
647900
648000           MOVE ZEROES TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
648100           GO TO 4500-ADD-TECH-CASES.
648200
648300 4500-COMPUTE-AUTOLITT.
648400
648500     MOVE  5300.00 TO H-CSTMED-AUTOLITT-STOP.
648600
648700     COMPUTE H-LESSER-AUTOLITT-STOP-1 ROUNDED =
648800                  H-CSTMED-AUTOLITT-STOP.
648900
649000     COMPUTE H-LESSER-AUTOLITT-STOP-2 ROUNDED =
649100          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
649200                     H-BASE-DRG-PAYMENT)) * .5.
649300
649400     IF H-LESSER-AUTOLITT-STOP-2 > 0
649500        IF H-LESSER-AUTOLITT-STOP-1 < H-LESSER-AUTOLITT-STOP-2
649600         MOVE H-LESSER-AUTOLITT-STOP-1 TO
649700                                H-NEW-TECH-ADDON-AUTOLITT-STOP
649800        ELSE
649900         MOVE H-LESSER-AUTOLITT-STOP-2 TO
650000                                H-NEW-TECH-ADDON-AUTOLITT-STOP
650100     ELSE
650200        MOVE ZEROES          TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
650300
650400
650500 4500-ADD-TECH-CASES.
650600
650700     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
650800             H-NEW-TECH-PAY-ADD-ON +
650900             H-NEW-TECH-ADDON-AUTOLITT-STOP.
651000*
651100 4500-EXIT.    EXIT.
651200
651300
651400 4600-DIFICID-TECH-ADD-ON.
651500***********************************************************
651600***** CASES INVOLVING DIFICID PROCESS DECOMPRESSION SYSTEM
651700***********************************************************
651800***** PER HPAR 8041H TEST WAS CHANGED FR 0845 TO 00845
651900***********************************************************
652000
652100
652200     MOVE 0 TO H-NEW-TECH-ADDON-DIFICID
652300               H-LESSER-DIFICID-STOP-1
652400               H-LESSER-DIFICID-STOP-2
652500               H-CSTMED-DIFICID-STOP.
652600
652700     IF '00845  ' =  B-OTHER-DIAG-CODE1   OR
652800                     B-OTHER-DIAG-CODE2   OR
652900                     B-OTHER-DIAG-CODE3   OR
653000                     B-OTHER-DIAG-CODE4   OR
653100                     B-OTHER-DIAG-CODE5   OR
653200                     B-OTHER-DIAG-CODE6   OR
653300                     B-OTHER-DIAG-CODE7   OR
653400                     B-OTHER-DIAG-CODE8   OR
653500                     B-OTHER-DIAG-CODE9   OR
653600                     B-OTHER-DIAG-CODE10  OR
653700                     B-OTHER-DIAG-CODE11  OR
653800                     B-OTHER-DIAG-CODE12  OR
653900                     B-OTHER-DIAG-CODE13  OR
654000                     B-OTHER-DIAG-CODE14  OR
654100                     B-OTHER-DIAG-CODE15  OR
654200                     B-OTHER-DIAG-CODE16  OR
654300                     B-OTHER-DIAG-CODE17  OR
654400                     B-OTHER-DIAG-CODE18  OR
654500                     B-OTHER-DIAG-CODE19  OR
654600                     B-OTHER-DIAG-CODE20  OR
654700                     B-OTHER-DIAG-CODE21  OR
654800                     B-OTHER-DIAG-CODE22  OR
654900                     B-OTHER-DIAG-CODE23  OR
655000                     B-OTHER-DIAG-CODE24  OR
655100                     B-OTHER-DIAG-CODE25
655200           GO TO 4600-COMPUTE-DIFICID
655300     ELSE
655400           NEXT SENTENCE.
655500
655600           MOVE ZEROES TO H-NEW-TECH-ADDON-DIFICID.
655700           GO TO 4600-ADD-TECH-CASES.
655800
655900 4600-COMPUTE-DIFICID.
656000
656100     MOVE  868.00 TO H-CSTMED-DIFICID-STOP.
656200
656300     COMPUTE H-LESSER-DIFICID-STOP-1 ROUNDED =
656400                  H-CSTMED-DIFICID-STOP.
656500
656600     COMPUTE H-LESSER-DIFICID-STOP-2 ROUNDED =
656700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
656800                     H-BASE-DRG-PAYMENT)) * .5.
656900
657000     IF H-LESSER-DIFICID-STOP-2 > 0
657100        IF H-LESSER-DIFICID-STOP-1 < H-LESSER-DIFICID-STOP-2
657200         MOVE H-LESSER-DIFICID-STOP-1 TO
657300                                H-NEW-TECH-ADDON-DIFICID
657400        ELSE
657500         MOVE H-LESSER-DIFICID-STOP-2 TO
657600                                H-NEW-TECH-ADDON-DIFICID
657700     ELSE
657800        MOVE ZEROES          TO H-NEW-TECH-ADDON-DIFICID.
657900
658000
658100
658200 4600-ADD-TECH-CASES.
658300
658400     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
658500             H-NEW-TECH-PAY-ADD-ON +
658600             H-NEW-TECH-ADDON-DIFICID.
658700*
658800 4600-EXIT.    EXIT.
658900
659000 4700-ZENITH-TECH-ADD-ON.
659100***********************************************************
659200***** CASES INVOLVING ZENITH PROCESS DECOMPRESSION SYSTEM
659300***********************************************************
659400
659500     MOVE 0 TO H-NEW-TECH-ADDON-ZENITH
659600               H-LESSER-ZENITH-STOP-1
659700               H-LESSER-ZENITH-STOP-2
659800               H-CSTMED-ZENITH-STOP.
659900
660000
660100
660200     IF '3978   ' =  B-PRIN-PROC-CODE     OR
660300                     B-OTHER-PROC-CODE1   OR
660400                     B-OTHER-PROC-CODE2   OR
660500                     B-OTHER-PROC-CODE3   OR
660600                     B-OTHER-PROC-CODE4   OR
660700                     B-OTHER-PROC-CODE5   OR
660800                     B-OTHER-PROC-CODE6   OR
660900                     B-OTHER-PROC-CODE7   OR
661000                     B-OTHER-PROC-CODE8   OR
661100                     B-OTHER-PROC-CODE9   OR
661200                     B-OTHER-PROC-CODE10  OR
661300                     B-OTHER-PROC-CODE11  OR
661400                     B-OTHER-PROC-CODE12  OR
661500                     B-OTHER-PROC-CODE13  OR
661600                     B-OTHER-PROC-CODE14  OR
661700                     B-OTHER-PROC-CODE15  OR
661800                     B-OTHER-PROC-CODE16  OR
661900                     B-OTHER-PROC-CODE17  OR
662000                     B-OTHER-PROC-CODE18  OR
662100                     B-OTHER-PROC-CODE19  OR
662200                     B-OTHER-PROC-CODE20  OR
662300                     B-OTHER-PROC-CODE21  OR
662400                     B-OTHER-PROC-CODE22  OR
662500                     B-OTHER-PROC-CODE23  OR
662600                     B-OTHER-PROC-CODE24
662700           GO TO 4700-COMPUTE-ZENITH
662800     ELSE
662900           NEXT SENTENCE.
663000
663100           MOVE ZEROES TO H-NEW-TECH-ADDON-ZENITH.
663200           GO TO 4700-ADD-TECH-CASES.
663300
663400 4700-COMPUTE-ZENITH.
663500
663600     MOVE  8171.50 TO H-CSTMED-ZENITH-STOP.
663700
663800     COMPUTE H-LESSER-ZENITH-STOP-1 ROUNDED =
663900                  H-CSTMED-ZENITH-STOP.
664000
664100     COMPUTE H-LESSER-ZENITH-STOP-2 ROUNDED =
664200          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
664300                     H-BASE-DRG-PAYMENT)) * .5.
664400
664500     IF H-LESSER-ZENITH-STOP-2 > 0
664600        IF H-LESSER-ZENITH-STOP-1 < H-LESSER-ZENITH-STOP-2
664700         MOVE H-LESSER-ZENITH-STOP-1 TO
664800                                H-NEW-TECH-ADDON-ZENITH
664900        ELSE
665000         MOVE H-LESSER-ZENITH-STOP-2 TO
665100                                H-NEW-TECH-ADDON-ZENITH
665200     ELSE
665300        MOVE ZEROES          TO H-NEW-TECH-ADDON-ZENITH.
665400
665500
665600 4700-ADD-TECH-CASES.
665700
665800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
665900             H-NEW-TECH-PAY-ADD-ON +
666000             H-NEW-TECH-ADDON-ZENITH.
666100*
666200 4700-EXIT.    EXIT.
666300
666400***********************************************************
666500 4800-VORAXAZE-TECH-ADD-ON.
666600***********************************************************
666700***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
666800***********************************************************
666900
667000     MOVE 0 TO H-NEW-TECH-ADDON-VORAXAZE
667100               H-LESSER-VORAXAZE-STOP-1
667200               H-LESSER-VORAXAZE-STOP-2
667300               H-CSTMED-VORAXAZE-STOP.
667400
667500
667600
667700     IF '0095   ' =  B-PRIN-PROC-CODE     OR
667800                     B-OTHER-PROC-CODE1   OR
667900                     B-OTHER-PROC-CODE2   OR
668000                     B-OTHER-PROC-CODE3   OR
668100                     B-OTHER-PROC-CODE4   OR
668200                     B-OTHER-PROC-CODE5   OR
668300                     B-OTHER-PROC-CODE6   OR
668400                     B-OTHER-PROC-CODE7   OR
668500                     B-OTHER-PROC-CODE8   OR
668600                     B-OTHER-PROC-CODE9   OR
668700                     B-OTHER-PROC-CODE10  OR
668800                     B-OTHER-PROC-CODE11  OR
668900                     B-OTHER-PROC-CODE12  OR
669000                     B-OTHER-PROC-CODE13  OR
669100                     B-OTHER-PROC-CODE14  OR
669200                     B-OTHER-PROC-CODE15  OR
669300                     B-OTHER-PROC-CODE16  OR
669400                     B-OTHER-PROC-CODE17  OR
669500                     B-OTHER-PROC-CODE18  OR
669600                     B-OTHER-PROC-CODE19  OR
669700                     B-OTHER-PROC-CODE20  OR
669800                     B-OTHER-PROC-CODE21  OR
669900                     B-OTHER-PROC-CODE22  OR
670000                     B-OTHER-PROC-CODE23  OR
670100                     B-OTHER-PROC-CODE24
670200           GO TO 4800-COMPUTE-VORAXAZE
670300     ELSE
670400           NEXT SENTENCE.
670500
670600           MOVE ZEROES TO H-NEW-TECH-ADDON-VORAXAZE.
670700           GO TO 4800-ADD-TECH-CASES.
670800
670900 4800-COMPUTE-VORAXAZE.
671000
671100     MOVE  47250.00 TO H-CSTMED-VORAXAZE-STOP.
671200
671300     COMPUTE H-LESSER-VORAXAZE-STOP-1 ROUNDED =
671400                  H-CSTMED-VORAXAZE-STOP.
671500
671600     COMPUTE H-LESSER-VORAXAZE-STOP-2 ROUNDED =
671700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
671800                     H-BASE-DRG-PAYMENT)) * .5.
671900
672000     IF H-LESSER-VORAXAZE-STOP-2 > 0
672100        IF H-LESSER-VORAXAZE-STOP-1 < H-LESSER-VORAXAZE-STOP-2
672200         MOVE H-LESSER-VORAXAZE-STOP-1 TO
672300                                H-NEW-TECH-ADDON-VORAXAZE
672400        ELSE
672500         MOVE H-LESSER-VORAXAZE-STOP-2 TO
672600                                H-NEW-TECH-ADDON-VORAXAZE
672700     ELSE
672800        MOVE ZEROES          TO H-NEW-TECH-ADDON-VORAXAZE.
672900
673000
673100 4800-ADD-TECH-CASES.
673200
673300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
673400             H-NEW-TECH-PAY-ADD-ON +
673500             H-NEW-TECH-ADDON-VORAXAZE.
673600*
673700 4800-EXIT.    EXIT.
673800
673900***********************************************************
674000 4810-ARGUS-TECH-ADD-ON.
674100***********************************************************
674200***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
674300***********************************************************
674400
674500     MOVE 0 TO H-NEW-TECH-ADDON-ARGUS
674600               H-LESSER-ARGUS-STOP-1
674700               H-LESSER-ARGUS-STOP-2
674800               H-CSTMED-ARGUS-STOP.
674900
675000
675100
675200     IF '1481   ' =  B-PRIN-PROC-CODE     OR
675300                     B-OTHER-PROC-CODE1   OR
675400                     B-OTHER-PROC-CODE2   OR
675500                     B-OTHER-PROC-CODE3   OR
675600                     B-OTHER-PROC-CODE4   OR
675700                     B-OTHER-PROC-CODE5   OR
675800                     B-OTHER-PROC-CODE6   OR
675900                     B-OTHER-PROC-CODE7   OR
676000                     B-OTHER-PROC-CODE8   OR
676100                     B-OTHER-PROC-CODE9   OR
676200                     B-OTHER-PROC-CODE10  OR
676300                     B-OTHER-PROC-CODE11  OR
676400                     B-OTHER-PROC-CODE12  OR
676500                     B-OTHER-PROC-CODE13  OR
676600                     B-OTHER-PROC-CODE14  OR
676700                     B-OTHER-PROC-CODE15  OR
676800                     B-OTHER-PROC-CODE16  OR
676900                     B-OTHER-PROC-CODE17  OR
677000                     B-OTHER-PROC-CODE18  OR
677100                     B-OTHER-PROC-CODE19  OR
677200                     B-OTHER-PROC-CODE20  OR
677300                     B-OTHER-PROC-CODE21  OR
677400                     B-OTHER-PROC-CODE22  OR
677500                     B-OTHER-PROC-CODE23  OR
677600                     B-OTHER-PROC-CODE24
677700           GO TO 4810-COMPUTE-ARGUS
677800     ELSE
677900           NEXT SENTENCE.
678000
678100           MOVE ZEROES TO H-NEW-TECH-ADDON-ARGUS.
678200           GO TO 4810-ADD-TECH-CASES.
678300
678400 4810-COMPUTE-ARGUS.
678500
678600     MOVE  72028.75 TO H-CSTMED-ARGUS-STOP.
678700
678800     COMPUTE H-LESSER-ARGUS-STOP-1 ROUNDED =
678900                  H-CSTMED-ARGUS-STOP.
679000
679100     COMPUTE H-LESSER-ARGUS-STOP-2 ROUNDED =
679200          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
679300                     H-BASE-DRG-PAYMENT)) * .5.
679400
679500     IF H-LESSER-ARGUS-STOP-2 > 0
679600        IF H-LESSER-ARGUS-STOP-1 < H-LESSER-ARGUS-STOP-2
679700         MOVE H-LESSER-ARGUS-STOP-1 TO
679800                                H-NEW-TECH-ADDON-ARGUS
679900        ELSE
680000         MOVE H-LESSER-ARGUS-STOP-2 TO
680100                                H-NEW-TECH-ADDON-ARGUS
680200     ELSE
680300        MOVE ZEROES          TO H-NEW-TECH-ADDON-ARGUS.
680400
680500
680600 4810-ADD-TECH-CASES.
680700
680800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
680900             H-NEW-TECH-PAY-ADD-ON +
681000             H-NEW-TECH-ADDON-ARGUS.
681100*
681200 4810-EXIT.    EXIT.
681300
681400
681500***********************************************************
681600 4820-KCENTRA-TECH-ADD-ON.
681700***********************************************************
681800***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
681900***********************************************************
682000
682100     MOVE 0 TO H-NEW-TECH-ADDON-KCENTRA
682200               H-LESSER-KCENTRA-STOP-1
682300               H-LESSER-KCENTRA-STOP-2
682400               H-CSTMED-KCENTRA-STOP.
682500
682600
682700
682800     IF '0096   ' =  B-PRIN-PROC-CODE     OR
682900                     B-OTHER-PROC-CODE1   OR
683000                     B-OTHER-PROC-CODE2   OR
683100                     B-OTHER-PROC-CODE3   OR
683200                     B-OTHER-PROC-CODE4   OR
683300                     B-OTHER-PROC-CODE5   OR
683400                     B-OTHER-PROC-CODE6   OR
683500                     B-OTHER-PROC-CODE7   OR
683600                     B-OTHER-PROC-CODE8   OR
683700                     B-OTHER-PROC-CODE9   OR
683800                     B-OTHER-PROC-CODE10  OR
683900                     B-OTHER-PROC-CODE11  OR
684000                     B-OTHER-PROC-CODE12  OR
684100                     B-OTHER-PROC-CODE13  OR
684200                     B-OTHER-PROC-CODE14  OR
684300                     B-OTHER-PROC-CODE15  OR
684400                     B-OTHER-PROC-CODE16  OR
684500                     B-OTHER-PROC-CODE17  OR
684600                     B-OTHER-PROC-CODE18  OR
684700                     B-OTHER-PROC-CODE19  OR
684800                     B-OTHER-PROC-CODE20  OR
684900                     B-OTHER-PROC-CODE21  OR
685000                     B-OTHER-PROC-CODE22  OR
685100                     B-OTHER-PROC-CODE23  OR
685200                     B-OTHER-PROC-CODE24
685300           GO TO 4820-COMPUTE-KCENTRA
685400     ELSE
685500           NEXT SENTENCE.
685600
685700           MOVE ZEROES TO H-NEW-TECH-ADDON-KCENTRA.
685800           GO TO 4820-ADD-TECH-CASES.
685900
686000 4820-COMPUTE-KCENTRA.
686100
686200     MOVE  01587.50 TO H-CSTMED-KCENTRA-STOP.
686300
686400     COMPUTE H-LESSER-KCENTRA-STOP-1 ROUNDED =
686500                  H-CSTMED-KCENTRA-STOP.
686600
686700     COMPUTE H-LESSER-KCENTRA-STOP-2 ROUNDED =
686800          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
686900                     H-BASE-DRG-PAYMENT)) * .5.
687000
687100     IF H-LESSER-KCENTRA-STOP-2 > 0
687200        IF H-LESSER-KCENTRA-STOP-1 < H-LESSER-KCENTRA-STOP-2
687300         MOVE H-LESSER-KCENTRA-STOP-1 TO
687400                                H-NEW-TECH-ADDON-KCENTRA
687500        ELSE
687600         MOVE H-LESSER-KCENTRA-STOP-2 TO
687700                                H-NEW-TECH-ADDON-KCENTRA
687800     ELSE
687900        MOVE ZEROES          TO H-NEW-TECH-ADDON-KCENTRA.
688000
688100
688200 4820-ADD-TECH-CASES.
688300
688400     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
688500             H-NEW-TECH-PAY-ADD-ON +
688600             H-NEW-TECH-ADDON-KCENTRA.
688700*
688800 4820-EXIT.    EXIT.
688900
689000
689100***********************************************************
689200 4830-ZILVER-TECH-ADD-ON.
689300***********************************************************
689400***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
689500***********************************************************
689600
689700     MOVE 0 TO H-NEW-TECH-ADDON-ZILVER
689800               H-LESSER-ZILVER-STOP-1
689900               H-LESSER-ZILVER-STOP-2
690000               H-CSTMED-ZILVER-STOP.
690100
690200
690300
690400     IF '0060   ' =  B-PRIN-PROC-CODE     OR
690500                     B-OTHER-PROC-CODE1   OR
690600                     B-OTHER-PROC-CODE2   OR
690700                     B-OTHER-PROC-CODE3   OR
690800                     B-OTHER-PROC-CODE4   OR
690900                     B-OTHER-PROC-CODE5   OR
691000                     B-OTHER-PROC-CODE6   OR
691100                     B-OTHER-PROC-CODE7   OR
691200                     B-OTHER-PROC-CODE8   OR
691300                     B-OTHER-PROC-CODE9   OR
691400                     B-OTHER-PROC-CODE10  OR
691500                     B-OTHER-PROC-CODE11  OR
691600                     B-OTHER-PROC-CODE12  OR
691700                     B-OTHER-PROC-CODE13  OR
691800                     B-OTHER-PROC-CODE14  OR
691900                     B-OTHER-PROC-CODE15  OR
692000                     B-OTHER-PROC-CODE16  OR
692100                     B-OTHER-PROC-CODE17  OR
692200                     B-OTHER-PROC-CODE18  OR
692300                     B-OTHER-PROC-CODE19  OR
692400                     B-OTHER-PROC-CODE20  OR
692500                     B-OTHER-PROC-CODE21  OR
692600                     B-OTHER-PROC-CODE22  OR
692700                     B-OTHER-PROC-CODE23  OR
692800                     B-OTHER-PROC-CODE24
692900           GO TO 4830-COMPUTE-ZILVER
693000     ELSE
693100           NEXT SENTENCE.
693200
693300           MOVE ZEROES TO H-NEW-TECH-ADDON-ZILVER.
693400           GO TO 4830-ADD-TECH-CASES.
693500
693600 4830-COMPUTE-ZILVER.
693700
693800     MOVE  01705.25 TO H-CSTMED-ZILVER-STOP.
693900
694000     COMPUTE H-LESSER-ZILVER-STOP-1 ROUNDED =
694100                  H-CSTMED-ZILVER-STOP.
694200
694300     COMPUTE H-LESSER-ZILVER-STOP-2 ROUNDED =
694400          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
694500                     H-BASE-DRG-PAYMENT)) * .5.
694600
694700     IF H-LESSER-ZILVER-STOP-2 > 0
694800        IF H-LESSER-ZILVER-STOP-1 < H-LESSER-ZILVER-STOP-2
694900         MOVE H-LESSER-ZILVER-STOP-1 TO
695000                                H-NEW-TECH-ADDON-ZILVER
695100        ELSE
695200         MOVE H-LESSER-ZILVER-STOP-2 TO
695300                                H-NEW-TECH-ADDON-ZILVER
695400     ELSE
695500        MOVE ZEROES          TO H-NEW-TECH-ADDON-ZILVER.
695600
695700
695800 4830-ADD-TECH-CASES.
695900
696000     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
696100             H-NEW-TECH-PAY-ADD-ON +
696200             H-NEW-TECH-ADDON-ZILVER.
696300*
696400 4830-EXIT.    EXIT.
696500
696600
696700***********************************************************
696800 5000-CAP-CALC-TECH-ADD-ON.
696900***********************************************************
697000***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
697100***********************************************************
697200
697300     MOVE 0 TO H-NEW-TECH-ADDON-CAP.
697400     MOVE 0 TO H-NEW-TECH-ADDON-CAPDIF.
697500
697600     COMPUTE H-OPER-BILL-COSTS ROUNDED =
697700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
697800         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
697900
698000     COMPUTE H-NEW-TECH-ADDON-CAP ROUNDED =
698100                 (H-BASE-DRG-PAYMENT + H-NEW-TECH-PAY-ADD-ON).
698200
698300     COMPUTE H-NEW-TECH-ADDON-CAPDIF ROUNDED =
698400                 (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
698500
698600     IF (H-NEW-TECH-ADDON-CAP > H-OPER-BILL-COSTS) AND
698700         H-NEW-TECH-ADDON-CAPDIF  > 0
698800        COMPUTE H-NEW-TECH-PAY-ADD-ON  ROUNDED =
698900             (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
699000
699100*
699200 5000-EXIT.    EXIT.
699300
699400***********************************************************
699500 5010-CARDIO-MEMES-ADD-ON.
699600***********************************************************
699700***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
699800***********************************************************
699900
700000     MOVE 0 TO H-NEW-TECH-ADDON-CARDIO
700100               H-LESSER-CARDIO-STOP-1
700200               H-LESSER-CARDIO-STOP-2
700300               H-CSTMED-CARDIO-STOP.
700400
700500
700600
700700     IF '3826   ' =  B-PRIN-PROC-CODE     OR
700800                     B-OTHER-PROC-CODE1   OR
700900                     B-OTHER-PROC-CODE2   OR
701000                     B-OTHER-PROC-CODE3   OR
701100                     B-OTHER-PROC-CODE4   OR
701200                     B-OTHER-PROC-CODE5   OR
701300                     B-OTHER-PROC-CODE6   OR
701400                     B-OTHER-PROC-CODE7   OR
701500                     B-OTHER-PROC-CODE8   OR
701600                     B-OTHER-PROC-CODE9   OR
701700                     B-OTHER-PROC-CODE10  OR
701800                     B-OTHER-PROC-CODE11  OR
701900                     B-OTHER-PROC-CODE12  OR
702000                     B-OTHER-PROC-CODE13  OR
702100                     B-OTHER-PROC-CODE14  OR
702200                     B-OTHER-PROC-CODE15  OR
702300                     B-OTHER-PROC-CODE16  OR
702400                     B-OTHER-PROC-CODE17  OR
702500                     B-OTHER-PROC-CODE18  OR
702600                     B-OTHER-PROC-CODE19  OR
702700                     B-OTHER-PROC-CODE20  OR
702800                     B-OTHER-PROC-CODE21  OR
702900                     B-OTHER-PROC-CODE22  OR
703000                     B-OTHER-PROC-CODE23  OR
703100                     B-OTHER-PROC-CODE24
703200           GO TO 5010-COMPUTE-CARDIO
703300     ELSE
703400           NEXT SENTENCE.
703500
703600           MOVE ZEROES TO H-NEW-TECH-ADDON-CARDIO.
703700           GO TO 5010-ADD-TECH-CASES.
703800
703900 5010-COMPUTE-CARDIO.
704000
704100     MOVE  08875.00 TO H-CSTMED-CARDIO-STOP.
704200
704300     COMPUTE H-LESSER-CARDIO-STOP-1 ROUNDED =
704400                  H-CSTMED-CARDIO-STOP.
704500
704600     COMPUTE H-LESSER-CARDIO-STOP-2 ROUNDED =
704700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
704800                     H-BASE-DRG-PAYMENT)) * .5.
704900
705000     IF H-LESSER-CARDIO-STOP-2 > 0
705100        IF H-LESSER-CARDIO-STOP-1 < H-LESSER-CARDIO-STOP-2
705200         MOVE H-LESSER-CARDIO-STOP-1 TO
705300                                H-NEW-TECH-ADDON-CARDIO
705400        ELSE
705500         MOVE H-LESSER-CARDIO-STOP-2 TO
705600                                H-NEW-TECH-ADDON-CARDIO
705700     ELSE
705800        MOVE ZEROES          TO H-NEW-TECH-ADDON-CARDIO.
705900
706000
706100 5010-ADD-TECH-CASES.
706200
706300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
706400             H-NEW-TECH-PAY-ADD-ON +
706500             H-NEW-TECH-ADDON-CARDIO.
706600*
706700*
706800 5010-EXIT.    EXIT.
706900***********************************************************
707000***********************************************************
707100 5020-MITRA-CLIP-ADD-ON.
707200***********************************************************
707300***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
707400***********************************************************
707500
707600     MOVE 0 TO H-NEW-TECH-ADDON-MITRACLP
707700               H-LESSER-MITRACLP-STOP-1
707800               H-LESSER-MITRACLP-STOP-2
707900               H-CSTMED-MITRACLP-STOP.
708000
708100
708200
708300     IF '3597   ' =  B-PRIN-PROC-CODE     OR
708400                     B-OTHER-PROC-CODE1   OR
708500                     B-OTHER-PROC-CODE2   OR
708600                     B-OTHER-PROC-CODE3   OR
708700                     B-OTHER-PROC-CODE4   OR
708800                     B-OTHER-PROC-CODE5   OR
708900                     B-OTHER-PROC-CODE6   OR
709000                     B-OTHER-PROC-CODE7   OR
709100                     B-OTHER-PROC-CODE8   OR
709200                     B-OTHER-PROC-CODE9   OR
709300                     B-OTHER-PROC-CODE10  OR
709400                     B-OTHER-PROC-CODE11  OR
709500                     B-OTHER-PROC-CODE12  OR
709600                     B-OTHER-PROC-CODE13  OR
709700                     B-OTHER-PROC-CODE14  OR
709800                     B-OTHER-PROC-CODE15  OR
709900                     B-OTHER-PROC-CODE16  OR
710000                     B-OTHER-PROC-CODE17  OR
710100                     B-OTHER-PROC-CODE18  OR
710200                     B-OTHER-PROC-CODE19  OR
710300                     B-OTHER-PROC-CODE20  OR
710400                     B-OTHER-PROC-CODE21  OR
710500                     B-OTHER-PROC-CODE22  OR
710600                     B-OTHER-PROC-CODE23  OR
710700                     B-OTHER-PROC-CODE24
710800           GO TO 5020-COMPUTE-MITRACLP
710900     ELSE
711000           NEXT SENTENCE.
711100
711200           MOVE ZEROES TO H-NEW-TECH-ADDON-MITRACLP.
711300           GO TO 5020-ADD-TECH-CASES.
711400
711500 5020-COMPUTE-MITRACLP.
711600
711700     MOVE  15000.00 TO H-CSTMED-MITRACLP-STOP.
711800
711900     COMPUTE H-LESSER-MITRACLP-STOP-1 ROUNDED =
712000                  H-CSTMED-MITRACLP-STOP.
712100
712200     COMPUTE H-LESSER-MITRACLP-STOP-2 ROUNDED =
712300          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
712400                     H-BASE-DRG-PAYMENT)) * .5.
712500
712600     IF H-LESSER-MITRACLP-STOP-2 > 0
712700        IF H-LESSER-MITRACLP-STOP-1 < H-LESSER-MITRACLP-STOP-2
712800         MOVE H-LESSER-MITRACLP-STOP-1 TO
712900                                H-NEW-TECH-ADDON-MITRACLP
713000        ELSE
713100         MOVE H-LESSER-MITRACLP-STOP-2 TO
713200                                H-NEW-TECH-ADDON-MITRACLP
713300     ELSE
713400        MOVE ZEROES          TO H-NEW-TECH-ADDON-MITRACLP.
713500
713600
713700 5020-ADD-TECH-CASES.
713800
713900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
714000             H-NEW-TECH-PAY-ADD-ON +
714100             H-NEW-TECH-ADDON-MITRACLP.
714200*
714300*
714400 5020-EXIT.    EXIT.
714500
714600***********************************************************
714700***********************************************************
714800 5030-RNS-SYS-ADD-ON.
714900***********************************************************
715000***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
715100***********************************************************
715200
715300     MOVE 0 TO H-NEW-TECH-ADDON-RNSSYS
715400               H-LESSER-RNSSYS-STOP-1
715500               H-LESSER-RNSSYS-STOP-2
715600               H-CSTMED-RNSSYS-STOP.
715700
715800
715900     IF '0120   ' =  B-PRIN-PROC-CODE     OR
716000                     B-OTHER-PROC-CODE1   OR
716100                     B-OTHER-PROC-CODE2   OR
716200                     B-OTHER-PROC-CODE3   OR
716300                     B-OTHER-PROC-CODE4   OR
716400                     B-OTHER-PROC-CODE5   OR
716500                     B-OTHER-PROC-CODE6   OR
716600                     B-OTHER-PROC-CODE7   OR
716700                     B-OTHER-PROC-CODE8   OR
716800                     B-OTHER-PROC-CODE9   OR
716900                     B-OTHER-PROC-CODE10  OR
717000                     B-OTHER-PROC-CODE11  OR
717100                     B-OTHER-PROC-CODE12  OR
717200                     B-OTHER-PROC-CODE13  OR
717300                     B-OTHER-PROC-CODE14  OR
717400                     B-OTHER-PROC-CODE15  OR
717500                     B-OTHER-PROC-CODE16  OR
717600                     B-OTHER-PROC-CODE17  OR
717700                     B-OTHER-PROC-CODE18  OR
717800                     B-OTHER-PROC-CODE19  OR
717900                     B-OTHER-PROC-CODE20  OR
718000                     B-OTHER-PROC-CODE21  OR
718100                     B-OTHER-PROC-CODE22  OR
718200                     B-OTHER-PROC-CODE23  OR
718300                     B-OTHER-PROC-CODE24
718400           NEXT SENTENCE
718500     ELSE
718600           MOVE ZEROES TO H-NEW-TECH-ADDON-RNSSYS
718700           GO TO 5030-ADD-TECH-CASES.
718800
718900
719000     IF '0293   ' =  B-PRIN-PROC-CODE     OR
719100                     B-OTHER-PROC-CODE1   OR
719200                     B-OTHER-PROC-CODE2   OR
719300                     B-OTHER-PROC-CODE3   OR
719400                     B-OTHER-PROC-CODE4   OR
719500                     B-OTHER-PROC-CODE5   OR
719600                     B-OTHER-PROC-CODE6   OR
719700                     B-OTHER-PROC-CODE7   OR
719800                     B-OTHER-PROC-CODE8   OR
719900                     B-OTHER-PROC-CODE9   OR
720000                     B-OTHER-PROC-CODE10  OR
720100                     B-OTHER-PROC-CODE11  OR
720200                     B-OTHER-PROC-CODE12  OR
720300                     B-OTHER-PROC-CODE13  OR
720400                     B-OTHER-PROC-CODE14  OR
720500                     B-OTHER-PROC-CODE15  OR
720600                     B-OTHER-PROC-CODE16  OR
720700                     B-OTHER-PROC-CODE17  OR
720800                     B-OTHER-PROC-CODE18  OR
720900                     B-OTHER-PROC-CODE19  OR
721000                     B-OTHER-PROC-CODE20  OR
721100                     B-OTHER-PROC-CODE21  OR
721200                     B-OTHER-PROC-CODE22  OR
721300                     B-OTHER-PROC-CODE23  OR
721400                     B-OTHER-PROC-CODE24
721500           GO TO 5030-COMPUTE-RNSSYS
721600     ELSE
721700           NEXT SENTENCE.
721800
721900           MOVE ZEROES TO H-NEW-TECH-ADDON-RNSSYS.
722000           GO TO 5030-ADD-TECH-CASES.
722100
722200 5030-COMPUTE-RNSSYS.
722300
722400     MOVE  18475.00 TO H-CSTMED-RNSSYS-STOP.
722500
722600     COMPUTE H-LESSER-RNSSYS-STOP-1 ROUNDED =
722700                  H-CSTMED-RNSSYS-STOP.
722800
722900     COMPUTE H-LESSER-RNSSYS-STOP-2 ROUNDED =
723000          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
723100                     H-BASE-DRG-PAYMENT)) * .5.
723200
723300     IF H-LESSER-RNSSYS-STOP-2 > 0
723400        IF H-LESSER-RNSSYS-STOP-1 < H-LESSER-RNSSYS-STOP-2
723500         MOVE H-LESSER-RNSSYS-STOP-1 TO
723600                                H-NEW-TECH-ADDON-RNSSYS
723700        ELSE
723800         MOVE H-LESSER-RNSSYS-STOP-2 TO
723900                                H-NEW-TECH-ADDON-RNSSYS
724000     ELSE
724100        MOVE ZEROES          TO H-NEW-TECH-ADDON-RNSSYS.
724200
724300
724400 5030-ADD-TECH-CASES.
724500
724600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
724700             H-NEW-TECH-PAY-ADD-ON +
724800             H-NEW-TECH-ADDON-RNSSYS.
724900*
725000*
725100 5030-EXIT.    EXIT.
725200
725300***********************************************************
725400 6000-CALC-READMIS-REDU.
725500***********************************************************
725600***** CASES INVOLVING READMISN PROCESS ADJUSTMENTS
725700**    FOR FY 2014 THE LOWEST FACTOR CAN BE 0.98 **********
725800***********************************************************
725900
726000     MOVE 0 TO H-READMIS-ADJUST-AMT.
726100
726200     IF P-HOSP-READMISSION-REDU = '1'
726300           GO TO 6000-EDIT-READMISN
726400     ELSE
726500           NEXT SENTENCE.
726600
726700     IF P-HOSP-READMISSION-REDU = '0' AND
726800        P-HOSP-HRR-ADJUSTMT = 0.0000
726900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
727000           GO TO 6000-EXIT.
727100
727200     IF P-HOSP-READMISSION-REDU = '0' AND
727300        P-HOSP-HRR-ADJUSTMT > 0.0000
727400           MOVE 65 TO PPS-RTC
727500           MOVE ZEROES TO H-READMIS-ADJUST-AMT
727600           GO TO 6000-EXIT.
727700
727800
727900     IF P-HOSP-READMISSION-REDU = '2' OR '3' OR '4' OR '5' OR
728000                                  '6' OR '7' OR '8' OR
728100                                  '9' OR ' '
728200           MOVE 65 TO PPS-RTC
728300           MOVE ZEROES TO H-READMIS-ADJUST-AMT
728400           GO TO 6000-EXIT.
728500
728600 6000-EDIT-READMISN.
728700
728800     IF P-HOSP-HRR-ADJUSTMT < 0.9700
728900           MOVE 65 TO PPS-RTC
729000           MOVE ZEROES TO H-READMIS-ADJUST-AMT
729100           GO TO 6000-EXIT.
729200
729300
729400     IF P-HOSP-HRR-ADJUSTMT > 1.0000
729500           MOVE 65 TO PPS-RTC
729600           MOVE ZEROES TO H-READMIS-ADJUST-AMT
729700           GO TO 6000-EXIT.
729800
729900     IF P-READ-INVALID-STATE
730000           MOVE 65 TO PPS-RTC
730100           MOVE ZEROES TO H-READMIS-ADJUST-AMT
730200           GO TO 6000-EXIT.
730300
730400
730500 6000-COMPUTE-READMISN.
730600
730700
730800        COMPUTE H-READMIS-ADJUST-AMT         ROUNDED =
730900              ((P-HOSP-HRR-ADJUSTMT * H-OPER-BASE-DRG-PAY) -
731000                H-OPER-BASE-DRG-PAY).
731100
731200
731300 6000-EXIT.    EXIT.
731400
731500***********************************************************
731600 7000-CALC-VALUE-BASED-PURCH.
731700***********************************************************
731800***** CASES INVOLVING VALUE BASE PURCH ADJUSTMENTS
731900**    FOR FY 2014 THE LOWEST FACTOR CAN BE 0.9875  *******
732000***********************************************************
732100
732200     MOVE 0 TO H-VAL-BASED-PURCH-ADJUST-AMT.
732300
732400     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N' OR 'Y'
732500           NEXT SENTENCE
732600     ELSE
732700           MOVE 68 TO PPS-RTC
732800           GO TO 7000-EXIT.
732900
733000     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N'
733100           GO TO 7000-EXIT.
733200
733300     IF  P-VAL-BASED-PURCH-PARTIPNT = 'Y' AND
733400         P-NEW-CBSA-HOSP-QUAL-IND = '1'
733500           NEXT SENTENCE
733600     ELSE
733700           MOVE 68 TO PPS-RTC
733800           GO TO 7000-EXIT.
733900
734000     IF  P-VBP-INVALID-STATE
734100           MOVE 68 TO PPS-RTC
734200           GO TO 7000-EXIT
734300     ELSE
734400           NEXT SENTENCE.
734500
734600     IF P-VAL-BASED-PURCH-ADJUST < 0.9850000000 OR
734700        P-VAL-BASED-PURCH-ADJUST > 2.0000000000
734800           MOVE 68 TO PPS-RTC
734900           MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT
735000           GO TO 7000-EXIT
735100     ELSE
735200           GO TO 7000-COMPUTE-VAL-BASED-PUR.
735300
735400 7000-COMPUTE-VAL-BASED-PUR.
735500
735600     COMPUTE H-VAL-BASED-PURCH-ADJUST-AMT  ROUNDED =
735700              ((P-VAL-BASED-PURCH-ADJUST *
735800                  H-OPER-BASE-DRG-PAY) -
735900                  H-OPER-BASE-DRG-PAY).
736000*
736100 7000-EXIT.    EXIT.
736200
736300***********************************************************
736400 8000-CALC-BUNDLE-REDU.
736500***********************************************************
736600***** CASES INVOLVING BUNDLE PROCESS ADJUSTMENTS
736700***********************************************************
736800
736900
737000     MOVE 0 TO H-BUNDLE-ADJUST-AMT.
737100     MOVE 0 TO WK-MODEL1-BUNDLE-DISPRCNT.
737200
737300     IF '61' =  B-DEMO-CODE1  OR
737400                B-DEMO-CODE2  OR
737500                B-DEMO-CODE3  OR
737600                B-DEMO-CODE4
737700         NEXT SENTENCE
737800     ELSE
737900         MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
738000           GO TO 8000-EXIT.
738100
738200     IF P-MODEL1-BUNDLE-DISPRCNT > .00
738300           GO TO 8000-COMPUTE-BUNDLE
738400     ELSE
738500           NEXT SENTENCE.
738600
738700     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
738800           GO TO 8000-EXIT.
738900
739000 8000-COMPUTE-BUNDLE.
739100
739200     IF  B-DISCHARGE-DATE < 20140401 AND
739300         P-MODEL1-BUNDLE-DISPRCNT = .01
739400         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
739500          (1 - (P-MODEL1-BUNDLE-DISPRCNT * .5))
739600     ELSE
739700         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
739800          (1 - (P-MODEL1-BUNDLE-DISPRCNT * 1)).
739900
740000        COMPUTE H-BUNDLE-ADJUST-AMT      ROUNDED =
740100              ((WK-MODEL1-BUNDLE-DISPRCNT *
740200                                     H-OPER-BASE-DRG-PAY) -
740300                H-OPER-BASE-DRG-PAY).
740400
740500        COMPUTE H-BUNDLE-ADJUST-AMT ROUNDED = H-BUNDLE-ADJUST-AMT.
740600
740700 8000-EXIT.    EXIT.
740800
740900***********************************************************
741000 9000-CALC-EHR-SAVING.
741100***********************************************************
741200***** CASES INVOLVING EHR SVINGS
741300***********************************************************
741400
741500***********************************************************
741600****YEARCHANGE 2015.0**************************************
741700****
741800     MOVE 1.007144617 TO H-MB-RATIO-EHR-FULL.
741900     MOVE 1.007196030 TO H-MB-RATIO-EHR-QUAL-FULL.
742000     MOVE 0 TO H-EHR-SUBSAV-QUANT.
742100     MOVE 0 TO H-EHR-SUBSAV-LV.
742200     MOVE 0 TO H-EHR-SUBSAV-QUANT-INCLV.
742300     MOVE 0 TO H-EHR-RESTORE-FULL-QUANT.
742400
742500     IF P-EHR-REDUC-IND = 'Y'
742600         NEXT SENTENCE
742700     ELSE
742800         GO TO 9000-EXIT.
742900
743000 9000-COMPUTE-EHR.
743100
743200*
743300* LOGIC TO IMPLEMENT EHR SAVINGS CALCULATION -
743400* ACTUAL EHR REDUCTIONS WILL BE BUILT INTO NEW RATE
743500* TABLES (5,6,7,&8) UP FRONT BUT OESS WANTS TO HAVE THE
743600* AMOUNT OF MONEY THE EHR POLICY 'SAVED' IN ITS OWN FIELD
743700* WHICH INVOLVES RESTORING THE FULL MARKET  BASKET
743800* TO THE PAYMENT TO GET THE 'WOULD'VE PAID' AND THEN
743900* TAKING THE DIFFERENCE BETWEEN ACTUAL PAID AND
744000* WOULD'VE PAID FOR THE SAVINGS.  OUTLIERS ARE TO BE
744100* LEFT OUT AT MOMENT SINCE OUTLIER SHOULD BE LOWER
744200* ON THE FULL RATE THAN IT WINDS UP BEING ON THE
744300* REDUCED RATE - LIKEWISE NEW TECH IS BEING LEFT
744400* OUT.
744500*
744600*
744700* FOR EHR NEED TO EXCLUDE NEW TECH AND OUTLIERS FROM
744800* SAVINGS CALCULATION SO CALCULATE AN OPERATING
744900* PAYMENT SUBTOTAL ON SO CALCULATE AN OPERATING
745000* PAYMENT SUBTOTAL ON EHR PAYMENTS THAT EXCLUDES
745100* OUTLIERS AND NEW TECH FOR CLAIMS WITH AN EHR FLAG
745200*
745300*
745400
745500      COMPUTE H-EHR-SUBSAV-QUANT =
745600           (PPS-OPER-HSP-PART +
745700            PPS-OPER-FSP-PART +
745800            PPS-OPER-DSH-ADJ +
745900            PPS-OPER-IME-ADJ +
746000            H-READMIS-ADJUST-AMT +
746100            H-VAL-BASED-PURCH-ADJUST-AMT +
746200            H-BUNDLE-ADJUST-AMT).
746300
746400*
746500*
746600* NEED TO ENSURE THAT LOW VOLUME, IF APPLICABLE IS
746700* INCLUDED - CAN'T USE PRICER'S LOW VOLUME PAYMENT
746800* AS THAT INCLUDES NEW TECH OUTLIERS AND CAPITAL -
746900* READM VBP AND BUNDLE
747000* DON'T MULTIPLY BY LV ADJUSTMENT SO MAKE A NEW LV AMT
747100* FOR ERH SAVINGS FIELD;
747200*
747300*
747400*
747500
747600      MOVE 0 TO H-EHR-SUBSAV-LV.
747700
747800      IF  WK-LOW-VOL25PCT < 1.000000
747900
748000      COMPUTE H-EHR-SUBSAV-LV =
748100          (PPS-OPER-HSP-PART +
748200           PPS-OPER-FSP-PART +
748300           PPS-OPER-DSH-ADJ +
748400           PPS-OPER-IME-ADJ )  * WK-LOW-VOL25PCT.
748500
748600      COMPUTE H-EHR-SUBSAV-QUANT-INCLV =
748700           H-EHR-SUBSAV-QUANT + H-EHR-SUBSAV-LV.
748800
748900*
749000* H-MB-RATIO-EHR-FULL IS THE RATIO OF THE FULL MARKET
749100* BASKET TO THE REDUCED EHR MB - NEED TO CARRY 2 RATIOS
749200* FOR PROVIDERS FAILING EHR AND FOR PROVIDERS FAILING EHR
749300* AND QUALITY IN COMBINATION.  EHR SAVINGS REQUIRES
749400* BACKING OFF THE LOW UPDATE AND MULTIPLYING ON THE
749500* FULL UPDATE SO USING RATIO OF LOW/FULL AND LOW/QUALHIT
749600* OF .625 ONLY.
749700*
749800
749900       COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
750000       H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-FULL.
750100
750200     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1'
750300        COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
750400          H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-QUAL-FULL.
750500
750600        COMPUTE  H-EHR-ADJUST-AMT ROUNDED =
750700          H-EHR-RESTORE-FULL-QUANT - H-EHR-SUBSAV-QUANT-INCLV.
750800
750900
751000
751100 9000-EXIT.    EXIT.
751200
751300
751400 9010-CALC-STANDARD-CHG.
751500
751600***********************************************************
751700***CM-P3 STANDARDIZED OPERATING COST CALCULATION
751800
751900     IF ((H-LABOR-PCT * H-WAGE-INDEX) +
752000               (H-NONLABOR-PCT * H-OPER-COLA)) > 0
752100        COMPUTE  H-OPER-BILL-STDZ-COSTS ROUNDED =
752200        (B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO) /
752300        ((H-LABOR-PCT * H-WAGE-INDEX) +
752400               (H-NONLABOR-PCT * H-OPER-COLA))
752500     ELSE MOVE 0 TO H-OPER-BILL-STDZ-COSTS.
752600
752700***********************************************************
752800***CM-P3 STANDARDIZED CAPITAL COST CALCULATION
752900
753000     IF (H-CAPI-GAF * H-CAPI-COLA) > 0
753100       COMPUTE  H-CAPI-BILL-STDZ-COSTS ROUNDED =
753200        (B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO) /
753300               (H-CAPI-GAF * H-CAPI-COLA)
753400     ELSE MOVE 0 TO H-CAPI-BILL-STDZ-COSTS.
753500
753600***********************************************************
753700***CM-P3 STANDARDIZED OPERATING TRESHOLD
753800
753900     MOVE 5431.22 TO H-OPER-BASE.
754000
754100     COMPUTE   H-OPER-STDZ-DOLLAR-THRESHOLD ROUNDED =
754200      (H-CST-THRESH * H-OPER-SHARE-DOLL-THRESHOLD)  +
754300                        +
754400           (H-OPER-BASE * H-DRG-WT-FRCTN)
754500                        +
754600              H-NEW-TECH-PAY-ADD-ON.
754700
754800******************************************************
754900***CM-P3 STANDARDIZED CAPITAL TRESHOLD
755000
755100     MOVE 434.26 TO H-CAPI-BASE.
755200
755300     COMPUTE   H-CAPI-STDZ-DOLLAR-THRESHOLD ROUNDED =
755400     (H-CST-THRESH * H-CAPI-SHARE-DOLL-THRESHOLD)
755500                     +
755600     (H-CAPI-BASE * H-DRG-WT-FRCTN).
755700
755800
755900******************************************************
756000***CM-P3 STANDARDIZED OPERATING OUTLIER CALCULATION
756100
756200     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
756300        (H-OPER-STDZ-DOLLAR-THRESHOLD +
756400                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
756500                          AND
756600         H-OPER-BILL-STDZ-COSTS > H-OPER-STDZ-DOLLAR-THRESHOLD
756700
756800       COMPUTE  H-OPER-STDZ-COST-OUTLIER ROUNDED =
756900        (H-CSTOUT-PCT  *
757000        (H-OPER-BILL-STDZ-COSTS - H-OPER-STDZ-DOLLAR-THRESHOLD))
757100
757200     ELSE
757300       MOVE 0 TO H-OPER-STDZ-COST-OUTLIER.
757400
757500******************************************************
757600***CM-P3 STANDARDIZED CAPITAL OUTLIER CALCULATION
757700
757800     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
757900        (H-OPER-STDZ-DOLLAR-THRESHOLD +
758000                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
758100                          AND
758200         H-CAPI-BILL-STDZ-COSTS > H-CAPI-STDZ-DOLLAR-THRESHOLD
758300
758400      COMPUTE  H-CAPI-STDZ-COST-OUTLIER ROUNDED =
758500      (H-CSTOUT-PCT  *
758600      (H-CAPI-BILL-STDZ-COSTS - H-CAPI-STDZ-DOLLAR-THRESHOLD))
758700     ELSE
758800      MOVE 0 TO H-CAPI-STDZ-COST-OUTLIER.
758900
759000*******************************************************
759100***CM-P3 STANDARDIZED ALLOWED AMOUNT CALCULATION
759200
759300      COMPUTE H-STANDARD-ALLOWED-AMOUNT ROUNDED =
759400       (H-OPER-BASE + H-CAPI-BASE)
759500                 *
759600       H-DRG-WT-FRCTN
759700                 +
759800       H-OPER-STDZ-COST-OUTLIER
759900                 +
760000       H-CAPI-STDZ-COST-OUTLIER
760100                 +
760200       H-NEW-TECH-PAY-ADD-ON.
760300
760400 9010-EXIT.    EXIT.
760500
760600***********************************************************
760700******        L A S T   S O U R C E   S T A T E M E N T   *****
