000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL135.
000300*AUTHOR.            DDS TEAM    .
000400*REMARKS. 11/01/13 11:05  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     'PPCAL135      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C13.5'.
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  R1                             PIC S9(04) COMP SYNC.
002900 01  R2                             PIC S9(04) COMP SYNC.
003000 01  R3                             PIC S9(04) COMP SYNC.
003100 01  R4                             PIC S9(04) COMP SYNC.
003200 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003300 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003400
003500***************************************************************
003600**************YEARCHANGE 2013.0 *******************************
003700* TABLE 1                                                     *
003800*    (68.8% LABOR SHARE/31.2% NONLABOR SHARE)                 *
003900*    (FULL UPDATE (.697)                                      *
004000*    (QUALITY = 1 WAGE INDEX > 1)                             *
004100***************************************************************
004200 01  TB1-RATE-TABLE.
004300     02  TB1-RATE-WORK.
004400*RATE 20121001 REGION  LABOR AND NON-LABOR RATES
004500*                  R3=1     /     R3=2
004600*               LARGE URBAN / OTHER URBAN
004700*               LABOR / NON / LABOR / NON
004800*                     /LABOR/       /LABOR
004900*             --------------------------------------------
005000         05  FILLER PIC X(08) VALUE '20121001'.
005100         05  TB1-NAT    PIC X(30) VALUE
005200            ' 0367995 166881 0367995 166881'.
005300         05  TB1-PR     PIC X(30) VALUE
005400            ' 0156417 095462 0156417 095462'.
005500         05  TB1-NATPR  PIC X(30) VALUE
005600            ' 0367995 166881 0367995 166881'.
005700***************************************************************
005800     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
005900         05  TB1-RATE-PERIOD            OCCURS 1.
006000             10  TB1-RATE-EFF-DATE      PIC X(08).
006100             10  TB1-REG-NAT            OCCURS 3.
006200                 15  TB1-LARGE-OTHER    OCCURS 2.
006300                     20  FILLER         PIC X(01).
006400                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
006500                     20  FILLER         PIC X(01).
006600                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
006700
006800***************************************************************
006900************YEARCHANGE 2013.0 *********************************
007000* TABLE 2                                                     *
007100*    (68.8% LABOR SHARE/31.2% NONLABOR SHARE)                 *
007200*    (REDUCED UPDATE (.697)                                   *
007300*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *
007400***************************************************************
007500 01  TB2-RATE-TABLE.
007600     02  TB2-RATE-WORK.
007700*RATE 20121001 REGION  LABOR AND NON-LABOR RATES
007800*                  R3=1     /     R3=2
007900*               LARGE URBAN / OTHER URBAN
008000*               LABOR / NON / LABOR / NON
008100*                     /LABOR/       /LABOR
008200*             --------------------------------------------
008300         05  FILLER PIC X(08) VALUE '20121001'.
008400         05  TB2-NAT    PIC X(30) VALUE
008500            ' 0360765 163602 0360765 163602'.
008600         05  TB2-PR     PIC X(30) VALUE
008700            ' 0156417 095462 0156417 095462'.
008800         05  TB2-NATPR  PIC X(30) VALUE
008900            ' 0367995 156417 0367995 156417'.
009000***************************************************************
009100     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
009200         05  TB2-RATE-PERIOD             OCCURS 1.
009300             10  TB2-RATE-EFF-DATE       PIC X(08).
009400             10  TB2-REG-NAT             OCCURS 3.
009500                 15  TB2-LARGE-OTHER     OCCURS 2.
009600                     20  FILLER          PIC X(01).
009700                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
009800                     20  FILLER          PIC X(01).
009900                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
010000***************************************************************
010100************YEARCHANGE 2013.0 *********************************
010200* TABLE 3                                                     *
010300*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
010400*    (FULL UPDATE (.62%)                                      *
010500*    (QUALITY = 1 WAGE INDEX <= 1)                            *
010600***************************************************************
010700 01  TB3-RATE-TABLE.
010800     02  TB3-RATE-WORK.
010900*RATE 20121001 REGION  LABOR AND NON-LABOR RATES
011000*                  R3=1     /     R3=2
011100*               LARGE URBAN / OTHER URBAN
011200*               LABOR / NON / LABOR / NON
011300*                     /LABOR/       /LABOR
011400*             --------------------------------------------
011500         05  FILLER PIC X(08) VALUE '20121001'.
011600         05  TB3-NAT    PIC X(30) VALUE
011700            ' 0331623 203253 0331623 203253'.
011800         05  TB3-PR     PIC X(30) VALUE
011900            ' 0156165 095714 0156165 095714'.
012000         05  TB3-NATPR  PIC X(30) VALUE
012100            ' 0331623 203253 0331623 203253'.
012200****************************************************************
012300     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
012400         05  TB3-RATE-PERIOD            OCCURS 1.
012500             10  TB3-RATE-EFF-DATE      PIC X(08).
012600             10  TB3-REG-NAT            OCCURS 3.
012700                 15  TB3-LARGE-OTHER    OCCURS 2.
012800                     20  FILLER         PIC X(01).
012900                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
013000                     20  FILLER         PIC X(01).
013100                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
013200
013300***************************************************************
013400**********YEARCHANGE 2013.0 ***********************************
013500* TABLE 4                                                     *
013600*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
013700*    (REDUCED UPDATE (.62%)                                   *
013800*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *
013900***************************************************************
014000 01  TB4-RATE-TABLE.
014100     02  TB4-RATE-WORK.
014200*RATE 20121001 REGION  LABOR AND NON-LABOR RATES
014300*                  R3=1     /     R3=2
014400*               LARGE URBAN / OTHER URBAN
014500*               LABOR / NON / LABOR / NON
014600*                     /LABOR/       /LABOR
014700*             --------------------------------------------
014800         05  FILLER PIC X(08) VALUE '20121001'.
014900         05  TB4-NAT    PIC X(30) VALUE
015000            ' 0325108 199259 0325108 199259'.
015100         05  TB4-PR     PIC X(30) VALUE
015200            ' 0156165 095714 0156165 095714'.
015300         05  TB4-NATPR  PIC X(30) VALUE
015400            ' 0331623 203253 0331623 203253'.
015500***************************************************************
015600     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
015700         05  TB4-RATE-PERIOD             OCCURS 1.
015800             10  TB4-RATE-EFF-DATE       PIC X(08).
015900             10  TB4-REG-NAT             OCCURS 3.
016000                 15  TB4-LARGE-OTHER     OCCURS 2.
016100                     20  FILLER          PIC X(01).
016200                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
016300                     20  FILLER          PIC X(01).
016400                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
016500
016600 01  DRG-TABLE.
016700     05  D-TAB.
016800         10  FILLER                  PIC X(08) VALUE
016900       '20121001'.
017000         10  FILLER                  PIC X(56) VALUE
017100       '26029529400385139131155001971773692820034510883320900255'.
017200         10  FILLER                  PIC X(56) VALUE
017300       '10989416000217047178080000890961271470018205111009800114'.
017400         10  FILLER                  PIC X(56) VALUE
017500       '00000000000000038954080000860484341190014903157608500100'.
017600         10  FILLER                  PIC X(56) VALUE
017700       '01956605600065105255186002580000000000000006093217900199'.
017800         10  FILLER                  PIC X(56) VALUE
017900       '04581711000142000000000000000000000000000009101614500176'.
018000         10  FILLER                  PIC X(56) VALUE
018100       '06640011800135045056065000800523780790011103527904300065'.
018200         10  FILLER                  PIC X(56) VALUE
018300       '04595808100105029555053000680216310280003605602809900129'.
018400         10  FILLER                  PIC X(56) VALUE
018500       '02927704700064017854024000320426450850012002034803600053'.
018600         10  FILLER                  PIC X(56) VALUE
018700       '01438102000026036918047000700219650210003201661001300015'.
018800         10  FILLER                  PIC X(56) VALUE
018900       '03187005600083015741024000350102850140001603868008900117'.
019000         10  FILLER                  PIC X(56) VALUE
019100       '02133005000064017744026000340000000000000000000000000000'.
019200         10  FILLER                  PIC X(56) VALUE
019300       '00000000000000000000000000000000000000000000000000000000'.
019400         10  FILLER                  PIC X(56) VALUE
019500       '00000000000000000000000000000000000000000001490304300058'.
019600         10  FILLER                  PIC X(56) VALUE
019700       '00904602900035013962042000570104860320004301719405400071'.
019800         10  FILLER                  PIC X(56) VALUE
019900       '00968003600047016472054000700100880390004700780703100036'.
020000         10  FILLER                  PIC X(56) VALUE
020100       '02866806000078019551045000520153660320003701842404800066'.
020200         10  FILLER                  PIC X(56) VALUE
020300       '01134503700045008135026000310150740410005400889902600032'.
020400         10  FILLER                  PIC X(56) VALUE
020500       '00744902200027017056051000680101740370004700750602500030'.
020600         10  FILLER                  PIC X(56) VALUE
020700       '01282004100054008837031000400176110550007000894703200039'.
020800         10  FILLER                  PIC X(56) VALUE
020900       '01642604800060009790032000400072970240002901261603700052'.
021000         10  FILLER                  PIC X(56) VALUE
021100       '00741602700034019249033000560134580340004500869602200027'.
021200         10  FILLER                  PIC X(56) VALUE
021300       '02038705000068011874034000430076050220002701568704100053'.
021400         10  FILLER                  PIC X(56) VALUE
021500       '00979102700034007218018000220165830430006000921403100040'.
021600         10  FILLER                  PIC X(56) VALUE
021700       '00693802300028035656089001150246270630007902015804400055'.
021800         10  FILLER                  PIC X(56) VALUE
021900       '03371408900115018418061000770124270410004901557004300058'.
022000         10  FILLER                  PIC X(56) VALUE
022100       '00764302600033010209030000410068930230002900000000000000'.
022200         10  FILLER                  PIC X(56) VALUE
022300       '00000000000000000000000000000000000000000000000000000000'.
022400         10  FILLER                  PIC X(56) VALUE
022500       '00000000000000000000000000000000000000000000000000000000'.
022600         10  FILLER                  PIC X(56) VALUE
022700       '01858704100056009589022000290124070340004501502203500051'.
022800         10  FILLER                  PIC X(56) VALUE
022900       '00723401700023000000000000000000000000000000000000000000'.
023000         10  FILLER                  PIC X(56) VALUE
023100       '00958903900049006533032000390075420220002701188503600049'.
023200         10  FILLER                  PIC X(56) VALUE
023300       '00685002500032000000000000000000000000000000000000000000'.
023400         10  FILLER                  PIC X(56) VALUE
023500       '02150003700054012065023000290234430420006101236202100027'.
023600         10  FILLER                  PIC X(56) VALUE
023700       '01781803600054009177018000220200020400005901069701800023'.
023800         10  FILLER                  PIC X(56) VALUE
023900       '01319203800050007388019000230089220140001800000000000000'.
024000         10  FILLER                  PIC X(56) VALUE
024100       '00000000000000000000000000000000000000000000000000000000'.
024200         10  FILLER                  PIC X(56) VALUE
024300       '00000000000000022347063000910124860390005400748802400032'.
024400         10  FILLER                  PIC X(56) VALUE
024500       '00646202100025013890038000520064580220002801016603400044'.
024600         10  FILLER                  PIC X(56) VALUE
024700       '00660502500031014138043000570091370320004100634902300028'.
024800         10  FILLER                  PIC X(56) VALUE
024900       '01601004700066008988032000410059690210002600000000000000'.
025000         10  FILLER                  PIC X(56) VALUE
025100       '00000000000000000000000000000511931130013702619105800070'.
025200         10  FILLER                  PIC X(56) VALUE
025300       '01792203500041037513091001150200430540006801315303100041'.
025400         10  FILLER                  PIC X(56) VALUE
025500       '00000000000000000000000000000000000000000000000000000000'.
025600         10  FILLER                  PIC X(56) VALUE
025700       '00000000000000000000000000000158700550006601037903900046'.
025800         10  FILLER                  PIC X(56) VALUE
025900       '02054906600082014403053000640097990380004601756705600073'.
026000         10  FILLER                  PIC X(56) VALUE
026100       '01210803900051008275027000340148040500006201017103500042'.
026200         10  FILLER                  PIC X(56) VALUE
026300       '00696102400029015746049000640111690370004700754402600033'.
026400         10  FILLER                  PIC X(56) VALUE
026500       '01246104100052011860043000530095210360004400707202900034'.
026600         10  FILLER                  PIC X(56) VALUE
026700       '01489305100063009996039000470070780300003501682005500069'.
026800         10  FILLER                  PIC X(56) VALUE
026900       '01120903900048007879029000360189150610007801024203500045'.
027000         10  FILLER                  PIC X(56) VALUE
027100       '00679202600033008704033000400062280250003000682202100027'.
027200         10  FILLER                  PIC X(56) VALUE
027300       '01380904000053007763025000320536191250014602289905100070'.
027400         10  FILLER                  PIC X(56) VALUE
027500       '00000000000000000000000000000000000000000000000000000000'.
027600         10  FILLER                  PIC X(56) VALUE
027700       '00000000000000000000000000001410360850015009519013800164'.
027800         10  FILLER                  PIC X(56) VALUE
027900       '06349509000102053429065000740783901030012505243806800075'.
028000         10  FILLER                  PIC X(56) VALUE
028100       '04423205100056085506099001200610650440005907675808100100'.
028200         10  FILLER                  PIC X(56) VALUE
028300       '05760504000050067354061000870518860210003107081511200134'.
028400         10  FILLER                  PIC X(56) VALUE
028500       '04627907100080038111048000560752971030012105715108300091'.
028600         10  FILLER                  PIC X(56) VALUE
028700       '07229211900134048413081000870580140920010703777706000065'.
028800         10  FILLER                  PIC X(56) VALUE
028900       '05117007100100031863027000390461941110014102653107400091'.
029000         10  FILLER                  PIC X(56) VALUE
029100       '01482504700057037314061000780262040370004702062402300028'.
029200         10  FILLER                  PIC X(56) VALUE
029300       '04254002900043031566038000520199110200002503000304700064'.
029400         10  FILLER                  PIC X(56) VALUE
029500       '01796102300029029988052000710192370220003003022405300078'.
029600         10  FILLER                  PIC X(56) VALUE
029700       '02473904400059016609021000270243810670008801593405500068'.
029800         10  FILLER                  PIC X(56) VALUE
029900       '00953503200042026945050000650185900250003303662407700105'.
030000         10  FILLER                  PIC X(56) VALUE
030100       '01676903400044012343021000270190910380005902667405600083'.
030200         10  FILLER                  PIC X(56) VALUE
030300       '02439402500038000000000000000000000000000000000000000000'.
030400         10  FILLER                  PIC X(56) VALUE
030500       '00000000000000000000000000000000000000000000000000000000'.
030600         10  FILLER                  PIC X(56) VALUE
030700       '00000000000000000000000000000000000000000000000000000000'.
030800         10  FILLER                  PIC X(56) VALUE
030900       '00000000000000000000000000000000000000000001799904900063'.
031000         10  FILLER                  PIC X(56) VALUE
031100       '01096103200040007736021000260175390320005100804201900026'.
031200         10  FILLER                  PIC X(56) VALUE
031300       '00535301400017020617049000660107090240003102822907900099'.
031400         10  FILLER                  PIC X(56) VALUE
031500       '01814505900072012092041000500151740470006001003403800046'.
031600         10  FILLER                  PIC X(56) VALUE
031700       '00675102700032010229042000510064760350004001287801900028'.
031800         10  FILLER                  PIC X(56) VALUE
031900       '00645501300015004571011000120141860450005800967903700046'.
032000         10  FILLER                  PIC X(56) VALUE
032100       '00667902700034010142029000390057730190002301050303400044'.
032200         10  FILLER                  PIC X(56) VALUE
032300       '00618702100026013122040000520078400260003301228503900050'.
032400         10  FILLER                  PIC X(56) VALUE
032500       '00809802800035005541020000230052070180002200733902400029'.
032600         10  FILLER                  PIC X(56) VALUE
032700       '00561701700021018508049000670095270310004000622402000025'.
032800         10  FILLER                  PIC X(56) VALUE
032900       '00000000000000000000000000000000000000000000000000000000'.
033000         10  FILLER                  PIC X(56) VALUE
033100       '00000000000000000000000000000000000000000000000000000000'.
033200         10  FILLER                  PIC X(56) VALUE
033300       '00000000000000056118120001540268110630008201441302500033'.
033400         10  FILLER                  PIC X(56) VALUE
033500       '05259912100149025731074000860163610450005004614311200134'.
033600         10  FILLER                  PIC X(56) VALUE
033700       '02481406700078016181040000460431461120013402352907000084'.
033800         10  FILLER                  PIC X(56) VALUE
033900       '01553804000050032008083001000186750540006401202403000036'.
034000         10  FILLER                  PIC X(56) VALUE
034100       '02311604800066013516029000370095470160001903409409000115'.
034200         10  FILLER                  PIC X(56) VALUE
034300       '01712305600066011608039000440251690640008601390004200054'.
034400         10  FILLER                  PIC X(56) VALUE
034500       '00834302300028025082059000780137550340004400904302000024'.
034600         10  FILLER                  PIC X(56) VALUE
034700       '02819206300082015976040000500111720240002903946308900120'.
034800         10  FILLER                  PIC X(56) VALUE
034900       '02174705500071013629031000400000000000000000000000000000'.
035000         10  FILLER                  PIC X(56) VALUE
035100       '00000000000000000000000000000000000000000000000000000000'.
035200         10  FILLER                  PIC X(56) VALUE
035300       '00000000000000000000000000000000000000000001832705100066'.
035400         10  FILLER                  PIC X(56) VALUE
035500       '01066403500042007593025000300202000650008401227504900059'.
035600         10  FILLER                  PIC X(56) VALUE
035700       '00840103600043021284063000850127380430005500880902800035'.
035800         10  FILLER                  PIC X(56) VALUE
035900       '01781704900063010168034000400070150240002901931105600072'.
036000         10  FILLER                  PIC X(56) VALUE
036100       '01113003700046007917028000340133840440005600836502900035'.
036200         10  FILLER                  PIC X(56) VALUE
036300       '01907806300083010505041000510078780310003801656405400071'.
036400         10  FILLER                  PIC X(56) VALUE
036500       '00921703700046006372027000320118970390005100737502800034'.
036600         10  FILLER                  PIC X(56) VALUE
036700       '01666604800066009837035000440067910240003000000000000000'.
036800         10  FILLER                  PIC X(56) VALUE
036900       '00000000000000000000000000000000000000000000000000000000'.
037000         10  FILLER                  PIC X(56) VALUE
037100       '00000000000000000000000000000000000000000000000000000000'.
037200         10  FILLER                  PIC X(56) VALUE
037300       '05557511300152027303062000790182800410005003837510300128'.
037400         10  FILLER                  PIC X(56) VALUE
037500       '02268006900083016875048000570380400970011702598907000082'.
037600         10  FILLER                  PIC X(56) VALUE
037700       '01858204600053035643090001090207280600006901335403700044'.
037800         10  FILLER                  PIC X(56) VALUE
037900       '02518906100077017007042000510120500250003003850908700123'.
038000         10  FILLER                  PIC X(56) VALUE
038100       '01738104600062013006032000400433081020013602408106300083'.
038200         10  FILLER                  PIC X(56) VALUE
038300       '01575603800049000000000000000000000000000000000000000000'.
038400         10  FILLER                  PIC X(56) VALUE
038500       '00000000000000000000000000000000000000000001679204800063'.
038600         10  FILLER                  PIC X(56) VALUE
038700       '00931603400042006343026000320178160540007101193404000052'.
038800         10  FILLER                  PIC X(56) VALUE
038900       '00953702800036017844053000720096030370004600679002800033'.
039000         10  FILLER                  PIC X(56) VALUE
039100       '01876705100070009545035000440064730260003201603904700062'.
039200         10  FILLER                  PIC X(56) VALUE
039300       '01072003500043007583024000300000000000000000000000000000'.
039400         10  FILLER                  PIC X(56) VALUE
039500       '00000000000000000000000000000000000000000000000000000000'.
039600         10  FILLER                  PIC X(56) VALUE
039700       '10595210100126077979053000630587050310003609520410600131'.
039800         10  FILLER                  PIC X(56) VALUE
039900       '06417105600065049491033000370653900730009103878303100036'.
040000         10  FILLER                  PIC X(56) VALUE
040100       '04906206400077033745035000380544431090015102940606500082'.
040200         10  FILLER                  PIC X(56) VALUE
040300       '01880203900050050078070000870325160410004602607003100033'.
040400         10  FILLER                  PIC X(56) VALUE
040500       '03419606400076020953032000350470750650009002804102500036'.
040600         10  FILLER                  PIC X(56) VALUE
040700       '02125401500018035676089001160200710590007401017103000039'.
040800         10  FILLER                  PIC X(56) VALUE
040900       '03268108900110022663055000680169220320004103036707200085'.
041000         10  FILLER                  PIC X(56) VALUE
041100       '01934504900053015660040000430253140290003502095001900021'.
041200         10  FILLER                  PIC X(56) VALUE
041300       '03058308600103020808058000680148630420004901686503500043'.
041400         10  FILLER                  PIC X(56) VALUE
041500       '01248602400028018154032000450103540170002103103906700083'.
041600         10  FILLER                  PIC X(56) VALUE
041700       '01931004000048013938026000310299770750009801630604000052'.
041800         10  FILLER                  PIC X(56) VALUE
041900       '01120202000025021304053000720101060210002603136807800102'.
042000         10  FILLER                  PIC X(56) VALUE
042100       '01594004500057010670024000290230060680008701564104800059'.
042200         10  FILLER                  PIC X(56) VALUE
042300       '01147802600032013003030000400186890400005601207101800022'.
042400         10  FILLER                  PIC X(56) VALUE
042500       '01349402600037022963050000630152220320003801120101900022'.
042600         10  FILLER                  PIC X(56) VALUE
042700       '01340903600048008655021000260328310770009701974404600056'.
042800         10  FILLER                  PIC X(56) VALUE
042900       '01576702800035000000000000000000000000000000000000000000'.
043000         10  FILLER                  PIC X(56) VALUE
043100       '00000000000000000000000000000000000000000000000000000000'.
043200         10  FILLER                  PIC X(56) VALUE
043300       '00000000000000000000000000000000000000000000000000000000'.
043400         10  FILLER                  PIC X(56) VALUE
043500       '00000000000000000000000000000000000000000000000000000000'.
043600         10  FILLER                  PIC X(56) VALUE
043700       '01472504500061007366030000370127900420005400714603100035'.
043800         10  FILLER                  PIC X(56) VALUE
043900       '00863803400040006405024000280199820660008701269205000061'.
044000         10  FILLER                  PIC X(56) VALUE
044100       '00977003800048020293063000820117490430005400801203300039'.
044200         10  FILLER                  PIC X(56) VALUE
044300       '02478506100087011767041000520075810290003501746505800076'.
044400         10  FILLER                  PIC X(56) VALUE
044500       '01168304600056007723031000380163450500006400853303200039'.
044600         10  FILLER                  PIC X(56) VALUE
044700       '01208704300056006916029000360123480380005100703902600032'.
044800         10  FILLER                  PIC X(56) VALUE
044900       '01561305200065008594035000410187410520007001030003500044'.
045000         10  FILLER                  PIC X(56) VALUE
045100       '00611502000025013989044000560074630300003501445904700062'.
045200         10  FILLER                  PIC X(56) VALUE
045300       '00938603600045006786026000320000000000000000000000000000'.
045400         10  FILLER                  PIC X(56) VALUE
045500       '00000000000000024688075000990149690550006701003603900047'.
045600         10  FILLER                  PIC X(56) VALUE
045700       '03563708600130024469072000950132660400005304245708500129'.
045800         10  FILLER                  PIC X(56) VALUE
045900       '01896303900058011312023000320271860730009601487503700051'.
046000         10  FILLER                  PIC X(56) VALUE
046100       '00991602000025011283020000270089920150001701655003700053'.
046200         10  FILLER                  PIC X(56) VALUE
046300       '01138101800022000000000000000000000000000000000000000000'.
046400         10  FILLER                  PIC X(56) VALUE
046500       '00000000000000000000000000000000000000000001463205300069'.
046600         10  FILLER                  PIC X(56) VALUE
046700       '00991204400053006782032000390188030590007700888003600045'.
046800         10  FILLER                  PIC X(56) VALUE
046900       '01602605400072012280041000550066500230003100996804000050'.
047000         10  FILLER                  PIC X(56) VALUE
047100       '00624703000036014883052000650083920360004301329703900053'.
047200         10  FILLER                  PIC X(56) VALUE
047300       '00755202600032013936042000600068920280003600000000000000'.
047400         10  FILLER                  PIC X(56) VALUE
047500       '00000000000000000000000000000000000000000000000000000000'.
047600         10  FILLER                  PIC X(56) VALUE
047700       '00000000000000023998042000570140360230002704352511500141'.
047800         10  FILLER                  PIC X(56) VALUE
047900       '01971606200075011287040000500348760460007301860102500031'.
048000         10  FILLER                  PIC X(56) VALUE
048100       '01502601600019035668097001280182210590007300966203600044'.
048200         10  FILLER                  PIC X(56) VALUE
048300       '02360604400068012163020000290082170120001403293606800100'.
048400         10  FILLER                  PIC X(56) VALUE
048500       '02144006100074012266031000410000000000000000000000000000'.
048600         10  FILLER                  PIC X(56) VALUE
048700       '00000000000000000000000000000000000000000000000000000000'.
048800         10  FILLER                  PIC X(56) VALUE
048900       '01407004300057008218031000380055580220002701107603400047'.
049000         10  FILLER                  PIC X(56) VALUE
049100       '00692002700034011233033000460170940570007101050804000049'.
049200         10  FILLER                  PIC X(56) VALUE
049300       '00723302800034000000000000000000000000000000000000000000'.
049400         10  FILLER                  PIC X(56) VALUE
049500       '00000000000000000000000000000000000000000003082506000070'.
049600         10  FILLER                  PIC X(56) VALUE
049700       '06164913100160031279079000900209130470005603513607300095'.
049800         10  FILLER                  PIC X(56) VALUE
049900       '01990404600054014836029000320351920790010801882904400058'.
050000         10  FILLER                  PIC X(56) VALUE
050100       '01333502300029029941075001030152950380005201126001600020'.
050200         10  FILLER                  PIC X(56) VALUE
050300       '03073709500119016602045000620087600200002602473106700088'.
050400         10  FILLER                  PIC X(56) VALUE
050500       '01301503100042008326019000240145130370005200838301800023'.
050600         10  FILLER                  PIC X(56) VALUE
050700       '03059106400098021887051000700135580180002500000000000000'.
050800         10  FILLER                  PIC X(56) VALUE
050900       '00000000000000000000000000000000000000000000000000000000'.
051000         10  FILLER                  PIC X(56) VALUE
051100       '00000000000000015862049000650099580380004700643202600031'.
051200         10  FILLER                  PIC X(56) VALUE
051300       '00889902500035016823054000720104990360004700680502200029'.
051400         10  FILLER                  PIC X(56) VALUE
051500       '01178404500055007810032000390156320300004001056301700021'.
051600         10  FILLER                  PIC X(56) VALUE
051700       '01416904000052007017020000240129440420005500663902500031'.
051800         10  FILLER                  PIC X(56) VALUE
051900       '00824602500032015995052000660099980360004500685402600033'.
052000         10  FILLER                  PIC X(56) VALUE
052100       '00000000000000000000000000000000000000000000000000000000'.
052200         10  FILLER                  PIC X(56) VALUE
052300       '00000000000000000000000000000181340300004101293601500017'.
052400         10  FILLER                  PIC X(56) VALUE
052500       '02008704000064012991015000180196310550007800841802300032'.
052600         10  FILLER                  PIC X(56) VALUE
052700       '01323403100044006983016000180191490440006600965601300015'.
052800         10  FILLER                  PIC X(56) VALUE
052900       '01726104500062008657022000300000000000000000000000000000'.
053000         10  FILLER                  PIC X(56) VALUE
053100       '00000000000000016690054000720110660400005100650902000026'.
053200         10  FILLER                  PIC X(56) VALUE
053300       '01297604600059007085027000340140140500006300772103300039'.
053400         10  FILLER                  PIC X(56) VALUE
053500       '01035703400044006113020000250000000000000000000000000000'.
053600         10  FILLER                  PIC X(56) VALUE
053700       '00000000000000026652050000710116820190002304414010700130'.
053800         10  FILLER                  PIC X(56) VALUE
053900       '02004905400064012853030000340332190680009201568803300042'.
054000         10  FILLER                  PIC X(56) VALUE
054100       '01149901800022014157029000390096530170001901557304100059'.
054200         10  FILLER                  PIC X(56) VALUE
054300       '00810901800022013850030000440088180150001800977301400017'.
054400         10  FILLER                  PIC X(56) VALUE
054500       '02575506100086010675024000300000000000000000000000000000'.
054600         10  FILLER                  PIC X(56) VALUE
054700       '00000000000000019833059000810109900380005000577702100027'.
054800         10  FILLER                  PIC X(56) VALUE
054900       '01694506000078010790044000540071730310003700806202800036'.
055000         10  FILLER                  PIC X(56) VALUE
055100       '00495101800022000000000000000000000000000000000000000000'.
055200         10  FILLER                  PIC X(56) VALUE
055300       '01219403800048008586029000310092250250003201830404700058'.
055400         10  FILLER                  PIC X(56) VALUE
055500       '01466803300050006489016000200000000000000000000000000000'.
055600         10  FILLER                  PIC X(56) VALUE
055700       '00000000000000007217026000330057550210002400656502500032'.
055800         10  FILLER                  PIC X(56) VALUE
055900       '00877701900023005049021000310049620160001900189601100012'.
056000         10  FILLER                  PIC X(56) VALUE
056100       '00668702600038004050018000260000000000000000000000000000'.
056200         10  FILLER                  PIC X(56) VALUE
056300       '00000000000000000000000000000000000000000000000000000000'.
056400         10  FILLER                  PIC X(56) VALUE
056500       '01503501800018049579179001790338611330013302043108600086'.
056600         10  FILLER                  PIC X(56) VALUE
056700       '03478304700047012311034000340016670310003100000000000000'.
056800         10  FILLER                  PIC X(56) VALUE
056900       '00000000000000000000000000000514960970012702637205500071'.
057000         10  FILLER                  PIC X(56) VALUE
057100       '01573603000038036452083001140175760440005801121102300031'.
057200         10  FILLER                  PIC X(56) VALUE
057300       '00000000000000000000000000000000000000000002090205900078'.
057400         10  FILLER                  PIC X(56) VALUE
057500       '01176703700047008490027000340125560370005000787202600034'.
057600         10  FILLER                  PIC X(56) VALUE
057700       '01584103600050016794049000660101020350004500691802500031'.
057800         10  FILLER                  PIC X(56) VALUE
057900       '00000000000000000000000000000000000000000005722812700169'.
058000         10  FILLER                  PIC X(56) VALUE
058100       '02306605000069011935022000280453971170014802260306200081'.
058200         10  FILLER                  PIC X(56) VALUE
058300       '01271202700038048680109001400217650530006801340902800034'.
058400         10  FILLER                  PIC X(56) VALUE
058500       '03033506400096011804025000330000000000000000000000000000'.
058600         10  FILLER                  PIC X(56) VALUE
058700       '00000000000000051622099001610221330510008301099202800040'.
058800         10  FILLER                  PIC X(56) VALUE
058900       '06488116700225027537072001020124120470005603010307700105'.
059000         10  FILLER                  PIC X(56) VALUE
059100       '01619204800064010450030000400187190590007901221604300056'.
059200         10  FILLER                  PIC X(56) VALUE
059300       '00861202900038024374057000830104470290003500787802400030'.
059400         10  FILLER                  PIC X(56) VALUE
059500       '01339604600062000000000000000000000000000000000000000000'.
059600         10  FILLER                  PIC X(56) VALUE
059700       '05343111300146025583073000880153310350004904812510500140'.
059800         10  FILLER                  PIC X(56) VALUE
059900       '02064905800074012534038000470000000000000000000000000000'.
060000         10  FILLER                  PIC X(56) VALUE
060100       '00000000000000020099057000760098220380004700844302900037'.
060200         10  FILLER                  PIC X(56) VALUE
060300       '01518104400062007594028000340258610700009401076203900049'.
060400         10  FILLER                  PIC X(56) VALUE
060500       '00741502800035058399126001480188030520006901098804200050'.
060600         10  FILLER                  PIC X(56) VALUE
060700       '00000000000000000000000000000000000000000002709707500122'.
060800         10  FILLER                  PIC X(56) VALUE
060900       '00000000000000000000000000000000000000000000647402200030'.
061000         10  FILLER                  PIC X(56) VALUE
061100       '00635603200043006271031000420136130470008100985003900054'.
061200         10  FILLER                  PIC X(56) VALUE
061300       '00953905400074007812038000610094730310004700000000000000'.
061400         10  FILLER                  PIC X(56) VALUE
061500       '00000000000000000000000000000000000000000000000000000000'.
061600         10  FILLER                  PIC X(56) VALUE
061700       '00000000000000004278021000300109630920011701527104800067'.
061800         10  FILLER                  PIC X(56) VALUE
061900       '00678803200040000000000000000000000000000000000000000000'.
062000         10  FILLER                  PIC X(56) VALUE
062100       '04347709900149017079050000690098900300004002914507000101'.
062200         10  FILLER                  PIC X(56) VALUE
062300       '01263003400046011596024000360385650770010901951904500060'.
062400         10  FILLER                  PIC X(56) VALUE
062500       '01205102600033000000000000000000000000000000000000000000'.
062600         10  FILLER                  PIC X(56) VALUE
062700       '01227303800051006998025000310151680370005100504201700021'.
062800         10  FILLER                  PIC X(56) VALUE
062900       '01454203600049006304021000270166150440006000969303100040'.
063000         10  FILLER                  PIC X(56) VALUE
063100       '00663702200028014305039000570064380220002900000000000000'.
063200         10  FILLER                  PIC X(56) VALUE
063300       '00000000000000000000000000001640262250029604791911200153'.
063400         10  FILLER                  PIC X(56) VALUE
063500       '02242005200073000000000000000000000000000000000000000000'.
063600         10  FILLER                  PIC X(56) VALUE
063700       '02374002500053015123040000570134100330005000000000000000'.
063800         10  FILLER                  PIC X(56) VALUE
063900       '00000000000000000000000000000277690620009101810803600053'.
064000         10  FILLER                  PIC X(56) VALUE
064100       '01177602100027000000000000000000000000000000000000000000'.
064200         10  FILLER                  PIC X(56) VALUE
064300       '01320408300101012530065000740111310360004800701002700033'.
064400         10  FILLER                  PIC X(56) VALUE
064500       '00937202800042005693023000330081050240005900000000000000'.
064600         10  FILLER                  PIC X(56) VALUE
064700       '00000000000000000000000000000541700810011503637206900084'.
064800         10  FILLER                  PIC X(56) VALUE
064900       '06418209900139039004072000910256460470005800000000000000'.
065000         10  FILLER                  PIC X(56) VALUE
065100       '00000000000000000000000000000284830580008501497504400055'.
065200         10  FILLER                  PIC X(56) VALUE
065300       '00960003000036000000000000000000000000000000000000000000'.
065400         10  FILLER                  PIC X(56) VALUE
065500       '05481512000163026631055000740000000000000000000000000000'.
065600         10  FILLER                  PIC X(56) VALUE
065700       '00000000000000025943068000960131420480006200841603300041'.
065800         10  FILLER                  PIC X(56) VALUE
065900       '01051703500047000000000000000000000000000000000000000000'.
066000         10  FILLER                  PIC X(56) VALUE
066100       '05027010500137028276060000780171750290003803621710600131'.
066200         10  FILLER                  PIC X(56) VALUE
066300       '02089506100082010710025000360333740860011401814105000067'.
066400         10  FILLER                  PIC X(56) VALUE
066500       '01015002200030000000000000000000000000000000000000000000'.
066600         10  FILLER                  PIC X(56) VALUE
066700       '00000000000000000000000000000000000000000000000000000000'.
066800         10  FILLER                  PIC X(56) VALUE
066900       '00000000000000000000000000000000000000000000000000000000'.
067000     05  DRGX-TAB REDEFINES D-TAB.
067100         10  DRGX-PERIOD               OCCURS 1
067200                                        INDEXED BY DX5.
067300             15  DRGX-EFF-DATE         PIC X(08).
067400             15  DRG-DATA              OCCURS 1000
067500                                        INDEXED BY DX6.
067600                 20  DRG-WT            PIC 9(02)V9(04).
067700                 20  DRG-ALOS          PIC 9(02)V9(01).
067800                 20  DRG-DAYS-TRIM     PIC 9(02).
067900                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
068000
068100*****YEARCHANGE 2010.0 ** NOT USED IN 2013 ****************
068200
068300 01  PPS-SSRFBN-TABLE.
068400     02  WK-SSRFBN-DATA.
068500         05  FILLER   PIC X(58)  VALUE
068600     '01  099835  01 ALABAMA                                   '.
068700         05  FILLER   PIC X(58)  VALUE
068800     '02  099835  02 ALASKA                                    '.
068900         05  FILLER   PIC X(58)  VALUE
069000     '03  099835  03 ARIZONA                                   '.
069100         05  FILLER   PIC X(58)  VALUE
069200     '04  099835  04 ARKANSAS                                  '.
069300         05  FILLER   PIC X(58)  VALUE
069400     '05  099317  05 CALIFORNIA                                '.
069500          05  FILLER   PIC X(58)  VALUE
069600     '06  099413  06 COLORADO                                  '.
069700         05  FILLER   PIC X(58)  VALUE
069800     '07  098016  07 CONNECTICUT                               '.
069900         05  FILLER   PIC X(58)  VALUE
070000     '08  099835  08 DELAWARE                                  '.
070100         05  FILLER   PIC X(58)  VALUE
070200     '09  099835  09 DISTRICT OF CO                            '.
070300         05  FILLER   PIC X(58)  VALUE
070400     '10  099756  10 FLORIDA                                   '.
070500         05  FILLER   PIC X(58)  VALUE
070600     '11  099835  11 GEORGIA                                   '.
070700         05  FILLER   PIC X(58)  VALUE
070800     '12  099835  12 HAWAII                                    '.
070900         05  FILLER   PIC X(58)  VALUE
071000     '13  099835  13 IDAHO                                     '.
071100         05  FILLER   PIC X(58)  VALUE
071200     '14  099835  14 ILLINOIS                                  '.
071300         05  FILLER   PIC X(58)  VALUE
071400     '15  099813  15 INDIANA                                   '.
071500         05  FILLER   PIC X(58)  VALUE
071600     '16  099783  16 IOWA                                      '.
071700         05  FILLER   PIC X(58)  VALUE
071800     '17  099827  17 KANSAS                                    '.
071900         05  FILLER   PIC X(58)  VALUE
072000     '18  099835  18 KENTUCKY                                  '.
072100         05  FILLER   PIC X(58)  VALUE
072200     '19  099834  19 LOUISIANA                                 '.
072300         05  FILLER   PIC X(58)  VALUE
072400     '20  099835  20 MAINE                                     '.
072500         05  FILLER   PIC X(58)  VALUE
072600     '21  100000  21 MARYLAND                                  '.
072700         05  FILLER   PIC X(58)  VALUE
072800     '22  099834  22 MASSACHUSETTS                             '.
072900         05  FILLER   PIC X(58)  VALUE
073000     '23  099833  23 MICHIGAN                                  '.
073100         05  FILLER   PIC X(58)  VALUE
073200     '24  099835  24 MINNESOTA                                 '.
073300         05  FILLER   PIC X(58)  VALUE
073400     '25  099834  25 MISSISSIPPI                               '.
073500         05  FILLER   PIC X(58)  VALUE
073600     '26  099835  26 MISSOURI                                  '.
073700         05  FILLER   PIC X(58)  VALUE
073800     '27  099835  27 MONTANA                                   '.
073900         05  FILLER   PIC X(58)  VALUE
074000     '28  099835  28 NEBRASKA                                  '.
074100         05  FILLER   PIC X(58)  VALUE
074200     '29  099835  29 NEVADA                                    '.
074300         05  FILLER   PIC X(58)  VALUE
074400     '30  099699  30 NEW HAMPSHIRE                             '.
074500         05  FILLER   PIC X(58)  VALUE
074600     '31  098587  31 NEW JERSEY                                '.
074700         05  FILLER   PIC X(58)  VALUE
074800     '32  099577  32 NEW MEXICO                                '.
074900         05  FILLER   PIC X(58)  VALUE
075000     '33  099835  33 NEW YORK                                  '.
075100         05  FILLER   PIC X(58)  VALUE
075200     '34  099834  34 NORTH CAROLINA                            '.
075300         05  FILLER   PIC X(58)  VALUE
075400     '35  099833  35 NORTH DAKOTA                              '.
075500         05  FILLER   PIC X(58)  VALUE
075600     '36  099784  36 OHIO                                      '.
075700         05  FILLER   PIC X(58)  VALUE
075800     '37  099835  37 OKLAHOMA                                  '.
075900         05  FILLER   PIC X(58)  VALUE
076000     '38  099708  38 OREGON                                    '.
076100         05  FILLER   PIC X(58)  VALUE
076200     '39  099834  39 PENNSYLVANIA                              '.
076300         05  FILLER   PIC X(58)  VALUE
076400     '40  099835  40 PUERTO RICO                               '.
076500         05  FILLER   PIC X(58)  VALUE
076600     '41  099835  41 RHODE ISLAND                              '.
076700         05  FILLER   PIC X(58)  VALUE
076800     '42  099779  42 SOUTH CAROLINA                            '.
076900         05  FILLER   PIC X(58)  VALUE
077000     '43  099834  43 SOUTH DAKOTA                              '.
077100         05  FILLER   PIC X(58)  VALUE
077200     '44  099690  44 TENNESSEE                                 '.
077300         05  FILLER   PIC X(58)  VALUE
077400     '45  099832  45 TEXAS                                     '.
077500         05  FILLER   PIC X(58)  VALUE
077600     '46  099835  46 UTAH                                      '.
077700         05  FILLER   PIC X(58)  VALUE
077800     '47  099835  47 VERMONT                                   '.
077900         05  FILLER   PIC X(58)  VALUE
078000     '48  100000  48 VIRGIN ISLANDS                            '.
078100         05  FILLER   PIC X(58)  VALUE
078200     '49  099835  49 VIRGINIA                                  '.
078300         05  FILLER   PIC X(58)  VALUE
078400     '50  099792  50 WASHINGTON                                '.
078500         05  FILLER   PIC X(58)  VALUE
078600     '51  099712  51 WEST VIRGINIA                             '.
078700         05  FILLER   PIC X(58)  VALUE
078800     '52  099816  52 WISCONSIN                                 '.
078900         05  FILLER   PIC X(58)  VALUE
079000     '53  099835  53 WYOMING                                   '.
079100         05  FILLER   PIC X(58)  VALUE
079200     '55  099317  55 CALIFORNIA                                '.
079300         05  FILLER   PIC X(58)  VALUE
079400     '56  100000  56 CANADA                                    '.
079500         05  FILLER   PIC X(58)  VALUE
079600     '59  100000  59 MEXICO                                    '.
079700         05  FILLER   PIC X(58)  VALUE
079800     '64  100000  64 AMERICAN SAMOA                            '.
079900         05  FILLER   PIC X(58)  VALUE
080000     '65  100000  65 GUAM                                      '.
080100         05  FILLER   PIC X(58)  VALUE
080200     '66  100000  66 MARIANAS ISLANDS                          '.
080300         05  FILLER   PIC X(58)  VALUE
080400     '67  099832  67 TEXAS                                     '.
080500         05  FILLER   PIC X(58)  VALUE
080600     '68  099756  68 FLORIDA                                   '.
080700         05  FILLER   PIC X(58)  VALUE
080800     '69  099756  69 FLORIDA                                   '.
080900         05  FILLER   PIC X(58)  VALUE
081000     '70  099827  70 KANSAS                                    '.
081100         05  FILLER   PIC X(58)  VALUE
081200     '71  099834  71 LOUISIANA                                 '.
081300         05  FILLER   PIC X(58)  VALUE
081400     '72  099784  72 OHIO                                      '.
081500         05  FILLER   PIC X(58)  VALUE
081600     '73  099834  73 PENNSYLVANIA                              '.
081700         05  FILLER   PIC X(58)  VALUE
081800     '74  099832  74 TEXAS                                     '.
081900         05  FILLER   PIC X(58)  VALUE
082000     '75  099317  75 CALIFORNIA                                '.
082100         05  FILLER   PIC X(58)  VALUE
082200     '76  099783  76 IOWA                                      '.
082300         05  FILLER   PIC X(58)  VALUE
082400     '77  099835  77 MINNESOTA                                 '.
082500         05  FILLER   PIC X(58)  VALUE
082600     '78  099835  78 ILLINOIS                                  '.
082700         05  FILLER   PIC X(58)  VALUE
082800     '80  100000  80 MARYLAND                                  '.
082900      02  WK-SSRFBN-DATA2 REDEFINES WK-SSRFBN-DATA.
083000         05  SSRFBN-TAB OCCURS 72 ASCENDING KEY IS WK-SSRFBN-STATE
083100                               INDEXED BY SSRFBN-IDX.
083200           10  WK-SSRFBN-REASON-ALL.
083300              15 WK-SSRFBN-STATE  PIC 99.
083400              15 FILLER           PIC XX.
083500              15 WK-SSRFBN-RATE   PIC 9(1)V9(5).
083600              15 FILLER           PIC XX.
083700              15 WK-SSRFBN-CODE2  PIC 99.
083800              15 FILLER           PIC XX.
083900              15 WK-SSRFBN-STNAM  PIC X(20).
084000              15 WK-SSRFBN-REST   PIC X(22).
084100
084200***********************************************************
084300*****YEARCHANGE 2013.0 ************************************
084400***********************************************************
084500***  LOW VOLUME TABLE
084600***********************************************************
084700
084800 01  LOWVOL-PROV-TABLE.
084900     05 LOWVOL-PROV-DISCHG-DATA.
085000         10  FILLER      PIC X(13) VALUE '010007   1020'.
085100         10  FILLER      PIC X(13) VALUE '010008   0382'.
085200         10  FILLER      PIC X(13) VALUE '010009   0707'.
085300         10  FILLER      PIC X(13) VALUE '010015   0321'.
085400         10  FILLER      PIC X(13) VALUE '010018   0054'.
085500         10  FILLER      PIC X(13) VALUE '010021   0820'.
085600         10  FILLER      PIC X(13) VALUE '010022   0606'.
085700         10  FILLER      PIC X(13) VALUE '010025   1564'.
085800         10  FILLER      PIC X(13) VALUE '010027   0238'.
085900         10  FILLER      PIC X(13) VALUE '010032   0390'.
086000         10  FILLER      PIC X(13) VALUE '010034   1008'.
086100         10  FILLER      PIC X(13) VALUE '010043   0315'.
086200         10  FILLER      PIC X(13) VALUE '010044   0556'.
086300         10  FILLER      PIC X(13) VALUE '010045   0776'.
086400         10  FILLER      PIC X(13) VALUE '010047   0645'.
086500         10  FILLER      PIC X(13) VALUE '010050   0891'.
086600         10  FILLER      PIC X(13) VALUE '010051   0322'.
086700         10  FILLER      PIC X(13) VALUE '010052   0526'.
086800         10  FILLER      PIC X(13) VALUE '010058   0143'.
086900         10  FILLER      PIC X(13) VALUE '010059   0869'.
087000         10  FILLER      PIC X(13) VALUE '010062   0853'.
087100         10  FILLER      PIC X(13) VALUE '010066   0234'.
087200         10  FILLER      PIC X(13) VALUE '010069   0785'.
087300         10  FILLER      PIC X(13) VALUE '010073   0651'.
087400         10  FILLER      PIC X(13) VALUE '010086   1512'.
087500         10  FILLER      PIC X(13) VALUE '010087   1482'.
087600         10  FILLER      PIC X(13) VALUE '010091   0422'.
087700         10  FILLER      PIC X(13) VALUE '010095   0213'.
087800         10  FILLER      PIC X(13) VALUE '010097   0680'.
087900         10  FILLER      PIC X(13) VALUE '010099   1050'.
088000         10  FILLER      PIC X(13) VALUE '010101   1294'.
088100         10  FILLER      PIC X(13) VALUE '010102   0120'.
088200         10  FILLER      PIC X(13) VALUE '010108   1163'.
088300         10  FILLER      PIC X(13) VALUE '010109   0635'.
088400         10  FILLER      PIC X(13) VALUE '010110   0523'.
088500         10  FILLER      PIC X(13) VALUE '010112   1463'.
088600         10  FILLER      PIC X(13) VALUE '010120   0825'.
088700         10  FILLER      PIC X(13) VALUE '010125   1057'.
088800         10  FILLER      PIC X(13) VALUE '010126   0878'.
088900         10  FILLER      PIC X(13) VALUE '010128   0311'.
089000         10  FILLER      PIC X(13) VALUE '010129   0710'.
089100         10  FILLER      PIC X(13) VALUE '010130   0890'.
089200         10  FILLER      PIC X(13) VALUE '010137   0350'.
089300         10  FILLER      PIC X(13) VALUE '010138   0192'.
089400         10  FILLER      PIC X(13) VALUE '010145   1031'.
089500         10  FILLER      PIC X(13) VALUE '010146   0752'.
089600         10  FILLER      PIC X(13) VALUE '010148   1123'.
089700         10  FILLER      PIC X(13) VALUE '010150   0712'.
089800         10  FILLER      PIC X(13) VALUE '010152   0888'.
089900         10  FILLER      PIC X(13) VALUE '010157   0903'.
090000         10  FILLER      PIC X(13) VALUE '010158   1423'.
090100         10  FILLER      PIC X(13) VALUE '010168   1309'.
090200         10  FILLER      PIC X(13) VALUE '010169   0849'.
090300         10  FILLER      PIC X(13) VALUE '010170   0038'.
090400         10  FILLER      PIC X(13) VALUE '020006   1564'.
090500         10  FILLER      PIC X(13) VALUE '020008   0570'.
090600         10  FILLER      PIC X(13) VALUE '020012   1408'.
090700         10  FILLER      PIC X(13) VALUE '020018   0300'.
090800         10  FILLER      PIC X(13) VALUE '020024   0823'.
090900         10  FILLER      PIC X(13) VALUE '020027   0255'.
091000         10  FILLER      PIC X(13) VALUE '030001   1521'.
091100         10  FILLER      PIC X(13) VALUE '030022   1543'.
091200         10  FILLER      PIC X(13) VALUE '030033   1470'.
091300         10  FILLER      PIC X(13) VALUE '030062   1250'.
091400         10  FILLER      PIC X(13) VALUE '030067   0504'.
091500         10  FILLER      PIC X(13) VALUE '030068   0618'.
091600         10  FILLER      PIC X(13) VALUE '030071   0511'.
091700         10  FILLER      PIC X(13) VALUE '030073   0668'.
091800         10  FILLER      PIC X(13) VALUE '030074   0037'.
091900         10  FILLER      PIC X(13) VALUE '030077   0009'.
092000         10  FILLER      PIC X(13) VALUE '030078   0201'.
092100         10  FILLER      PIC X(13) VALUE '030084   0452'.
092200         10  FILLER      PIC X(13) VALUE '030102   0001'.
092300         10  FILLER      PIC X(13) VALUE '030107   0439'.
092400         10  FILLER      PIC X(13) VALUE '030108   0438'.
092500         10  FILLER      PIC X(13) VALUE '030112   0266'.
092600         10  FILLER      PIC X(13) VALUE '030113   0220'.
092700         10  FILLER      PIC X(13) VALUE '030117   1587'.
092800         10  FILLER      PIC X(13) VALUE '030118   1491'.
092900         10  FILLER      PIC X(13) VALUE '030120   0494'.
093000         10  FILLER      PIC X(13) VALUE '030126   1520'.
093100         10  FILLER      PIC X(13) VALUE '030128   1037'.
093200         10  FILLER      PIC X(13) VALUE '030129   0218'.
093300         10  FILLER      PIC X(13) VALUE '030130   0542'.
093400         10  FILLER      PIC X(13) VALUE '030131   0038'.
093500         10  FILLER      PIC X(13) VALUE '040001   1134'.
093600         10  FILLER      PIC X(13) VALUE '040002   0958'.
093700         10  FILLER      PIC X(13) VALUE '040011   1194'.
093800         10  FILLER      PIC X(13) VALUE '040015   0685'.
093900         10  FILLER      PIC X(13) VALUE '040018   1097'.
094000         10  FILLER      PIC X(13) VALUE '040019   0655'.
094100         10  FILLER      PIC X(13) VALUE '040047   0598'.
094200         10  FILLER      PIC X(13) VALUE '040050   0982'.
094300         10  FILLER      PIC X(13) VALUE '040051   1003'.
094400         10  FILLER      PIC X(13) VALUE '040067   0916'.
094500         10  FILLER      PIC X(13) VALUE '040069   0475'.
094600         10  FILLER      PIC X(13) VALUE '040072   0904'.
094700         10  FILLER      PIC X(13) VALUE '040074   0667'.
094800         10  FILLER      PIC X(13) VALUE '040076   1006'.
094900         10  FILLER      PIC X(13) VALUE '040080   1080'.
095000         10  FILLER      PIC X(13) VALUE '040085   0958'.
095100         10  FILLER      PIC X(13) VALUE '040091   0780'.
095200         10  FILLER      PIC X(13) VALUE '040137   1147'.
095300         10  FILLER      PIC X(13) VALUE '040147   1525'.
095400         10  FILLER      PIC X(13) VALUE '040152   0432'.
095500         10  FILLER      PIC X(13) VALUE '050008   1360'.
095600         10  FILLER      PIC X(13) VALUE '050014   1144'.
095700         10  FILLER      PIC X(13) VALUE '050016   1544'.
095800         10  FILLER      PIC X(13) VALUE '050018   1341'.
095900         10  FILLER      PIC X(13) VALUE '050028   0644'.
096000         10  FILLER      PIC X(13) VALUE '050040   0832'.
096100         10  FILLER      PIC X(13) VALUE '050042   1235'.
096200         10  FILLER      PIC X(13) VALUE '050046   0465'.
096300         10  FILLER      PIC X(13) VALUE '050054   1422'.
096400         10  FILLER      PIC X(13) VALUE '050055   1223'.
096500         10  FILLER      PIC X(13) VALUE '050067   0577'.
096600         10  FILLER      PIC X(13) VALUE '050090   0866'.
096700         10  FILLER      PIC X(13) VALUE '050091   0995'.
096800         10  FILLER      PIC X(13) VALUE '050096   0077'.
096900         10  FILLER      PIC X(13) VALUE '050110   1046'.
097000         10  FILLER      PIC X(13) VALUE '050113   0422'.
097100         10  FILLER      PIC X(13) VALUE '050127   1446'.
097200         10  FILLER      PIC X(13) VALUE '050131   1024'.
097300         10  FILLER      PIC X(13) VALUE '050136   1254'.
097400         10  FILLER      PIC X(13) VALUE '050158   1074'.
097500         10  FILLER      PIC X(13) VALUE '050159   1294'.
097600         10  FILLER      PIC X(13) VALUE '050167   0896'.
097700         10  FILLER      PIC X(13) VALUE '050189   0263'.
097800         10  FILLER      PIC X(13) VALUE '050192   0283'.
097900         10  FILLER      PIC X(13) VALUE '050196   0156'.
098000         10  FILLER      PIC X(13) VALUE '050205   0709'.
098100         10  FILLER      PIC X(13) VALUE '050211   1243'.
098200         10  FILLER      PIC X(13) VALUE '050219   0991'.
098300         10  FILLER      PIC X(13) VALUE '050234   1488'.
098400         10  FILLER      PIC X(13) VALUE '050248   0866'.
098500         10  FILLER      PIC X(13) VALUE '050257   0970'.
098600         10  FILLER      PIC X(13) VALUE '050264   0602'.
098700         10  FILLER      PIC X(13) VALUE '050276   1038'.
098800         10  FILLER      PIC X(13) VALUE '050279   1386'.
098900         10  FILLER      PIC X(13) VALUE '050296   0906'.
099000         10  FILLER      PIC X(13) VALUE '050298   1015'.
099100         10  FILLER      PIC X(13) VALUE '050313   1586'.
099200         10  FILLER      PIC X(13) VALUE '050315   0758'.
099300         10  FILLER      PIC X(13) VALUE '050320   1313'.
099400         10  FILLER      PIC X(13) VALUE '050325   0001'.
099500         10  FILLER      PIC X(13) VALUE '050349   0092'.
099600         10  FILLER      PIC X(13) VALUE '050352   0677'.
099700         10  FILLER      PIC X(13) VALUE '050357   0622'.
099800         10  FILLER      PIC X(13) VALUE '050366   0013'.
099900         10  FILLER      PIC X(13) VALUE '050373   1558'.
100000         10  FILLER      PIC X(13) VALUE '050376   1440'.
100100         10  FILLER      PIC X(13) VALUE '050378   1262'.
100200         10  FILLER      PIC X(13) VALUE '050385   0715'.
100300         10  FILLER      PIC X(13) VALUE '050397   0140'.
100400         10  FILLER      PIC X(13) VALUE '050407   0834'.
100500         10  FILLER      PIC X(13) VALUE '050417   0978'.
100600         10  FILLER      PIC X(13) VALUE '050423   0410'.
100700         10  FILLER      PIC X(13) VALUE '050434   0399'.
100800         10  FILLER      PIC X(13) VALUE '050435   1142'.
100900         10  FILLER      PIC X(13) VALUE '050448   0845'.
101000         10  FILLER      PIC X(13) VALUE '050517   1501'.
101100         10  FILLER      PIC X(13) VALUE '050526   1577'.
101200         10  FILLER      PIC X(13) VALUE '050528   0423'.
101300         10  FILLER      PIC X(13) VALUE '050531   0969'.
101400         10  FILLER      PIC X(13) VALUE '050537   1087'.
101500         10  FILLER      PIC X(13) VALUE '050543   0352'.
101600         10  FILLER      PIC X(13) VALUE '050545   0046'.
101700         10  FILLER      PIC X(13) VALUE '050546   0106'.
101800         10  FILLER      PIC X(13) VALUE '050547   0098'.
101900         10  FILLER      PIC X(13) VALUE '050548   0088'.
102000         10  FILLER      PIC X(13) VALUE '050552   0150'.
102100         10  FILLER      PIC X(13) VALUE '050568   1492'.
102200         10  FILLER      PIC X(13) VALUE '050608   1029'.
102300         10  FILLER      PIC X(13) VALUE '050618   0105'.
102400         10  FILLER      PIC X(13) VALUE '050641   0948'.
102500         10  FILLER      PIC X(13) VALUE '050644   1249'.
102600         10  FILLER      PIC X(13) VALUE '050668   0098'.
102700         10  FILLER      PIC X(13) VALUE '050680   0411'.
102800         10  FILLER      PIC X(13) VALUE '050688   1501'.
102900         10  FILLER      PIC X(13) VALUE '050697   0079'.
103000         10  FILLER      PIC X(13) VALUE '050708   0833'.
103100         10  FILLER      PIC X(13) VALUE '050714   0156'.
103200         10  FILLER      PIC X(13) VALUE '050717   0187'.
103300         10  FILLER      PIC X(13) VALUE '050726   0338'.
103400         10  FILLER      PIC X(13) VALUE '050727   1057'.
103500         10  FILLER      PIC X(13) VALUE '050732   1502'.
103600         10  FILLER      PIC X(13) VALUE '050736   1071'.
103700         10  FILLER      PIC X(13) VALUE '050738   0733'.
103800         10  FILLER      PIC X(13) VALUE '050744   0600'.
103900         10  FILLER      PIC X(13) VALUE '050745   0640'.
104000         10  FILLER      PIC X(13) VALUE '050747   0730'.
104100         10  FILLER      PIC X(13) VALUE '050748   0304'.
104200         10  FILLER      PIC X(13) VALUE '050749   0395'.
104300         10  FILLER      PIC X(13) VALUE '050751   0025'.
104400         10  FILLER      PIC X(13) VALUE '050754   0043'.
104500         10  FILLER      PIC X(13) VALUE '050758   1144'.
104600         10  FILLER      PIC X(13) VALUE '050765   1314'.
104700         10  FILLER      PIC X(13) VALUE '050766   0311'.
104800         10  FILLER      PIC X(13) VALUE '050767   1299'.
104900         10  FILLER      PIC X(13) VALUE '050768   0339'.
105000         10  FILLER      PIC X(13) VALUE '050769   1373'.
105100         10  FILLER      PIC X(13) VALUE '050770   0541'.
105200         10  FILLER      PIC X(13) VALUE '050771   0116'.
105300         10  FILLER      PIC X(13) VALUE '060004   0921'.
105400         10  FILLER      PIC X(13) VALUE '060006   1311'.
105500         10  FILLER      PIC X(13) VALUE '060008   0816'.
105600         10  FILLER      PIC X(13) VALUE '060016   1139'.
105700         10  FILLER      PIC X(13) VALUE '060036   0973'.
105800         10  FILLER      PIC X(13) VALUE '060043   0098'.
105900         10  FILLER      PIC X(13) VALUE '060044   0557'.
106000         10  FILLER      PIC X(13) VALUE '060049   0463'.
106100         10  FILLER      PIC X(13) VALUE '060054   0928'.
106200         10  FILLER      PIC X(13) VALUE '060071   1396'.
106300         10  FILLER      PIC X(13) VALUE '060075   0761'.
106400         10  FILLER      PIC X(13) VALUE '060076   0806'.
106500         10  FILLER      PIC X(13) VALUE '060096   0352'.
106600         10  FILLER      PIC X(13) VALUE '060103   0759'.
106700         10  FILLER      PIC X(13) VALUE '060107   0004'.
106800         10  FILLER      PIC X(13) VALUE '060117   0177'.
106900         10  FILLER      PIC X(13) VALUE '060118   0223'.
107000         10  FILLER      PIC X(13) VALUE '060124   0448'.
107100         10  FILLER      PIC X(13) VALUE '070004   1234'.
107200         10  FILLER      PIC X(13) VALUE '070008   1465'.
107300         10  FILLER      PIC X(13) VALUE '070012   1360'.
107400         10  FILLER      PIC X(13) VALUE '070015   1147'.
107500         10  FILLER      PIC X(13) VALUE '070019   1584'.
107600         10  FILLER      PIC X(13) VALUE '070038   0005'.
107700         10  FILLER      PIC X(13) VALUE '070039   0495'.
107800         10  FILLER      PIC X(13) VALUE '070040   0223'.
107900         10  FILLER      PIC X(13) VALUE '080009   0489'.
108000         10  FILLER      PIC X(13) VALUE '090008   1326'.
108100         10  FILLER      PIC X(13) VALUE '100048   0603'.
108200         10  FILLER      PIC X(13) VALUE '100054   1306'.
108300         10  FILLER      PIC X(13) VALUE '100081   0614'.
108400         10  FILLER      PIC X(13) VALUE '100106   0485'.
108500         10  FILLER      PIC X(13) VALUE '100130   0484'.
108600         10  FILLER      PIC X(13) VALUE '100134   0013'.
108700         10  FILLER      PIC X(13) VALUE '100139   0252'.
108800         10  FILLER      PIC X(13) VALUE '100140   1207'.
108900         10  FILLER      PIC X(13) VALUE '100142   1574'.
109000         10  FILLER      PIC X(13) VALUE '100150   1375'.
109100         10  FILLER      PIC X(13) VALUE '100175   1119'.
109200         10  FILLER      PIC X(13) VALUE '100240   0048'.
109300         10  FILLER      PIC X(13) VALUE '100277   0179'.
109400         10  FILLER      PIC X(13) VALUE '100298   0025'.
109500         10  FILLER      PIC X(13) VALUE '100313   0217'.
109600         10  FILLER      PIC X(13) VALUE '100314   0733'.
109700         10  FILLER      PIC X(13) VALUE '100315   0553'.
109800         10  FILLER      PIC X(13) VALUE '100316   0715'.
109900         10  FILLER      PIC X(13) VALUE '110004   1011'.
110000         10  FILLER      PIC X(13) VALUE '110015   0844'.
110100         10  FILLER      PIC X(13) VALUE '110026   0448'.
110200         10  FILLER      PIC X(13) VALUE '110027   0734'.
110300         10  FILLER      PIC X(13) VALUE '110040   0698'.
110400         10  FILLER      PIC X(13) VALUE '110041   1106'.
110500         10  FILLER      PIC X(13) VALUE '110042   1122'.
110600         10  FILLER      PIC X(13) VALUE '110044   0825'.
110700         10  FILLER      PIC X(13) VALUE '110045   0934'.
110800         10  FILLER      PIC X(13) VALUE '110050   0426'.
110900         10  FILLER      PIC X(13) VALUE '110051   0942'.
111000         10  FILLER      PIC X(13) VALUE '110059   0532'.
111100         10  FILLER      PIC X(13) VALUE '110071   0624'.
111200         10  FILLER      PIC X(13) VALUE '110073   0865'.
111300         10  FILLER      PIC X(13) VALUE '110086   0552'.
111400         10  FILLER      PIC X(13) VALUE '110092   1029'.
111500         10  FILLER      PIC X(13) VALUE '110100   0493'.
111600         10  FILLER      PIC X(13) VALUE '110101   0477'.
111700         10  FILLER      PIC X(13) VALUE '110104   1217'.
111800         10  FILLER      PIC X(13) VALUE '110109   0854'.
111900         10  FILLER      PIC X(13) VALUE '110111   0398'.
112000         10  FILLER      PIC X(13) VALUE '110112   0226'.
112100         10  FILLER      PIC X(13) VALUE '110113   0477'.
112200         10  FILLER      PIC X(13) VALUE '110121   0521'.
112300         10  FILLER      PIC X(13) VALUE '110124   1497'.
112400         10  FILLER      PIC X(13) VALUE '110130   0216'.
112500         10  FILLER      PIC X(13) VALUE '110132   0755'.
112600         10  FILLER      PIC X(13) VALUE '110135   0634'.
112700         10  FILLER      PIC X(13) VALUE '110142   0625'.
112800         10  FILLER      PIC X(13) VALUE '110146   0474'.
112900         10  FILLER      PIC X(13) VALUE '110153   0863'.
113000         10  FILLER      PIC X(13) VALUE '110183   0880'.
113100         10  FILLER      PIC X(13) VALUE '110187   0841'.
113200         10  FILLER      PIC X(13) VALUE '110189   1120'.
113300         10  FILLER      PIC X(13) VALUE '110190   0331'.
113400         10  FILLER      PIC X(13) VALUE '110194   0572'.
113500         10  FILLER      PIC X(13) VALUE '110200   0751'.
113600         10  FILLER      PIC X(13) VALUE '110203   0674'.
113700         10  FILLER      PIC X(13) VALUE '110205   0460'.
113800         10  FILLER      PIC X(13) VALUE '110212   1127'.
113900         10  FILLER      PIC X(13) VALUE '110230   1562'.
114000         10  FILLER      PIC X(13) VALUE '120004   1044'.
114100         10  FILLER      PIC X(13) VALUE '120010   1203'.
114200         10  FILLER      PIC X(13) VALUE '120014   1218'.
114300         10  FILLER      PIC X(13) VALUE '120019   0756'.
114400         10  FILLER      PIC X(13) VALUE '120028   0527'.
114500         10  FILLER      PIC X(13) VALUE '130024   0003'.
114600         10  FILLER      PIC X(13) VALUE '130025   0653'.
114700         10  FILLER      PIC X(13) VALUE '130063   0092'.
114800         10  FILLER      PIC X(13) VALUE '130065   0395'.
114900         10  FILLER      PIC X(13) VALUE '130066   0191'.
115000         10  FILLER      PIC X(13) VALUE '130067   0006'.
115100         10  FILLER      PIC X(13) VALUE '140001   1405'.
115200         10  FILLER      PIC X(13) VALUE '140019   0559'.
115300         10  FILLER      PIC X(13) VALUE '140026   1425'.
115400         10  FILLER      PIC X(13) VALUE '140059   0805'.
115500         10  FILLER      PIC X(13) VALUE '140068   1357'.
115600         10  FILLER      PIC X(13) VALUE '140077   0691'.
115700         10  FILLER      PIC X(13) VALUE '140089   0990'.
115800         10  FILLER      PIC X(13) VALUE '140095   1295'.
115900         10  FILLER      PIC X(13) VALUE '140100   0271'.
116000         10  FILLER      PIC X(13) VALUE '140110   1443'.
116100         10  FILLER      PIC X(13) VALUE '140137   0409'.
116200         10  FILLER      PIC X(13) VALUE '140143   1519'.
116300         10  FILLER      PIC X(13) VALUE '140145   0732'.
116400         10  FILLER      PIC X(13) VALUE '140147   1088'.
116500         10  FILLER      PIC X(13) VALUE '140151   1543'.
116600         10  FILLER      PIC X(13) VALUE '140161   0752'.
116700         10  FILLER      PIC X(13) VALUE '140167   0974'.
116800         10  FILLER      PIC X(13) VALUE '140210   1114'.
116900         10  FILLER      PIC X(13) VALUE '140234   1540'.
117000         10  FILLER      PIC X(13) VALUE '140294   0910'.
117100         10  FILLER      PIC X(13) VALUE '140300   0492'.
117200         10  FILLER      PIC X(13) VALUE '140301   0136'.
117300         10  FILLER      PIC X(13) VALUE '140305   0001'.
117400         10  FILLER      PIC X(13) VALUE '140306   0020'.
117500         10  FILLER      PIC X(13) VALUE '150001   1253'.
117600         10  FILLER      PIC X(13) VALUE '150022   0976'.
117700         10  FILLER      PIC X(13) VALUE '150037   1525'.
117800         10  FILLER      PIC X(13) VALUE '150038   0849'.
117900         10  FILLER      PIC X(13) VALUE '150045   0757'.
118000         10  FILLER      PIC X(13) VALUE '150061   0896'.
118100         10  FILLER      PIC X(13) VALUE '150064   1013'.
118200         10  FILLER      PIC X(13) VALUE '150072   0948'.
118300         10  FILLER      PIC X(13) VALUE '150075   1491'.
118400         10  FILLER      PIC X(13) VALUE '150076   1189'.
118500         10  FILLER      PIC X(13) VALUE '150091   0900'.
118600         10  FILLER      PIC X(13) VALUE '150097   1418'.
118700         10  FILLER      PIC X(13) VALUE '150101   0705'.
118800         10  FILLER      PIC X(13) VALUE '150102   0515'.
118900         10  FILLER      PIC X(13) VALUE '150104   0985'.
119000         10  FILLER      PIC X(13) VALUE '150129   0778'.
119100         10  FILLER      PIC X(13) VALUE '150146   1022'.
119200         10  FILLER      PIC X(13) VALUE '150149   0027'.
119300         10  FILLER      PIC X(13) VALUE '150150   1143'.
119400         10  FILLER      PIC X(13) VALUE '150157   1545'.
119500         10  FILLER      PIC X(13) VALUE '150160   0888'.
119600         10  FILLER      PIC X(13) VALUE '150163   0488'.
119700         10  FILLER      PIC X(13) VALUE '150164   0630'.
119800         10  FILLER      PIC X(13) VALUE '150165   0374'.
119900         10  FILLER      PIC X(13) VALUE '150166   0337'.
120000         10  FILLER      PIC X(13) VALUE '150167   0937'.
120100         10  FILLER      PIC X(13) VALUE '150168   1124'.
120200         10  FILLER      PIC X(13) VALUE '150170   0013'.
120300         10  FILLER      PIC X(13) VALUE '150172   0155'.
120400         10  FILLER      PIC X(13) VALUE '150175   1064'.
120500         10  FILLER      PIC X(13) VALUE '150176   0966'.
120600         10  FILLER      PIC X(13) VALUE '150177   0530'.
120700         10  FILLER      PIC X(13) VALUE '160001   1510'.
120800         10  FILLER      PIC X(13) VALUE '160005   0900'.
120900         10  FILLER      PIC X(13) VALUE '160008   0959'.
121000         10  FILLER      PIC X(13) VALUE '160013   0777'.
121100         10  FILLER      PIC X(13) VALUE '160032   1051'.
121200         10  FILLER      PIC X(13) VALUE '160040   0569'.
121300         10  FILLER      PIC X(13) VALUE '160101   0535'.
121400         10  FILLER      PIC X(13) VALUE '160112   1280'.
121500         10  FILLER      PIC X(13) VALUE '160122   1021'.
121600         10  FILLER      PIC X(13) VALUE '160124   0516'.
121700         10  FILLER      PIC X(13) VALUE '160147   0687'.
121800         10  FILLER      PIC X(13) VALUE '170001   1282'.
121900         10  FILLER      PIC X(13) VALUE '170009   0809'.
122000         10  FILLER      PIC X(13) VALUE '170010   0530'.
122100         10  FILLER      PIC X(13) VALUE '170014   0731'.
122200         10  FILLER      PIC X(13) VALUE '170017   0761'.
122300         10  FILLER      PIC X(13) VALUE '170023   1027'.
122400         10  FILLER      PIC X(13) VALUE '170027   0782'.
122500         10  FILLER      PIC X(13) VALUE '170033   0244'.
122600         10  FILLER      PIC X(13) VALUE '170039   0208'.
122700         10  FILLER      PIC X(13) VALUE '170058   0834'.
122800         10  FILLER      PIC X(13) VALUE '170068   0553'.
122900         10  FILLER      PIC X(13) VALUE '170074   0630'.
123000         10  FILLER      PIC X(13) VALUE '170075   0163'.
123100         10  FILLER      PIC X(13) VALUE '170094   0441'.
123200         10  FILLER      PIC X(13) VALUE '170103   1450'.
123300         10  FILLER      PIC X(13) VALUE '170105   0600'.
123400         10  FILLER      PIC X(13) VALUE '170109   0295'.
123500         10  FILLER      PIC X(13) VALUE '170110   0135'.
123600         10  FILLER      PIC X(13) VALUE '170120   1412'.
123700         10  FILLER      PIC X(13) VALUE '170133   0812'.
123800         10  FILLER      PIC X(13) VALUE '170145   1327'.
123900         10  FILLER      PIC X(13) VALUE '170150   0529'.
124000         10  FILLER      PIC X(13) VALUE '170166   0507'.
124100         10  FILLER      PIC X(13) VALUE '170175   0971'.
124200         10  FILLER      PIC X(13) VALUE '170183   0625'.
124300         10  FILLER      PIC X(13) VALUE '170186   1461'.
124400         10  FILLER      PIC X(13) VALUE '170187   0278'.
124500         10  FILLER      PIC X(13) VALUE '170188   0308'.
124600         10  FILLER      PIC X(13) VALUE '170190   0115'.
124700         10  FILLER      PIC X(13) VALUE '170191   0755'.
124800         10  FILLER      PIC X(13) VALUE '170194   0231'.
124900         10  FILLER      PIC X(13) VALUE '170195   0185'.
125000         10  FILLER      PIC X(13) VALUE '170196   0596'.
125100         10  FILLER      PIC X(13) VALUE '170197   1590'.
125200         10  FILLER      PIC X(13) VALUE '170198   0113'.
125300         10  FILLER      PIC X(13) VALUE '170199   0053'.
125400         10  FILLER      PIC X(13) VALUE '170200   0907'.
125500         10  FILLER      PIC X(13) VALUE '180004   1081'.
125600         10  FILLER      PIC X(13) VALUE '180016   1214'.
125700         10  FILLER      PIC X(13) VALUE '180019   1315'.
125800         10  FILLER      PIC X(13) VALUE '180020   1294'.
125900         10  FILLER      PIC X(13) VALUE '180024   0880'.
126000         10  FILLER      PIC X(13) VALUE '180025   1274'.
126100         10  FILLER      PIC X(13) VALUE '180043   1389'.
126200         10  FILLER      PIC X(13) VALUE '180046   0506'.
126300         10  FILLER      PIC X(13) VALUE '180049   1467'.
126400         10  FILLER      PIC X(13) VALUE '180053   0771'.
126500         10  FILLER      PIC X(13) VALUE '180064   1021'.
126600         10  FILLER      PIC X(13) VALUE '180066   0987'.
126700         10  FILLER      PIC X(13) VALUE '180069   1465'.
126800         10  FILLER      PIC X(13) VALUE '180070   1242'.
126900         10  FILLER      PIC X(13) VALUE '180078   1424'.
127000         10  FILLER      PIC X(13) VALUE '180079   0955'.
127100         10  FILLER      PIC X(13) VALUE '180092   1278'.
127200         10  FILLER      PIC X(13) VALUE '180095   0832'.
127300         10  FILLER      PIC X(13) VALUE '180101   0940'.
127400         10  FILLER      PIC X(13) VALUE '180105   1385'.
127500         10  FILLER      PIC X(13) VALUE '180106   1097'.
127600         10  FILLER      PIC X(13) VALUE '180115   0642'.
127700         10  FILLER      PIC X(13) VALUE '180117   0533'.
127800         10  FILLER      PIC X(13) VALUE '180128   1329'.
127900         10  FILLER      PIC X(13) VALUE '180138   1485'.
128000         10  FILLER      PIC X(13) VALUE '180149   0980'.
128100         10  FILLER      PIC X(13) VALUE '190001   0991'.
128200         10  FILLER      PIC X(13) VALUE '190003   1101'.
128300         10  FILLER      PIC X(13) VALUE '190005   1143'.
128400         10  FILLER      PIC X(13) VALUE '190006   0497'.
128500         10  FILLER      PIC X(13) VALUE '190007   1165'.
128600         10  FILLER      PIC X(13) VALUE '190009   0180'.
128700         10  FILLER      PIC X(13) VALUE '190011   0647'.
128800         10  FILLER      PIC X(13) VALUE '190013   1543'.
128900         10  FILLER      PIC X(13) VALUE '190014   1386'.
129000         10  FILLER      PIC X(13) VALUE '190025   0985'.
129100         10  FILLER      PIC X(13) VALUE '190034   0920'.
129200         10  FILLER      PIC X(13) VALUE '190037   0014'.
129300         10  FILLER      PIC X(13) VALUE '190044   1384'.
129400         10  FILLER      PIC X(13) VALUE '190050   1093'.
129500         10  FILLER      PIC X(13) VALUE '190079   0613'.
129600         10  FILLER      PIC X(13) VALUE '190081   0713'.
129700         10  FILLER      PIC X(13) VALUE '190088   0645'.
129800         10  FILLER      PIC X(13) VALUE '190090   0673'.
129900         10  FILLER      PIC X(13) VALUE '190099   1023'.
130000         10  FILLER      PIC X(13) VALUE '190106   0533'.
130100         10  FILLER      PIC X(13) VALUE '190114   0991'.
130200         10  FILLER      PIC X(13) VALUE '190116   0797'.
130300         10  FILLER      PIC X(13) VALUE '190118   0706'.
130400         10  FILLER      PIC X(13) VALUE '190122   0426'.
130500         10  FILLER      PIC X(13) VALUE '190128   0278'.
130600         10  FILLER      PIC X(13) VALUE '190133   0151'.
130700         10  FILLER      PIC X(13) VALUE '190140   0927'.
130800         10  FILLER      PIC X(13) VALUE '190145   0524'.
130900         10  FILLER      PIC X(13) VALUE '190151   0456'.
131000         10  FILLER      PIC X(13) VALUE '190161   0114'.
131100         10  FILLER      PIC X(13) VALUE '190175   1238'.
131200         10  FILLER      PIC X(13) VALUE '190183   0767'.
131300         10  FILLER      PIC X(13) VALUE '190184   0289'.
131400         10  FILLER      PIC X(13) VALUE '190190   0435'.
131500         10  FILLER      PIC X(13) VALUE '190199   0020'.
131600         10  FILLER      PIC X(13) VALUE '190201   0443'.
131700         10  FILLER      PIC X(13) VALUE '190208   0349'.
131800         10  FILLER      PIC X(13) VALUE '190218   0569'.
131900         10  FILLER      PIC X(13) VALUE '190241   0075'.
132000         10  FILLER      PIC X(13) VALUE '190242   1433'.
132100         10  FILLER      PIC X(13) VALUE '190245   0099'.
132200         10  FILLER      PIC X(13) VALUE '190246   0404'.
132300         10  FILLER      PIC X(13) VALUE '190250   1490'.
132400         10  FILLER      PIC X(13) VALUE '190251   0036'.
132500         10  FILLER      PIC X(13) VALUE '190255   0014'.
132600         10  FILLER      PIC X(13) VALUE '190256   0004'.
132700         10  FILLER      PIC X(13) VALUE '190257   0249'.
132800         10  FILLER      PIC X(13) VALUE '190259   0292'.
132900         10  FILLER      PIC X(13) VALUE '190261   0004'.
133000         10  FILLER      PIC X(13) VALUE '190263   1258'.
133100         10  FILLER      PIC X(13) VALUE '190266   0144'.
133200         10  FILLER      PIC X(13) VALUE '190267   0054'.
133300         10  FILLER      PIC X(13) VALUE '190268   0027'.
133400         10  FILLER      PIC X(13) VALUE '190270   0346'.
133500         10  FILLER      PIC X(13) VALUE '190273   0031'.
133600         10  FILLER      PIC X(13) VALUE '190278   0352'.
133700         10  FILLER      PIC X(13) VALUE '190297   0264'.
133800         10  FILLER      PIC X(13) VALUE '190298   0438'.
133900         10  FILLER      PIC X(13) VALUE '190303   0152'.
134000         10  FILLER      PIC X(13) VALUE '190307   0009'.
134100         10  FILLER      PIC X(13) VALUE '200002   1024'.
134200         10  FILLER      PIC X(13) VALUE '200018   1293'.
134300         10  FILLER      PIC X(13) VALUE '200025   0660'.
134400         10  FILLER      PIC X(13) VALUE '200031   1098'.
134500         10  FILLER      PIC X(13) VALUE '200032   0173'.
134600         10  FILLER      PIC X(13) VALUE '200037   1199'.
134700         10  FILLER      PIC X(13) VALUE '200040   1277'.
134800         10  FILLER      PIC X(13) VALUE '200041   0835'.
134900         10  FILLER      PIC X(13) VALUE '200050   1582'.
135000         10  FILLER      PIC X(13) VALUE '200052   0792'.
135100         10  FILLER      PIC X(13) VALUE '210017   1125'.
135200         10  FILLER      PIC X(13) VALUE '210045   0338'.
135300         10  FILLER      PIC X(13) VALUE '210060   1136'.
135400         10  FILLER      PIC X(13) VALUE '220050   0716'.
135500         10  FILLER      PIC X(13) VALUE '220051   1196'.
135600         10  FILLER      PIC X(13) VALUE '220058   0476'.
135700         10  FILLER      PIC X(13) VALUE '220065   1508'.
135800         10  FILLER      PIC X(13) VALUE '220075   0461'.
135900         10  FILLER      PIC X(13) VALUE '220083   1343'.
136000         10  FILLER      PIC X(13) VALUE '220098   1028'.
136100         10  FILLER      PIC X(13) VALUE '220177   0187'.
136200         10  FILLER      PIC X(13) VALUE '230003   0974'.
136300         10  FILLER      PIC X(13) VALUE '230013   0765'.
136400         10  FILLER      PIC X(13) VALUE '230015   0808'.
136500         10  FILLER      PIC X(13) VALUE '230035   1374'.
136600         10  FILLER      PIC X(13) VALUE '230037   1534'.
136700         10  FILLER      PIC X(13) VALUE '230040   1494'.
136800         10  FILLER      PIC X(13) VALUE '230055   1506'.
136900         10  FILLER      PIC X(13) VALUE '230071   0521'.
137000         10  FILLER      PIC X(13) VALUE '230078   0393'.
137100         10  FILLER      PIC X(13) VALUE '230085   0450'.
137200         10  FILLER      PIC X(13) VALUE '230093   0998'.
137300         10  FILLER      PIC X(13) VALUE '230095   1550'.
137400         10  FILLER      PIC X(13) VALUE '230096   0786'.
137500         10  FILLER      PIC X(13) VALUE '230100   1034'.
137600         10  FILLER      PIC X(13) VALUE '230101   0964'.
137700         10  FILLER      PIC X(13) VALUE '230106   1329'.
137800         10  FILLER      PIC X(13) VALUE '230108   0686'.
137900         10  FILLER      PIC X(13) VALUE '230110   1171'.
138000         10  FILLER      PIC X(13) VALUE '230118   0734'.
138100         10  FILLER      PIC X(13) VALUE '230133   0800'.
138200         10  FILLER      PIC X(13) VALUE '230144   0122'.
138300         10  FILLER      PIC X(13) VALUE '230174   0857'.
138400         10  FILLER      PIC X(13) VALUE '230180   1066'.
138500         10  FILLER      PIC X(13) VALUE '230208   0679'.
138600         10  FILLER      PIC X(13) VALUE '230239   1523'.
138700         10  FILLER      PIC X(13) VALUE '230241   1048'.
138800         10  FILLER      PIC X(13) VALUE '230259   1437'.
138900         10  FILLER      PIC X(13) VALUE '230264   0018'.
139000         10  FILLER      PIC X(13) VALUE '230275   0094'.
139100         10  FILLER      PIC X(13) VALUE '230279   0066'.
139200         10  FILLER      PIC X(13) VALUE '230297   1427'.
139300         10  FILLER      PIC X(13) VALUE '230301   0221'.
139400         10  FILLER      PIC X(13) VALUE '240006   0515'.
139500         10  FILLER      PIC X(13) VALUE '240014   0686'.
139600         10  FILLER      PIC X(13) VALUE '240018   0808'.
139700         10  FILLER      PIC X(13) VALUE '240019   1269'.
139800         10  FILLER      PIC X(13) VALUE '240020   1441'.
139900         10  FILLER      PIC X(13) VALUE '240022   0461'.
140000         10  FILLER      PIC X(13) VALUE '240043   1296'.
140100         10  FILLER      PIC X(13) VALUE '240044   1433'.
140200         10  FILLER      PIC X(13) VALUE '240050   1597'.
140300         10  FILLER      PIC X(13) VALUE '240052   1173'.
140400         10  FILLER      PIC X(13) VALUE '240059   0636'.
140500         10  FILLER      PIC X(13) VALUE '240064   1136'.
140600         10  FILLER      PIC X(13) VALUE '240066   1466'.
140700         10  FILLER      PIC X(13) VALUE '240069   0977'.
140800         10  FILLER      PIC X(13) VALUE '240071   0824'.
140900         10  FILLER      PIC X(13) VALUE '240076   1166'.
141000         10  FILLER      PIC X(13) VALUE '240084   0958'.
141100         10  FILLER      PIC X(13) VALUE '240088   1588'.
141200         10  FILLER      PIC X(13) VALUE '240101   0919'.
141300         10  FILLER      PIC X(13) VALUE '240117   1541'.
141400         10  FILLER      PIC X(13) VALUE '240141   0719'.
141500         10  FILLER      PIC X(13) VALUE '240166   1012'.
141600         10  FILLER      PIC X(13) VALUE '240187   0755'.
141700         10  FILLER      PIC X(13) VALUE '240196   0124'.
141800         10  FILLER      PIC X(13) VALUE '240206   0081'.
141900         10  FILLER      PIC X(13) VALUE '240214   0802'.
142000         10  FILLER      PIC X(13) VALUE '250002   0584'.
142100         10  FILLER      PIC X(13) VALUE '250006   1397'.
142200         10  FILLER      PIC X(13) VALUE '250010   0641'.
142300         10  FILLER      PIC X(13) VALUE '250012   0423'.
142400         10  FILLER      PIC X(13) VALUE '250015   1347'.
142500         10  FILLER      PIC X(13) VALUE '250017   0546'.
142600         10  FILLER      PIC X(13) VALUE '250018   0006'.
142700         10  FILLER      PIC X(13) VALUE '250020   0857'.
142800         10  FILLER      PIC X(13) VALUE '250023   0007'.
142900         10  FILLER      PIC X(13) VALUE '250025   1586'.
143000         10  FILLER      PIC X(13) VALUE '250027   0312'.
143100         10  FILLER      PIC X(13) VALUE '250036   0753'.
143200         10  FILLER      PIC X(13) VALUE '250038   0522'.
143300         10  FILLER      PIC X(13) VALUE '250043   0500'.
143400         10  FILLER      PIC X(13) VALUE '250044   0856'.
143500         10  FILLER      PIC X(13) VALUE '250049   0755'.
143600         10  FILLER      PIC X(13) VALUE '250050   1255'.
143700         10  FILLER      PIC X(13) VALUE '250051   0128'.
143800         10  FILLER      PIC X(13) VALUE '250057   1316'.
143900         10  FILLER      PIC X(13) VALUE '250059   0884'.
144000         10  FILLER      PIC X(13) VALUE '250060   0191'.
144100         10  FILLER      PIC X(13) VALUE '250061   0342'.
144200         10  FILLER      PIC X(13) VALUE '250067   0833'.
144300         10  FILLER      PIC X(13) VALUE '250077   1002'.
144400         10  FILLER      PIC X(13) VALUE '250079   0192'.
144500         10  FILLER      PIC X(13) VALUE '250081   0833'.
144600         10  FILLER      PIC X(13) VALUE '250084   1430'.
144700         10  FILLER      PIC X(13) VALUE '250085   0468'.
144800         10  FILLER      PIC X(13) VALUE '250095   0595'.
144900         10  FILLER      PIC X(13) VALUE '250117   0998'.
145000         10  FILLER      PIC X(13) VALUE '250124   0853'.
145100         10  FILLER      PIC X(13) VALUE '250126   0576'.
145200         10  FILLER      PIC X(13) VALUE '250127   0017'.
145300         10  FILLER      PIC X(13) VALUE '250128   1028'.
145400         10  FILLER      PIC X(13) VALUE '250134   0118'.
145500         10  FILLER      PIC X(13) VALUE '250136   0057'.
145600         10  FILLER      PIC X(13) VALUE '250151   0140'.
145700         10  FILLER      PIC X(13) VALUE '250152   0003'.
145800         10  FILLER      PIC X(13) VALUE '250162   0810'.
145900         10  FILLER      PIC X(13) VALUE '250164   0010'.
146000         10  FILLER      PIC X(13) VALUE '250165   0030'.
146100         10  FILLER      PIC X(13) VALUE '250166   0007'.
146200         10  FILLER      PIC X(13) VALUE '260004   0211'.
146300         10  FILLER      PIC X(13) VALUE '260015   1445'.
146400         10  FILLER      PIC X(13) VALUE '260022   1559'.
146500         10  FILLER      PIC X(13) VALUE '260024   0844'.
146600         10  FILLER      PIC X(13) VALUE '260034   0742'.
146700         10  FILLER      PIC X(13) VALUE '260050   0501'.
146800         10  FILLER      PIC X(13) VALUE '260057   0969'.
146900         10  FILLER      PIC X(13) VALUE '260059   1176'.
147000         10  FILLER      PIC X(13) VALUE '260061   0471'.
147100         10  FILLER      PIC X(13) VALUE '260070   0937'.
147200         10  FILLER      PIC X(13) VALUE '260074   1273'.
147300         10  FILLER      PIC X(13) VALUE '260080   0208'.
147400         10  FILLER      PIC X(13) VALUE '260097   1038'.
147500         10  FILLER      PIC X(13) VALUE '260102   0876'.
147600         10  FILLER      PIC X(13) VALUE '260115   0741'.
147700         10  FILLER      PIC X(13) VALUE '260142   1024'.
147800         10  FILLER      PIC X(13) VALUE '260147   0268'.
147900         10  FILLER      PIC X(13) VALUE '260160   0705'.
148000         10  FILLER      PIC X(13) VALUE '260162   1384'.
148100         10  FILLER      PIC X(13) VALUE '260175   1327'.
148200         10  FILLER      PIC X(13) VALUE '260195   1430'.
148300         10  FILLER      PIC X(13) VALUE '260207   0462'.
148400         10  FILLER      PIC X(13) VALUE '260209   0280'.
148500         10  FILLER      PIC X(13) VALUE '260211   0089'.
148600         10  FILLER      PIC X(13) VALUE '260214   1104'.
148700         10  FILLER      PIC X(13) VALUE '260219   1141'.
148800         10  FILLER      PIC X(13) VALUE '270032   0483'.
148900         10  FILLER      PIC X(13) VALUE '270074   0246'.
149000         10  FILLER      PIC X(13) VALUE '270086   0235'.
149100         10  FILLER      PIC X(13) VALUE '270087   0291'.
149200         10  FILLER      PIC X(13) VALUE '280105   1023'.
149300         10  FILLER      PIC X(13) VALUE '280111   1126'.
149400         10  FILLER      PIC X(13) VALUE '280119   0048'.
149500         10  FILLER      PIC X(13) VALUE '280127   0323'.
149600         10  FILLER      PIC X(13) VALUE '280129   0534'.
149700         10  FILLER      PIC X(13) VALUE '280131   0265'.
149800         10  FILLER      PIC X(13) VALUE '280132   1314'.
149900         10  FILLER      PIC X(13) VALUE '280133   0228'.
150000         10  FILLER      PIC X(13) VALUE '290002   0110'.
150100         10  FILLER      PIC X(13) VALUE '290006   0916'.
150200         10  FILLER      PIC X(13) VALUE '290008   0772'.
150300         10  FILLER      PIC X(13) VALUE '290020   0089'.
150400         10  FILLER      PIC X(13) VALUE '290042   0139'.
150500         10  FILLER      PIC X(13) VALUE '290049   1459'.
150600         10  FILLER      PIC X(13) VALUE '290051   0395'.
150700         10  FILLER      PIC X(13) VALUE '310058   0750'.
150800         10  FILLER      PIC X(13) VALUE '310118   1228'.
150900         10  FILLER      PIC X(13) VALUE '310120   0607'.
151000         10  FILLER      PIC X(13) VALUE '310129   0140'.
151100         10  FILLER      PIC X(13) VALUE '320003   0831'.
151200         10  FILLER      PIC X(13) VALUE '320011   0849'.
151300         10  FILLER      PIC X(13) VALUE '320013   0853'.
151400         10  FILLER      PIC X(13) VALUE '320014   0880'.
151500         10  FILLER      PIC X(13) VALUE '320016   0995'.
151600         10  FILLER      PIC X(13) VALUE '320017   1307'.
151700         10  FILLER      PIC X(13) VALUE '320022   1425'.
151800         10  FILLER      PIC X(13) VALUE '320030   0433'.
151900         10  FILLER      PIC X(13) VALUE '320033   0456'.
152000         10  FILLER      PIC X(13) VALUE '320037   0253'.
152100         10  FILLER      PIC X(13) VALUE '320038   1187'.
152200         10  FILLER      PIC X(13) VALUE '320057   0049'.
152300         10  FILLER      PIC X(13) VALUE '320058   0060'.
152400         10  FILLER      PIC X(13) VALUE '320059   0711'.
152500         10  FILLER      PIC X(13) VALUE '320060   0134'.
152600         10  FILLER      PIC X(13) VALUE '320061   0809'.
152700         10  FILLER      PIC X(13) VALUE '320062   0202'.
152800         10  FILLER      PIC X(13) VALUE '320065   1028'.
152900         10  FILLER      PIC X(13) VALUE '320067   0133'.
153000         10  FILLER      PIC X(13) VALUE '320069   0047'.
153100         10  FILLER      PIC X(13) VALUE '320070   0116'.
153200         10  FILLER      PIC X(13) VALUE '320074   1337'.
153300         10  FILLER      PIC X(13) VALUE '320083   1589'.
153400         10  FILLER      PIC X(13) VALUE '320084   0495'.
153500         10  FILLER      PIC X(13) VALUE '320086   0784'.
153600         10  FILLER      PIC X(13) VALUE '320087   0147'.
153700         10  FILLER      PIC X(13) VALUE '330008   0692'.
153800         10  FILLER      PIC X(13) VALUE '330029   0118'.
153900         10  FILLER      PIC X(13) VALUE '330033   1027'.
154000         10  FILLER      PIC X(13) VALUE '330037   0618'.
154100         10  FILLER      PIC X(13) VALUE '330049   1377'.
154200         10  FILLER      PIC X(13) VALUE '330053   1183'.
154300         10  FILLER      PIC X(13) VALUE '330079   1192'.
154400         10  FILLER      PIC X(13) VALUE '330084   1262'.
154500         10  FILLER      PIC X(13) VALUE '330086   1288'.
154600         10  FILLER      PIC X(13) VALUE '330088   1012'.
154700         10  FILLER      PIC X(13) VALUE '330096   1052'.
154800         10  FILLER      PIC X(13) VALUE '330100   0134'.
154900         10  FILLER      PIC X(13) VALUE '330111   0643'.
155000         10  FILLER      PIC X(13) VALUE '330115   1472'.
155100         10  FILLER      PIC X(13) VALUE '330132   1099'.
155200         10  FILLER      PIC X(13) VALUE '330144   0535'.
155300         10  FILLER      PIC X(13) VALUE '330151   0985'.
155400         10  FILLER      PIC X(13) VALUE '330166   0064'.
155500         10  FILLER      PIC X(13) VALUE '330177   0534'.
155600         10  FILLER      PIC X(13) VALUE '330189   0005'.
155700         10  FILLER      PIC X(13) VALUE '330197   1368'.
155800         10  FILLER      PIC X(13) VALUE '330205   1143'.
155900         10  FILLER      PIC X(13) VALUE '330211   1177'.
156000         10  FILLER      PIC X(13) VALUE '330213   0585'.
156100         10  FILLER      PIC X(13) VALUE '330223   1252'.
156200         10  FILLER      PIC X(13) VALUE '330224   1104'.
156300         10  FILLER      PIC X(13) VALUE '330229   0953'.
156400         10  FILLER      PIC X(13) VALUE '330238   1249'.
156500         10  FILLER      PIC X(13) VALUE '330249   1073'.
156600         10  FILLER      PIC X(13) VALUE '330263   0615'.
156700         10  FILLER      PIC X(13) VALUE '330268   0311'.
156800         10  FILLER      PIC X(13) VALUE '330290   0013'.
156900         10  FILLER      PIC X(13) VALUE '330385   1148'.
157000         10  FILLER      PIC X(13) VALUE '330403   0001'.
157100         10  FILLER      PIC X(13) VALUE '330404   0769'.
157200         10  FILLER      PIC X(13) VALUE '330405   0491'.
157300         10  FILLER      PIC X(13) VALUE '330406   0909'.
157400         10  FILLER      PIC X(13) VALUE '340011   1171'.
157500         10  FILLER      PIC X(13) VALUE '340036   0743'.
157600         10  FILLER      PIC X(13) VALUE '340037   1095'.
157700         10  FILLER      PIC X(13) VALUE '340038   1428'.
157800         10  FILLER      PIC X(13) VALUE '340049   0615'.
157900         10  FILLER      PIC X(13) VALUE '340055   1072'.
158000         10  FILLER      PIC X(13) VALUE '340084   0442'.
158100         10  FILLER      PIC X(13) VALUE '340085   1470'.
158200         10  FILLER      PIC X(13) VALUE '340087   1102'.
158300         10  FILLER      PIC X(13) VALUE '340120   0860'.
158400         10  FILLER      PIC X(13) VALUE '340127   1192'.
158500         10  FILLER      PIC X(13) VALUE '340133   1219'.
158600         10  FILLER      PIC X(13) VALUE '340148   0316'.
158700         10  FILLER      PIC X(13) VALUE '340156   0165'.
158800         10  FILLER      PIC X(13) VALUE '340159   0928'.
158900         10  FILLER      PIC X(13) VALUE '340160   1236'.
159000         10  FILLER      PIC X(13) VALUE '340168   0100'.
159100         10  FILLER      PIC X(13) VALUE '340186   0044'.
159200         10  FILLER      PIC X(13) VALUE '350063   0160'.
159300         10  FILLER      PIC X(13) VALUE '360002   1302'.
159400         10  FILLER      PIC X(13) VALUE '360013   1108'.
159500         10  FILLER      PIC X(13) VALUE '360014   1272'.
159600         10  FILLER      PIC X(13) VALUE '360032   1136'.
159700         10  FILLER      PIC X(13) VALUE '360038   0005'.
159800         10  FILLER      PIC X(13) VALUE '360044   1415'.
159900         10  FILLER      PIC X(13) VALUE '360046   1172'.
160000         10  FILLER      PIC X(13) VALUE '360058   0813'.
160100         10  FILLER      PIC X(13) VALUE '360071   0778'.
160200         10  FILLER      PIC X(13) VALUE '360089   1137'.
160300         10  FILLER      PIC X(13) VALUE '360092   0720'.
160400         10  FILLER      PIC X(13) VALUE '360107   0915'.
160500         10  FILLER      PIC X(13) VALUE '360109   1289'.
160600         10  FILLER      PIC X(13) VALUE '360116   0616'.
160700         10  FILLER      PIC X(13) VALUE '360121   1250'.
160800         10  FILLER      PIC X(13) VALUE '360130   0299'.
160900         10  FILLER      PIC X(13) VALUE '360148   0406'.
161000         10  FILLER      PIC X(13) VALUE '360153   0513'.
161100         10  FILLER      PIC X(13) VALUE '360156   0976'.
161200         10  FILLER      PIC X(13) VALUE '360170   1431'.
161300         10  FILLER      PIC X(13) VALUE '360189   0663'.
161400         10  FILLER      PIC X(13) VALUE '360195   1556'.
161500         10  FILLER      PIC X(13) VALUE '360197   0983'.
161600         10  FILLER      PIC X(13) VALUE '360210   1434'.
161700         10  FILLER      PIC X(13) VALUE '360245   0197'.
161800         10  FILLER      PIC X(13) VALUE '360247   0437'.
161900         10  FILLER      PIC X(13) VALUE '360258   0002'.
162000         10  FILLER      PIC X(13) VALUE '360261   0024'.
162100         10  FILLER      PIC X(13) VALUE '360263   0335'.
162200         10  FILLER      PIC X(13) VALUE '360269   0082'.
162300         10  FILLER      PIC X(13) VALUE '360270   1044'.
162400         10  FILLER      PIC X(13) VALUE '360271   0007'.
162500         10  FILLER      PIC X(13) VALUE '360274   0075'.
162600         10  FILLER      PIC X(13) VALUE '360347   0273'.
162700         10  FILLER      PIC X(13) VALUE '360348   1483'.
162800         10  FILLER      PIC X(13) VALUE '360350   0119'.
162900         10  FILLER      PIC X(13) VALUE '360352   0197'.
163000         10  FILLER      PIC X(13) VALUE '360355   0222'.
163100         10  FILLER      PIC X(13) VALUE '360356   0150'.
163200         10  FILLER      PIC X(13) VALUE '360358   0032'.
163300         10  FILLER      PIC X(13) VALUE '360359   1572'.
163400         10  FILLER      PIC X(13) VALUE '370002   0637'.
163500         10  FILLER      PIC X(13) VALUE '370004   1550'.
163600         10  FILLER      PIC X(13) VALUE '370006   1594'.
163700         10  FILLER      PIC X(13) VALUE '370007   0205'.
163800         10  FILLER      PIC X(13) VALUE '370011   0318'.
163900         10  FILLER      PIC X(13) VALUE '370015   0476'.
164000         10  FILLER      PIC X(13) VALUE '370019   0767'.
164100         10  FILLER      PIC X(13) VALUE '370029   0739'.
164200         10  FILLER      PIC X(13) VALUE '370030   0461'.
164300         10  FILLER      PIC X(13) VALUE '370036   0363'.
164400         10  FILLER      PIC X(13) VALUE '370039   1252'.
164500         10  FILLER      PIC X(13) VALUE '370040   1163'.
164600         10  FILLER      PIC X(13) VALUE '370041   0189'.
164700         10  FILLER      PIC X(13) VALUE '370048   0927'.
164800         10  FILLER      PIC X(13) VALUE '370051   0345'.
164900         10  FILLER      PIC X(13) VALUE '370054   0865'.
165000         10  FILLER      PIC X(13) VALUE '370057   0556'.
165100         10  FILLER      PIC X(13) VALUE '370065   0918'.
165200         10  FILLER      PIC X(13) VALUE '370072   0375'.
165300         10  FILLER      PIC X(13) VALUE '370080   0231'.
165400         10  FILLER      PIC X(13) VALUE '370083   0464'.
165500         10  FILLER      PIC X(13) VALUE '370097   1287'.
165600         10  FILLER      PIC X(13) VALUE '370099   1168'.
165700         10  FILLER      PIC X(13) VALUE '370100   0998'.
165800         10  FILLER      PIC X(13) VALUE '370103   0306'.
165900         10  FILLER      PIC X(13) VALUE '370112   0540'.
166000         10  FILLER      PIC X(13) VALUE '370138   0258'.
166100         10  FILLER      PIC X(13) VALUE '370139   0325'.
166200         10  FILLER      PIC X(13) VALUE '370153   0620'.
166300         10  FILLER      PIC X(13) VALUE '370156   0579'.
166400         10  FILLER      PIC X(13) VALUE '370158   0769'.
166500         10  FILLER      PIC X(13) VALUE '370166   0908'.
166600         10  FILLER      PIC X(13) VALUE '370169   0022'.
166700         10  FILLER      PIC X(13) VALUE '370170   0036'.
166800         10  FILLER      PIC X(13) VALUE '370171   0399'.
166900         10  FILLER      PIC X(13) VALUE '370172   0218'.
167000         10  FILLER      PIC X(13) VALUE '370173   0138'.
167100         10  FILLER      PIC X(13) VALUE '370178   0933'.
167200         10  FILLER      PIC X(13) VALUE '370180   0429'.
167300         10  FILLER      PIC X(13) VALUE '370183   0359'.
167400         10  FILLER      PIC X(13) VALUE '370190   0193'.
167500         10  FILLER      PIC X(13) VALUE '370192   0058'.
167600         10  FILLER      PIC X(13) VALUE '370199   0016'.
167700         10  FILLER      PIC X(13) VALUE '370201   0084'.
167800         10  FILLER      PIC X(13) VALUE '370203   0627'.
167900         10  FILLER      PIC X(13) VALUE '370206   0394'.
168000         10  FILLER      PIC X(13) VALUE '370210   1161'.
168100         10  FILLER      PIC X(13) VALUE '370211   1158'.
168200         10  FILLER      PIC X(13) VALUE '370212   0215'.
168300         10  FILLER      PIC X(13) VALUE '370214   0039'.
168400         10  FILLER      PIC X(13) VALUE '370216   0792'.
168500         10  FILLER      PIC X(13) VALUE '370218   1212'.
168600         10  FILLER      PIC X(13) VALUE '370220   0065'.
168700         10  FILLER      PIC X(13) VALUE '370225   0144'.
168800         10  FILLER      PIC X(13) VALUE '370227   0485'.
168900         10  FILLER      PIC X(13) VALUE '370228   0502'.
169000         10  FILLER      PIC X(13) VALUE '370229   0369'.
169100         10  FILLER      PIC X(13) VALUE '370232   1037'.
169200         10  FILLER      PIC X(13) VALUE '370235   0926'.
169300         10  FILLER      PIC X(13) VALUE '380001   0990'.
169400         10  FILLER      PIC X(13) VALUE '380005   0772'.
169500         10  FILLER      PIC X(13) VALUE '380022   1597'.
169600         10  FILLER      PIC X(13) VALUE '380029   0826'.
169700         10  FILLER      PIC X(13) VALUE '380033   0592'.
169800         10  FILLER      PIC X(13) VALUE '380037   1101'.
169900         10  FILLER      PIC X(13) VALUE '380038   1565'.
170000         10  FILLER      PIC X(13) VALUE '380040   1027'.
170100         10  FILLER      PIC X(13) VALUE '380052   1421'.
170200         10  FILLER      PIC X(13) VALUE '380056   0502'.
170300         10  FILLER      PIC X(13) VALUE '390003   0717'.
170400         10  FILLER      PIC X(13) VALUE '390008   1143'.
170500         10  FILLER      PIC X(13) VALUE '390019   1213'.
170600         10  FILLER      PIC X(13) VALUE '390025   0056'.
170700         10  FILLER      PIC X(13) VALUE '390035   1350'.
170800         10  FILLER      PIC X(13) VALUE '390043   1268'.
170900         10  FILLER      PIC X(13) VALUE '390056   1039'.
171000         10  FILLER      PIC X(13) VALUE '390062   0893'.
171100         10  FILLER      PIC X(13) VALUE '390068   1209'.
171200         10  FILLER      PIC X(13) VALUE '390071   0751'.
171300         10  FILLER      PIC X(13) VALUE '390084   1009'.
171400         10  FILLER      PIC X(13) VALUE '390090   1255'.
171500         10  FILLER      PIC X(13) VALUE '390093   1594'.
171600         10  FILLER      PIC X(13) VALUE '390095   1167'.
171700         10  FILLER      PIC X(13) VALUE '390104   0654'.
171800         10  FILLER      PIC X(13) VALUE '390112   0950'.
171900         10  FILLER      PIC X(13) VALUE '390117   1185'.
172000         10  FILLER      PIC X(13) VALUE '390118   1495'.
172100         10  FILLER      PIC X(13) VALUE '390122   1002'.
172200         10  FILLER      PIC X(13) VALUE '390125   1561'.
172300         10  FILLER      PIC X(13) VALUE '390130   0659'.
172400         10  FILLER      PIC X(13) VALUE '390138   1466'.
172500         10  FILLER      PIC X(13) VALUE '390146   1427'.
172600         10  FILLER      PIC X(13) VALUE '390150   1396'.
172700         10  FILLER      PIC X(13) VALUE '390183   1138'.
172800         10  FILLER      PIC X(13) VALUE '390184   0618'.
172900         10  FILLER      PIC X(13) VALUE '390189   1349'.
173000         10  FILLER      PIC X(13) VALUE '390192   0769'.
173100         10  FILLER      PIC X(13) VALUE '390198   1263'.
173200         10  FILLER      PIC X(13) VALUE '390199   1067'.
173300         10  FILLER      PIC X(13) VALUE '390236   0649'.
173400         10  FILLER      PIC X(13) VALUE '390266   1060'.
173500         10  FILLER      PIC X(13) VALUE '390272   0210'.
173600         10  FILLER      PIC X(13) VALUE '390278   0667'.
173700         10  FILLER      PIC X(13) VALUE '390302   0017'.
173800         10  FILLER      PIC X(13) VALUE '390307   0048'.
173900         10  FILLER      PIC X(13) VALUE '390312   0277'.
174000         10  FILLER      PIC X(13) VALUE '390313   0630'.
174100         10  FILLER      PIC X(13) VALUE '390314   0385'.
174200         10  FILLER      PIC X(13) VALUE '390316   0217'.
174300         10  FILLER      PIC X(13) VALUE '390318   0284'.
174400         10  FILLER      PIC X(13) VALUE '390321   0229'.
174500         10  FILLER      PIC X(13) VALUE '390322   0136'.
174600         10  FILLER      PIC X(13) VALUE '390323   0180'.
174700         10  FILLER      PIC X(13) VALUE '390324   0007'.
174800         10  FILLER      PIC X(13) VALUE '390325   0376'.
174900         10  FILLER      PIC X(13) VALUE '410010   0775'.
175000         10  FILLER      PIC X(13) VALUE '420005   1052'.
175100         10  FILLER      PIC X(13) VALUE '420011   0488'.
175200         10  FILLER      PIC X(13) VALUE '420016   0418'.
175300         10  FILLER      PIC X(13) VALUE '420019   0861'.
175400         10  FILLER      PIC X(13) VALUE '420033   1540'.
175500         10  FILLER      PIC X(13) VALUE '420037   0957'.
175600         10  FILLER      PIC X(13) VALUE '420038   1443'.
175700         10  FILLER      PIC X(13) VALUE '420039   1213'.
175800         10  FILLER      PIC X(13) VALUE '420053   0939'.
175900         10  FILLER      PIC X(13) VALUE '420054   0566'.
176000         10  FILLER      PIC X(13) VALUE '420056   0332'.
176100         10  FILLER      PIC X(13) VALUE '420057   0292'.
176200         10  FILLER      PIC X(13) VALUE '420062   1131'.
176300         10  FILLER      PIC X(13) VALUE '420066   0519'.
176400         10  FILLER      PIC X(13) VALUE '420069   0892'.
176500         10  FILLER      PIC X(13) VALUE '420072   0515'.
176600         10  FILLER      PIC X(13) VALUE '420089   1522'.
176700         10  FILLER      PIC X(13) VALUE '420101   0774'.
176800         10  FILLER      PIC X(13) VALUE '420102   0535'.
176900         10  FILLER      PIC X(13) VALUE '420103   0692'.
177000         10  FILLER      PIC X(13) VALUE '420104   0393'.
177100         10  FILLER      PIC X(13) VALUE '430008   0552'.
177200         10  FILLER      PIC X(13) VALUE '430013   1258'.
177300         10  FILLER      PIC X(13) VALUE '430015   0702'.
177400         10  FILLER      PIC X(13) VALUE '430048   0629'.
177500         10  FILLER      PIC X(13) VALUE '430081   0170'.
177600         10  FILLER      PIC X(13) VALUE '430082   0001'.
177700         10  FILLER      PIC X(13) VALUE '430083   0031'.
177800         10  FILLER      PIC X(13) VALUE '430084   0144'.
177900         10  FILLER      PIC X(13) VALUE '430089   0463'.
178000         10  FILLER      PIC X(13) VALUE '430090   0431'.
178100         10  FILLER      PIC X(13) VALUE '430091   0655'.
178200         10  FILLER      PIC X(13) VALUE '430092   0198'.
178300         10  FILLER      PIC X(13) VALUE '430093   0053'.
178400         10  FILLER      PIC X(13) VALUE '430094   0023'.
178500         10  FILLER      PIC X(13) VALUE '430096   0138'.
178600         10  FILLER      PIC X(13) VALUE '440001   0903'.
178700         10  FILLER      PIC X(13) VALUE '440007   0759'.
178800         10  FILLER      PIC X(13) VALUE '440008   0717'.
178900         10  FILLER      PIC X(13) VALUE '440010   0432'.
179000         10  FILLER      PIC X(13) VALUE '440016   0502'.
179100         10  FILLER      PIC X(13) VALUE '440020   0790'.
179200         10  FILLER      PIC X(13) VALUE '440031   1323'.
179300         10  FILLER      PIC X(13) VALUE '440032   1085'.
179400         10  FILLER      PIC X(13) VALUE '440033   1382'.
179500         10  FILLER      PIC X(13) VALUE '440040   0510'.
179600         10  FILLER      PIC X(13) VALUE '440047   0285'.
179700         10  FILLER      PIC X(13) VALUE '440050   1073'.
179800         10  FILLER      PIC X(13) VALUE '440051   0956'.
179900         10  FILLER      PIC X(13) VALUE '440054   0804'.
180000         10  FILLER      PIC X(13) VALUE '440057   0951'.
180100         10  FILLER      PIC X(13) VALUE '440060   0176'.
180200         10  FILLER      PIC X(13) VALUE '440061   1293'.
180300         10  FILLER      PIC X(13) VALUE '440064   1009'.
180400         10  FILLER      PIC X(13) VALUE '440067   1449'.
180500         10  FILLER      PIC X(13) VALUE '440068   1228'.
180600         10  FILLER      PIC X(13) VALUE '440070   0584'.
180700         10  FILLER      PIC X(13) VALUE '440081   1594'.
180800         10  FILLER      PIC X(13) VALUE '440083   1353'.
180900         10  FILLER      PIC X(13) VALUE '440084   1529'.
181000         10  FILLER      PIC X(13) VALUE '440102   0748'.
181100         10  FILLER      PIC X(13) VALUE '440109   0866'.
181200         10  FILLER      PIC X(13) VALUE '440110   1232'.
181300         10  FILLER      PIC X(13) VALUE '440111   0624'.
181400         10  FILLER      PIC X(13) VALUE '440115   0457'.
181500         10  FILLER      PIC X(13) VALUE '440130   1310'.
181600         10  FILLER      PIC X(13) VALUE '440131   0596'.
181700         10  FILLER      PIC X(13) VALUE '440141   0469'.
181800         10  FILLER      PIC X(13) VALUE '440148   0689'.
181900         10  FILLER      PIC X(13) VALUE '440152   1295'.
182000         10  FILLER      PIC X(13) VALUE '440153   1050'.
182100         10  FILLER      PIC X(13) VALUE '440159   0808'.
182200         10  FILLER      PIC X(13) VALUE '440168   0235'.
182300         10  FILLER      PIC X(13) VALUE '440174   0553'.
182400         10  FILLER      PIC X(13) VALUE '440175   1541'.
182500         10  FILLER      PIC X(13) VALUE '440180   0885'.
182600         10  FILLER      PIC X(13) VALUE '440181   0281'.
182700         10  FILLER      PIC X(13) VALUE '440182   0796'.
182800         10  FILLER      PIC X(13) VALUE '440186   0731'.
182900         10  FILLER      PIC X(13) VALUE '440192   0788'.
183000         10  FILLER      PIC X(13) VALUE '440200   0343'.
183100         10  FILLER      PIC X(13) VALUE '440218   0371'.
183200         10  FILLER      PIC X(13) VALUE '450005   0794'.
183300         10  FILLER      PIC X(13) VALUE '450052   0496'.
183400         10  FILLER      PIC X(13) VALUE '450055   0671'.
183500         10  FILLER      PIC X(13) VALUE '450073   0372'.
183600         10  FILLER      PIC X(13) VALUE '450078   0284'.
183700         10  FILLER      PIC X(13) VALUE '450082   0789'.
183800         10  FILLER      PIC X(13) VALUE '450085   0565'.
183900         10  FILLER      PIC X(13) VALUE '450090   0746'.
184000         10  FILLER      PIC X(13) VALUE '450099   0893'.
184100         10  FILLER      PIC X(13) VALUE '450108   0594'.
184200         10  FILLER      PIC X(13) VALUE '450123   0539'.
184300         10  FILLER      PIC X(13) VALUE '450143   0447'.
184400         10  FILLER      PIC X(13) VALUE '450144   0214'.
184500         10  FILLER      PIC X(13) VALUE '450154   1226'.
184600         10  FILLER      PIC X(13) VALUE '450155   0206'.
184700         10  FILLER      PIC X(13) VALUE '450162   0570'.
184800         10  FILLER      PIC X(13) VALUE '450165   1010'.
184900         10  FILLER      PIC X(13) VALUE '450177   0889'.
185000         10  FILLER      PIC X(13) VALUE '450178   0458'.
185100         10  FILLER      PIC X(13) VALUE '450187   0778'.
185200         10  FILLER      PIC X(13) VALUE '450188   1011'.
185300         10  FILLER      PIC X(13) VALUE '450192   0966'.
185400         10  FILLER      PIC X(13) VALUE '450194   0975'.
185500         10  FILLER      PIC X(13) VALUE '450210   0563'.
185600         10  FILLER      PIC X(13) VALUE '450214   0765'.
185700         10  FILLER      PIC X(13) VALUE '450219   0402'.
185800         10  FILLER      PIC X(13) VALUE '450221   0369'.
185900         10  FILLER      PIC X(13) VALUE '450224   0002'.
186000         10  FILLER      PIC X(13) VALUE '450234   0632'.
186100         10  FILLER      PIC X(13) VALUE '450235   0480'.
186200         10  FILLER      PIC X(13) VALUE '450236   1283'.
186300         10  FILLER      PIC X(13) VALUE '450241   0257'.
186400         10  FILLER      PIC X(13) VALUE '450243   0144'.
186500         10  FILLER      PIC X(13) VALUE '450253   0311'.
186600         10  FILLER      PIC X(13) VALUE '450270   0676'.
186700         10  FILLER      PIC X(13) VALUE '450283   0244'.
186800         10  FILLER      PIC X(13) VALUE '450292   1269'.
186900         10  FILLER      PIC X(13) VALUE '450293   0208'.
187000         10  FILLER      PIC X(13) VALUE '450296   0861'.
187100         10  FILLER      PIC X(13) VALUE '450306   0212'.
187200         10  FILLER      PIC X(13) VALUE '450315   0032'.
187300         10  FILLER      PIC X(13) VALUE '450347   1460'.
187400         10  FILLER      PIC X(13) VALUE '450348   0417'.
187500         10  FILLER      PIC X(13) VALUE '450351   1071'.
187600         10  FILLER      PIC X(13) VALUE '450369   0442'.
187700         10  FILLER      PIC X(13) VALUE '450370   0558'.
187800         10  FILLER      PIC X(13) VALUE '450373   0350'.
187900         10  FILLER      PIC X(13) VALUE '450379   0839'.
188000         10  FILLER      PIC X(13) VALUE '450395   1196'.
188100         10  FILLER      PIC X(13) VALUE '450399   0418'.
188200         10  FILLER      PIC X(13) VALUE '450400   0793'.
188300         10  FILLER      PIC X(13) VALUE '450411   0683'.
188400         10  FILLER      PIC X(13) VALUE '450419   1149'.
188500         10  FILLER      PIC X(13) VALUE '450422   0283'.
188600         10  FILLER      PIC X(13) VALUE '450438   0660'.
188700         10  FILLER      PIC X(13) VALUE '450446   0450'.
188800         10  FILLER      PIC X(13) VALUE '450451   0497'.
188900         10  FILLER      PIC X(13) VALUE '450460   0524'.
189000         10  FILLER      PIC X(13) VALUE '450465   1260'.
189100         10  FILLER      PIC X(13) VALUE '450475   0769'.
189200         10  FILLER      PIC X(13) VALUE '450488   0032'.
189300         10  FILLER      PIC X(13) VALUE '450489   0233'.
189400         10  FILLER      PIC X(13) VALUE '450497   0562'.
189500         10  FILLER      PIC X(13) VALUE '450498   0387'.
189600         10  FILLER      PIC X(13) VALUE '450539   0582'.
189700         10  FILLER      PIC X(13) VALUE '450547   0192'.
189800         10  FILLER      PIC X(13) VALUE '450565   0943'.
189900         10  FILLER      PIC X(13) VALUE '450573   0815'.
190000         10  FILLER      PIC X(13) VALUE '450578   0081'.
190100         10  FILLER      PIC X(13) VALUE '450580   1030'.
190200         10  FILLER      PIC X(13) VALUE '450584   0351'.
190300         10  FILLER      PIC X(13) VALUE '450586   0302'.
190400         10  FILLER      PIC X(13) VALUE '450591   0669'.
190500         10  FILLER      PIC X(13) VALUE '450596   1236'.
190600         10  FILLER      PIC X(13) VALUE '450597   1024'.
190700         10  FILLER      PIC X(13) VALUE '450605   0579'.
190800         10  FILLER      PIC X(13) VALUE '450615   0739'.
190900         10  FILLER      PIC X(13) VALUE '450620   0296'.
191000         10  FILLER      PIC X(13) VALUE '450630   0024'.
191100         10  FILLER      PIC X(13) VALUE '450641   0488'.
191200         10  FILLER      PIC X(13) VALUE '450653   1306'.
191300         10  FILLER      PIC X(13) VALUE '450654   0856'.
191400         10  FILLER      PIC X(13) VALUE '450658   0415'.
191500         10  FILLER      PIC X(13) VALUE '450661   1355'.
191600         10  FILLER      PIC X(13) VALUE '450674   0169'.
191700         10  FILLER      PIC X(13) VALUE '450683   0536'.
191800         10  FILLER      PIC X(13) VALUE '450690   1340'.
191900         10  FILLER      PIC X(13) VALUE '450694   0422'.
192000         10  FILLER      PIC X(13) VALUE '450698   0245'.
192100         10  FILLER      PIC X(13) VALUE '450746   0105'.
192200         10  FILLER      PIC X(13) VALUE '450749   0395'.
192300         10  FILLER      PIC X(13) VALUE '450754   1127'.
192400         10  FILLER      PIC X(13) VALUE '450755   0286'.
192500         10  FILLER      PIC X(13) VALUE '450770   0472'.
192600         10  FILLER      PIC X(13) VALUE '450774   0161'.
192700         10  FILLER      PIC X(13) VALUE '450780   0345'.
192800         10  FILLER      PIC X(13) VALUE '450795   0538'.
192900         10  FILLER      PIC X(13) VALUE '450796   0042'.
193000         10  FILLER      PIC X(13) VALUE '450797   0002'.
193100         10  FILLER      PIC X(13) VALUE '450803   1325'.
193200         10  FILLER      PIC X(13) VALUE '450804   1103'.
193300         10  FILLER      PIC X(13) VALUE '450808   0171'.
193400         10  FILLER      PIC X(13) VALUE '450813   0258'.
193500         10  FILLER      PIC X(13) VALUE '450822   1286'.
193600         10  FILLER      PIC X(13) VALUE '450824   0225'.
193700         10  FILLER      PIC X(13) VALUE '450825   0273'.
193800         10  FILLER      PIC X(13) VALUE '450827   0797'.
193900         10  FILLER      PIC X(13) VALUE '450828   1499'.
194000         10  FILLER      PIC X(13) VALUE '450831   0023'.
194100         10  FILLER      PIC X(13) VALUE '450833   0778'.
194200         10  FILLER      PIC X(13) VALUE '450834   0157'.
194300         10  FILLER      PIC X(13) VALUE '450839   0552'.
194400         10  FILLER      PIC X(13) VALUE '450840   1178'.
194500         10  FILLER      PIC X(13) VALUE '450841   0295'.
194600         10  FILLER      PIC X(13) VALUE '450845   0350'.
194700         10  FILLER      PIC X(13) VALUE '450848   1294'.
194800         10  FILLER      PIC X(13) VALUE '450851   1250'.
194900         10  FILLER      PIC X(13) VALUE '450853   0476'.
195000         10  FILLER      PIC X(13) VALUE '450856   0390'.
195100         10  FILLER      PIC X(13) VALUE '450860   0116'.
195200         10  FILLER      PIC X(13) VALUE '450864   0785'.
195300         10  FILLER      PIC X(13) VALUE '450865   0174'.
195400         10  FILLER      PIC X(13) VALUE '450871   0271'.
195500         10  FILLER      PIC X(13) VALUE '450872   0544'.
195600         10  FILLER      PIC X(13) VALUE '450874   0043'.
195700         10  FILLER      PIC X(13) VALUE '450875   0529'.
195800         10  FILLER      PIC X(13) VALUE '450877   1085'.
195900         10  FILLER      PIC X(13) VALUE '450878   0472'.
196000         10  FILLER      PIC X(13) VALUE '450880   0306'.
196100         10  FILLER      PIC X(13) VALUE '450883   0054'.
196200         10  FILLER      PIC X(13) VALUE '450884   0405'.
196300         10  FILLER      PIC X(13) VALUE '450886   0038'.
196400         10  FILLER      PIC X(13) VALUE '450888   0357'.
196500         10  FILLER      PIC X(13) VALUE '450889   0040'.
196600         10  FILLER      PIC X(13) VALUE '450891   0122'.
196700         10  FILLER      PIC X(13) VALUE '450893   0117'.
196800         10  FILLER      PIC X(13) VALUE '450894   0211'.
196900         10  FILLER      PIC X(13) VALUE '460003   1368'.
197000         10  FILLER      PIC X(13) VALUE '460007   1001'.
197100         10  FILLER      PIC X(13) VALUE '460011   0667'.
197200         10  FILLER      PIC X(13) VALUE '460013   1153'.
197300         10  FILLER      PIC X(13) VALUE '460014   0655'.
197400         10  FILLER      PIC X(13) VALUE '460015   1554'.
197500         10  FILLER      PIC X(13) VALUE '460017   0215'.
197600         10  FILLER      PIC X(13) VALUE '460019   0364'.
197700         10  FILLER      PIC X(13) VALUE '460023   1506'.
197800         10  FILLER      PIC X(13) VALUE '460026   0330'.
197900         10  FILLER      PIC X(13) VALUE '460030   0397'.
198000         10  FILLER      PIC X(13) VALUE '460033   0131'.
198100         10  FILLER      PIC X(13) VALUE '460035   0139'.
198200         10  FILLER      PIC X(13) VALUE '460039   0157'.
198300         10  FILLER      PIC X(13) VALUE '460041   1499'.
198400         10  FILLER      PIC X(13) VALUE '460043   0012'.
198500         10  FILLER      PIC X(13) VALUE '460044   1195'.
198600         10  FILLER      PIC X(13) VALUE '460049   0678'.
198700         10  FILLER      PIC X(13) VALUE '460052   1078'.
198800         10  FILLER      PIC X(13) VALUE '460054   0253'.
198900         10  FILLER      PIC X(13) VALUE '460057   0274'.
199000         10  FILLER      PIC X(13) VALUE '460058   0496'.
199100         10  FILLER      PIC X(13) VALUE '470001   1498'.
199200         10  FILLER      PIC X(13) VALUE '470011   0828'.
199300         10  FILLER      PIC X(13) VALUE '470024   1133'.
199400         10  FILLER      PIC X(13) VALUE '480001   0964'.
199500         10  FILLER      PIC X(13) VALUE '480002   1039'.
199600         10  FILLER      PIC X(13) VALUE '490002   1428'.
199700         10  FILLER      PIC X(13) VALUE '490012   1496'.
199800         10  FILLER      PIC X(13) VALUE '490027   1168'.
199900         10  FILLER      PIC X(13) VALUE '490033   1095'.
200000         10  FILLER      PIC X(13) VALUE '490038   1186'.
200100         10  FILLER      PIC X(13) VALUE '490084   1263'.
200200         10  FILLER      PIC X(13) VALUE '490088   0979'.
200300         10  FILLER      PIC X(13) VALUE '490089   1045'.
200400         10  FILLER      PIC X(13) VALUE '490092   1239'.
200500         10  FILLER      PIC X(13) VALUE '490094   0989'.
200600         10  FILLER      PIC X(13) VALUE '490097   1310'.
200700         10  FILLER      PIC X(13) VALUE '490105   0027'.
200800         10  FILLER      PIC X(13) VALUE '490106   0005'.
200900         10  FILLER      PIC X(13) VALUE '490109   0129'.
201000         10  FILLER      PIC X(13) VALUE '490111   1169'.
201100         10  FILLER      PIC X(13) VALUE '490114   1306'.
201200         10  FILLER      PIC X(13) VALUE '490117   0461'.
201300         10  FILLER      PIC X(13) VALUE '490123   0924'.
201400         10  FILLER      PIC X(13) VALUE '490127   0874'.
201500         10  FILLER      PIC X(13) VALUE '490134   0011'.
201600         10  FILLER      PIC X(13) VALUE '490135   0180'.
201700         10  FILLER      PIC X(13) VALUE '490140   1160'.
201800         10  FILLER      PIC X(13) VALUE '490141   1143'.
201900         10  FILLER      PIC X(13) VALUE '490142   0045'.
202000         10  FILLER      PIC X(13) VALUE '500033   0939'.
202100         10  FILLER      PIC X(13) VALUE '500037   0450'.
202200         10  FILLER      PIC X(13) VALUE '500049   0683'.
202300         10  FILLER      PIC X(13) VALUE '500052   0004'.
202400         10  FILLER      PIC X(13) VALUE '500060   0804'.
202500         10  FILLER      PIC X(13) VALUE '500084   0630'.
202600         10  FILLER      PIC X(13) VALUE '500148   0393'.
202700         10  FILLER      PIC X(13) VALUE '510012   1569'.
202800         10  FILLER      PIC X(13) VALUE '510013   1022'.
202900         10  FILLER      PIC X(13) VALUE '510018   0913'.
203000         10  FILLER      PIC X(13) VALUE '510033   1580'.
203100         10  FILLER      PIC X(13) VALUE '510038   1449'.
203200         10  FILLER      PIC X(13) VALUE '510053   0531'.
203300         10  FILLER      PIC X(13) VALUE '510059   0001'.
203400         10  FILLER      PIC X(13) VALUE '510072   0635'.
203500         10  FILLER      PIC X(13) VALUE '510077   1079'.
203600         10  FILLER      PIC X(13) VALUE '510082   0983'.
203700         10  FILLER      PIC X(13) VALUE '510086   0277'.
203800         10  FILLER      PIC X(13) VALUE '520002   1597'.
203900         10  FILLER      PIC X(13) VALUE '520011   1291'.
204000         10  FILLER      PIC X(13) VALUE '520017   1096'.
204100         10  FILLER      PIC X(13) VALUE '520019   1116'.
204200         10  FILLER      PIC X(13) VALUE '520028   1379'.
204300         10  FILLER      PIC X(13) VALUE '520033   1360'.
204400         10  FILLER      PIC X(13) VALUE '520034   1060'.
204500         10  FILLER      PIC X(13) VALUE '520038   1042'.
204600         10  FILLER      PIC X(13) VALUE '520041   1093'.
204700         10  FILLER      PIC X(13) VALUE '520044   1524'.
204800         10  FILLER      PIC X(13) VALUE '520057   0962'.
204900         10  FILLER      PIC X(13) VALUE '520062   1462'.
205000         10  FILLER      PIC X(13) VALUE '520063   1366'.
205100         10  FILLER      PIC X(13) VALUE '520071   1420'.
205200         10  FILLER      PIC X(13) VALUE '520076   1194'.
205300         10  FILLER      PIC X(13) VALUE '520091   1260'.
205400         10  FILLER      PIC X(13) VALUE '520095   0883'.
205500         10  FILLER      PIC X(13) VALUE '520102   1524'.
205600         10  FILLER      PIC X(13) VALUE '520109   0767'.
205700         10  FILLER      PIC X(13) VALUE '520116   0893'.
205800         10  FILLER      PIC X(13) VALUE '520194   0412'.
205900         10  FILLER      PIC X(13) VALUE '520196   0158'.
206000         10  FILLER      PIC X(13) VALUE '520198   1370'.
206100         10  FILLER      PIC X(13) VALUE '520204   0777'.
206200         10  FILLER      PIC X(13) VALUE '520205   0571'.
206300         10  FILLER      PIC X(13) VALUE '520206   0975'.
206400         10  FILLER      PIC X(13) VALUE '520207   1520'.
206500         10  FILLER      PIC X(13) VALUE '530002   0715'.
206600         10  FILLER      PIC X(13) VALUE '530006   0963'.
206700         10  FILLER      PIC X(13) VALUE '530008   0599'.
206800         10  FILLER      PIC X(13) VALUE '530010   0700'.
206900         10  FILLER      PIC X(13) VALUE '530011   0578'.
207000         10  FILLER      PIC X(13) VALUE '530015   0501'.
207100         10  FILLER      PIC X(13) VALUE '530025   0747'.
207200         10  FILLER      PIC X(13) VALUE '530032   0268'.
207300         10  FILLER      PIC X(13) VALUE '530033   0404'.
207400         10  FILLER      PIC X(13) VALUE '640001   0235'.
207500         10  FILLER      PIC X(13) VALUE '650001   1588'.
207600         10  FILLER      PIC X(13) VALUE '660001   0247'.
207700         10  FILLER      PIC X(13) VALUE '670002   0901'.
207800         10  FILLER      PIC X(13) VALUE '670004   1054'.
207900         10  FILLER      PIC X(13) VALUE '670005   0062'.
208000         10  FILLER      PIC X(13) VALUE '670006   0517'.
208100         10  FILLER      PIC X(13) VALUE '670008   0227'.
208200         10  FILLER      PIC X(13) VALUE '670010   0001'.
208300         10  FILLER      PIC X(13) VALUE '670011   0015'.
208400         10  FILLER      PIC X(13) VALUE '670012   0730'.
208500         10  FILLER      PIC X(13) VALUE '670018   0122'.
208600         10  FILLER      PIC X(13) VALUE '670019   0953'.
208700         10  FILLER      PIC X(13) VALUE '670021   0014'.
208800         10  FILLER      PIC X(13) VALUE '670029   0131'.
208900         10  FILLER      PIC X(13) VALUE '670043   1099'.
209000         10  FILLER      PIC X(13) VALUE '670046   0160'.
209100         10  FILLER      PIC X(13) VALUE '670049   0192'.
209200         10  FILLER      PIC X(13) VALUE '670050   0254'.
209300         10  FILLER      PIC X(13) VALUE '670052   0513'.
209400         10  FILLER      PIC X(13) VALUE '670053   1447'.
209500         10  FILLER      PIC X(13) VALUE '670054   0155'.
209600         10  FILLER      PIC X(13) VALUE '670059   0419'.
209700         10  FILLER      PIC X(13) VALUE '670061   0255'.
209800         10  FILLER      PIC X(13) VALUE '670063   0074'.
209900         10  FILLER      PIC X(13) VALUE '670064   0009'.
210000         10  FILLER      PIC X(13) VALUE '670065   0001'.
210100         10  FILLER      PIC X(13) VALUE '670066   0093'.
210200         10  FILLER      PIC X(13) VALUE '670067   0345'.
210300         10  FILLER      PIC X(13) VALUE '670068   0899'.
210400         10  FILLER      PIC X(13) VALUE '670069   0117'.
210500         10  FILLER      PIC X(13) VALUE '670070   0038'.
210600         10  FILLER      PIC X(13) VALUE '670071   0469'.
210700         10  FILLER      PIC X(13) VALUE '670072   0598'.
210800         10  FILLER      PIC X(13) VALUE '670073   0264'.
210900         10  FILLER      PIC X(13) VALUE '670075   0642'.
211000         10  FILLER      PIC X(13) VALUE '670076   0057'.
211100         10  FILLER      PIC X(13) VALUE '670077   0474'.
211200      02  WK-LOWVOL-DATA2 REDEFINES LOWVOL-PROV-DISCHG-DATA.
211300         05  LOWVOL-TAB OCCURS 1262
211400                        ASCENDING KEY IS WK-LOWVOL-PROV
211500                        INDEXED BY LOWVOL-IDX.
211600           10  WK-LOWVOL-COUNT-ALL.
211700              15  WK-LOWVOL-PROV           PIC X(6).
211800              15  FILLER                   PIC XXX.
211900              15  WK-LOWVOL-PROV-DISCHG    PIC 9999.
212000
212100
212200*****YEARCHANGE 2013.0 ************************************
212300
212400
212500 01  MES-ADD-PROV                   PIC X(53) VALUE SPACES.
212600 01  MES-CHG-PROV                   PIC X(53) VALUE SPACES.
212700 01  MES-PPS-PROV                   PIC X(06).
212800 01  MES-PPS-STATE                  PIC X(02).
212900 01  MES-INTRO                      PIC X(53) VALUE SPACES.
213000 01  MES-TOT-PAY                    PIC 9(07)V9(02) VALUE 0.
213100 01  MES-SSRFBN.
213200     05 MES-SSRFBN-STATE PIC 99.
213300     05 FILLER           PIC XX.
213400     05 MES-SSRFBN-RATE  PIC 9(1)V9(5).
213500     05 FILLER           PIC XX.
213600     05 MES-SSRFBN-CODE2 PIC 99.
213700     05 FILLER           PIC XX.
213800     05 MES-SSRFBN-STNAM PIC X(20).
213900     05 MES-SSRFBN-REST  PIC X(22).
214000
214100
214200 01  MES-LOWVOL.
214300     05  MES-LOWVOL-PROV             PIC X(6).
214400     05  FILLER                      PIC XXX.
214500     05  MESWK-LOWVOL-PROV-DISCHG    PIC 9999.
214600
214700
214800 01  HOLD-AREA.
214900     02  HOLD-PPS-COMPONENTS.
215000         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
215100         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
215200
215300         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
215400         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
215500
215600         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
215700         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
215800         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
215900
216000         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
216100         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
216200         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
216300
216400         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
216500         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
216600
216700         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
216800         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
216900
217000         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
217100         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
217200
217300         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
217400         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
217500         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
217600         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
217700         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
217800         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
217900         05  H-CAPI-COLA                  PIC 9(01)V9(03).
218000         05  H-CAPI-SCH                   PIC 9(05)V9(02).
218100         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
218200         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
218300         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
218400         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
218500         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
218600         05  H-CAPI-GAF                   PIC 9(05)V9(04).
218700         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
218800         05  H-BLEND-GAF                  PIC 9(05)V9(04).
218900         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
219000         05  H-COV-DAYS                   PIC 9(3).
219100         05  H-PERDIEM-DAYS               PIC 9(3).
219200         05  H-REG-DAYS                   PIC 9(3).
219300         05  H-LTR-DAYS                   PIC 9(3).
219400         05  H-DSCHG-FRCTN                PIC 9(3)V9999.
219500         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
219600         05  H-ALOS                       PIC 9(02)V9(01).
219700         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
219800         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
219900         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
220000         05  H-CST-THRESH                 PIC 9(05)V9(02).
220100         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
220200         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
220300         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
220400         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
220500         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
220600         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
220700         05  H-BUDG-NUTR06                PIC 9(01)V9(06).
220800         05  H-BUDG-NUTR07                PIC 9(01)V9(06).
220900         05  H-BUDG-NUTR08                PIC 9(01)V9(06).
221000         05  H-BUDG-NUTR09                PIC 9(01)V9(06).
221100         05  H-BUDG-NUTR10                PIC 9(01)V9(06).
221200         05  H-BUDG-NUTR109               PIC 9(01)V9(06).
221300         05  H-BUDG-NUTR113               PIC 9(01)V9(06).
221400         05  H-BUDG-NUTR120               PIC 9(01)V9(06).
221500         05  H-BUDG-NUTR130               PIC 9(01)V9(06).
221600         05  H-CASE-MIX-ADJ               PIC 9(01)V9(04).
221700         05  H-UPDATE-01                  PIC 9(01)V9(04).
221800         05  H-UPDATE-02                  PIC 9(01)V9(04).
221900         05  H-UPDATE-03                  PIC 9(01)V9(04).
222000         05  H-UPDATE-04                  PIC 9(01)V9(04).
222100         05  H-UPDATE-05                  PIC 9(01)V9(04).
222200         05  H-UPDATE-06                  PIC 9(01)V9(04).
222300         05  H-UPDATE-07                  PIC 9(01)V9(04).
222400         05  H-UPDATE-08                  PIC 9(01)V9(04).
222500         05  H-UPDATE-09                  PIC 9(01)V9(04).
222600         05  H-UPDATE-10                  PIC 9(01)V9(04).
222700         05  H-UPDATE-109                 PIC 9(01)V9(04).
222800         05  H-UPDATE-113                 PIC 9(01)V9(04).
222900         05  H-UPDATE-120                 PIC 9(01)V9(04).
223000         05  H-UPDATE-130                 PIC 9(01)V9(04).
223100         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
223200         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
223300         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
223400         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
223500         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
223600         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
223700         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
223800         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
223900         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
224000         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
224100         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
224200         05  H-LABOR-PCT                  PIC 9(01)V9(04).
224300         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
224400         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
224500         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
224600         05  H-HSP-RATE                   PIC 9(08)V9(09).
224700         05  H-FSP-RATE                   PIC 9(08)V9(09).
224800         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
224900         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
225000         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
225100         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
225200         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
225300         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
225400         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
225500         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
225600         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
225700         05  H-NEW-TECH-ADDON-CAP         PIC S9(07)V99.
225800         05  H-NEW-TECH-ADDON-CAPDIF      PIC S9(07)V99.
225900         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
226000         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
226100         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.
226200         05  H-NEW-TECH-ADDON-HRTIMP-STOP PIC S9(07)V99.
226300         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.
226400         05  H-NEW-TECH-ADDON-SPIRAT-STOP PIC S9(07)V99.
226500         05  H-NEW-TECH-ADDON-SPIRAT      PIC S9(07)V99.
226600         05  H-NEW-TECH-ADDON-AUTOLITT-STOP PIC S9(07)V99.
226700         05  H-NEW-TECH-ADDON-AUTOLITT    PIC S9(07)V99.
226800         05  H-NEW-TECH-ADDON-DIFICID-STOP PIC S9(07)V99.
226900         05  H-NEW-TECH-ADDON-DIFICID     PIC S9(07)V99.
227000         05  H-NEW-TECH-ADDON-ZENITH-STOP PIC S9(07)V99.
227100         05  H-NEW-TECH-ADDON-ZENITH      PIC S9(07)V99.
227200         05  H-NEW-TECH-ADDON-VORAXAZE-STOP PIC S9(07)V99.
227300         05  H-NEW-TECH-ADDON-VORAXAZE    PIC S9(07)V99.
227400         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).
227500         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).
227600         05  H-READMIS-ADJUST-AMT         PIC S9(07)V99.
227700         05  H-VAL-BASED-PURCH-ADJUST-AMT PIC S9(07)V99.
227800         05  H-BUNDLE-ADJUST-AMT          PIC S9(07)V99.
227900
228000         05  H-LESSER-NEURO-1             PIC S9(07)V99.
228100         05  H-LESSER-NEURO-2             PIC S9(07)V99.
228200
228300         05  H-LESSER-GRAFT-1             PIC S9(07)V99.
228400         05  H-LESSER-GRAFT-2             PIC S9(07)V99.
228500
228600         05  H-LESSER-X-STOP-1            PIC S9(07)V99.
228700         05  H-LESSER-X-STOP-2            PIC S9(07)V99.
228800
228900         05  H-LESSER-HRTIMP-STOP-1       PIC S9(07)V99.
229000         05  H-LESSER-HRTIMP-STOP-2       PIC S9(07)V99.
229100
229200         05  H-LESSER-SPIRAT-STOP-1       PIC S9(07)V99.
229300         05  H-LESSER-SPIRAT-STOP-2       PIC S9(07)V99.
229400
229500         05  H-LESSER-AUTOLITT-STOP-1     PIC S9(07)V99.
229600         05  H-LESSER-AUTOLITT-STOP-2     PIC S9(07)V99.
229700
229800         05  H-LESSER-DIFICID-STOP-1      PIC S9(07)V99.
229900         05  H-LESSER-DIFICID-STOP-2      PIC S9(07)V99.
230000
230100         05  H-LESSER-ZENITH-STOP-1       PIC S9(07)V99.
230200         05  H-LESSER-ZENITH-STOP-2       PIC S9(07)V99.
230300
230400         05  H-LESSER-VORAXAZE-STOP-1     PIC S9(07)V99.
230500         05  H-LESSER-VORAXAZE-STOP-2     PIC S9(07)V99.
230600
230700         05  H-LESSER-VAL-BASED-PUR-STOP-1 PIC S9(07)V99.
230800         05  H-LESSER-VAL-BASED-PUR-STOP-2 PIC S9(07)V99.
230900
231000         05  H-CSTMED-NEURO               PIC S9(07)V99.
231100         05  H-CSTMED-GRAFT               PIC S9(07)V99.
231200         05  H-CSTMED-X-STOP              PIC S9(07)V99.
231300         05  H-CSTMED-HRTIMP-STOP         PIC S9(07)V99.
231400         05  H-CSTMED-SPIRAT-STOP         PIC S9(07)V99.
231500         05  H-CSTMED-AUTOLITT-STOP       PIC S9(07)V99.
231600         05  H-CSTMED-DIFICID-STOP        PIC S9(07)V99.
231700         05  H-CSTMED-ZENITH-STOP         PIC S9(07)V99.
231800         05  H-CSTMED-VORAXAZE-STOP       PIC S9(07)V99.
231900
232000
232100     02  HOLD-ADDITIONAL-VARIABLES.
232200         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
232300         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
232400         05  H-NAT-PCT                    PIC 9(01)V9(02).
232500         05  H-REG-PCT                    PIC 9(01)V9(02).
232600         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
232700         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
232800         05  H-DRG-WT                     PIC 9(02)V9(04).
232900         05  H-NAT-LABOR                  PIC 9(05)V9(02).
233000         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
233100         05  H-REG-LABOR                  PIC 9(05)V9(02).
233200         05  H-REG-NONLABOR               PIC 9(05)V9(02).
233300         05  H-OPER-COLA                  PIC 9(01)V9(03).
233400         05  H-INTERN-RATIO               PIC 9(01)V9(04).
233500         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
233600         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
233700         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
233800
233900     02  HOLD-CAPITAL-VARIABLES.
234000         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
234100         05  H-CAPI-HSP                   PIC 9(07)V9(02).
234200         05  H-CAPI-FSP                   PIC 9(07)V9(02).
234300         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
234400         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
234500         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
234600         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
234700         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
234800
234900     02  HOLD-CAPITAL2-VARIABLES.
235000         05  H-CAPI2-PAY-CODE             PIC X(1).
235100         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
235200         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
235300
235400     02  HOLD-OTHER-VARIABLES.
235500         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
235600         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
235700         05  H-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
235800         05  H-VAL-BASED-PURCH-PARTIPNT   PIC X.
235900         05  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
236000         05  H-HOSP-READMISSION-REDU      PIC X.
236100         05  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
236200         05  H-OPERATNG-DATA.
236300             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
236400             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
236500             10  H-OPER-HSP-AMT              PIC 9(08)V99.
236600
236700     02  HOLD-PC-OTH-VARIABLES.
236800         05  H-OPER-DSH                   PIC 9(01)V9(04).
236900         05  H-CAPI-DSH                   PIC 9(01)V9(04).
237000         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
237100         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
237200         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
237300         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
237400         05  H-TRANSFER-ADJ               PIC 9(01)V9(04).
237500         05  H-PC-HMO-FLAG                PIC X(01).
237600         05  H-PC-COT-FLAG                PIC X(01).
237700         05  H-FILLER                     PIC X(0998).
237800
237900 01  HLD-PPS-DATA.
238000         10  HLD-PPS-RTC                PIC 9(02).
238100         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
238200         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
238300         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
238400         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
238500         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
238600         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
238700         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
238800         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
238900         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
239000         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
239100         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
239200         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
239300         10  HLD-PPS-CALC-VERS          PIC X(05).
239400
239500 LINKAGE SECTION.
239600***************************************************************
239700*                 * * * * * * * * *                           *
239800*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
239900*    IN HOW TO PAY THE BILL.                                  *
240000*                         *****                               *
240100*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
240200*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
240300*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
240400*                 OUTLIER COMPUTATION.                        *
240500*                         *****                               *
240600*         REVIEW-CODE:                                        *
240700*            00 = PAY-WITH-OUTLIER.                           *
240800*                 WILL CALCULATE THE STANDARD PAYMENT.        *
240900*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
241000*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
241100*            03 = PAY-PERDIEM-DAYS.                           *
241200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
241300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
241400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
241500*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
241600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
241700*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
241800*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
241900*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
242000*                 BILL EXCEED THE COST THRESHOLD.             *
242100*            06 = PAY-XFER-NO-COST                            *
242200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
242300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
242400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
242500*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
242600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
242700*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
242800*                 CALCULATE ANY COST OUTLIER PORTION          *
242900*                 OF THE PAYMENT.                             *
243000*            07 = PAY-WITHOUT-COST.                           *
243100*                 WILL CALCULATE THE STANDARD PAYMENT         *
243200*                 WITHOUT COST PORTION.                       *
243300*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
243400*                 50-50> 28  29  30  40  41  42  219
243500*                        220 221 477 478 479 480 481
243600*                        482 492 493 494 500 501 502
243700*                        515 516 517 495 496 497
243800* =======================================================
243900* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
244000* =======================================================
244100*
244200*
244300*     FULL PERDIEM >   3   4   25  26  27  28          31
244400*                      32  33              54  55  56  57
244500*                      64  65  66  70  71  72  85  86  87
244600*                      91  92  93  100 101 163 164 165 166
244700*                      167 168 175 176 177 178 179 186 187
244800*                      188 190 191 192 193 194 195 196 197
244900*                      198 205 206 207 216 217 218
245000*                          228 229 230 233 234 235 236 239
245100*                      240 241 242 243 244 255 256 257 264
245200*                      280 281 282 288 289 290 291 292 293
245300*                      299 300 301 314 315 316 326 327 328
245400*                      329 330 331 332 333 334 335 336 337
245500*                      356 357 358 371 372 373 374 375 376
245600*                      377 378 379 380 381 382 388 389 390
245700*                      405 406 407 414 415 416 441 442 443
245800*                      459 460 463 464 465 466 467 468 469
245900*                      470 474 475 476
246000*                          483 484 488 489
246100*                                          510 511 512
246200*                              533 534 535 536 539 540 541
246300*                      542 543 544 545 546 547 551 552 557
246400*                      558 559 560 561 562 563 573 574 575
246500*                      579 580 581 592 593 594 602 603 616
246600*                      617 618 622 623 624 628 629 630 637
246700*                      638 639 640 641 643 644 645 653 654
246800*                      655 659 660 661 682 683 684 689 690
246900*                      698 699 700 840 841 842 853 854 855
247000*                      856 857 858 862 863 867 868 869 870
247100*                      871 872 884 896 897 907 908 909 917
247200*                      918 945 946 947 948 956 981 982 983
247300*                      987 988 989
247400*
247500*                               POST-ACUTE TRANSFERS          *
247600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
247700*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
247800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
247900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
248000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
248100*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
248200*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
248300*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
248400*                 BILL EXCEED THE COST THRESHOLD.             *
248500*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
248600*                 POST-ACUTE TRANSFERS                        *
248700*                 50-50> 28  29  30  40  41  42  219
248800*                        216 217 218
248900*                        220 221 477 478 479 480 481
249000*                        482 492 493 494 500 501 502
249100*                        515 516 517 495 496 497
249200*
249300* =======================================================
249400* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
249500* =======================================================
249600*
249700*     FULL PERDIEM >     3   4   25  26  27              31
249800*                        32  33              54  55  56  57
249900*                        64  65  66  70  71  72  85  86  87
250000*                        91  92  93  100 101 163 164 165 166
250100*                        167 168 175 176 177 178 179 186 187
250200*                        188 190 191 192 193 194 195 196 197
250300*                        198 205 206 207
250400*                            228 229 230 233 234 235 236 239
250500*                        240 241 242 243 244 255 256 257 264
250600*                        280 281 282 288 289 290 291 292 293
250700*                        299 300 301 314 315 316 326 327 328
250800*                        329 330 331 332 333 334 335 336 337
250900*                        356 357 358 371 372 373 374 375 376
251000*                        377 378 379 380 381 382 388 389 390
251100*                        405 406 407 414 415 416 441 442 443
251200*                        459 460 463 464 465 466 467 468 469
251300*                        470 474 475 476
251400*                            483 484 488 489
251500*                                            510 511 512
251600*                                533 534 535 536 539 540 541
251700*                        542 543 544 545 546 547 551 552 557
251800*                        558 559 560 561 562 563 573 574 575
251900*                        579 580 581 592 593 594 602 603 616
252000*                        617 618 622 623 624 628 629 630 637
252100*                        638 639 640 641 643 644 645 653 654
252200*                        655 659 660 661 682 683 684 689 690
252300*                        698 699 700 840 841 842 853 854 855
252400*                        856 857 858 862 863 867 868 869 870
252500*                        871 872 884 896 897 907 908 909 917
252600*                        918 945 946 947 948 956 981 982 983
252700*                        987 988 989
252800*
252900*
253000*                               POST-ACUTE TRANSFERS          *
253100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
253200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
253300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
253400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
253500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
253600*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
253700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
253800*                 PAYMENT.                                    *
253900***************************************************************
254000
254100**************************************************************
254200*      MILLINNIUM COMPATIBLE                                 *
254300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
254400*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
254500*      IN THE NEW FORMAT                                     *
254600**************************************************************
254700 01  BILL-NEW-DATA.
254800         10  B-NPI10.
254900             15  B-NPI8             PIC X(08).
255000             15  B-NPI-FILLER       PIC X(02).
255100         10  B-PROVIDER-NO          PIC X(06).
255200         10  B-REVIEW-CODE          PIC 9(02).
255300             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
255400             88  PAY-WITH-OUTLIER     VALUE 00 07.
255500             88  PAY-PERDIEM-DAYS     VALUE 03.
255600             88  PAY-XFER-NO-COST     VALUE 06.
255700             88  PAY-WITHOUT-COST     VALUE 07.
255800             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
255900             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
256000         10  B-DRG                  PIC 9(03).
256100             88  B-DRG-POSTACUTE-50-50
256200                   VALUE 28  29  30  40  41  42  219
256300                         216 217 218
256400                         220 221 477 478 479 480 481
256500                         482 492 493 494 495 496 497
256600                         500 501 502 515 516 517.
256700
256800             88  B-DRG-SPIRATN-DRG
256900                   VALUE 163 164 165.
257000
257100             88  B-DRG-SPIRATN-DRG11
257200                   VALUE 199 200 201.
257300
257400
257500             88  B-DRG-AUTOLITT-DRG
257600                   VALUE 25 26 27.
257700
257800* =======================================================
257900* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
258000* =======================================================
258100*
258200             88  B-DRG-POSTACUTE-PERDIEM
258300                   VALUE 3   4   25  26  27  23  24      31
258400                         32  33              54  55  56  57
258500                         64  65  66  70  71  72  85  86  87
258600                         91  92  93  100 101 163 164 165 166
258700                         167 168 175 176 177 178 179 186 187
258800                         188 190 191 192 193 194 195 196 197
258900                         198 205 206 207
259000                                         233 234 235 236 239
259100                         240 241 242 243 244 255 256 257 264
259200                         280 281 282 288 289 290 291 292 293
259300                         299 300 301 314 315 316 326 327 328
259400                         329 330 331 332 333 334 335 336 337
259500                         356 357 358 371 372 373 374 375 376
259600                         377 378 379 380 381 382 388 389 390
259700                         405 406 407 414 415 416 441 442 443
259800                         459 460 463 464 465 466 467 468 469
259900                         470 474 475 476
260000                             483 484 488 489
260100                                             510 511 512
260200                                             570 571 572
260300                                 533 534 535 536 539 540 541
260400                         542 543 544 545 546 547 551 552 557
260500                         558 559 560 561 562 563 573 574 575
260600                         579 580 581 592 593 594 602 603 616
260700                         617 618 622 623 624 628 629 630 637
260800                         638 639 640 641 643 644 645 653 654
260900                         655 659 660 661 682 683 684 689 690
261000                         698 699 700 840 841 842 853 854 855
261100                         856 857 858 862 863 867 868 869 870
261200                         871 872 884 896 897 907 908 909 917
261300                         918 945 946 947 948 956 981 982 983
261400                         987 988 989.
261500
261600         10  B-LOS                  PIC 9(03).
261700         10  B-COVERED-DAYS         PIC 9(03).
261800         10  B-LTR-DAYS             PIC 9(02).
261900         10  B-DISCHARGE-DATE.
262000             15  B-DISCHG-CC        PIC 9(02).
262100             15  B-DISCHG-YY        PIC 9(02).
262200             15  B-DISCHG-MM        PIC 9(02).
262300             15  B-DISCHG-DD        PIC 9(02).
262400         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
262500         10  B-PRIN-PROC-CODE       PIC X(07).
262600         10  B-OTHER-PROC-CODE1     PIC X(07).
262700         10  B-OTHER-PROC-CODE2     PIC X(07).
262800         10  B-OTHER-PROC-CODE3     PIC X(07).
262900         10  B-OTHER-PROC-CODE4     PIC X(07).
263000         10  B-OTHER-PROC-CODE5     PIC X(07).
263100         10  B-OTHER-PROC-CODE6     PIC X(07).
263200         10  B-OTHER-PROC-CODE7     PIC X(07).
263300         10  B-OTHER-PROC-CODE8     PIC X(07).
263400         10  B-OTHER-PROC-CODE9     PIC X(07).
263500         10  B-OTHER-PROC-CODE10    PIC X(07).
263600         10  B-OTHER-PROC-CODE11    PIC X(07).
263700         10  B-OTHER-PROC-CODE12    PIC X(07).
263800         10  B-OTHER-PROC-CODE13    PIC X(07).
263900         10  B-OTHER-PROC-CODE14    PIC X(07).
264000         10  B-OTHER-PROC-CODE15    PIC X(07).
264100         10  B-OTHER-PROC-CODE16    PIC X(07).
264200         10  B-OTHER-PROC-CODE17    PIC X(07).
264300         10  B-OTHER-PROC-CODE18    PIC X(07).
264400         10  B-OTHER-PROC-CODE19    PIC X(07).
264500         10  B-OTHER-PROC-CODE20    PIC X(07).
264600         10  B-OTHER-PROC-CODE21    PIC X(07).
264700         10  B-OTHER-PROC-CODE22    PIC X(07).
264800         10  B-OTHER-PROC-CODE23    PIC X(07).
264900         10  B-OTHER-PROC-CODE24    PIC X(07).
265000         10  B-OTHER-DIAG-CODE1     PIC X(07).
265100             88  B-DIAG-AUTOLITT-DIAG
265200                   VALUE '1910   ' '1911   ' '1912   ' '1913  '
265300                         '1914   ' '1915   ' '1916   ' '1917  '
265400                         '1918   ' '1919   ' 'C710   ' 'C711  '
265500                         'C712   ' 'C713   ' 'C714   ' 'C715  '
265600                         'C716   ' 'C717   ' 'C718   ' 'C719  '.
265700         10  B-OTHER-DIAG-CODE2     PIC X(07).
265800         10  B-OTHER-DIAG-CODE3     PIC X(07).
265900         10  B-OTHER-DIAG-CODE4     PIC X(07).
266000         10  B-OTHER-DIAG-CODE5     PIC X(07).
266100         10  B-OTHER-DIAG-CODE6     PIC X(07).
266200         10  B-OTHER-DIAG-CODE7     PIC X(07).
266300         10  B-OTHER-DIAG-CODE8     PIC X(07).
266400         10  B-OTHER-DIAG-CODE9     PIC X(07).
266500         10  B-OTHER-DIAG-CODE10    PIC X(07).
266600         10  B-OTHER-DIAG-CODE11    PIC X(07).
266700         10  B-OTHER-DIAG-CODE12    PIC X(07).
266800         10  B-OTHER-DIAG-CODE13    PIC X(07).
266900         10  B-OTHER-DIAG-CODE14    PIC X(07).
267000         10  B-OTHER-DIAG-CODE15    PIC X(07).
267100         10  B-OTHER-DIAG-CODE16    PIC X(07).
267200         10  B-OTHER-DIAG-CODE17    PIC X(07).
267300         10  B-OTHER-DIAG-CODE18    PIC X(07).
267400         10  B-OTHER-DIAG-CODE19    PIC X(07).
267500         10  B-OTHER-DIAG-CODE20    PIC X(07).
267600         10  B-OTHER-DIAG-CODE21    PIC X(07).
267700         10  B-OTHER-DIAG-CODE22    PIC X(07).
267800         10  B-OTHER-DIAG-CODE23    PIC X(07).
267900         10  B-OTHER-DIAG-CODE24    PIC X(07).
268000         10  B-OTHER-DIAG-CODE25    PIC X(07).
268100         10  B-DEMO-DATA.
268200             15  B-DEMO-CODE1           PIC X(02).
268300             15  B-DEMO-CODE2           PIC X(02).
268400             15  B-DEMO-CODE3           PIC X(02).
268500             15  B-DEMO-CODE4           PIC X(02).
268600         10  B-NDC-DATA.
268700             15  B-NDC-NUMBER           PIC X(11).
268800               88  B-NDC-DIFICID-NDC
268900                   VALUE '52015008001'.
269000         10  FILLER                     PIC X(73).
269100
269200
269300***************************************************************
269400*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
269500*    AND PASSED BACK TO THE CALLING PROGRAM                   *
269600*            RETURN CODE VALUES (PPS-RTC)                     *
269700*                                                             *
269800*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
269900*                                                             *
270000*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
270100*                                                             *
270200*           30,00 = PAID NORMAL DRG PAYMENT                   *
270300*                                                             *
270400*              01 = PAID AS A DAY-OUTLIER.                    *
270500*                   NOTE:                                     *
270600*                     DAY-OUTLIER NO LONGER BEING PAID        *
270700*                         AS OF 10/01/97                      *
270800*                                                             *
270900*              02 = PAID AS A COST-OUTLIER.                   *
271000*                                                             *
271100*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
271200*                   AND INCLUDING THE FULL DRG.               *
271300*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
271400*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
271500*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
271600*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
271700*                   AND INCLUDING THE FULL DRG. PROVIDER      *
271800*                   REFUSED COST OUTLIER.                     *
271900*           40,10 = POST-ACUTE TRANSFER                       *
272000*                   DRG = 28  29  30  40  41  42  219
272100*                         220 221 477 478 479 480 481
272200*                         482 492 493 494 500 501 502
272300*                         515 516 517
272400*
272500* =======================================================
272600* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
272700* =======================================================
272800*
272900*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
273000*                       THE FOLLOWING DRG'S                   *
273100*                   DRG = 3   4   25  26  27              31
273200*                         32  33              54  55  56  57
273300*                         64  65  66  70  71  72  85  86  87
273400*                         91  92  93  100 101 163 164 165 166
273500*                         167 168 175 176 177 178 179 186 187
273600*                         188 190 191 192 193 194 195 196 197
273700*                         198 205 206 207 216 217 218
273800*                             228 229 230 233 234 235 236 239
273900*                         240 241 242 243 244 255 256 257 264
274000*                         280 281 282 288 289 290 291 292 293
274100*                         299 300 301 314 315 316 326 327 328
274200*                         329 330 331 332 333 334 335 336 337
274300*                         356 357 358 371 372 373 374 375 376
274400*                         377 378 379 380 381 382 388 389 390
274500*                         405 406 407 414 415 416 441 442 443
274600*                         459 460 463 464 465 466 467 468 469
274700*                         470 474 475 476
274800*                             483 484 488 489             495
274900*                         496 497             510 511 512
275000*                                 533 534 535 536 539 540 541
275100*                         542 543 544 545 546 547 551 552 557
275200*                         558 559 560 561 562 563 573 574 575
275300*                         579 580 581 592 593 594 602 603 616
275400*                         617 618 622 623 624 628 629 630 637
275500*                         638 639 640 641 643 644 645 653 654
275600*                         655 659 660 661 682 683 684 689 690
275700*                         698 699 700 840 841 842 853 854 855
275800*                         856 857 858 862 863 867 868 869 870
275900*                         871 872 884 896 897 907 908 909 917
276000*                         918 945 946 947 948 956 981 982 983
276100*                         987 988 989
276200*
276300*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
276400*                    PERDIEM DAYS = OR > GM  ALOS             *
276500*              16 = PAID AS A COST-OUTLIER WITH               *
276600*                    PERDIEM DAYS = OR > GM  ALOS             *
276700*                                                             *
276800*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
276900*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
277000*              52 = INVALID CBSA# IN PROVIDER FILE            *
277100*                   OR INVALID WAGE INDEX                     *
277200*                                      OR                     *
277300*                   INVALID PROVIDER TYPES ON PROVIDER FILE   *
277400*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
277500*              54 = INVALID DRG                               *
277600*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
277700*                                      OR                     *
277800*                   DISCHARGE DATE < CBSA EFF START DATE      *
277900*                   FOR PPS                                   *
278000*                                      OR                     *
278100*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
278200*                   DISCHARGE DATE                            *
278300*              56 = INVALID LENGTH OF STAY                    *
278400*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
278500*                                        NOT 11)              *
278600*              58 = TOTAL CHARGES NOT NUMERIC                 *
278700*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
278800*                   OR BILL-LTR-DAYS > 60                     *
278900*              62 = INVALID NUMBER OF COVERED DAYS            *
279000*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER        *
279100*                   SPECIFIC FILE FOR CAPITAL                  *
279200*                   OR                                         *
279300*                   INVALID READMISSION FLAG IN PSF FILE       *
279400*                   OR                                         *
279500*                   BLANK READMISSION FLAG IN PSF FILE         *
279600*                   OR                                         *
279700*                   READMISSION ADJUSTMENT IS INVALID OR       *
279800*                   OUT OF RANGE IN PSF FILE                   *
279900*                   OR                                         *
280000*                   BLANK READMISSION ADJUSTMENT IN PSF FILE   *
280100*                   OR                                         *
280200*                   INVALID STATE CODE IN COMBINATION WITH     *
280300*                   READMISSION FLAG IN PSF FILE               *
280400*              67 = COST OUTLIER WITH LOS > COVERED DAYS      **
280500*                   OR COST OUTLIER THRESHOLD CALUCULATION    **
280600*              68 = INVALID VALUE BASED PURCHASE FLAG IN PSF   *
280700*                   FILE                                       *
280800*                   OR                                         *
280900*                   BLANK VALUE BASED PURCHASE FLAG IN PSF FILE*
281000*                   OR                                         *
281100*                   VALUE BASED PURCHASE ADJUSTMEMT IS INVALID *
281200*                   OR OUT OF RANGE IN PSF FILE                *
281300*                   INDICATOR                                  *
281400*                   OR                                         *
281500*                   BLANK VALUE BASED PURCHASE ADJUSTMEMT IN   *
281600*                   PSF FILE                                   *
281700*                   OR                                         *
281800*                   INVALID COMBINATION OF HOSPITAL QUALITY    *
281900*                   INDICATOR                                  *
282000*                   AND VALUE BASED PURCHASE FLAG IN PSF FILE  *
282100*                   OR                                         *
282200*                   INVALID STATE CODE IN COMBINATION WITH VALUE
282300*                   BASED PURCHASE FLAG IN PSF FILE            *
282400*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
282500***************************************************************
282600 01  PPS-DATA.
282700         10  PPS-RTC                PIC 9(02).
282800         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
282900         10  PPS-OUTLIER-DAYS       PIC 9(03).
283000         10  PPS-AVG-LOS            PIC 9(02)V9(01).
283100         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
283200         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
283300         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
283400         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
283500         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
283600         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
283700         10  PPS-REG-DAYS-USED      PIC 9(03).
283800         10  PPS-LTR-DAYS-USED      PIC 9(02).
283900         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
284000         10  PPS-CALC-VERS          PIC X(05).
284100
284200******************************************************************
284300*            THESE ARE THE VERSIONS OF THE PPCAL
284400*           PROGRAMS THAT WILL BE PASSED BACK----
284500*          ASSOCIATED WITH THE BILL BEING PROCESSED
284600******************************************************************
284700 01  PRICER-OPT-VERS-SW.
284800     02  PRICER-OPTION-SW          PIC X(01).
284900         88  ALL-TABLES-PASSED          VALUE 'A'.
285000         88  PROV-RECORD-PASSED         VALUE 'P'.
285100         88  ADDITIONAL-VARIABLES       VALUE 'M'.
285200         88  PC-PRICER                  VALUE 'C'.
285300     02  PPS-VERSIONS.
285400         10  PPDRV-VERSION         PIC X(05).
285500
285600******************************************************************
285700*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
285800*          ASSOCIATED WITH THE BILL BEING PROCESSED
285900******************************************************************
286000 01  PPS-ADDITIONAL-VARIABLES.
286100     05  PPS-HSP-PCT                PIC 9(01)V9(02).
286200     05  PPS-FSP-PCT                PIC 9(01)V9(02).
286300     05  PPS-NAT-PCT                PIC 9(01)V9(02).
286400     05  PPS-REG-PCT                PIC 9(01)V9(02).
286500     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
286600     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
286700     05  PPS-DRG-WT                 PIC 9(02)V9(04).
286800     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
286900     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
287000     05  PPS-REG-LABOR              PIC 9(05)V9(02).
287100     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
287200     05  PPS-OPER-COLA              PIC 9(01)V9(03).
287300     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
287400     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
287500     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
287600     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
287700     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
287800     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
287900     05  PPS-CAPITAL-VARIABLES.
288000         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
288100         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
288200         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
288300         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
288400         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
288500         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
288600         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
288700         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
288800     05  PPS-CAPITAL2-VARIABLES.
288900         10  PPS-CAPI2-PAY-CODE             PIC X(1).
289000         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
289100         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
289200
289300     05  PPS-OTHER-VARIABLES.
289400         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
289500         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
289600         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
289700         10  PPS-VAL-BASED-PURCH-PARTIPNT   PIC X.
289800         10  PPS-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
289900         10  PPS-HOSP-READMISSION-REDU      PIC X.
290000         10  PPS-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
290100         10  PPS-OPERATNG-DATA.
290200             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
290300             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
290400             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
290500
290600     05  PPS-PC-OTH-VARIABLES.
290700         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
290800         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
290900         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
291000         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
291100         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
291200         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
291300         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(04).
291400         10  PPS-PC-HMO-FLAG                PIC X(01).
291500         10  PPS-PC-COT-FLAG                PIC X(01).
291600         10  FILLER                         PIC X(0998).
291700
291800 01  PROV-NEW-HOLD.
291900     02  PROV-NEWREC-HOLD1.
292000         05  P-NEW-NPI10.
292100             10  P-NEW-NPI8             PIC X(08).
292200             10  P-NEW-NPI-FILLER       PIC X(02).
292300         05  P-NEW-PROVIDER-NO.
292400             88  P-NEW-DSH-ADJ-PROVIDERS
292500                             VALUE '180049' '190044' '190144'
292600                                   '190191' '330047' '340085'
292700                                   '370016' '370149' '420043'.
292800             10  P-NEW-STATE            PIC 9(02).
292900                 88  P-VBP-INVALID-STATE
293000                             VALUE 21 80 40.
293100                 88  P-READ-INVALID-STATE
293200                             VALUE 40.
293300             10  FILLER                 PIC X(04).
293400         05  P-NEW-DATE-DATA.
293500             10  P-NEW-EFF-DATE.
293600                 15  P-NEW-EFF-DT-CC    PIC 9(02).
293700                 15  P-NEW-EFF-DT-YY    PIC 9(02).
293800                 15  P-NEW-EFF-DT-MM    PIC 9(02).
293900                 15  P-NEW-EFF-DT-DD    PIC 9(02).
294000             10  P-NEW-FY-BEGIN-DATE.
294100                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
294200                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
294300                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
294400                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
294500             10  P-NEW-REPORT-DATE.
294600                 15  P-NEW-REPORT-DT-CC PIC 9(02).
294700                 15  P-NEW-REPORT-DT-YY PIC 9(02).
294800                 15  P-NEW-REPORT-DT-MM PIC 9(02).
294900                 15  P-NEW-REPORT-DT-DD PIC 9(02).
295000             10  P-NEW-TERMINATION-DATE.
295100                 15  P-NEW-TERM-DT-CC   PIC 9(02).
295200                 15  P-NEW-TERM-DT-YY   PIC 9(02).
295300                 15  P-NEW-TERM-DT-MM   PIC 9(02).
295400                 15  P-NEW-TERM-DT-DD   PIC 9(02).
295500         05  P-NEW-WAIVER-CODE          PIC X(01).
295600             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
295700         05  P-NEW-INTER-NO             PIC 9(05).
295800         05  P-NEW-PROVIDER-TYPE        PIC X(02).
295900             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
296000             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
296100                                                  '15' '17'
296200                                                  '22'.
296300             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
296400             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
296500             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
296600             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
296700             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
296800             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
296900             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
297000             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
297100             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
297200             88  P-N-EACH                   VALUE '21' '22'.
297300             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
297400             88  P-N-NHCMQ-II-SNF           VALUE '32'.
297500             88  P-N-NHCMQ-III-SNF          VALUE '33'.
297600*            88  P-N-INVALID-PROV-TYPES     VALUE '14' '15'.
297700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
297800             88  P-N-NEW-ENGLAND            VALUE  1.
297900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
298000             88  P-N-SOUTH-ATLANTIC         VALUE  3.
298100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
298200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
298300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
298400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
298500             88  P-N-MOUNTAIN               VALUE  8.
298600             88  P-N-PACIFIC                VALUE  9.
298700         05  P-NEW-CURRENT-DIV   REDEFINES
298800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
298900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
299000         05  P-NEW-MSA-DATA.
299100             10  P-NEW-CHG-CODE-INDEX       PIC X.
299200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
299300             10  P-NEW-GEO-LOC-MSA9   REDEFINES
299400                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
299500             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
299600             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
299700             10  P-NEW-STAND-AMT-LOC-MSA9
299800       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
299900                 15  P-NEW-RURAL-1ST.
300000                     20  P-NEW-STAND-RURAL  PIC XX.
300100                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
300200                 15  P-NEW-RURAL-2ND        PIC XX.
300300         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
300400                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
300500                 88  P-NEW-SCH-YR82       VALUE   '82'.
300600                 88  P-NEW-SCH-YR87       VALUE   '87'.
300700         05  P-NEW-LUGAR                    PIC X.
300800         05  P-NEW-TEMP-RELIEF-IND          PIC X.
300900         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
301000         05  FILLER                         PIC X(05).
301100     02  PROV-NEWREC-HOLD2.
301200         05  P-NEW-VARIABLES.
301300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
301400             10  P-NEW-COLA              PIC  9(01)V9(03).
301500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
301600             10  P-NEW-BED-SIZE          PIC  9(05).
301700             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
301800             10  P-NEW-CMI               PIC  9(01)V9(04).
301900             10  P-NEW-SSI-RATIO         PIC  V9(04).
302000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
302100             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
302200             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
302300             10  P-NEW-DSH-PERCENT       PIC  V9(04).
302400             10  P-NEW-FYE-DATE          PIC  X(08).
302500         05  P-NEW-CBSA-DATA.
302600             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
302700             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
302800             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
302900             10  P-NEW-CBSA-GEO-RURAL REDEFINES
303000                 P-NEW-CBSA-GEO-LOC.
303100                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
303200                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
303300                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
303400
303500             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
303600             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
303700             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
303800     02  PROV-NEWREC-HOLD3.
303900         05  P-NEW-PASS-AMT-DATA.
304000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
304100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
304200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
304300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
304400         05  P-NEW-CAPI-DATA.
304500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
304600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
304700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
304800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
304900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
305000             15  P-NEW-CAPI-NEW-HOSP       PIC X.
305100             15  P-NEW-CAPI-IME            PIC 9V9999.
305200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
305300         05  P-HVBP-HRR-DATA.
305400             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
305500             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
305600             15  P-HOSP-READMISSION-REDU    PIC X.
305700             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
305800         05  P-MODEL1-BUNDLE-DATA.
305900             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
306000             15  P-HAC-REDUC-IND            PIC X.
306100             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
306200             15  P-EHR-REDUC-IND            PIC X.
306300         05  FILLER                         PIC X(09).
306400
306500******************************************************************
306600 01  WAGE-NEW-CBSA-INDEX-RECORD.
306700     05  W-CBSA                        PIC X(5).
306800     05  W-CBSA-SIZE                   PIC X.
306900         88  LARGE-URBAN       VALUE 'L'.
307000         88  OTHER-URBAN       VALUE 'O'.
307100         88  ALL-RURAL         VALUE 'R'.
307200     05  W-CBSA-EFF-DATE               PIC X(8).
307300     05  FILLER                        PIC X.
307400     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
307500     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
307600
307700
307800 PROCEDURE DIVISION  USING BILL-NEW-DATA
307900                           PPS-DATA
308000                           PRICER-OPT-VERS-SW
308100                           PPS-ADDITIONAL-VARIABLES
308200                           PROV-NEW-HOLD
308300                           WAGE-NEW-CBSA-INDEX-RECORD.
308400
308500***************************************************************
308600*    PROCESSING:                                              *
308700*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
308800*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
308900*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
309000*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
309100*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
309200*           GOBACK.                                           *
309300*        D. ASSEMBLE PRICING COMPONENTS.                      *
309400*        E. CALCULATE THE PRICE.                              *
309500***************************************************************
309600
309700     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
309800     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT.
309900     MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT.
310000     MOVE ZEROES TO H-READMIS-ADJUST-AMT.
310100     MOVE 'N' TO TEMP-RELIEF-FLAG.
310200     MOVE 'N' TO OUTLIER-RECON-FLAG.
310300
310400     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
310500
310600     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
310700     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
310800     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
310900     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
311000     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
311100     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
311200     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
311300     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
311400
311500     IF (PPS-RTC = '00' OR '03' OR '10' OR
311600                   '12' OR '14')
311700        MOVE 'Y' TO OUTLIER-RECON-FLAG
311800        MOVE PPS-DATA TO HLD-PPS-DATA
311900        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
312000        MOVE HLD-PPS-DATA TO PPS-DATA.
312100
312200     GOBACK.
312300
312400 0200-MAINLINE-CONTROL.
312500
312600     MOVE 'N' TO HMO-TAG.
312700
312800     IF PPS-PC-HMO-FLAG = 'Y' OR
312900               HMO-FLAG = 'Y'
313000        MOVE 'Y' TO HMO-TAG.
313100
313200     IF P-NEW-STATE NOT = 40
313300        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
313400
313500     MOVE ALL '0' TO PPS-DATA
313600                     H-OPER-DSH-SCH
313700                     H-OPER-DSH-RRC
313800                     HOLD-PPS-COMPONENTS
313900                     HOLD-PPS-COMPONENTS
314000                     HOLD-ADDITIONAL-VARIABLES
314100                     HOLD-CAPITAL-VARIABLES
314200                     HOLD-CAPITAL2-VARIABLES
314300                     HOLD-OTHER-VARIABLES
314400                     HOLD-PC-OTH-VARIABLES.
314500
314600     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
314700        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
314800
314900     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
315000        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
315100
315200     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
315300        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
315400
315500     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
315600        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
315700
315800     IF P-HOSP-HRR-ADJUSTMT     NOT NUMERIC
315900        MOVE 0 TO P-HOSP-HRR-ADJUSTMT.
316000
316100     IF P-VAL-BASED-PURCH-ADJUST NOT NUMERIC
316200        MOVE 0 TO P-VAL-BASED-PURCH-ADJUST.
316300
316400
316500     PERFORM 1000-EDIT-THE-BILL-INFO.
316600
316700     IF  PPS-RTC = 00
316800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
316900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
317000
317100     IF OUTLIER-RECON-FLAG = 'Y'
317200        MOVE 'N' TO OUTLIER-RECON-FLAG
317300        GO TO 0200-EXIT.
317400
317500     IF PPS-RTC = 00
317600        IF H-PERDIEM-DAYS = H-ALOS OR
317700           H-PERDIEM-DAYS > H-ALOS
317800           MOVE 14 TO PPS-RTC.
317900
318000     IF PPS-RTC = 02
318100        IF H-PERDIEM-DAYS = H-ALOS OR
318200           H-PERDIEM-DAYS > H-ALOS
318300           MOVE 16 TO PPS-RTC.
318400
318500 0200-EXIT.   EXIT.
318600
318700 1000-EDIT-THE-BILL-INFO.
318800
318900     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
319000     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
319100
319200     IF  PPS-RTC = 00
319300         IF  P-NEW-WAIVER-STATE
319400             MOVE 53 TO PPS-RTC.
319500
319600     IF  PPS-RTC = 00
319700         IF  B-DRG < 001
319800               OR = 009 OR = 015
319900               OR = 018 OR = 019 OR = 043 OR = 044
320000               OR = 045 OR = 046 OR = 047 OR = 048
320100               OR = 049 OR = 050 OR = 051 OR = 104
320200               OR = 105 OR = 106 OR = 107 OR = 108
320300               OR = 109 OR = 110 OR = 111 OR = 112
320400               OR = 118 OR = 119 OR = 120 OR = 126
320500               OR = 127 OR = 128 OR = 140 OR = 141
320600               OR = 142 OR = 143 OR = 144 OR = 145
320700               OR = 160 OR = 161 OR = 162 OR = 169
320800               OR = 170 OR = 171 OR = 172 OR = 173
320900               OR = 174 OR = 209 OR = 210 OR = 211
321000               OR = 212 OR = 213 OR = 214
321100               OR = 266 OR = 267 OR = 268 OR = 269
321200               OR = 270 OR = 271 OR = 272 OR = 273
321300               OR = 274 OR = 275 OR = 276 OR = 277
321400               OR = 278 OR = 279 OR = 317 OR = 318
321500               OR = 319 OR = 320 OR = 321 OR = 322
321600               OR = 323 OR = 324 OR = 325 OR = 359
321700               OR = 360 OR = 361 OR = 362 OR = 363
321800               OR = 364 OR = 365 OR = 366 OR = 367
321900               OR = 396 OR = 397 OR = 398 OR = 399
322000               OR = 400 OR = 401 OR = 402 OR = 403
322100               OR = 404 OR = 426 OR = 427 OR = 428
322200               OR = 429 OR = 430 OR = 431 OR = 447
322300               OR = 448 OR = 449 OR = 450 OR = 451
322400               OR = 452 OR = 518 OR = 519 OR = 520
322500               OR = 521 OR = 522 OR = 523 OR = 524
322600               OR = 525 OR = 526 OR = 527 OR = 528
322700               OR = 529 OR = 530 OR = 531 OR = 532
322800               OR = 567 OR = 568 OR = 569
322900               OR = 586 OR = 587
323000               OR = 588 OR = 589 OR = 590 OR = 591
323100               OR = 608 OR = 609 OR = 610 OR = 611
323200               OR = 612 OR = 613 OR = 631 OR = 632
323300               OR = 633 OR = 634 OR = 635 OR = 636
323400               OR = 646 OR = 647 OR = 648 OR = 649
323500               OR = 650 OR = 651 OR = 676 OR = 677
323600               OR = 678 OR = 679 OR = 680 OR = 681
323700               OR = 701 OR = 702 OR = 703 OR = 704
323800               OR = 705 OR = 706 OR = 719 OR = 720
323900               OR = 721 OR = 731 OR = 732 OR = 733
324000               OR = 751 OR = 752 OR = 753 OR = 762
324100               OR = 763 OR = 764 OR = 771 OR = 772
324200               OR = 773 OR = 783 OR = 784 OR = 785
324300               OR = 786 OR = 787 OR = 788 OR = 796
324400               OR = 797 OR = 798 OR = 805 OR = 806
324500               OR = 807 OR = 817 OR = 818 OR = 819
324600               OR = 831 OR = 832 OR = 833 OR = 850
324700               OR = 851 OR = 852 OR = 859 OR = 860
324800               OR = 861 OR = 873 OR = 874 OR = 875
324900               OR = 877 OR = 878 OR = 879
325000               OR = 888 OR = 889 OR = 890
325100               OR = 891 OR = 892
325200               OR = 893 OR = 898 OR = 899 OR = 900
325300               OR = 910 OR = 911 OR = 912 OR = 924
325400               OR = 925 OR = 926 OR = 930 OR = 931
325500               OR = 932 OR = 936 OR = 937 OR = 938
325600               OR = 942 OR = 943 OR = 944 OR = 952
325700               OR = 953 OR = 954 OR = 960 OR = 961
325800               OR = 962 OR = 966 OR = 967 OR = 968
325900               OR = 971 OR = 972 OR = 973 OR = 978
326000               OR = 979 OR = 980 OR = 990 OR = 991
326100               OR = 992 OR = 993 OR = 994 OR = 995
326200               OR = 996 OR = 997
326300             MOVE 54 TO PPS-RTC.
326400
326500     IF  PPS-RTC = 00
326600            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
326700                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
326800                MOVE 55 TO PPS-RTC.
326900
327000     IF  PPS-RTC = 00
327100         IF P-NEW-TERMINATION-DATE > 00000000
327200            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
327300                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
327400                  MOVE 55 TO PPS-RTC.
327500
327600     IF  PPS-RTC = 00
327700         IF  B-LOS NOT NUMERIC
327800             MOVE 56 TO PPS-RTC
327900         ELSE
328000         IF  B-LOS = 0
328100             IF B-REVIEW-CODE NOT = 00 AND
328200                              NOT = 03 AND
328300                              NOT = 06 AND
328400                              NOT = 07 AND
328500                              NOT = 09 AND
328600                              NOT = 11
328700             MOVE 56 TO PPS-RTC.
328800
328900     IF  PPS-RTC = 00
329000         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
329100             MOVE 61 TO PPS-RTC
329200         ELSE
329300             MOVE B-LTR-DAYS TO H-LTR-DAYS.
329400
329500     IF  PPS-RTC = 00
329600         IF  B-COVERED-DAYS NOT NUMERIC
329700             MOVE 62 TO PPS-RTC
329800         ELSE
329900         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
330000             MOVE 62 TO PPS-RTC
330100         ELSE
330200             MOVE B-COVERED-DAYS TO H-COV-DAYS.
330300
330400     IF  PPS-RTC = 00
330500         IF  H-LTR-DAYS  > H-COV-DAYS
330600             MOVE 62 TO PPS-RTC
330700         ELSE
330800             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
330900
331000     IF  PPS-RTC = 00
331100         IF  NOT VALID-REVIEW-CODE
331200             MOVE 57 TO PPS-RTC.
331300
331400     IF  PPS-RTC = 00
331500         IF  B-CHARGES-CLAIMED NOT NUMERIC
331600             MOVE 58 TO PPS-RTC.
331700
331800     IF PPS-RTC = 00
331900           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
332000                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
332100                                            NOT = 'B' AND
332200                                            NOT = 'C'
332300                 MOVE 65 TO PPS-RTC.
332400
332500*    IF PPS-RTC = 00
332600*          IF P-N-INVALID-PROV-TYPES
332700*                MOVE 52 TO PPS-RTC.
332800
332900 2000-ASSEMBLE-PPS-VARIABLES.
333000***  GET THE PROVIDER SPECIFIC VARIABLES.
333100***  GET THE PROVIDER SPECIFIC VARIABLES.
333200
333300     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
333400     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
333500
333600     IF  (P-NEW-STATE = 02 OR 12)
333700         MOVE P-NEW-COLA TO H-OPER-COLA
333800     ELSE
333900         MOVE 1.000  TO H-OPER-COLA.
334000
334100***************************************************************
334200***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
334300***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
334400
334500     PERFORM 2600-GET-DRG-WEIGHT
334600             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
334700
334800***************************************************************
334900***  GET THE WAGE-INDEX
335000***  GET THE WAGE-INDEX
335100
335200     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
335300     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
335400     MOVE P-NEW-STATE            TO MES-PPS-STATE.
335500*****YEARCHANGE 2011.0 ** NOT USED
335600
335700
335800
335900*****YEARCHANGE 2011.0 ** NOT USED 2013 *******************
336000
336100***************************************************************
336200***  GET THE LABOR, NON-LABOR STANDARD RATES
336300
336400     IF  P-NEW-STATE = 40
336500         MOVE 2 TO R2
336600         MOVE 3 TO R4
336700     ELSE
336800         MOVE 1 TO R2
336900         MOVE 1 TO R4.
337000
337100     IF  LARGE-URBAN
337200         MOVE 1 TO R3
337300     ELSE
337400         MOVE 2 TO R3.
337500
337600     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
337700        (H-WAGE-INDEX > 01.0000))
337800        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
337900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
338000
338100     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
338200         (H-WAGE-INDEX > 01.0000))
338300        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
338400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
338500
338600     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
338700         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
338800        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
338900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
339000
339100     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
339200         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
339300        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
339400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
339500
339600     IF P-NEW-STATE = 40
339700        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
339800            (H-PR-WAGE-INDEX > 01.0000))
339900             PERFORM 2300-GET-PR-LAB-TB1-RATES
340000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
340100
340200
340300     IF P-NEW-STATE = 40
340400        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
340500             (H-PR-WAGE-INDEX > 01.0000))
340600              PERFORM 2300-GET-PR-LAB-TB2-RATES
340700                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
340800
340900     IF P-NEW-STATE = 40
341000        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
341100         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
341200          PERFORM 2300-GET-PR-LAB-TB3-RATES
341300              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
341400
341500     IF P-NEW-STATE = 40
341600        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
341700         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
341800          PERFORM 2300-GET-PR-LAB-TB4-RATES
341900              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
342000
342100***************************************************************
342200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
342300***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
342400
342500     MOVE 0.00  TO H-OPER-HSP-PCT.
342600     MOVE 1.00  TO H-OPER-FSP-PCT.
342700
342800***************************************************************
342900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
343000***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
343100
343200      MOVE 1.00 TO H-NAT-PCT.
343300      MOVE 0.00 TO H-REG-PCT.
343400
343500     IF  P-NEW-STATE = 40
343600         MOVE 0.75 TO H-NAT-PCT
343700         MOVE 0.25 TO H-REG-PCT.
343800
343900     IF  P-N-SCH-REBASED-FY90 OR
344000         P-N-EACH OR
344100         P-N-MDH-REBASED-FY90
344200         MOVE 1.00 TO H-OPER-HSP-PCT.
344300
344400 2300-GET-LAB-NONLAB-TB1-RATES.
344500
344600     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
344700         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
344800         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
344900         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
345000         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
345100
345200 2300-GET-LAB-NONLAB-TB2-RATES.
345300
345400     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
345500         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
345600         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
345700         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
345800         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
345900
346000 2300-GET-LAB-NONLAB-TB3-RATES.
346100
346200     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
346300         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
346400         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
346500         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
346600         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
346700
346800 2300-GET-LAB-NONLAB-TB4-RATES.
346900
347000     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
347100         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
347200         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
347300         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
347400         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
347500
347600 2300-GET-PR-LAB-TB1-RATES.
347700
347800     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
347900         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
348000         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
348100
348200 2300-GET-PR-LAB-TB2-RATES.
348300
348400     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
348500         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
348600         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
348700
348800 2300-GET-PR-LAB-TB3-RATES.
348900
349000     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
349100         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
349200         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
349300
349400 2300-GET-PR-LAB-TB4-RATES.
349500
349600     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
349700         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
349800         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
349900
350000
350100 2600-GET-DRG-WEIGHT.
350200
350300     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
350400         SET DX6 TO B-DRG
350500         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
350600         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
350700         MOVE ZEROES                   TO H-DAYS-CUTOFF
350800         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
350900
351000 3000-CALC-PAYMENT.
351100***************************************************************
351200
351300     PERFORM 3100-CALC-STAY-UTILIZATION.
351400     PERFORM 3300-CALC-OPER-FSP-AMT.
351500     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
351600
351700***********************************************************
351800***  OPERATING IME CALCULATION
351900***  OPERATING IME CALCULATION
352000
352100     COMPUTE H-OPER-IME-TEACH ROUNDED =
352200            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
352300
352400***********************************************************
352500*
352600*    IF P-N-SCH-REBASED-FY90 OR
352700*       P-N-EACH OR
352800*       P-N-MDH-REBASED-FY90
352900*        PERFORM 3450-CALC-ADDITIONAL-HSP.
353000*
353100     MOVE 00                 TO  PPS-RTC.
353200     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
353300     MOVE H-ALOS             TO  PPS-AVG-LOS.
353400     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
353500
353600     MOVE B-LOS TO H-PERDIEM-DAYS.
353700     IF H-PERDIEM-DAYS < 1
353800         MOVE 1 TO H-PERDIEM-DAYS.
353900     ADD 1 TO H-PERDIEM-DAYS.
354000
354100     MOVE 1 TO H-DSCHG-FRCTN.
354200
354300     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
354400
354500     IF (PAY-PERDIEM-DAYS  OR
354600         PAY-XFER-NO-COST) OR
354700        (PAY-XFER-SPEC-DRG AND
354800         B-DRG-POSTACUTE-PERDIEM)
354900         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
355000         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
355100         IF H-DSCHG-FRCTN > 1
355200              MOVE 1 TO H-DSCHG-FRCTN
355300              MOVE 1 TO H-TRANSFER-ADJ
355400         ELSE
355500              COMPUTE H-DRG-WT-FRCTN ROUNDED =
355600                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
355700
355800     IF (PAY-XFER-SPEC-DRG AND
355900         B-DRG-POSTACUTE-50-50)
356000         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
356100         COMPUTE H-DSCHG-FRCTN  ROUNDED =
356200                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
356300         IF H-DSCHG-FRCTN > 1
356400              MOVE 1 TO H-DSCHG-FRCTN
356500              MOVE 1 TO H-TRANSFER-ADJ
356600         ELSE
356700              COMPUTE H-DRG-WT-FRCTN ROUNDED =
356800            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
356900
357000
357100***********************************************************
357200***  CAPITAL DSH CALCULATION
357300***  CAPITAL DSH CALCULATION
357400
357500     MOVE 0 TO H-CAPI-DSH.
357600
357700     IF P-NEW-BED-SIZE NOT NUMERIC
357800         MOVE 0 TO P-NEW-BED-SIZE.
357900
358000     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
358100         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
358200                  (.2025 * (P-NEW-SSI-RATIO
358300                          + P-NEW-MEDICAID-RATIO)) - 1.
358400
358500***********************************************************
358600***  CAPITAL IME TEACH CALCULATION
358700***  CAPITAL IME TEACH CALCULATION
358800
358900     MOVE 0 TO H-WK-CAPI-IME-TEACH.
359000
359100     IF P-NEW-CAPI-IME NUMERIC
359200        IF P-NEW-CAPI-IME > 1.5000
359300           MOVE 1.5000 TO P-NEW-CAPI-IME.
359400
359500*****YEARCHANGE 2009.5 ****************************************
359600***
359700***  PER POLICY, WE REMOVED THE .5 MULTIPLER
359800***
359900***********************************************************
360000     IF P-NEW-CAPI-IME NUMERIC
360100        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
360200         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
360300
360400*****YEARCHANGE 2009.5 ****************************************
360500***********************************************************
360600     MOVE 0.00 TO H-DAYOUT-PCT.
360700     MOVE 0.80 TO H-CSTOUT-PCT.
360800
360900******************************************************************
361000**
361100** BURN DRGS FOR FY09 ARE 927, 928, 929, 933, 934 AND 935.
361200**
361300******************************************************************
361400
361500     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
361600             MOVE 0.90 TO H-CSTOUT-PCT.
361700
361800***     NATIONAL PERCENTAGE
361900     MOVE 0.6880   TO H-LABOR-PCT.
362000     MOVE 0.3120   TO H-NONLABOR-PCT.
362100
362200***     PUERTO RICO PERCENTAGE
362300     MOVE 0.6210   TO H-PR-LABOR-PCT.
362400     MOVE 0.3790   TO H-PR-NONLABOR-PCT.
362500
362600     IF (H-WAGE-INDEX < 01.0000 OR
362700         H-WAGE-INDEX = 01.0000)
362800        MOVE 0.6200 TO H-LABOR-PCT
362900        MOVE 0.3800 TO H-NONLABOR-PCT.
363000***
363100     IF P-NEW-STATE = 40
363200       IF (H-PR-WAGE-INDEX < 01.0000 OR
363300           H-PR-WAGE-INDEX = 01.0000)
363400          MOVE 0.6200 TO H-PR-LABOR-PCT
363500          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
363600
363700
363800     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
363900             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
364000     ELSE
364100             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
364200
364300     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
364400             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
364500     ELSE
364600             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
364700
364800***********************************************************
364900*****YEARCHANGE 2010.0 ************************************
365000***  CAPITAL PAYMENT METHOD B - YEARCHNG
365100***  CAPITAL PAYMENT METHOD B
365200
365300     IF W-CBSA-SIZE = 'L'
365400        MOVE 1.00 TO H-CAPI-LARG-URBAN
365500     ELSE
365600        MOVE 1.00 TO H-CAPI-LARG-URBAN.
365700
365800     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
365900     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
366000
366100*****YEARCHANGE 2013.0 ************************************
366200     COMPUTE H-FEDERAL-RATE ROUNDED =
366300                                 (0425.49 * H-CAPI-GAF).
366400     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
366500                                 (0207.25 * H-PR-CAPI-GAF).
366600*****YEARCHANGE 2013.0 ************************************
366700
366800     COMPUTE H-CAPI-COLA ROUNDED =
366900                     (.3152 * (H-OPER-COLA - 1) + 1).
367000
367100     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
367200
367300     IF P-NEW-STATE = 40
367400        COMPUTE  H-CAPI-FED-RATE ROUNDED =
367500                 (H-NAT-PCT * H-FEDERAL-RATE) +
367600                 (H-REG-PCT * H-PUERTO-RICO-RATE).
367700***********************************************************
367800***  CAPITAL FSP CALCULATION
367900***  CAPITAL FSP CALCULATION
368000
368100     COMPUTE H-CAPI-FSP-PART ROUNDED =
368200                               H-DRG-WT       *
368300                               H-CAPI-FED-RATE *
368400                               H-CAPI-COLA *
368500                               H-CAPI-LARG-URBAN.
368600
368700***********************************************************
368800***  CAPITAL PAYMENT METHOD A
368900***  CAPITAL PAYMENT METHOD A
369000
369100     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
369200        MOVE 1.00 TO H-CAPI-SCH
369300     ELSE
369400        MOVE 0.85 TO H-CAPI-SCH.
369500
369600***********************************************************
369700***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
369800***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
369900
370000     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
370100                    (P-NEW-CAPI-OLD-HARM-RATE *
370200                    H-CAPI-SCH).
370300
370400***********************************************************
370500        IF PAY-PERDIEM-DAYS
370600            IF  H-PERDIEM-DAYS < H-ALOS
370700                IF  NOT (B-DRG = 789)
370800                    PERFORM 3500-CALC-PERDIEM-AMT
370900                    MOVE 03 TO PPS-RTC.
371000
371100        IF PAY-XFER-SPEC-DRG
371200            IF  H-PERDIEM-DAYS < H-ALOS
371300                IF  NOT (B-DRG = 789)
371400                    PERFORM 3550-CALC-PERDIEM-AMT.
371500
371600        IF  PAY-XFER-NO-COST
371700            MOVE 00 TO PPS-RTC
371800            IF H-PERDIEM-DAYS < H-ALOS
371900               IF  NOT (B-DRG = 789)
372000                   PERFORM 3500-CALC-PERDIEM-AMT
372100                   MOVE 06 TO PPS-RTC.
372200
372300     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
372400
372500     PERFORM 6000-CALC-READMIS-REDU THRU 6000-EXIT.
372600
372700     IF PPS-RTC = 65 OR 67 OR 68
372800               GO TO 3000-CONTINUE.
372900
373000     PERFORM 7000-CALC-VALUE-BASED-PURCH THRU 7000-EXIT.
373100
373200     IF PPS-RTC = 65 OR 67 OR 68
373300               GO TO 3000-CONTINUE.
373400
373500     PERFORM 8000-CALC-BUNDLE-REDU  THRU 8000-EXIT.
373600
373700     IF PPS-RTC = 65 OR 67 OR 68
373800               GO TO 3000-CONTINUE.
373900
374000     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
374100
374200     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
374300
374400     IF PPS-RTC = 65 OR 67 OR 68
374500               GO TO 3000-CONTINUE.
374600
374700        IF PAY-XFER-SPEC-DRG
374800            IF  H-PERDIEM-DAYS < H-ALOS
374900                IF  NOT (B-DRG = 789)
375000                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
375100
375200
375300        IF  PAY-PERDIEM-DAYS
375400            IF  H-OPER-OUTCST-PART > 0
375500                MOVE H-OPER-OUTCST-PART TO
375600                     H-OPER-OUTLIER-PART
375700                MOVE 05 TO PPS-RTC
375800            ELSE
375900            IF  PPS-RTC NOT = 03
376000                MOVE 00 TO PPS-RTC
376100                MOVE 0  TO H-OPER-OUTLIER-PART.
376200
376300        IF  PAY-PERDIEM-DAYS
376400            IF  H-CAPI-OUTCST-PART > 0
376500                MOVE H-CAPI-OUTCST-PART TO
376600                     H-CAPI-OUTLIER-PART
376700                MOVE 05 TO PPS-RTC
376800            ELSE
376900            IF  PPS-RTC NOT = 03
377000                MOVE 0  TO H-CAPI-OUTLIER-PART.
377100
377200
377300     IF P-N-SCH-REBASED-FY90 OR
377400        P-N-EACH OR
377500        P-N-MDH-REBASED-FY90
377600         PERFORM 3450-CALC-ADDITIONAL-HSP.
377700
377800
377900 3000-CONTINUE.
378000
378100***********************************************************
378200***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
378300***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
378400
378500     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
378600
378700***********************************************************
378800
378900     IF  PPS-RTC = 67
379000         MOVE H-OPER-DOLLAR-THRESHOLD TO
379100              WK-H-OPER-DOLLAR-THRESHOLD.
379200
379300     IF  PPS-RTC < 50
379400         PERFORM 3800-CALC-TOT-AMT THRU 3800-EXIT
379500     ELSE
379600         MOVE ALL '0' TO PPS-OPER-HSP-PART
379700                         PPS-OPER-FSP-PART
379800                         PPS-OPER-OUTLIER-PART
379900                         PPS-OUTLIER-DAYS
380000                         PPS-REG-DAYS-USED
380100                         PPS-LTR-DAYS-USED
380200                         PPS-TOTAL-PAYMENT
380300                         PPS-OPER-DSH-ADJ
380400                         PPS-OPER-IME-ADJ
380500                         H-DSCHG-FRCTN
380600                         H-DRG-WT-FRCTN
380700                         HOLD-ADDITIONAL-VARIABLES
380800                         HOLD-CAPITAL-VARIABLES
380900                         HOLD-CAPITAL2-VARIABLES
381000                         HOLD-OTHER-VARIABLES
381100                         HOLD-PC-OTH-VARIABLES.
381200
381300     IF  PPS-RTC = 67
381400         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
381500                 H-OPER-DOLLAR-THRESHOLD.
381600
381700 3000-EXIT.  EXIT.
381800
381900 3100-CALC-STAY-UTILIZATION.
382000
382100     MOVE 0 TO PPS-REG-DAYS-USED.
382200     MOVE 0 TO PPS-LTR-DAYS-USED.
382300
382400     IF H-REG-DAYS > 0
382500        IF H-REG-DAYS > B-LOS
382600           MOVE B-LOS TO PPS-REG-DAYS-USED
382700        ELSE
382800           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
382900     ELSE
383000        IF H-LTR-DAYS > B-LOS
383100           MOVE B-LOS TO PPS-LTR-DAYS-USED
383200        ELSE
383300           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
383400
383500
383600
383700 3300-CALC-OPER-FSP-AMT.
383800***********************************************************
383900***  OPERATING FSP CALCULATION
384000***  OPERATING FSP CALCULATION
384100
384200     COMPUTE H-OPER-FSP-PART ROUNDED =
384300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
384400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
384500                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
384600
384700     IF P-NEW-STATE = 40
384800       COMPUTE H-OPER-FSP-PART ROUNDED =
384900           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
385000            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
385100                           +
385200           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
385300            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
385400                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
385500
385600
385700 3500-CALC-PERDIEM-AMT.
385800***********************************************************
385900***  REVIEW CODE = 03 OR 06
386000***  OPERATING PERDIEM-AMT CALCULATION
386100***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
386200
386300        COMPUTE H-OPER-FSP-PART ROUNDED =
386400        H-OPER-FSP-PART * H-TRANSFER-ADJ
386500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
386600
386700***********************************************************
386800***********************************************************
386900***  REVIEW CODE = 03 OR 06
387000***  CAPITAL   PERDIEM-AMT CALCULATION
387100***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
387200
387300        COMPUTE H-CAPI-FSP-PART ROUNDED =
387400        H-CAPI-FSP-PART * H-TRANSFER-ADJ
387500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
387600
387700***********************************************************
387800***  REVIEW CODE = 03 OR 06
387900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
388000***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
388100
388200        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
388300        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
388400        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
388500
388600 3550-CALC-PERDIEM-AMT.
388700***********************************************************
388800***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
388900***  OPERATING PERDIEM-AMT CALCULATION
389000***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
389100
389200     IF (B-DRG-POSTACUTE-50-50)
389300        MOVE 10 TO PPS-RTC
389400        COMPUTE H-OPER-FSP-PART ROUNDED =
389500        H-OPER-FSP-PART * H-DSCHG-FRCTN
389600        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
389700
389800     IF (B-DRG-POSTACUTE-PERDIEM)
389900        MOVE 12 TO PPS-RTC
390000        COMPUTE H-OPER-FSP-PART ROUNDED =
390100        H-OPER-FSP-PART *  H-TRANSFER-ADJ
390200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
390300
390400***********************************************************
390500***  CAPITAL PERDIEM-AMT CALCULATION
390600***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
390700
390800     IF (B-DRG-POSTACUTE-50-50)
390900        MOVE 10 TO PPS-RTC
391000        COMPUTE H-CAPI-FSP-PART ROUNDED =
391100        H-CAPI-FSP-PART * H-DSCHG-FRCTN
391200        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
391300
391400     IF (B-DRG-POSTACUTE-PERDIEM)
391500        MOVE 12 TO PPS-RTC
391600        COMPUTE H-CAPI-FSP-PART ROUNDED =
391700        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
391800        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
391900
392000***********************************************************
392100***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
392200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
392300
392400     IF (B-DRG-POSTACUTE-50-50)
392500        MOVE 10 TO PPS-RTC
392600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
392700        H-CAPI-OLD-HARMLESS * H-DSCHG-FRCTN
392800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
392900
393000     IF (B-DRG-POSTACUTE-PERDIEM)
393100        MOVE 12 TO PPS-RTC
393200        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
393300        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
393400        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
393500
393600 3560-CHECK-RTN-CODE.
393700
393800     IF (B-DRG-POSTACUTE-50-50)
393900        MOVE 10 TO PPS-RTC.
394000     IF (B-DRG-POSTACUTE-PERDIEM)
394100        MOVE 12 TO PPS-RTC.
394200
394300 3560-EXIT.    EXIT.
394400
394500 3600-CALC-OUTLIER.
394600***********************************************************
394700***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
394800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
394900
395000     IF OUTLIER-RECON-FLAG = 'Y'
395100        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
395200               (H-OPER-CSTCHG-RATIO + .2).
395300
395400     IF H-CAPI-CSTCHG-RATIO > 0 OR
395500       H-OPER-CSTCHG-RATIO > 0
395600        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
395700                H-OPER-CSTCHG-RATIO /
395800               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
395900        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
396000                H-CAPI-CSTCHG-RATIO /
396100               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
396200     ELSE
396300         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
396400                   H-CAPI-SHARE-DOLL-THRESHOLD.
396500
396600***********************************************************
396700*****YEARCHANGE 2013.0 ************************************
396800***  OUTLIER THRESHOLD AMOUNTS
396900***  OUTLIER THRESHOLD AMOUNTS
397000
397100*****YEARCHANGE 2013.0 ************************************
397200
397300     MOVE 21821.00 TO H-CST-THRESH.
397400
397500*****YEARCHANGE 2013.0 ************************************
397600
397700     IF (B-REVIEW-CODE = '03') AND
397800         H-PERDIEM-DAYS < H-ALOS
397900        COMPUTE H-CST-THRESH ROUNDED =
398000                      (H-CST-THRESH * H-TRANSFER-ADJ)
398100                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
398200
398300     IF ((B-REVIEW-CODE = '09') AND
398400         (H-PERDIEM-DAYS < H-ALOS))
398500         IF (B-DRG-POSTACUTE-PERDIEM)
398600            COMPUTE H-CST-THRESH ROUNDED =
398700                      (H-CST-THRESH * H-TRANSFER-ADJ)
398800                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
398900
399000     IF ((B-REVIEW-CODE = '09') AND
399100         (H-PERDIEM-DAYS < H-ALOS))
399200         IF (B-DRG-POSTACUTE-50-50)
399300           COMPUTE H-CST-THRESH ROUNDED =
399400          H-CST-THRESH * H-DSCHG-FRCTN
399500                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
399600
399700     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
399800        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
399900         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
400000          H-OPER-SHARE-DOLL-THRESHOLD.
400100
400200     IF P-NEW-STATE = 40
400300        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
400400           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
400500            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
400600             H-OPER-SHARE-DOLL-THRESHOLD
400700        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
400800               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
400900               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
401000
401100***********************************************************
401200
401300     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
401400          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
401500          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
401600
401700
401800     IF P-NEW-STATE = 40
401900        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
402000           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
402100           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
402200        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
402300               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
402400               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
402500
402600
402700     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
402800      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
402900                       +
403000             H-OPER-DOLLAR-THRESHOLD
403100                       +
403200                 H-NEW-TECH-PAY-ADD-ON.
403300
403400     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
403500      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
403600                       +
403700             H-CAPI-DOLLAR-THRESHOLD.
403800
403900     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
404000         MOVE 0 TO H-CAPI-COST-OUTLIER.
404100
404200
404300***********************************************************
404400***  OPERATING COST CALCULATION
404500***  OPERATING COST CALCULATION
404600
404700     COMPUTE H-OPER-BILL-COSTS ROUNDED =
404800         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
404900         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
405000
405100
405200     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
405300         COMPUTE H-OPER-OUTCST-PART ROUNDED =
405400         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
405500                         H-OPER-COST-OUTLIER).
405600
405700     IF PAY-WITHOUT-COST OR
405800        PAY-XFER-NO-COST OR
405900        PAY-XFER-SPEC-DRG-NO-COST
406000         MOVE 0 TO H-OPER-OUTCST-PART.
406100
406200***********************************************************
406300***  CAPITAL COST CALCULATION
406400***  CAPITAL COST CALCULATION
406500
406600     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
406700             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
406800         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
406900
407000     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
407100         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
407200         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
407300                         H-CAPI-COST-OUTLIER).
407400
407500     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
407600       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
407700              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
407800
407900     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
408000        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
408100               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
408200
408300     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
408400        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
408500        MOVE 0 TO H-CAPI-OUTCST-PART
408600                  H-OPER-OUTCST-PART.
408700
408800     IF PAY-WITHOUT-COST OR
408900        PAY-XFER-NO-COST OR
409000        PAY-XFER-SPEC-DRG-NO-COST
409100         MOVE 0 TO H-CAPI-OUTCST-PART.
409200
409300***********************************************************
409400***  DETERMINES THE BILL TO BE COST  OUTLIER
409500
409600     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
409700         MOVE 0 TO H-CAPI-OUTDAY-PART
409800                   H-CAPI-OUTCST-PART.
409900
410000     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
410100                 MOVE H-OPER-OUTCST-PART TO
410200                      H-OPER-OUTLIER-PART
410300                 MOVE H-CAPI-OUTCST-PART TO
410400                      H-CAPI-OUTLIER-PART
410500                 MOVE 02 TO PPS-RTC.
410600
410700     IF OUTLIER-RECON-FLAG = 'Y'
410800        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
410900           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
411000           GO TO 3600-EXIT
411100        ELSE
411200           GO TO 3600-EXIT
411300     ELSE
411400        NEXT SENTENCE.
411500
411600
411700***********************************************************
411800***  DETERMINES IF COST OUTLIER
411900***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
412000***         RETURN CODE OF 02
412100
412200     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
412300
412400     IF PPS-RTC = 02
412500             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
412600                     (H-CAPI-COST-OUTLIER  +
412700                      H-OPER-COST-OUTLIER)
412800                             /
412900                    (H-CAPI-CSTCHG-RATIO  +
413000                     H-OPER-CSTCHG-RATIO)
413100             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
413200
413300***********************************************************
413400***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
413500***         RETURN CODE OF 67
413600
413700     IF PPS-RTC = 02
413800         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
413900            PPS-PC-COT-FLAG = 'Y'
414000             MOVE 67 TO PPS-RTC.
414100***********************************************************
414200
414300***********************************************************
414400***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
414500***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
414600
414700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
414800        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
414900                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
415000         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
415100
415200     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
415300        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
415400                H-CAPI-OUTLIER-PART.
415500
415600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
415700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
415800                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
415900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
416000
416100 3600-EXIT.   EXIT.
416200
416300 3450-CALC-ADDITIONAL-HSP.
416400***********************************************************
416500*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
416600*    SOLE COMMUNITY
416700*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
416800*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
416900***********************************************************
417000***         GET THE UPDATING FACTOR
417100***         GET THE UPDATING FACTOR
417200
417300*****YEARCHANGE 2013.0 ****************************************
417400     MOVE 0.998431 TO H-BUDG-NUTR130.
417500*****YEARCHANGE 2013.0 ****************************************
417600
417700
417800     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
417900*****YEARCHANGE 2013.0 ****************************************
418000        MOVE 1.0180 TO H-UPDATE-130
418100     ELSE
418200        MOVE 0.9980 TO H-UPDATE-130.
418300*****YEARCHANGE 2013.0 ****************************************
418400
418500     IF P-NEW-STATE = 40
418600*****YEARCHANGE 2013.0 ****************************************
418700        MOVE 1.0180 TO H-UPDATE-130.
418800*****YEARCHANGE 2013.0 ****************************************
418900
419000********YEARCHANGE 2013.0 *************************************
419100***         CASE MIX ADJUSTMENT - BROUGHT BACK FOR 2011
419200***         CASE MIX ADJUSTMENT - BROUGHT BACK FOR 2011
419300     MOVE 0.9480 TO H-CASE-MIX-ADJ.
419400
419500     COMPUTE H-UPDATE-FACTOR ROUNDED =
419600                       (H-UPDATE-130 *
419700                        H-BUDG-NUTR130 *
419800                        H-CASE-MIX-ADJ).
419900
420000     COMPUTE H-HSP-RATE ROUNDED =
420100         H-FAC-SPEC-RATE * H-UPDATE-FACTOR * H-DRG-WT.
420200***************************************************************
420300*
420400*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
420500*       COMPUTE H-HSP-RATE ROUNDED =
420600*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
420700*    ELSE
420800*       COMPUTE H-HSP-RATE ROUNDED =
420900*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
421000*
421100***************************************************************
421200********YEARCHANGE 2011.0 *************************************
421300***     OUTLIER OFFSETS
421400***     OPERATING NATIONAL
421500***     OPERATING PUERTO RICO BLEND
421600
421700********YEARCHANGE 2013.0 *************************************
421800
421900      MOVE 0.948999 TO H-OUTLIER-OFFSET-NAT
422000      MOVE 0.944760 TO H-OUTLIER-OFFSET-PR.
422100
422200********YEARCHANGE 2013.0 *XXXXXX******************************
422300*      THE HSP BUCKET FOR SCH                      ************
422400***************************************************************
422500     COMPUTE H-FSP-RATE ROUNDED =
422600        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
422700         H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
422800                           *
422900     (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
423000                         H-OPER-OUTLIER-PART
423100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
423200
423300     IF P-NEW-STATE = 40
423400       COMPUTE H-FSP-RATE ROUNDED =
423500         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
423600         H-NAT-NONLABOR * H-OPER-COLA))  * H-DRG-WT-FRCTN)
423700                           *
423800         (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
423900                            H-OPER-OUTLIER-PART
424000                               +
424100        ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
424200         H-REG-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN)
424300                           *
424400       (1 + H-OPER-IME-TEACH + H-OPER-DSH)
424500                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
424600
424700
424800     IF  H-HSP-RATE > H-FSP-RATE
424900           COMPUTE H-OPER-HSP-PART ROUNDED =
425000             (H-HSP-RATE - H-FSP-RATE)
425100                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
425200     ELSE
425300         MOVE 0 TO H-OPER-HSP-PART.
425400
425500***************************************************************
425600***         GET THE MDH REBASE
425700
425800
425900     IF  H-HSP-RATE > H-FSP-RATE
426000         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
426100           COMPUTE H-OPER-HSP-PART ROUNDED =
426200             (H-HSP-RATE - H-FSP-RATE) * .75
426300                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
426400
426500***********************************************************
426600 3800-CALC-TOT-AMT.
426700***********************************************************
426800***  CALCULATE TOTALS FOR CAPITAL
426900***  CALCULATE TOTALS FOR CAPITAL
427000
427100     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
427200
427300     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
427400        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
427500        MOVE 0.00 TO H-CAPI-HSP-PCT.
427600
427700     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
427800        MOVE 0    TO H-CAPI-OLD-HARMLESS
427900        MOVE 1.00 TO H-CAPI-FSP-PCT
428000        MOVE 0.00 TO H-CAPI-HSP-PCT.
428100
428200     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
428300        MOVE 0    TO H-CAPI-OLD-HARMLESS
428400        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
428500        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
428600
428700     COMPUTE H-CAPI-HSP ROUNDED =
428800         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
428900
429000     COMPUTE H-CAPI-FSP ROUNDED =
429100         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
429200
429300     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
429400
429500     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
429600
429700     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
429800             H-CAPI-FSP
429900              * H-CAPI-DSH.
430000
430100     COMPUTE H-CAPI-IME-ADJ ROUNDED =
430200          H-CAPI-FSP *
430300                 H-WK-CAPI-IME-TEACH.
430400
430500     COMPUTE H-CAPI-OUTLIER ROUNDED =
430600             1.00 * H-CAPI-OUTLIER-PART.
430700
430800     COMPUTE H-CAPI2-B-FSP ROUNDED =
430900             1.00 * H-CAPI2-B-FSP-PART.
431000
431100     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
431200             1.00 * H-CAPI2-B-OUTLIER-PART.
431300***********************************************************
431400***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
431500***        THIS ZEROES OUT ALL CAPITAL DATA
431600
431700     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
431800        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
431900***********************************************************
432000
432100***********************************************************
432200***  CALCULATE FINAL TOTALS FOR OPERATING
432300***  CALCULATE FINAL TOTALS FOR OPERATING
432400
432500     IF (H-CAPI-OUTLIER > 0 AND
432600         PPS-OPER-OUTLIER-PART = 0)
432700            COMPUTE PPS-OPER-OUTLIER-PART =
432800                    PPS-OPER-OUTLIER-PART + .01.
432900
433000***********************************************************
433100***  LOW VOLUME CALCULATION
433200***  LOW VOLUME CALCULATION
433300
433400     MOVE 01.000 TO WK-LOW-VOL25PCT.
433500
433600     IF P-NEW-TEMP-RELIEF-IND = 'Y'
433700     MOVE P-NEW-PROVIDER-NO      TO MES-PPS-PROV
433800     PERFORM 4400-LOWVOL-CODE-RTN THRU 4400-EXIT.
433900
434000*****SET THE LOW-VOLUME DISCHARGE PERCENT
434100**   ADD ON TO 25% FOR DISCHARGES
434200
434300*    IF P-NEW-TEMP-RELIEF-IND = 'Y'
434400*           MOVE 00.250 TO WK-LOW-VOL25PCT
434500*           GO TO LOW-VOL-CALC.
434600
434700     IF P-NEW-TEMP-RELIEF-IND = 'Y'
434800     AND MESWK-LOWVOL-PROV-DISCHG <= 200
434900            MOVE 00.250 TO WK-LOW-VOL25PCT
435000            GO TO LOW-VOL-CALC.
435100
435200***  CALCULATE THE LOW VOLUME DISCHARGE PERCENT
435300***  SLIDING SCALE ADD ON FOR
435400
435500     IF P-NEW-TEMP-RELIEF-IND = 'Y'
435600        AND MESWK-LOWVOL-PROV-DISCHG > 200
435700        AND MESWK-LOWVOL-PROV-DISCHG < 1600
435800            COMPUTE  WK-LOW-VOL25PCT ROUNDED =
435900            ((4 / 14) - (MESWK-LOWVOL-PROV-DISCHG / 5600))
436000            GO TO LOW-VOL-CALC
436100     ELSE
436200           MOVE 01.000 TO WK-LOW-VOL25PCT.
436300
436400
436500 LOW-VOL-CALC.
436600
436700     MOVE ZERO TO PPS-OPER-DSH-ADJ.
436800
436900     IF  H-OPER-DSH NUMERIC
437000         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
437100                          PPS-OPER-FSP-PART  * H-OPER-DSH.
437200
437300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
437400                         PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
437500
437600
437700     COMPUTE PPS-OPER-FSP-PART ROUNDED =
437800                           H-OPER-FSP-PART * H-OPER-FSP-PCT.
437900
438000     COMPUTE PPS-OPER-HSP-PART ROUNDED =
438100                           H-OPER-HSP-PART * H-OPER-HSP-PCT.
438200
438300     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
438400                         H-OPER-OUTLIER-PART * H-OPER-FSP-PCT.
438500
438600     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
438700                                H-NEW-TECH-PAY-ADD-ON.
438800
438900     IF  WK-LOW-VOL25PCT < 1.000000
439000     COMPUTE WK-LOW-VOL-ADDON  ROUNDED =
439100              (PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
439200               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
439300                      PPS-OPER-IME-ADJ
439400                           +
439500             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
439600             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
439700             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM +
439800                 PPS-NEW-TECH-PAY-ADD-ON) *  WK-LOW-VOL25PCT
439900     ELSE
440000     COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0.000000.
440100
440200     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
440300
440400     IF HMO-TAG  = 'Y'
440500        PERFORM 3850-HMO-IME-ADJ.
440600
440700***********************************************************
440800***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
440900***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
441000
441100     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
441200             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
441300             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
441400             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
441500
441600     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
441700               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
441800               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
441900                      PPS-OPER-IME-ADJ
442000                           +
442100                 PPS-NEW-TECH-PAY-ADD-ON
442200                           +
442300                  WK-LOW-VOL-ADDON
442400                           +
442500                 H-WK-PASS-AMT-PLUS-MISC
442600                           +
442700                   H-CAPI-TOTAL-PAY
442800                           +
442900                 H-READMIS-ADJUST-AMT
443000                           +
443100               H-VAL-BASED-PURCH-ADJUST-AMT
443200                           +
443300                 H-BUNDLE-ADJUST-AMT.
443400
443500     MOVE     P-VAL-BASED-PURCH-PARTIPNT TO
443600              H-VAL-BASED-PURCH-PARTIPNT.
443700
443800     MOVE     P-VAL-BASED-PURCH-ADJUST   TO
443900              H-VAL-BASED-PURCH-ADJUST.
444000
444100     MOVE     P-HOSP-READMISSION-REDU    TO
444200              H-HOSP-READMISSION-REDU.
444300
444400     MOVE     P-HOSP-HRR-ADJUSTMT        TO
444500              H-HOSP-HRR-ADJUSTMT.
444600
444700 3800-EXIT.   EXIT.
444800
444900 3850-HMO-IME-ADJ.
445000***********************************************************
445100***  HMO CALC FOR PASS-THRU ADDON
445200***  HMO CALC FOR PASS-THRU ADDON
445300
445400     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
445500          (P-NEW-PASS-AMT-PLUS-MISC -
445600          (P-NEW-PASS-AMT-ORGAN-ACQ +
445700           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
445800
445900***********************************************************
446000***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
446100
446200     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
446300                   PPS-OPER-IME-ADJ * .0.
446400
446500***********************************************************
446600
446700
446800 3900A-CALC-OPER-DSH.
446900
447000***  OPERATING DSH CALCULATION
447100***  OPERATING DSH CALCULATION
447200
447300      MOVE 0.0000 TO H-OPER-DSH.
447400
447500      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
447600                                     + P-NEW-MEDICAID-RATIO).
447700
447800***********************************************************
447900**1**    0-99 BEDS
448000***  NOT TO EXCEED 12%
448100
448200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
448300                               AND H-WK-OPER-DSH > .1499
448400                               AND H-WK-OPER-DSH < .2020
448500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
448600                                      * .65 + .025
448700        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
448800
448900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
449000                               AND H-WK-OPER-DSH > .2019
449100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
449200                                      * .825 + .0588
449300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
449400
449500***********************************************************
449600**2**   100 + BEDS
449700***  NO CAP >> CAN EXCEED 12%
449800
449900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
450000                               AND H-WK-OPER-DSH > .1499
450100                               AND H-WK-OPER-DSH < .2020
450200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
450300                                      * .65 + .025.
450400
450500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
450600                               AND H-WK-OPER-DSH > .2019
450700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
450800                                      * .825 + .0588.
450900
451000***********************************************************
451100**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
451200***  NOT TO EXCEED 12%
451300
451400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
451500                               AND H-WK-OPER-DSH > .1499
451600                               AND H-WK-OPER-DSH < .2020
451700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
451800                                 * .65 + .025
451900        IF H-OPER-DSH > .1200
452000              MOVE .1200 TO H-OPER-DSH.
452100
452200      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
452300                               AND H-WK-OPER-DSH > .2019
452400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
452500                                 * .825 + .0588
452600        IF H-OPER-DSH > .1200
452700                 MOVE .1200 TO H-OPER-DSH.
452800***********************************************************
452900**4**   OTHER RURAL HOSPITALS 500 BEDS +
453000***  NO CAP >> CAN EXCEED 12%
453100
453200      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
453300                               AND H-WK-OPER-DSH > .1499
453400                               AND H-WK-OPER-DSH < .2020
453500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
453600                                 * .65 + .025.
453700
453800      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
453900                               AND H-WK-OPER-DSH > .2019
454000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
454100                                 * .825 + .0588.
454200
454300***********************************************************
454400**7**   RURAL HOSPITALS SCH
454500***  NOT TO EXCEED 12%
454600
454700      IF W-CBSA-SIZE = 'R'
454800         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
454900                               AND H-WK-OPER-DSH > .1499
455000                               AND H-WK-OPER-DSH < .2020
455100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
455200                                 * .65 + .025
455300        IF H-OPER-DSH > .1200
455400                 MOVE .1200 TO H-OPER-DSH.
455500
455600      IF W-CBSA-SIZE = 'R'
455700         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
455800                               AND H-WK-OPER-DSH > .2019
455900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
456000                                 * .825 + .0588
456100        IF H-OPER-DSH > .1200
456200                 MOVE .1200 TO H-OPER-DSH.
456300
456400***********************************************************
456500**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
456600***  RRC OVERRIDES SCH CAP
456700***  NO CAP >> CAN EXCEED 12%
456800
456900         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
457000                                   '17' OR '22')
457100                               AND H-WK-OPER-DSH > .1499
457200                               AND H-WK-OPER-DSH < .2020
457300         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
457400                                 * .65 + .025.
457500
457600         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
457700                                   '17' OR '22')
457800                               AND H-WK-OPER-DSH > .2019
457900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
458000                                 * .825 + .0588.
458100
458200      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
458300
458400 3900A-EXIT.   EXIT.
458500
458600 4000-CALC-TECH-ADDON.
458700
458800***********************************************************
458900***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
459000***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
459100
459200     COMPUTE PPS-OPER-HSP-PART ROUNDED =
459300         H-OPER-HSP-PCT * H-OPER-HSP-PART.
459400
459500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
459600         H-OPER-FSP-PCT * H-OPER-FSP-PART.
459700
459800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
459900
460000     IF  H-OPER-DSH NUMERIC
460100             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
460200              PPS-OPER-FSP-PART
460300              * H-OPER-DSH.
460400
460500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
460600             PPS-OPER-FSP-PART *
460700             H-OPER-IME-TEACH.
460800
460900     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
461000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
461100             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
461200
461300***********************************************************
461400***********************************************************
461500* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
461600
461700     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
461800*
461900     IF   B-DIAG-AUTOLITT-DIAG AND
462000          B-DRG-AUTOLITT-DRG
462100        PERFORM 4500-AUTOLIT-TECH-ADD-ON THRU 4500-EXIT.
462200
462300     IF   B-NDC-DIFICID-NDC
462400       PERFORM 4600-DIFICID-TECH-ADD-ON THRU 4600-EXIT.
462500
462600     PERFORM 4700-ZENITH-TECH-ADD-ON THRU 4700-EXIT.
462700
462800     PERFORM 4800-VORAXAZE-TECH-ADD-ON THRU 4800-EXIT.
462900
463000     PERFORM 5000-CAP-CALC-TECH-ADD-ON THRU 5000-EXIT.
463100
463200     COMPUTE H-OPER-BASE-DRG-PAY ROUNDED =
463300             H-OPER-FSP-PART +
463400             H-NEW-TECH-PAY-ADD-ON.
463500
463600*
463700 4000-EXIT.    EXIT.
463800***********************************************************
463900
464000 4100-ISLET-ISOLATION-ADD-ON.
464100***********************************************************
464200***  TECHNICAL TRANSPLANTATION OF CELLS
464300***
464400*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
464500*** ISLETS OF LANGERHAUS) AND
464600*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
464700*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
464800*** TIMES IN ANY OTHER PROC-CODE
464900***********************************************************
465000*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
465100*** V70.7
465200***********************************************************
465300
465400     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
465500               H-TECH-ADDON-ISLET-CNTR2
465600               H-NEW-TECH-ADDON-ISLET.
465700
465800     IF '5285   ' =  B-PRIN-PROC-CODE     OR
465900                     B-OTHER-PROC-CODE1   OR
466000                     B-OTHER-PROC-CODE2   OR
466100                     B-OTHER-PROC-CODE3   OR
466200                     B-OTHER-PROC-CODE4   OR
466300                     B-OTHER-PROC-CODE5   OR
466400                     B-OTHER-PROC-CODE6   OR
466500                     B-OTHER-PROC-CODE7   OR
466600                     B-OTHER-PROC-CODE8   OR
466700                     B-OTHER-PROC-CODE9   OR
466800                     B-OTHER-PROC-CODE10  OR
466900                     B-OTHER-PROC-CODE11  OR
467000                     B-OTHER-PROC-CODE12  OR
467100                     B-OTHER-PROC-CODE13  OR
467200                     B-OTHER-PROC-CODE14  OR
467300                     B-OTHER-PROC-CODE15  OR
467400                     B-OTHER-PROC-CODE16  OR
467500                     B-OTHER-PROC-CODE17  OR
467600                     B-OTHER-PROC-CODE18  OR
467700                     B-OTHER-PROC-CODE19  OR
467800                     B-OTHER-PROC-CODE20  OR
467900                     B-OTHER-PROC-CODE21  OR
468000                     B-OTHER-PROC-CODE22  OR
468100                     B-OTHER-PROC-CODE23  OR
468200                     B-OTHER-PROC-CODE24
468300           NEXT SENTENCE
468400     ELSE
468500           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
468600           GO TO 4100-ADD-TECH-CASES.
468700
468800     IF '5285   ' =  B-PRIN-PROC-CODE
468900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
469000                       H-TECH-ADDON-ISLET-CNTR + 1.
469100
469200     IF '5285   ' =  B-OTHER-PROC-CODE1
469300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
469400                       H-TECH-ADDON-ISLET-CNTR + 1.
469500
469600     IF '5285   ' =  B-OTHER-PROC-CODE2
469700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
469800                       H-TECH-ADDON-ISLET-CNTR + 1.
469900
470000     IF '5285   ' =  B-OTHER-PROC-CODE3
470100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
470200                       H-TECH-ADDON-ISLET-CNTR + 1.
470300
470400     IF '5285   ' =  B-OTHER-PROC-CODE4
470500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
470600                       H-TECH-ADDON-ISLET-CNTR + 1.
470700
470800
470900     IF '5285   ' =  B-OTHER-PROC-CODE5
471000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
471100                       H-TECH-ADDON-ISLET-CNTR + 1.
471200
471300     IF '5285   ' =  B-OTHER-PROC-CODE6
471400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
471500                       H-TECH-ADDON-ISLET-CNTR + 1.
471600
471700     IF '5285   ' =  B-OTHER-PROC-CODE7
471800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
471900                       H-TECH-ADDON-ISLET-CNTR + 1.
472000
472100     IF '5285   ' =  B-OTHER-PROC-CODE8
472200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
472300                       H-TECH-ADDON-ISLET-CNTR + 1.
472400
472500     IF '5285   ' =  B-OTHER-PROC-CODE9
472600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
472700                       H-TECH-ADDON-ISLET-CNTR + 1.
472800
472900     IF '5285   ' =  B-OTHER-PROC-CODE10
473000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
473100                       H-TECH-ADDON-ISLET-CNTR + 1.
473200
473300     IF '5285   ' =  B-OTHER-PROC-CODE11
473400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
473500                       H-TECH-ADDON-ISLET-CNTR + 1.
473600
473700     IF '5285   ' =  B-OTHER-PROC-CODE12
473800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
473900                       H-TECH-ADDON-ISLET-CNTR + 1.
474000
474100     IF '5285   ' =  B-OTHER-PROC-CODE13
474200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
474300                       H-TECH-ADDON-ISLET-CNTR + 1.
474400
474500     IF '5285   ' =  B-OTHER-PROC-CODE14
474600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
474700                       H-TECH-ADDON-ISLET-CNTR + 1.
474800
474900     IF '5285   ' =  B-OTHER-PROC-CODE15
475000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
475100                       H-TECH-ADDON-ISLET-CNTR + 1.
475200
475300     IF '5285   ' =  B-OTHER-PROC-CODE16
475400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
475500                       H-TECH-ADDON-ISLET-CNTR + 1.
475600
475700     IF '5285   ' =  B-OTHER-PROC-CODE17
475800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
475900                       H-TECH-ADDON-ISLET-CNTR + 1.
476000
476100     IF '5285   ' =  B-OTHER-PROC-CODE18
476200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
476300                       H-TECH-ADDON-ISLET-CNTR + 1.
476400
476500     IF '5285   ' =  B-OTHER-PROC-CODE19
476600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
476700                       H-TECH-ADDON-ISLET-CNTR + 1.
476800
476900     IF '5285   ' =  B-OTHER-PROC-CODE20
477000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
477100                       H-TECH-ADDON-ISLET-CNTR + 1.
477200
477300     IF '5285   ' =  B-OTHER-PROC-CODE21
477400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
477500                       H-TECH-ADDON-ISLET-CNTR + 1.
477600
477700     IF '5285   ' =  B-OTHER-PROC-CODE22
477800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
477900                       H-TECH-ADDON-ISLET-CNTR + 1.
478000
478100     IF '5285   ' =  B-OTHER-PROC-CODE23
478200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
478300                       H-TECH-ADDON-ISLET-CNTR + 1.
478400
478500     IF '5285   ' =  B-OTHER-PROC-CODE24
478600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
478700                       H-TECH-ADDON-ISLET-CNTR + 1.
478800
478900     IF  H-TECH-ADDON-ISLET-CNTR = 1
479000     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
479100           GO TO 4100-ADD-TECH-CASES.
479200
479300     IF  H-TECH-ADDON-ISLET-CNTR > 1
479400     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
479500           GO TO 4100-ADD-TECH-CASES.
479600
479700     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
479800
479900
480000 4100-ADD-TECH-CASES.
480100
480200     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
480300             H-NEW-TECH-PAY-ADD-ON +
480400             H-NEW-TECH-ADDON-ISLET.
480500
480600 4100-EXIT.    EXIT.
480700
480800*
480900*
481000***********************************************************
481100* THIS IS A SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
481200* DISCHARGE COUNTS.
481300***********************************************************
481400 4400-LOWVOL-CODE-RTN.
481500
481600     SET LOWVOL-IDX TO 1.
481700     SEARCH LOWVOL-TAB VARYING LOWVOL-IDX
481800         AT END
481900           MOVE ' NO LOWVOL PROVIDER FOUND' TO MES-LOWVOL
482000           MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG
482100       WHEN WK-LOWVOL-PROV (LOWVOL-IDX) = MES-PPS-PROV
482200         MOVE WK-LOWVOL-PROV-DISCHG(LOWVOL-IDX)
482300                            TO MESWK-LOWVOL-PROV-DISCHG.
482400
482500 4400-EXIT.   EXIT.
482600
482700***********************************************************
482800
482900 4500-AUTOLIT-TECH-ADD-ON.
483000***********************************************************
483100***** CASES INVOLVING AUTOLITT PROCESS DECOMPRESSION SYSTEM
483200***********************************************************
483300
483400     MOVE 0 TO H-NEW-TECH-ADDON-AUTOLITT
483500               H-LESSER-AUTOLITT-STOP-1
483600               H-LESSER-AUTOLITT-STOP-2
483700               H-CSTMED-AUTOLITT-STOP.
483800
483900
484000
484100     IF '1761   ' =  B-PRIN-PROC-CODE     OR
484200                     B-OTHER-PROC-CODE1   OR
484300                     B-OTHER-PROC-CODE2   OR
484400                     B-OTHER-PROC-CODE3   OR
484500                     B-OTHER-PROC-CODE4   OR
484600                     B-OTHER-PROC-CODE5   OR
484700                     B-OTHER-PROC-CODE6   OR
484800                     B-OTHER-PROC-CODE7   OR
484900                     B-OTHER-PROC-CODE8   OR
485000                     B-OTHER-PROC-CODE9   OR
485100                     B-OTHER-PROC-CODE10  OR
485200                     B-OTHER-PROC-CODE11  OR
485300                     B-OTHER-PROC-CODE12  OR
485400                     B-OTHER-PROC-CODE13  OR
485500                     B-OTHER-PROC-CODE14  OR
485600                     B-OTHER-PROC-CODE15  OR
485700                     B-OTHER-PROC-CODE16  OR
485800                     B-OTHER-PROC-CODE17  OR
485900                     B-OTHER-PROC-CODE18  OR
486000                     B-OTHER-PROC-CODE19  OR
486100                     B-OTHER-PROC-CODE20  OR
486200                     B-OTHER-PROC-CODE21  OR
486300                     B-OTHER-PROC-CODE22  OR
486400                     B-OTHER-PROC-CODE23  OR
486500                     B-OTHER-PROC-CODE24
486600           GO TO 4500-COMPUTE-AUTOLITT
486700     ELSE
486800           NEXT SENTENCE.
486900
487000           MOVE ZEROES TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
487100           GO TO 4500-ADD-TECH-CASES.
487200
487300 4500-COMPUTE-AUTOLITT.
487400
487500     MOVE  5300.00 TO H-CSTMED-AUTOLITT-STOP.
487600
487700     COMPUTE H-LESSER-AUTOLITT-STOP-1 ROUNDED =
487800                  H-CSTMED-AUTOLITT-STOP.
487900
488000     COMPUTE H-LESSER-AUTOLITT-STOP-2 ROUNDED =
488100          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
488200                     H-BASE-DRG-PAYMENT)) * .5.
488300
488400     IF H-LESSER-AUTOLITT-STOP-2 > 0
488500        IF H-LESSER-AUTOLITT-STOP-1 < H-LESSER-AUTOLITT-STOP-2
488600         MOVE H-LESSER-AUTOLITT-STOP-1 TO
488700                                H-NEW-TECH-ADDON-AUTOLITT-STOP
488800        ELSE
488900         MOVE H-LESSER-AUTOLITT-STOP-2 TO
489000                                H-NEW-TECH-ADDON-AUTOLITT-STOP
489100     ELSE
489200        MOVE ZEROES          TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
489300
489400
489500 4500-ADD-TECH-CASES.
489600
489700     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
489800             H-NEW-TECH-PAY-ADD-ON +
489900             H-NEW-TECH-ADDON-AUTOLITT-STOP.
490000*
490100 4500-EXIT.    EXIT.
490200
490300
490400 4600-DIFICID-TECH-ADD-ON.
490500***********************************************************
490600***** CASES INVOLVING DIFICID PROCESS DECOMPRESSION SYSTEM
490700***********************************************************
490800***** PER HPAR 8041H TEST WAS CHANGED FR 0845 TO 00845
490900***********************************************************
491000
491100
491200     MOVE 0 TO H-NEW-TECH-ADDON-DIFICID
491300               H-LESSER-DIFICID-STOP-1
491400               H-LESSER-DIFICID-STOP-2
491500               H-CSTMED-DIFICID-STOP.
491600
491700     IF '00845  ' =  B-OTHER-DIAG-CODE1   OR
491800                     B-OTHER-DIAG-CODE2   OR
491900                     B-OTHER-DIAG-CODE3   OR
492000                     B-OTHER-DIAG-CODE4   OR
492100                     B-OTHER-DIAG-CODE5   OR
492200                     B-OTHER-DIAG-CODE6   OR
492300                     B-OTHER-DIAG-CODE7   OR
492400                     B-OTHER-DIAG-CODE8   OR
492500                     B-OTHER-DIAG-CODE9   OR
492600                     B-OTHER-DIAG-CODE10  OR
492700                     B-OTHER-DIAG-CODE11  OR
492800                     B-OTHER-DIAG-CODE12  OR
492900                     B-OTHER-DIAG-CODE13  OR
493000                     B-OTHER-DIAG-CODE14  OR
493100                     B-OTHER-DIAG-CODE15  OR
493200                     B-OTHER-DIAG-CODE16  OR
493300                     B-OTHER-DIAG-CODE17  OR
493400                     B-OTHER-DIAG-CODE18  OR
493500                     B-OTHER-DIAG-CODE19  OR
493600                     B-OTHER-DIAG-CODE20  OR
493700                     B-OTHER-DIAG-CODE21  OR
493800                     B-OTHER-DIAG-CODE22  OR
493900                     B-OTHER-DIAG-CODE23  OR
494000                     B-OTHER-DIAG-CODE24  OR
494100                     B-OTHER-DIAG-CODE25
494200           GO TO 4600-COMPUTE-DIFICID
494300     ELSE
494400           NEXT SENTENCE.
494500
494600           MOVE ZEROES TO H-NEW-TECH-ADDON-DIFICID.
494700           GO TO 4600-ADD-TECH-CASES.
494800
494900 4600-COMPUTE-DIFICID.
495000
495100     MOVE  868.00 TO H-CSTMED-DIFICID-STOP.
495200
495300     COMPUTE H-LESSER-DIFICID-STOP-1 ROUNDED =
495400                  H-CSTMED-DIFICID-STOP.
495500
495600     COMPUTE H-LESSER-DIFICID-STOP-2 ROUNDED =
495700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
495800                     H-BASE-DRG-PAYMENT)) * .5.
495900
496000     IF H-LESSER-DIFICID-STOP-2 > 0
496100        IF H-LESSER-DIFICID-STOP-1 < H-LESSER-DIFICID-STOP-2
496200         MOVE H-LESSER-DIFICID-STOP-1 TO
496300                                H-NEW-TECH-ADDON-DIFICID
496400        ELSE
496500         MOVE H-LESSER-DIFICID-STOP-2 TO
496600                                H-NEW-TECH-ADDON-DIFICID
496700     ELSE
496800        MOVE ZEROES          TO H-NEW-TECH-ADDON-DIFICID.
496900
497000
497100
497200 4600-ADD-TECH-CASES.
497300
497400     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
497500             H-NEW-TECH-PAY-ADD-ON +
497600             H-NEW-TECH-ADDON-DIFICID.
497700*
497800 4600-EXIT.    EXIT.
497900
498000 4700-ZENITH-TECH-ADD-ON.
498100***********************************************************
498200***** CASES INVOLVING ZENITH PROCESS DECOMPRESSION SYSTEM
498300***********************************************************
498400
498500     MOVE 0 TO H-NEW-TECH-ADDON-ZENITH
498600               H-LESSER-ZENITH-STOP-1
498700               H-LESSER-ZENITH-STOP-2
498800               H-CSTMED-ZENITH-STOP.
498900
499000
499100
499200     IF '3978   ' =  B-PRIN-PROC-CODE     OR
499300                     B-OTHER-PROC-CODE1   OR
499400                     B-OTHER-PROC-CODE2   OR
499500                     B-OTHER-PROC-CODE3   OR
499600                     B-OTHER-PROC-CODE4   OR
499700                     B-OTHER-PROC-CODE5   OR
499800                     B-OTHER-PROC-CODE6   OR
499900                     B-OTHER-PROC-CODE7   OR
500000                     B-OTHER-PROC-CODE8   OR
500100                     B-OTHER-PROC-CODE9   OR
500200                     B-OTHER-PROC-CODE10  OR
500300                     B-OTHER-PROC-CODE11  OR
500400                     B-OTHER-PROC-CODE12  OR
500500                     B-OTHER-PROC-CODE13  OR
500600                     B-OTHER-PROC-CODE14  OR
500700                     B-OTHER-PROC-CODE15  OR
500800                     B-OTHER-PROC-CODE16  OR
500900                     B-OTHER-PROC-CODE17  OR
501000                     B-OTHER-PROC-CODE18  OR
501100                     B-OTHER-PROC-CODE19  OR
501200                     B-OTHER-PROC-CODE20  OR
501300                     B-OTHER-PROC-CODE21  OR
501400                     B-OTHER-PROC-CODE22  OR
501500                     B-OTHER-PROC-CODE23  OR
501600                     B-OTHER-PROC-CODE24
501700           GO TO 4700-COMPUTE-ZENITH
501800     ELSE
501900           NEXT SENTENCE.
502000
502100           MOVE ZEROES TO H-NEW-TECH-ADDON-ZENITH.
502200           GO TO 4700-ADD-TECH-CASES.
502300
502400 4700-COMPUTE-ZENITH.
502500
502600     MOVE  8171.50 TO H-CSTMED-ZENITH-STOP.
502700
502800     COMPUTE H-LESSER-ZENITH-STOP-1 ROUNDED =
502900                  H-CSTMED-ZENITH-STOP.
503000
503100     COMPUTE H-LESSER-ZENITH-STOP-2 ROUNDED =
503200          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
503300                     H-BASE-DRG-PAYMENT)) * .5.
503400
503500     IF H-LESSER-ZENITH-STOP-2 > 0
503600        IF H-LESSER-ZENITH-STOP-1 < H-LESSER-ZENITH-STOP-2
503700         MOVE H-LESSER-ZENITH-STOP-1 TO
503800                                H-NEW-TECH-ADDON-ZENITH
503900        ELSE
504000         MOVE H-LESSER-ZENITH-STOP-2 TO
504100                                H-NEW-TECH-ADDON-ZENITH
504200     ELSE
504300        MOVE ZEROES          TO H-NEW-TECH-ADDON-ZENITH.
504400
504500
504600 4700-ADD-TECH-CASES.
504700
504800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
504900             H-NEW-TECH-PAY-ADD-ON +
505000             H-NEW-TECH-ADDON-ZENITH.
505100*
505200 4700-EXIT.    EXIT.
505300
505400***********************************************************
505500 4800-VORAXAZE-TECH-ADD-ON.
505600***********************************************************
505700***** CASES INVOLVING VORAXAZE PROCESS DECOMPRESSION SYSTEM
505800***********************************************************
505900
506000     MOVE 0 TO H-NEW-TECH-ADDON-VORAXAZE
506100               H-LESSER-VORAXAZE-STOP-1
506200               H-LESSER-VORAXAZE-STOP-2
506300               H-CSTMED-VORAXAZE-STOP.
506400
506500
506600
506700     IF '0095   ' =  B-PRIN-PROC-CODE     OR
506800                     B-OTHER-PROC-CODE1   OR
506900                     B-OTHER-PROC-CODE2   OR
507000                     B-OTHER-PROC-CODE3   OR
507100                     B-OTHER-PROC-CODE4   OR
507200                     B-OTHER-PROC-CODE5   OR
507300                     B-OTHER-PROC-CODE6   OR
507400                     B-OTHER-PROC-CODE7   OR
507500                     B-OTHER-PROC-CODE8   OR
507600                     B-OTHER-PROC-CODE9   OR
507700                     B-OTHER-PROC-CODE10  OR
507800                     B-OTHER-PROC-CODE11  OR
507900                     B-OTHER-PROC-CODE12  OR
508000                     B-OTHER-PROC-CODE13  OR
508100                     B-OTHER-PROC-CODE14  OR
508200                     B-OTHER-PROC-CODE15  OR
508300                     B-OTHER-PROC-CODE16  OR
508400                     B-OTHER-PROC-CODE17  OR
508500                     B-OTHER-PROC-CODE18  OR
508600                     B-OTHER-PROC-CODE19  OR
508700                     B-OTHER-PROC-CODE20  OR
508800                     B-OTHER-PROC-CODE21  OR
508900                     B-OTHER-PROC-CODE22  OR
509000                     B-OTHER-PROC-CODE23  OR
509100                     B-OTHER-PROC-CODE24
509200           GO TO 4800-COMPUTE-VORAXAZE
509300     ELSE
509400           NEXT SENTENCE.
509500
509600           MOVE ZEROES TO H-NEW-TECH-ADDON-VORAXAZE.
509700           GO TO 4800-ADD-TECH-CASES.
509800
509900 4800-COMPUTE-VORAXAZE.
510000
510100     MOVE  45000.00 TO H-CSTMED-VORAXAZE-STOP.
510200
510300     COMPUTE H-LESSER-VORAXAZE-STOP-1 ROUNDED =
510400                  H-CSTMED-VORAXAZE-STOP.
510500
510600     COMPUTE H-LESSER-VORAXAZE-STOP-2 ROUNDED =
510700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
510800                     H-BASE-DRG-PAYMENT)) * .5.
510900
511000     IF H-LESSER-VORAXAZE-STOP-2 > 0
511100        IF H-LESSER-VORAXAZE-STOP-1 < H-LESSER-VORAXAZE-STOP-2
511200         MOVE H-LESSER-VORAXAZE-STOP-1 TO
511300                                H-NEW-TECH-ADDON-VORAXAZE
511400        ELSE
511500         MOVE H-LESSER-VORAXAZE-STOP-2 TO
511600                                H-NEW-TECH-ADDON-VORAXAZE
511700     ELSE
511800        MOVE ZEROES          TO H-NEW-TECH-ADDON-VORAXAZE.
511900
512000
512100 4800-ADD-TECH-CASES.
512200
512300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
512400             H-NEW-TECH-PAY-ADD-ON +
512500             H-NEW-TECH-ADDON-VORAXAZE.
512600*
512700 4800-EXIT.    EXIT.
512800
512900
513000***********************************************************
513100 5000-CAP-CALC-TECH-ADD-ON.
513200***********************************************************
513300***** CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM
513400***********************************************************
513500
513600     MOVE 0 TO H-NEW-TECH-ADDON-CAP.
513700     MOVE 0 TO H-NEW-TECH-ADDON-CAPDIF.
513800
513900     COMPUTE H-OPER-BILL-COSTS ROUNDED =
514000         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
514100         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
514200
514300     COMPUTE H-NEW-TECH-ADDON-CAP ROUNDED =
514400                 (H-BASE-DRG-PAYMENT + H-NEW-TECH-PAY-ADD-ON).
514500
514600     COMPUTE H-NEW-TECH-ADDON-CAPDIF ROUNDED =
514700                 (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
514800
514900     IF (H-NEW-TECH-ADDON-CAP > H-OPER-BILL-COSTS) AND
515000         H-NEW-TECH-ADDON-CAPDIF  > 0
515100        COMPUTE H-NEW-TECH-PAY-ADD-ON  ROUNDED =
515200             (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
515300
515400*
515500 5000-EXIT.    EXIT.
515600
515700***********************************************************
515800 6000-CALC-READMIS-REDU.
515900***********************************************************
516000***** CASES INVOLVING READMISN PROCESS ADJUSTMENTS
516100***********************************************************
516200
516300     MOVE 0 TO H-READMIS-ADJUST-AMT.
516400
516500     IF P-HOSP-READMISSION-REDU = '1'
516600           GO TO 6000-EDIT-READMISN
516700     ELSE
516800           NEXT SENTENCE.
516900
517000     IF P-HOSP-READMISSION-REDU = '0' AND
517100        P-HOSP-HRR-ADJUSTMT = 0.0000
517200           MOVE ZEROES TO H-READMIS-ADJUST-AMT
517300           GO TO 6000-EXIT.
517400
517500     IF P-HOSP-READMISSION-REDU = '0' AND
517600        P-HOSP-HRR-ADJUSTMT > 0.0000
517700           MOVE 65 TO PPS-RTC
517800           MOVE ZEROES TO H-READMIS-ADJUST-AMT
517900           GO TO 6000-EXIT.
518000
518100
518200     IF P-HOSP-READMISSION-REDU = '2' OR '3' OR '4' OR '5' OR
518300                                  '6' OR '7' OR '8' OR
518400                                  '9' OR ' '
518500           MOVE 65 TO PPS-RTC
518600           MOVE ZEROES TO H-READMIS-ADJUST-AMT
518700           GO TO 6000-EXIT.
518800
518900 6000-EDIT-READMISN.
519000
519100     IF P-HOSP-HRR-ADJUSTMT < 0.9900
519200           MOVE 65 TO PPS-RTC
519300           MOVE ZEROES TO H-READMIS-ADJUST-AMT
519400           GO TO 6000-EXIT.
519500
519600
519700     IF P-HOSP-HRR-ADJUSTMT > 1.0000
519800           MOVE 65 TO PPS-RTC
519900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
520000           GO TO 6000-EXIT.
520100
520200     IF P-READ-INVALID-STATE
520300           MOVE 65 TO PPS-RTC
520400           MOVE ZEROES TO H-READMIS-ADJUST-AMT
520500           GO TO 6000-EXIT.
520600
520700
520800 6000-COMPUTE-READMISN.
520900
521000
521100        COMPUTE H-READMIS-ADJUST-AMT         ROUNDED =
521200              ((P-HOSP-HRR-ADJUSTMT * H-OPER-BASE-DRG-PAY) -
521300                H-OPER-BASE-DRG-PAY).
521400
521500
521600 6000-EXIT.    EXIT.
521700
521800***********************************************************
521900 7000-CALC-VALUE-BASED-PURCH.
522000***********************************************************
522100***** CASES INVOLVING VALUE BASE PURCH ADJUSTMENTS
522200***********************************************************
522300
522400     MOVE 0 TO H-VAL-BASED-PURCH-ADJUST-AMT.
522500
522600     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N' OR 'Y'
522700           NEXT SENTENCE
522800     ELSE
522900           MOVE 68 TO PPS-RTC
523000           GO TO 7000-EXIT.
523100
523200     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N'
523300           GO TO 7000-EXIT.
523400
523500     IF  P-VAL-BASED-PURCH-PARTIPNT = 'Y' AND
523600         P-NEW-CBSA-HOSP-QUAL-IND = '1'
523700           NEXT SENTENCE
523800     ELSE
523900           MOVE 68 TO PPS-RTC
524000           GO TO 7000-EXIT.
524100
524200     IF  P-VBP-INVALID-STATE
524300           MOVE 68 TO PPS-RTC
524400           GO TO 7000-EXIT
524500     ELSE
524600           NEXT SENTENCE.
524700
524800     IF P-VAL-BASED-PURCH-ADJUST > 0.9900000000 AND
524900        P-VAL-BASED-PURCH-ADJUST < 2.0000000000
525000           GO TO 7000-COMPUTE-VAL-BASED-PUR
525100     ELSE
525200           MOVE 68 TO PPS-RTC
525300           MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT.
525400           GO TO 7000-EXIT.
525500
525600 7000-COMPUTE-VAL-BASED-PUR.
525700
525800     COMPUTE H-VAL-BASED-PURCH-ADJUST-AMT  ROUNDED =
525900              ((P-VAL-BASED-PURCH-ADJUST *
526000                  H-OPER-BASE-DRG-PAY) -
526100                  H-OPER-BASE-DRG-PAY).
526200*
526300 7000-EXIT.    EXIT.
526400
526500***********************************************************
526600 8000-CALC-BUNDLE-REDU.
526700***********************************************************
526800***** CASES INVOLVING BUNDLE PROCESS ADJUSTMENTS
526900***********************************************************
527000
527100     MOVE 0 TO H-BUNDLE-ADJUST-AMT.
527200
527300     IF '61' =  B-DEMO-CODE1  OR
527400                B-DEMO-CODE2  OR
527500                B-DEMO-CODE3  OR
527600                B-DEMO-CODE4
527700         NEXT SENTENCE
527800     ELSE
527900         MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
528000           GO TO 8000-EXIT.
528100
528200     IF P-MODEL1-BUNDLE-DISPRCNT > .00
528300           GO TO 8000-COMPUTE-BUNDLE
528400     ELSE
528500           NEXT SENTENCE.
528600
528700     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
528800           GO TO 8000-EXIT.
528900
529000 8000-COMPUTE-BUNDLE.
529100
529200        COMPUTE H-BUNDLE-ADJUST-AMT      ROUNDED =
529300              ((P-MODEL1-BUNDLE-DISPRCNT *
529400                                     H-OPER-BASE-DRG-PAY) -
529500                H-OPER-BASE-DRG-PAY).
529600
529700 8000-EXIT.    EXIT.
529800
529900***********************************************************
530000******        L A S T   S O U R C E   S T A T E M E N T   *****
