000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL119.
000300*AUTHOR.            DDS TEAM    .
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL119      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C11.9'.
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 2011.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 20101001 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 '20101001'.
005100         05  TB1-NAT    PIC X(30) VALUE
005200            ' 0355291 161120 0355291 161120'.
005300         05  TB1-PR     PIC X(30) VALUE
005400            ' 0151814 092653 0151814 092653'.
005500         05  TB1-NATPR  PIC X(30) VALUE
005600            ' 0355291 161120 0355291 161120'.
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 2011.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 20101001 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 '20101001'.
008400         05  TB2-NAT    PIC X(30) VALUE
008500            ' 0348349 157972 0348349 157972'.
008600         05  TB2-PR     PIC X(30) VALUE
008700            ' 0151814 092653 0151814 092653'.
008800         05  TB2-NATPR  PIC X(30) VALUE
008900            ' 0348349 157972 0348349 157972'.
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 2011.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 20101001 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 '20101001'.
011600         05  TB3-NAT    PIC X(30) VALUE
011700            ' 0320175 196236 0320175 196236'.
011800         05  TB3-PR     PIC X(30) VALUE
011900            ' 0151570 092897 0151570 092897'.
012000         05  TB3-NATPR  PIC X(30) VALUE
012100            ' 0320175 196236 0320175 196236'.
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 2011.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 20101001 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 '20101001'.
014900         05  TB4-NAT    PIC X(30) VALUE
015000            ' 0313919 192402 0313919 192402'.
015100         05  TB4-PR     PIC X(30) VALUE
015200            ' 0151570 092897 0151570 092897'.
015300         05  TB4-NATPR  PIC X(30) VALUE
015400            ' 0313919 192402 0313919 192402'.
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       '20101001'.
017000         10  FILLER                  PIC X(56) VALUE
017100       '26344131600419136127176002261812393010036611240322200271'.
017200         10  FILLER                  PIC X(56) VALUE
017300       '10177114900199048353083000930933501540018604963210100117'.
017400         10  FILLER                  PIC X(56) VALUE
017500       '00000000000000037831086000970476661230015503131108500101'.
017600         10  FILLER                  PIC X(56) VALUE
017700       '01950505700068115947211002820595041670019300000000000000'.
017800         10  FILLER                  PIC X(56) VALUE
017900       '00000000000000000000000000000000000000000008247914100173'.
018000         10  FILLER                  PIC X(56) VALUE
018100       '06288612100139041581067000840508830820011803495205700081'.
018200         10  FILLER                  PIC X(56) VALUE
018300       '04757508800115029825058000730213070300003905354910100131'.
018400         10  FILLER                  PIC X(56) VALUE
018500       '02874104700066016433025000330412610860012301922003600053'.
018600         10  FILLER                  PIC X(56) VALUE
018700       '01362602100026035242047000700214370220003201639001300015'.
018800         10  FILLER                  PIC X(56) VALUE
018900       '03154305700084015462024000350101850140001703935309000121'.
019000         10  FILLER                  PIC X(56) VALUE
019100       '02143005000067016905024000320000000000000000000000000000'.
019200         10  FILLER                  PIC X(56) VALUE
019300       '00000000000000000000000000000000000000000000000000000000'.
019400         10  FILLER                  PIC X(56) VALUE
019500       '00000000000000000000000000000000000000000001610904500067'.
019600         10  FILLER                  PIC X(56) VALUE
019700       '00844102900036014863046000630106490350004601674805500071'.
019800         10  FILLER                  PIC X(56) VALUE
019900       '00935003700048015856054000720098110410004900757803200038'.
020000         10  FILLER                  PIC X(56) VALUE
020100       '02956806400084019479048000560152510340003901867405100069'.
020200         10  FILLER                  PIC X(56) VALUE
020300       '01166704000048008198027000330142310420005500875102700033'.
020400         10  FILLER                  PIC X(56) VALUE
020500       '00731102300028018417056000730110540410005100749902500031'.
020600         10  FILLER                  PIC X(56) VALUE
020700       '01290704200056008606032000410165670550007000905003300039'.
020800         10  FILLER                  PIC X(56) VALUE
020900       '01737605100064010154035000440075330260003101190903600049'.
021000         10  FILLER                  PIC X(56) VALUE
021100       '00739202700034020130035000610132640340004700895902200028'.
021200         10  FILLER                  PIC X(56) VALUE
021300       '02142305200072012051037000460079290230002901487204200055'.
021400         10  FILLER                  PIC X(56) VALUE
021500       '00966702900037006927019000230163180440006200940403300042'.
021600         10  FILLER                  PIC X(56) VALUE
021700       '00682702400029036769089001170239770660008401924704600056'.
021800         10  FILLER                  PIC X(56) VALUE
021900       '03219109000116019106064000790120840410005201510704500060'.
022000         10  FILLER                  PIC X(56) VALUE
022100       '00761902800034010288031000430067010240003000000000000000'.
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       '01831103900056008989020000260120840350004601267503000044'.
022800         10  FILLER                  PIC X(56) VALUE
022900       '00730501600020000000000000000000000000000000000000000000'.
023000         10  FILLER                  PIC X(56) VALUE
023100       '00910404100051006522033000400071440220002701190303800053'.
023200         10  FILLER                  PIC X(56) VALUE
023300       '00685902700034000000000000000000000000000000000000000000'.
023400         10  FILLER                  PIC X(56) VALUE
023500       '02234903700052012299023000290209150410005601244702100027'.
023600         10  FILLER                  PIC X(56) VALUE
023700       '01700003600054008514017000210190820430006400975101700023'.
023800         10  FILLER                  PIC X(56) VALUE
023900       '01300703600050007841019000250087560140001800000000000000'.
024000         10  FILLER                  PIC X(56) VALUE
024100       '00000000000000000000000000000000000000000000000000000000'.
024200         10  FILLER                  PIC X(56) VALUE
024300       '00000000000000021886065000910124130410005700806602400033'.
024400         10  FILLER                  PIC X(56) VALUE
024500       '00638902200026012808037000500063930230002900958403300043'.
024600         10  FILLER                  PIC X(56) VALUE
024700       '00629002500031013965043000580090170330004200622602400029'.
024800         10  FILLER                  PIC X(56) VALUE
024900       '01579404800067009027034000440058970220002700000000000000'.
025000         10  FILLER                  PIC X(56) VALUE
025100       '00000000000000000000000000000508281150014002623606200074'.
025200         10  FILLER                  PIC X(56) VALUE
025300       '01775803700044037383095001190205670580007401300803300043'.
025400         10  FILLER                  PIC X(56) VALUE
025500       '00000000000000000000000000000000000000000000000000000000'.
025600         10  FILLER                  PIC X(56) VALUE
025700       '00000000000000000000000000000160960570006801070604200049'.
025800         10  FILLER                  PIC X(56) VALUE
025900       '02066706800085014887056000680098610410005001736105700075'.
026000         10  FILLER                  PIC X(56) VALUE
026100       '01218204200054008096028000370149420520006500975503600043'.
026200         10  FILLER                  PIC X(56) VALUE
026300       '00680302600030015637053000670110270390004900767802800035'.
026400         10  FILLER                  PIC X(56) VALUE
026500       '01280904300055011924045000550097350380004600722003100037'.
026600         10  FILLER                  PIC X(56) VALUE
026700       '01479605300065010152042000500070960310003701606205600069'.
026800         10  FILLER                  PIC X(56) VALUE
026900       '01117604200051008203031000380178950630008001025203700048'.
027000         10  FILLER                  PIC X(56) VALUE
027100       '00721002800036008424034000410060810260003200671402100027'.
027200         10  FILLER                  PIC X(56) VALUE
027300       '01297203900053007575026000330520681260014702263005100070'.
027400         10  FILLER                  PIC X(56) VALUE
027500       '00000000000000000000000000000000000000000000000000000000'.
027600         10  FILLER                  PIC X(56) VALUE
027700       '00000000000000000000000000001260860690012210023814600170'.
027800         10  FILLER                  PIC X(56) VALUE
027900       '06803809800109053293072000800808311080013105378707200080'.
028000         10  FILLER                  PIC X(56) VALUE
028100       '04480105600060085230094001180642500450006207581907700097'.
028200         10  FILLER                  PIC X(56) VALUE
028300       '06020204200053064510050000770519360200003107588111800142'.
028400         10  FILLER                  PIC X(56) VALUE
028500       '04774507200083035451046000550785821090012905818308500094'.
028600         10  FILLER                  PIC X(56) VALUE
028700       '07208112100137048281082000890585300930010803770706000065'.
028800         10  FILLER                  PIC X(56) VALUE
028900       '05190307100101030830029000420455441120014302658907800096'.
029000         10  FILLER                  PIC X(56) VALUE
029100       '01463105000060037277063000810265080390004902039802200028'.
029200         10  FILLER                  PIC X(56) VALUE
029300       '04248602500038031802035000500196910180002302924804400060'.
029400         10  FILLER                  PIC X(56) VALUE
029500       '01773202200028028836050000700179920220003002975405200079'.
029600         10  FILLER                  PIC X(56) VALUE
029700       '02401404400060016152020000270250430700009201596905600070'.
029800         10  FILLER                  PIC X(56) VALUE
029900       '00975003400043028880052000700183340240003203550007700107'.
030000         10  FILLER                  PIC X(56) VALUE
030100       '01646903200045011246020000260175650350005602530505500082'.
030200         10  FILLER                  PIC X(56) VALUE
030300       '02315702300034000000000000000000000000000000000000000000'.
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       '00000000000000000000000000000000000000000001850305200066'.
031000         10  FILLER                  PIC X(56) VALUE
031100       '01191203600044008064022000280171510320005100888802100030'.
031200         10  FILLER                  PIC X(56) VALUE
031300       '00571201400018020014048000650108790250003202939708600108'.
031400         10  FILLER                  PIC X(56) VALUE
031500       '01849206400078012959044000560149430480006201030204000049'.
031600         10  FILLER                  PIC X(56) VALUE
031700       '00685302800033010373044000540064030340004001169201800028'.
031800         10  FILLER                  PIC X(56) VALUE
031900       '00679201400017004497011000120140720470006100977603900049'.
032000         10  FILLER                  PIC X(56) VALUE
032100       '00661502800035009755030000400058300200002401026303500046'.
032200         10  FILLER                  PIC X(56) VALUE
032300       '00613802200028014667044000590079740270003401233904000052'.
032400         10  FILLER                  PIC X(56) VALUE
032500       '00838703000037005709021000250050700180002200717202400029'.
032600         10  FILLER                  PIC X(56) VALUE
032700       '00549901700021018145050000680096810330004200614702100026'.
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       '00000000000000058142126001620272310690008801429802900038'.
033400         10  FILLER                  PIC X(56) VALUE
033500       '05280712500154025830078000910162670480005304863511800142'.
033600         10  FILLER                  PIC X(56) VALUE
033700       '02496007100081015979042000490427771140013702345607200088'.
033800         10  FILLER                  PIC X(56) VALUE
033900       '01478904000051032115083001000186590560006501239303200037'.
034000         10  FILLER                  PIC X(56) VALUE
034100       '02264304900066013246030000380095680170002003158608900112'.
034200         10  FILLER                  PIC X(56) VALUE
034300       '01703506000070011883042000460241830630008801370504100054'.
034400         10  FILLER                  PIC X(56) VALUE
034500       '00798102300029024877056000790135390350004500862801900024'.
034600         10  FILLER                  PIC X(56) VALUE
034700       '02751006300084015523040000500103290230002804029309200127'.
034800         10  FILLER                  PIC X(56) VALUE
034900       '02146605700074013010030000400000000000000000000000000000'.
035000         10  FILLER                  PIC X(56) VALUE
035100       '00000000000000000000000000000000000000000000000000000000'.
035200         10  FILLER                  PIC X(56) VALUE
035300       '00000000000000000000000000000000000000000001757805100067'.
035400         10  FILLER                  PIC X(56) VALUE
035500       '01077203700045007546026000310209860680008801293505300065'.
035600         10  FILLER                  PIC X(56) VALUE
035700       '00859903900046020674063000840128010440005800847802800036'.
035800         10  FILLER                  PIC X(56) VALUE
035900       '01754105000064010274035000420071460260003001965605800076'.
036000         10  FILLER                  PIC X(56) VALUE
036100       '01120703900048008130029000350119820420005300832603000036'.
036200         10  FILLER                  PIC X(56) VALUE
036300       '01910206300084010435042000530078130320003901645705500072'.
036400         10  FILLER                  PIC X(56) VALUE
036500       '00934403900048006369028000330115500390005100717302800034'.
036600         10  FILLER                  PIC X(56) VALUE
036700       '01659304900068009939037000470067490250003100000000000000'.
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       '05574312000158027791065000840186650420005203936811000135'.
037400         10  FILLER                  PIC X(56) VALUE
037500       '02487507400089016114049000580368180990011802491207000083'.
037600         10  FILLER                  PIC X(56) VALUE
037700       '01718004500054036675093001140208970620007301308003700044'.
037800         10  FILLER                  PIC X(56) VALUE
037900       '02502906200078016996044000540116980240003003644309200130'.
038000         10  FILLER                  PIC X(56) VALUE
038100       '01891005100070012742030000410445771090014402433507100091'.
038200         10  FILLER                  PIC X(56) VALUE
038300       '01627304400057000000000000000000000000000000000000000000'.
038400         10  FILLER                  PIC X(56) VALUE
038500       '00000000000000000000000000000000000000000001700105000065'.
038600         10  FILLER                  PIC X(56) VALUE
038700       '00954803600046006152025000320180180560007401221504200055'.
038800         10  FILLER                  PIC X(56) VALUE
038900       '00900402800037018342054000750100890400005000689002900035'.
039000         10  FILLER                  PIC X(56) VALUE
039100       '01824205100071009857037000480066150270003301558604800062'.
039200         10  FILLER                  PIC X(56) VALUE
039300       '01068803600045007411025000310000000000000000000000000000'.
039400         10  FILLER                  PIC X(56) VALUE
039500       '00000000000000000000000000000000000000000000000000000000'.
039600         10  FILLER                  PIC X(56) VALUE
039700       '10265310700135072559055000670543080310003709288510800134'.
039800         10  FILLER                  PIC X(56) VALUE
039900       '06202405900070049379035000400650650740009103871303300039'.
040000         10  FILLER                  PIC X(56) VALUE
040100       '04938506700082033425037000410499831100015102852806900089'.
040200         10  FILLER                  PIC X(56) VALUE
040300       '01790504100053049144073000900323210430005002572803300036'.
040400         10  FILLER                  PIC X(56) VALUE
040500       '03472406700080021039034000370473010660009302772202600038'.
040600         10  FILLER                  PIC X(56) VALUE
040700       '02076801500018034905091001190195940610007700992003200041'.
040800         10  FILLER                  PIC X(56) VALUE
040900       '03328608900111022546053000680163670240003403093907700090'.
041000         10  FILLER                  PIC X(56) VALUE
041100       '01888605100056015372041000450240190300003701955402000022'.
041200         10  FILLER                  PIC X(56) VALUE
041300       '03213109000110020339061000720147240440005101721703800047'.
041400         10  FILLER                  PIC X(56) VALUE
041500       '01214102500029017916030000430099140170002103067006800086'.
041600         10  FILLER                  PIC X(56) VALUE
041700       '01851904200050013140027000320286830760010201620704100054'.
041800         10  FILLER                  PIC X(56) VALUE
041900       '01077002000026019912054000730099170220003003028807600103'.
042000         10  FILLER                  PIC X(56) VALUE
042100       '01584604600060010305023000280228090650008501568505000062'.
042200         10  FILLER                  PIC X(56) VALUE
042300       '01077002500031011815027000380187110340004501395601700021'.
042400         10  FILLER                  PIC X(56) VALUE
042500       '01314802300035021704050000630146900320003901046101800021'.
042600         10  FILLER                  PIC X(56) VALUE
042700       '01300703500048008209021000270318940770009801924404700059'.
042800         10  FILLER                  PIC X(56) VALUE
042900       '01479702600034000000000000000000000000000000000000000000'.
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       '01565704900065007601031000390135270450005800719103200037'.
043800         10  FILLER                  PIC X(56) VALUE
043900       '00827503500041006108026000310204670710009401312605400068'.
044000         10  FILLER                  PIC X(56) VALUE
044100       '00871303700047019521063000830115970450005600777503400041'.
044200         10  FILLER                  PIC X(56) VALUE
044300       '02546706400090011712042000540073480290003601964806700088'.
044400         10  FILLER                  PIC X(56) VALUE
044500       '01203504800061008276033000400163980520006800820403300040'.
044600         10  FILLER                  PIC X(56) VALUE
044700       '01135504300055006812030000370109540360004900656802600032'.
044800         10  FILLER                  PIC X(56) VALUE
044900       '01602105400068008823036000440177170520007201002203600046'.
045000         10  FILLER                  PIC X(56) VALUE
045100       '00621102100026013944045000580071530300003601470204900065'.
045200         10  FILLER                  PIC X(56) VALUE
045300       '00909503800047006625028000340000000000000000000000000000'.
045400         10  FILLER                  PIC X(56) VALUE
045500       '00000000000000000000000000000000000000000000000000000000'.
045600         10  FILLER                  PIC X(56) VALUE
045700       '03246109100125018675067000850108990420005203924809100130'.
045800         10  FILLER                  PIC X(56) VALUE
045900       '01703504100062010416024000330295760770010401495903800054'.
046000         10  FILLER                  PIC X(56) VALUE
046100       '00922301800024010567020000270084540150001701515303500050'.
046200         10  FILLER                  PIC X(56) VALUE
046300       '01041101700022000000000000000000000000000000000000000000'.
046400         10  FILLER                  PIC X(56) VALUE
046500       '00000000000000000000000000000000000000000001766906200082'.
046600         10  FILLER                  PIC X(56) VALUE
046700       '01070904800058007591036000460186900590007800877903700046'.
046800         10  FILLER                  PIC X(56) VALUE
046900       '01559605500075010611041000540062650250003200960204100049'.
047000         10  FILLER                  PIC X(56) VALUE
047100       '00672803000036014748053000670083770380004501236103900052'.
047200         10  FILLER                  PIC X(56) VALUE
047300       '00718202700033013082043000600068570280003700000000000000'.
047400         10  FILLER                  PIC X(56) VALUE
047500       '00000000000000000000000000000000000000000000000000000000'.
047600         10  FILLER                  PIC X(56) VALUE
047700       '00000000000000024554047000650139700250003004493412400156'.
047800         10  FILLER                  PIC X(56) VALUE
047900       '02000606500079012006041000510352140460007401862702600034'.
048000         10  FILLER                  PIC X(56) VALUE
048100       '01474701600019034166094001250185580610007601012203800047'.
048200         10  FILLER                  PIC X(56) VALUE
048300       '02242304600069011701021000300078210120001403381907200106'.
048400         10  FILLER                  PIC X(56) VALUE
048500       '02265006500080014164034000450000000000000000000000000000'.
048600         10  FILLER                  PIC X(56) VALUE
048700       '00000000000000000000000000000000000000000000000000000000'.
048800         10  FILLER                  PIC X(56) VALUE
048900       '01446204500059008306032000400055440230002801140003600051'.
049000         10  FILLER                  PIC X(56) VALUE
049100       '00691602900036010290034000470181590600007601065504200052'.
049200         10  FILLER                  PIC X(56) VALUE
049300       '00719802900036000000000000000000000000000000000000000000'.
049400         10  FILLER                  PIC X(56) VALUE
049500       '00000000000000000000000000000000000000000003044206300074'.
049600         10  FILLER                  PIC X(56) VALUE
049700       '06092913600166030054082000930195670480005603571307700100'.
049800         10  FILLER                  PIC X(56) VALUE
049900       '02000404900059014224030000340349880790010801903004500060'.
050000         10  FILLER                  PIC X(56) VALUE
050100       '01264102400029030158075001070147180360005201107401500019'.
050200         10  FILLER                  PIC X(56) VALUE
050300       '02865308700113016440045000640079190180002402517506600089'.
050400         10  FILLER                  PIC X(56) VALUE
050500       '01259703200044007770018000230144000410005600788501800022'.
050600         10  FILLER                  PIC X(56) VALUE
050700       '02926005900095020934046000670133790160002100000000000000'.
050800         10  FILLER                  PIC X(56) VALUE
050900       '00000000000000000000000000000000000000000000000000000000'.
051000         10  FILLER                  PIC X(56) VALUE
051100       '00000000000000016407051000680102430400004900658702800034'.
051200         10  FILLER                  PIC X(56) VALUE
051300       '00894402500034018238058000780108380380005000647902200028'.
051400         10  FILLER                  PIC X(56) VALUE
051500       '01218504600058007864034000410161560330004301118601800023'.
051600         10  FILLER                  PIC X(56) VALUE
051700       '01350503900052007096021000260120820430005700659002600032'.
051800         10  FILLER                  PIC X(56) VALUE
051900       '00777102400031016098052000680099990370004700675702600032'.
052000         10  FILLER                  PIC X(56) VALUE
052100       '00000000000000000000000000000000000000000000000000000000'.
052200         10  FILLER                  PIC X(56) VALUE
052300       '00000000000000000000000000000177470320004201258101600019'.
052400         10  FILLER                  PIC X(56) VALUE
052500       '01863003400057012712014000170176390520007300808402100027'.
052600         10  FILLER                  PIC X(56) VALUE
052700       '01180202900041006544016000180174330410006000997401200014'.
052800         10  FILLER                  PIC X(56) VALUE
052900       '01613804600064008044020000260000000000000000000000000000'.
053000         10  FILLER                  PIC X(56) VALUE
053100       '00000000000000016891054000770101900390005100621102100027'.
053200         10  FILLER                  PIC X(56) VALUE
053300       '01274204700061007013028000350136570490006400761203300041'.
053400         10  FILLER                  PIC X(56) VALUE
053500       '00989203600047006414023000290000000000000000000000000000'.
053600         10  FILLER                  PIC X(56) VALUE
053700       '00000000000000024364052000700116840220002704394311500140'.
053800         10  FILLER                  PIC X(56) VALUE
053900       '02037505700066012324032000360343000740009801528003800047'.
054000         10  FILLER                  PIC X(56) VALUE
054100       '01097902200026013883032000410090790180002101515104000055'.
054200         10  FILLER                  PIC X(56) VALUE
054300       '00804502000024013373030000420088520150001800916901400017'.
054400         10  FILLER                  PIC X(56) VALUE
054500       '02527506200085009368022000280000000000000000000000000000'.
054600         10  FILLER                  PIC X(56) VALUE
054700       '00000000000000020295064000880114440400005300636102300031'.
054800         10  FILLER                  PIC X(56) VALUE
054900       '01656506000078010963047000570073680330004000838802900038'.
055000         10  FILLER                  PIC X(56) VALUE
055100       '00521901800022000000000000000000000000000000000000000000'.
055200         10  FILLER                  PIC X(56) VALUE
055300       '01126903900049007995029000310091110240002701811204700058'.
055400         10  FILLER                  PIC X(56) VALUE
055500       '02063103500057007017016000210000000000000000000000000000'.
055600         10  FILLER                  PIC X(56) VALUE
055700       '00000000000000006848026000320052560210002300651302600034'.
055800         10  FILLER                  PIC X(56) VALUE
055900       '00740601700021004942021000320053110160002100228401200016'.
056000         10  FILLER                  PIC X(56) VALUE
056100       '00680902700039004744019000260000000000000000000000000000'.
056200         10  FILLER                  PIC X(56) VALUE
056300       '00000000000000000000000000000000000000000000000000000000'.
056400         10  FILLER                  PIC X(56) VALUE
056500       '01487701800018049058179001790335051330013302021608600086'.
056600         10  FILLER                  PIC X(56) VALUE
056700       '03441704700047012181034000340016490310003100000000000000'.
056800         10  FILLER                  PIC X(56) VALUE
056900       '00000000000000000000000000000494341040013502587405900075'.
057000         10  FILLER                  PIC X(56) VALUE
057100       '01558603100039036171085001210189050480006501044602300030'.
057200         10  FILLER                  PIC X(56) VALUE
057300       '00000000000000000000000000000000000000000002147906300082'.
057400         10  FILLER                  PIC X(56) VALUE
057500       '01195104000051009230030000370125440380005200795702800036'.
057600         10  FILLER                  PIC X(56) VALUE
057700       '01437203600050016431050000690100240360004600681802600032'.
057800         10  FILLER                  PIC X(56) VALUE
057900       '00000000000000000000000000000000000000000005711213100172'.
058000         10  FILLER                  PIC X(56) VALUE
058100       '02399805300074012253023000310456401220015902305506600087'.
058200         10  FILLER                  PIC X(56) VALUE
058300       '01241802800040048666112001470214590530006901386103100038'.
058400         10  FILLER                  PIC X(56) VALUE
058500       '02709306300094010976024000320000000000000000000000000000'.
058600         10  FILLER                  PIC X(56) VALUE
058700       '00000000000000049277101001620242840570009201138603000045'.
058800         10  FILLER                  PIC X(56) VALUE
058900       '06659917800235031428081001220128230460005702931707800106'.
059000         10  FILLER                  PIC X(56) VALUE
059100       '01637605100068010389032000420183630600008001194004300056'.
059200         10  FILLER                  PIC X(56) VALUE
059300       '00802902900037021961054000800098600280003400807802400030'.
059400         10  FILLER                  PIC X(56) VALUE
059500       '01262704400061000000000000000000000000000000000000000000'.
059600         10  FILLER                  PIC X(56) VALUE
059700       '05523712000156027883082001000137970390005305129611200150'.
059800         10  FILLER                  PIC X(56) VALUE
059900       '02097506200079013050041000510000000000000000000000000000'.
060000         10  FILLER                  PIC X(56) VALUE
060100       '00000000000000019511058000770097900400004900827603000038'.
060200         10  FILLER                  PIC X(56) VALUE
060300       '01565104500065007462028000350247080670009201161404300054'.
060400         10  FILLER                  PIC X(56) VALUE
060500       '00720703000036058305128001510190740540007201154504500054'.
060600         10  FILLER                  PIC X(56) VALUE
060700       '00000000000000000000000000000000000000000002814308100127'.
060800         10  FILLER                  PIC X(56) VALUE
060900       '00000000000000000000000000000000000000000000616102300030'.
061000         10  FILLER                  PIC X(56) VALUE
061100       '00617803100042006276031000430106940490007700930804000053'.
061200         10  FILLER                  PIC X(56) VALUE
061300       '00904105400074007903038000590078880290004100000000000000'.
061400         10  FILLER                  PIC X(56) VALUE
061500       '00000000000000000000000000000000000000000000000000000000'.
061600         10  FILLER                  PIC X(56) VALUE
061700       '00000000000000004074021000300102750850010901456504700065'.
061800         10  FILLER                  PIC X(56) VALUE
061900       '00651303200040000000000000000000000000000000000000000000'.
062000         10  FILLER                  PIC X(56) VALUE
062100       '03904209100140017922054000750106240330004402933507200109'.
062200         10  FILLER                  PIC X(56) VALUE
062300       '01171403400045010356021000310382680780011101925104700063'.
062400         10  FILLER                  PIC X(56) VALUE
062500       '01155402600034000000000000000000000000000000000000000000'.
062600         10  FILLER                  PIC X(56) VALUE
062700       '01344404000056006994026000320142520360005100486701700021'.
062800         10  FILLER                  PIC X(56) VALUE
062900       '01486803700051006269021000270159030440006200978503200043'.
063000         10  FILLER                  PIC X(56) VALUE
063100       '00621602200028013478038000540068080230003200000000000000'.
063200         10  FILLER                  PIC X(56) VALUE
063300       '00000000000000000000000000001266512180028504772410800148'.
063400         10  FILLER                  PIC X(56) VALUE
063500       '02055705200077000000000000000000000000000000000000000000'.
063600         10  FILLER                  PIC X(56) VALUE
063700       '02197902300051013556041000580129190350005200000000000000'.
063800         10  FILLER                  PIC X(56) VALUE
063900       '00000000000000000000000000000287020690010001679703600054'.
064000         10  FILLER                  PIC X(56) VALUE
064100       '01145702000026000000000000000000000000000000000000000000'.
064200         10  FILLER                  PIC X(56) VALUE
064300       '01279508200101011273066000750109520370004900686502700034'.
064400         10  FILLER                  PIC X(56) VALUE
064500       '01000602600044005040022000280065930220004000000000000000'.
064600         10  FILLER                  PIC X(56) VALUE
064700       '00000000000000000000000000000553360890012603370407000085'.
064800         10  FILLER                  PIC X(56) VALUE
064900       '06251910100142037692075000960232080470005900000000000000'.
065000         10  FILLER                  PIC X(56) VALUE
065100       '00000000000000000000000000000281230600008701490104500056'.
065200         10  FILLER                  PIC X(56) VALUE
065300       '00938603100038000000000000000000000000000000000000000000'.
065400         10  FILLER                  PIC X(56) VALUE
065500       '05507312000171026755063000860000000000000000000000000000'.
065600         10  FILLER                  PIC X(56) VALUE
065700       '00000000000000025849068000960136400510006600897503500044'.
065800         10  FILLER                  PIC X(56) VALUE
065900       '01048603700049000000000000000000000000000000000000000000'.
066000         10  FILLER                  PIC X(56) VALUE
066100       '05063411000141029402068000870177670310004303324210500133'.
066200         10  FILLER                  PIC X(56) VALUE
066300       '02150806800090011140027000400344950930012101873905600074'.
066400         10  FILLER                  PIC X(56) VALUE
066500       '01058902500035000000000000000000000000000000000000000000'.
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 ************************************
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*****YEARCHANGE 2010.0 ************************************
084300
084400 01  LOWVOL-PROV-TABLE.
084500     05 LOWVOL-PROV-DISCHG-DATA.
084600         10  FILLER      PIC X(13) VALUE '010007   1325'.
084700         10  FILLER      PIC X(13) VALUE '010008   0389'.
084800         10  FILLER      PIC X(13) VALUE '010009   0884'.
084900         10  FILLER      PIC X(13) VALUE '010015   0560'.
085000         10  FILLER      PIC X(13) VALUE '010018   0067'.
085100         10  FILLER      PIC X(13) VALUE '010021   0897'.
085200         10  FILLER      PIC X(13) VALUE '010022   0618'.
085300         10  FILLER      PIC X(13) VALUE '010025   1511'.
085400         10  FILLER      PIC X(13) VALUE '010027   0462'.
085500         10  FILLER      PIC X(13) VALUE '010032   0413'.
085600         10  FILLER      PIC X(13) VALUE '010034   1047'.
085700         10  FILLER      PIC X(13) VALUE '010043   0295'.
085800         10  FILLER      PIC X(13) VALUE '010044   0636'.
085900         10  FILLER      PIC X(13) VALUE '010045   0877'.
086000         10  FILLER      PIC X(13) VALUE '010047   1049'.
086100         10  FILLER      PIC X(13) VALUE '010050   0727'.
086200         10  FILLER      PIC X(13) VALUE '010051   0324'.
086300         10  FILLER      PIC X(13) VALUE '010052   0618'.
086400         10  FILLER      PIC X(13) VALUE '010058   0147'.
086500         10  FILLER      PIC X(13) VALUE '010059   1075'.
086600         10  FILLER      PIC X(13) VALUE '010062   0978'.
086700         10  FILLER      PIC X(13) VALUE '010064   0132'.
086800         10  FILLER      PIC X(13) VALUE '010066   0323'.
086900         10  FILLER      PIC X(13) VALUE '010069   0754'.
087000         10  FILLER      PIC X(13) VALUE '010073   0925'.
087100         10  FILLER      PIC X(13) VALUE '010086   1238'.
087200         10  FILLER      PIC X(13) VALUE '010087   1379'.
087300         10  FILLER      PIC X(13) VALUE '010091   0328'.
087400         10  FILLER      PIC X(13) VALUE '010095   0374'.
087500         10  FILLER      PIC X(13) VALUE '010097   0761'.
087600         10  FILLER      PIC X(13) VALUE '010099   1278'.
087700         10  FILLER      PIC X(13) VALUE '010101   1392'.
087800         10  FILLER      PIC X(13) VALUE '010102   0129'.
087900         10  FILLER      PIC X(13) VALUE '010108   1217'.
088000         10  FILLER      PIC X(13) VALUE '010109   0781'.
088100         10  FILLER      PIC X(13) VALUE '010110   0526'.
088200         10  FILLER      PIC X(13) VALUE '010112   1487'.
088300         10  FILLER      PIC X(13) VALUE '010120   1115'.
088400         10  FILLER      PIC X(13) VALUE '010125   1380'.
088500         10  FILLER      PIC X(13) VALUE '010126   1042'.
088600         10  FILLER      PIC X(13) VALUE '010128   0528'.
088700         10  FILLER      PIC X(13) VALUE '010129   0511'.
088800         10  FILLER      PIC X(13) VALUE '010130   0527'.
088900         10  FILLER      PIC X(13) VALUE '010137   0495'.
089000         10  FILLER      PIC X(13) VALUE '010138   0319'.
089100         10  FILLER      PIC X(13) VALUE '010143   0724'.
089200         10  FILLER      PIC X(13) VALUE '010145   1556'.
089300         10  FILLER      PIC X(13) VALUE '010146   0762'.
089400         10  FILLER      PIC X(13) VALUE '010148   1286'.
089500         10  FILLER      PIC X(13) VALUE '010150   1043'.
089600         10  FILLER      PIC X(13) VALUE '010152   1259'.
089700         10  FILLER      PIC X(13) VALUE '010157   0677'.
089800         10  FILLER      PIC X(13) VALUE '010158   1473'.
089900         10  FILLER      PIC X(13) VALUE '010167   1105'.
090000         10  FILLER      PIC X(13) VALUE '010169   0797'.
090100         10  FILLER      PIC X(13) VALUE '020006   1469'.
090200         10  FILLER      PIC X(13) VALUE '020008   0488'.
090300         10  FILLER      PIC X(13) VALUE '020012   1134'.
090400         10  FILLER      PIC X(13) VALUE '020017   1563'.
090500         10  FILLER      PIC X(13) VALUE '020018   0262'.
090600         10  FILLER      PIC X(13) VALUE '020024   0849'.
090700         10  FILLER      PIC X(13) VALUE '020026   1357'.
090800         10  FILLER      PIC X(13) VALUE '020027   0304'.
090900         10  FILLER      PIC X(13) VALUE '030001   1493'.
091000         10  FILLER      PIC X(13) VALUE '030022   1444'.
091100         10  FILLER      PIC X(13) VALUE '030033   1520'.
091200         10  FILLER      PIC X(13) VALUE '030062   1244'.
091300         10  FILLER      PIC X(13) VALUE '030067   0524'.
091400         10  FILLER      PIC X(13) VALUE '030068   0662'.
091500         10  FILLER      PIC X(13) VALUE '030071   0456'.
091600         10  FILLER      PIC X(13) VALUE '030073   0771'.
091700         10  FILLER      PIC X(13) VALUE '030074   0070'.
091800         10  FILLER      PIC X(13) VALUE '030077   0022'.
091900         10  FILLER      PIC X(13) VALUE '030078   0230'.
092000         10  FILLER      PIC X(13) VALUE '030084   0476'.
092100         10  FILLER      PIC X(13) VALUE '030099   0001'.
092200         10  FILLER      PIC X(13) VALUE '030100   1547'.
092300         10  FILLER      PIC X(13) VALUE '030107   0428'.
092400         10  FILLER      PIC X(13) VALUE '030108   0268'.
092500         10  FILLER      PIC X(13) VALUE '030112   0283'.
092600         10  FILLER      PIC X(13) VALUE '030113   0238'.
092700         10  FILLER      PIC X(13) VALUE '030118   1431'.
092800         10  FILLER      PIC X(13) VALUE '030120   0548'.
092900         10  FILLER      PIC X(13) VALUE '030123   1544'.
093000         10  FILLER      PIC X(13) VALUE '030124   0012'.
093100         10  FILLER      PIC X(13) VALUE '030125   0006'.
093200         10  FILLER      PIC X(13) VALUE '030126   0740'.
093300         10  FILLER      PIC X(13) VALUE '040001   1141'.
093400         10  FILLER      PIC X(13) VALUE '040002   1026'.
093500         10  FILLER      PIC X(13) VALUE '040011   1283'.
093600         10  FILLER      PIC X(13) VALUE '040015   0507'.
093700         10  FILLER      PIC X(13) VALUE '040018   0938'.
093800         10  FILLER      PIC X(13) VALUE '040019   0759'.
093900         10  FILLER      PIC X(13) VALUE '040047   0611'.
094000         10  FILLER      PIC X(13) VALUE '040050   1028'.
094100         10  FILLER      PIC X(13) VALUE '040051   1179'.
094200         10  FILLER      PIC X(13) VALUE '040067   0819'.
094300         10  FILLER      PIC X(13) VALUE '040069   0587'.
094400         10  FILLER      PIC X(13) VALUE '040072   0955'.
094500         10  FILLER      PIC X(13) VALUE '040074   1028'.
094600         10  FILLER      PIC X(13) VALUE '040076   1212'.
094700         10  FILLER      PIC X(13) VALUE '040080   1233'.
094800         10  FILLER      PIC X(13) VALUE '040081   0326'.
094900         10  FILLER      PIC X(13) VALUE '040085   1066'.
095000         10  FILLER      PIC X(13) VALUE '040091   0868'.
095100         10  FILLER      PIC X(13) VALUE '040132   0004'.
095200         10  FILLER      PIC X(13) VALUE '040137   1314'.
095300         10  FILLER      PIC X(13) VALUE '040142   0883'.
095400         10  FILLER      PIC X(13) VALUE '040145   0048'.
095500         10  FILLER      PIC X(13) VALUE '040147   1306'.
095600         10  FILLER      PIC X(13) VALUE '040152   0023'.
095700         10  FILLER      PIC X(13) VALUE '050008   1319'.
095800         10  FILLER      PIC X(13) VALUE '050014   1166'.
095900         10  FILLER      PIC X(13) VALUE '050016   1341'.
096000         10  FILLER      PIC X(13) VALUE '050028   0786'.
096100         10  FILLER      PIC X(13) VALUE '050040   0756'.
096200         10  FILLER      PIC X(13) VALUE '050046   0368'.
096300         10  FILLER      PIC X(13) VALUE '050054   0960'.
096400         10  FILLER      PIC X(13) VALUE '050055   1158'.
096500         10  FILLER      PIC X(13) VALUE '050067   0640'.
096600         10  FILLER      PIC X(13) VALUE '050070   0236'.
096700         10  FILLER      PIC X(13) VALUE '050090   0778'.
096800         10  FILLER      PIC X(13) VALUE '050091   0715'.
096900         10  FILLER      PIC X(13) VALUE '050096   0111'.
097000         10  FILLER      PIC X(13) VALUE '050110   0979'.
097100         10  FILLER      PIC X(13) VALUE '050113   0531'.
097200         10  FILLER      PIC X(13) VALUE '050127   1363'.
097300         10  FILLER      PIC X(13) VALUE '050131   1027'.
097400         10  FILLER      PIC X(13) VALUE '050136   1267'.
097500         10  FILLER      PIC X(13) VALUE '050158   1490'.
097600         10  FILLER      PIC X(13) VALUE '050159   1427'.
097700         10  FILLER      PIC X(13) VALUE '050167   1003'.
097800         10  FILLER      PIC X(13) VALUE '050173   0405'.
097900         10  FILLER      PIC X(13) VALUE '050188   0620'.
098000         10  FILLER      PIC X(13) VALUE '050189   0353'.
098100         10  FILLER      PIC X(13) VALUE '050192   0397'.
098200         10  FILLER      PIC X(13) VALUE '050193   0812'.
098300         10  FILLER      PIC X(13) VALUE '050196   0727'.
098400         10  FILLER      PIC X(13) VALUE '050205   0546'.
098500         10  FILLER      PIC X(13) VALUE '050211   1330'.
098600         10  FILLER      PIC X(13) VALUE '050219   1200'.
098700         10  FILLER      PIC X(13) VALUE '050234   1357'.
098800         10  FILLER      PIC X(13) VALUE '050248   0802'.
098900         10  FILLER      PIC X(13) VALUE '050257   1290'.
099000         10  FILLER      PIC X(13) VALUE '050276   1239'.
099100         10  FILLER      PIC X(13) VALUE '050279   0994'.
099200         10  FILLER      PIC X(13) VALUE '050296   0861'.
099300         10  FILLER      PIC X(13) VALUE '050298   1111'.
099400         10  FILLER      PIC X(13) VALUE '050301   1583'.
099500         10  FILLER      PIC X(13) VALUE '050315   0798'.
099600         10  FILLER      PIC X(13) VALUE '050320   1259'.
099700         10  FILLER      PIC X(13) VALUE '050325   0032'.
099800         10  FILLER      PIC X(13) VALUE '050342   1526'.
099900         10  FILLER      PIC X(13) VALUE '050349   0085'.
100000         10  FILLER      PIC X(13) VALUE '050352   0781'.
100100         10  FILLER      PIC X(13) VALUE '050357   0669'.
100200         10  FILLER      PIC X(13) VALUE '050366   0827'.
100300         10  FILLER      PIC X(13) VALUE '050376   1468'.
100400         10  FILLER      PIC X(13) VALUE '050378   1212'.
100500         10  FILLER      PIC X(13) VALUE '050385   0705'.
100600         10  FILLER      PIC X(13) VALUE '050397   0200'.
100700         10  FILLER      PIC X(13) VALUE '050407   0944'.
100800         10  FILLER      PIC X(13) VALUE '050417   1135'.
100900         10  FILLER      PIC X(13) VALUE '050423   0443'.
101000         10  FILLER      PIC X(13) VALUE '050430   0004'.
101100         10  FILLER      PIC X(13) VALUE '050434   0472'.
101200         10  FILLER      PIC X(13) VALUE '050435   1146'.
101300         10  FILLER      PIC X(13) VALUE '050448   1030'.
101400         10  FILLER      PIC X(13) VALUE '050478   0183'.
101500         10  FILLER      PIC X(13) VALUE '050517   1270'.
101600         10  FILLER      PIC X(13) VALUE '050526   1572'.
101700         10  FILLER      PIC X(13) VALUE '050528   0508'.
101800         10  FILLER      PIC X(13) VALUE '050531   1089'.
101900         10  FILLER      PIC X(13) VALUE '050537   0957'.
102000         10  FILLER      PIC X(13) VALUE '050543   0473'.
102100         10  FILLER      PIC X(13) VALUE '050545   0047'.
102200         10  FILLER      PIC X(13) VALUE '050547   0084'.
102300         10  FILLER      PIC X(13) VALUE '050548   0029'.
102400         10  FILLER      PIC X(13) VALUE '050552   0253'.
102500         10  FILLER      PIC X(13) VALUE '050568   1184'.
102600         10  FILLER      PIC X(13) VALUE '050588   1577'.
102700         10  FILLER      PIC X(13) VALUE '050608   1032'.
102800         10  FILLER      PIC X(13) VALUE '050618   0165'.
102900         10  FILLER      PIC X(13) VALUE '050641   0781'.
103000         10  FILLER      PIC X(13) VALUE '050660   0708'.
103100         10  FILLER      PIC X(13) VALUE '050662   0003'.
103200         10  FILLER      PIC X(13) VALUE '050667   0048'.
103300         10  FILLER      PIC X(13) VALUE '050668   0058'.
103400         10  FILLER      PIC X(13) VALUE '050680   1453'.
103500         10  FILLER      PIC X(13) VALUE '050682   0001'.
103600         10  FILLER      PIC X(13) VALUE '050684   1465'.
103700         10  FILLER      PIC X(13) VALUE '050688   1251'.
103800         10  FILLER      PIC X(13) VALUE '050693   0412'.
103900         10  FILLER      PIC X(13) VALUE '050694   0186'.
104000         10  FILLER      PIC X(13) VALUE '050697   0089'.
104100         10  FILLER      PIC X(13) VALUE '050708   0888'.
104200         10  FILLER      PIC X(13) VALUE '050714   0196'.
104300         10  FILLER      PIC X(13) VALUE '050717   0238'.
104400         10  FILLER      PIC X(13) VALUE '050722   0079'.
104500         10  FILLER      PIC X(13) VALUE '050723   0391'.
104600         10  FILLER      PIC X(13) VALUE '050725   0166'.
104700         10  FILLER      PIC X(13) VALUE '050726   0390'.
104800         10  FILLER      PIC X(13) VALUE '050727   1236'.
104900         10  FILLER      PIC X(13) VALUE '050732   1256'.
105000         10  FILLER      PIC X(13) VALUE '050733   0347'.
105100         10  FILLER      PIC X(13) VALUE '050736   1334'.
105200         10  FILLER      PIC X(13) VALUE '050738   0875'.
105300         10  FILLER      PIC X(13) VALUE '050744   0675'.
105400         10  FILLER      PIC X(13) VALUE '050745   0638'.
105500         10  FILLER      PIC X(13) VALUE '050747   0706'.
105600         10  FILLER      PIC X(13) VALUE '050748   0243'.
105700         10  FILLER      PIC X(13) VALUE '050749   0215'.
105800         10  FILLER      PIC X(13) VALUE '050751   0097'.
105900         10  FILLER      PIC X(13) VALUE '050754   0064'.
106000         10  FILLER      PIC X(13) VALUE '050758   1178'.
106100         10  FILLER      PIC X(13) VALUE '050760   0241'.
106200         10  FILLER      PIC X(13) VALUE '050762   0021'.
106300         10  FILLER      PIC X(13) VALUE '050763   1172'.
106400         10  FILLER      PIC X(13) VALUE '050765   0591'.
106500         10  FILLER      PIC X(13) VALUE '050766   0052'.
106600         10  FILLER      PIC X(13) VALUE '060004   1196'.
106700         10  FILLER      PIC X(13) VALUE '060006   1291'.
106800         10  FILLER      PIC X(13) VALUE '060008   0908'.
106900         10  FILLER      PIC X(13) VALUE '060016   1059'.
107000         10  FILLER      PIC X(13) VALUE '060018   0001'.
107100         10  FILLER      PIC X(13) VALUE '060036   0931'.
107200         10  FILLER      PIC X(13) VALUE '060043   0159'.
107300         10  FILLER      PIC X(13) VALUE '060044   0524'.
107400         10  FILLER      PIC X(13) VALUE '060049   0435'.
107500         10  FILLER      PIC X(13) VALUE '060054   1024'.
107600         10  FILLER      PIC X(13) VALUE '060071   1492'.
107700         10  FILLER      PIC X(13) VALUE '060075   0741'.
107800         10  FILLER      PIC X(13) VALUE '060076   0790'.
107900         10  FILLER      PIC X(13) VALUE '060096   0353'.
108000         10  FILLER      PIC X(13) VALUE '060103   0705'.
108100         10  FILLER      PIC X(13) VALUE '060107   0004'.
108200         10  FILLER      PIC X(13) VALUE '060115   0013'.
108300         10  FILLER      PIC X(13) VALUE '060116   0701'.
108400         10  FILLER      PIC X(13) VALUE '060117   0153'.
108500         10  FILLER      PIC X(13) VALUE '060118   0186'.
108600         10  FILLER      PIC X(13) VALUE '060121   0060'.
108700         10  FILLER      PIC X(13) VALUE '060123   0159'.
108800         10  FILLER      PIC X(13) VALUE '070004   1197'.
108900         10  FILLER      PIC X(13) VALUE '070008   1441'.
109000         10  FILLER      PIC X(13) VALUE '070012   1563'.
109100         10  FILLER      PIC X(13) VALUE '070015   1223'.
109200         10  FILLER      PIC X(13) VALUE '070038   0005'.
109300         10  FILLER      PIC X(13) VALUE '070039   0622'.
109400         10  FILLER      PIC X(13) VALUE '070040   0238'.
109500         10  FILLER      PIC X(13) VALUE '090008   1502'.
109600         10  FILLER      PIC X(13) VALUE '100024   0279'.
109700         10  FILLER      PIC X(13) VALUE '100048   0688'.
109800         10  FILLER      PIC X(13) VALUE '100054   1257'.
109900         10  FILLER      PIC X(13) VALUE '100069   1432'.
110000         10  FILLER      PIC X(13) VALUE '100079   0452'.
110100         10  FILLER      PIC X(13) VALUE '100081   0601'.
110200         10  FILLER      PIC X(13) VALUE '100106   0570'.
110300         10  FILLER      PIC X(13) VALUE '100130   0473'.
110400         10  FILLER      PIC X(13) VALUE '100134   0008'.
110500         10  FILLER      PIC X(13) VALUE '100139   0209'.
110600         10  FILLER      PIC X(13) VALUE '100140   1142'.
110700         10  FILLER      PIC X(13) VALUE '100142   1517'.
110800         10  FILLER      PIC X(13) VALUE '100150   1226'.
110900         10  FILLER      PIC X(13) VALUE '100160   0444'.
111000         10  FILLER      PIC X(13) VALUE '100175   0984'.
111100         10  FILLER      PIC X(13) VALUE '100211   1584'.
111200         10  FILLER      PIC X(13) VALUE '100240   0068'.
111300         10  FILLER      PIC X(13) VALUE '100277   0216'.
111400         10  FILLER      PIC X(13) VALUE '100298   0033'.
111500         10  FILLER      PIC X(13) VALUE '100308   0001'.
111600         10  FILLER      PIC X(13) VALUE '100309   0007'.
111700         10  FILLER      PIC X(13) VALUE '100310   0029'.
111800         10  FILLER      PIC X(13) VALUE '100311   0022'.
111900         10  FILLER      PIC X(13) VALUE '110015   0976'.
112000         10  FILLER      PIC X(13) VALUE '110023   1579'.
112100         10  FILLER      PIC X(13) VALUE '110026   0600'.
112200         10  FILLER      PIC X(13) VALUE '110027   0739'.
112300         10  FILLER      PIC X(13) VALUE '110032   1559'.
112400         10  FILLER      PIC X(13) VALUE '110040   0648'.
112500         10  FILLER      PIC X(13) VALUE '110041   1179'.
112600         10  FILLER      PIC X(13) VALUE '110042   0984'.
112700         10  FILLER      PIC X(13) VALUE '110044   0857'.
112800         10  FILLER      PIC X(13) VALUE '110045   0812'.
112900         10  FILLER      PIC X(13) VALUE '110046   1428'.
113000         10  FILLER      PIC X(13) VALUE '110050   0614'.
113100         10  FILLER      PIC X(13) VALUE '110051   0961'.
113200         10  FILLER      PIC X(13) VALUE '110059   0626'.
113300         10  FILLER      PIC X(13) VALUE '110071   0673'.
113400         10  FILLER      PIC X(13) VALUE '110073   0929'.
113500         10  FILLER      PIC X(13) VALUE '110086   0729'.
113600         10  FILLER      PIC X(13) VALUE '110092   1197'.
113700         10  FILLER      PIC X(13) VALUE '110100   0664'.
113800         10  FILLER      PIC X(13) VALUE '110101   0616'.
113900         10  FILLER      PIC X(13) VALUE '110104   1431'.
114000         10  FILLER      PIC X(13) VALUE '110109   0903'.
114100         10  FILLER      PIC X(13) VALUE '110111   0538'.
114200         10  FILLER      PIC X(13) VALUE '110112   0275'.
114300         10  FILLER      PIC X(13) VALUE '110113   0747'.
114400         10  FILLER      PIC X(13) VALUE '110121   0496'.
114500         10  FILLER      PIC X(13) VALUE '110130   0254'.
114600         10  FILLER      PIC X(13) VALUE '110132   1068'.
114700         10  FILLER      PIC X(13) VALUE '110135   0829'.
114800         10  FILLER      PIC X(13) VALUE '110142   0734'.
114900         10  FILLER      PIC X(13) VALUE '110146   0492'.
115000         10  FILLER      PIC X(13) VALUE '110153   1123'.
115100         10  FILLER      PIC X(13) VALUE '110183   0828'.
115200         10  FILLER      PIC X(13) VALUE '110187   0749'.
115300         10  FILLER      PIC X(13) VALUE '110189   1218'.
115400         10  FILLER      PIC X(13) VALUE '110190   0406'.
115500         10  FILLER      PIC X(13) VALUE '110194   0759'.
115600         10  FILLER      PIC X(13) VALUE '110200   0695'.
115700         10  FILLER      PIC X(13) VALUE '110203   0630'.
115800         10  FILLER      PIC X(13) VALUE '110205   0542'.
115900         10  FILLER      PIC X(13) VALUE '110209   1174'.
116000         10  FILLER      PIC X(13) VALUE '110212   1042'.
116100         10  FILLER      PIC X(13) VALUE '110225   1340'.
116200         10  FILLER      PIC X(13) VALUE '110226   1137'.
116300         10  FILLER      PIC X(13) VALUE '110230   1365'.
116400         10  FILLER      PIC X(13) VALUE '110231   0019'.
116500         10  FILLER      PIC X(13) VALUE '120004   0840'.
116600         10  FILLER      PIC X(13) VALUE '120010   1283'.
116700         10  FILLER      PIC X(13) VALUE '120014   0891'.
116800         10  FILLER      PIC X(13) VALUE '120019   0599'.
116900         10  FILLER      PIC X(13) VALUE '120028   0353'.
117000         10  FILLER      PIC X(13) VALUE '130024   0810'.
117100         10  FILLER      PIC X(13) VALUE '130025   0782'.
117200         10  FILLER      PIC X(13) VALUE '130063   0093'.
117300         10  FILLER      PIC X(13) VALUE '130065   0261'.
117400         10  FILLER      PIC X(13) VALUE '130066   0156'.
117500         10  FILLER      PIC X(13) VALUE '130067   0007'.
117600         10  FILLER      PIC X(13) VALUE '130069   0011'.
117700         10  FILLER      PIC X(13) VALUE '130070   0011'.
117800         10  FILLER      PIC X(13) VALUE '140001   0915'.
117900         10  FILLER      PIC X(13) VALUE '140019   0758'.
118000         10  FILLER      PIC X(13) VALUE '140033   0010'.
118100         10  FILLER      PIC X(13) VALUE '140059   0883'.
118200         10  FILLER      PIC X(13) VALUE '140066   0193'.
118300         10  FILLER      PIC X(13) VALUE '140068   1294'.
118400         10  FILLER      PIC X(13) VALUE '140075   0001'.
118500         10  FILLER      PIC X(13) VALUE '140077   0638'.
118600         10  FILLER      PIC X(13) VALUE '140089   1270'.
118700         10  FILLER      PIC X(13) VALUE '140094   1444'.
118800         10  FILLER      PIC X(13) VALUE '140095   1364'.
118900         10  FILLER      PIC X(13) VALUE '140100   0289'.
119000         10  FILLER      PIC X(13) VALUE '140110   1432'.
119100         10  FILLER      PIC X(13) VALUE '140137   0512'.
119200         10  FILLER      PIC X(13) VALUE '140143   1547'.
119300         10  FILLER      PIC X(13) VALUE '140145   0958'.
119400         10  FILLER      PIC X(13) VALUE '140147   1116'.
119500         10  FILLER      PIC X(13) VALUE '140151   1504'.
119600         10  FILLER      PIC X(13) VALUE '140161   0903'.
119700         10  FILLER      PIC X(13) VALUE '140167   1372'.
119800         10  FILLER      PIC X(13) VALUE '140207   0071'.
119900         10  FILLER      PIC X(13) VALUE '140210   1261'.
120000         10  FILLER      PIC X(13) VALUE '140294   1057'.
120100         10  FILLER      PIC X(13) VALUE '140300   0940'.
120200         10  FILLER      PIC X(13) VALUE '140301   0269'.
120300         10  FILLER      PIC X(13) VALUE '140303   0379'.
120400         10  FILLER      PIC X(13) VALUE '150022   1123'.
120500         10  FILLER      PIC X(13) VALUE '150038   0803'.
120600         10  FILLER      PIC X(13) VALUE '150045   0645'.
120700         10  FILLER      PIC X(13) VALUE '150057   1367'.
120800         10  FILLER      PIC X(13) VALUE '150061   1024'.
120900         10  FILLER      PIC X(13) VALUE '150064   1243'.
121000         10  FILLER      PIC X(13) VALUE '150065   1356'.
121100         10  FILLER      PIC X(13) VALUE '150072   0820'.
121200         10  FILLER      PIC X(13) VALUE '150076   1197'.
121300         10  FILLER      PIC X(13) VALUE '150091   0575'.
121400         10  FILLER      PIC X(13) VALUE '150097   1334'.
121500         10  FILLER      PIC X(13) VALUE '150101   0559'.
121600         10  FILLER      PIC X(13) VALUE '150102   0519'.
121700         10  FILLER      PIC X(13) VALUE '150104   0913'.
121800         10  FILLER      PIC X(13) VALUE '150129   0818'.
121900         10  FILLER      PIC X(13) VALUE '150133   1570'.
122000         10  FILLER      PIC X(13) VALUE '150146   0749'.
122100         10  FILLER      PIC X(13) VALUE '150149   0083'.
122200         10  FILLER      PIC X(13) VALUE '150150   1080'.
122300         10  FILLER      PIC X(13) VALUE '150160   1053'.
122400         10  FILLER      PIC X(13) VALUE '150163   0811'.
122500         10  FILLER      PIC X(13) VALUE '150164   0831'.
122600         10  FILLER      PIC X(13) VALUE '150165   0440'.
122700         10  FILLER      PIC X(13) VALUE '150166   0256'.
122800         10  FILLER      PIC X(13) VALUE '150167   0633'.
122900         10  FILLER      PIC X(13) VALUE '150168   0759'.
123000         10  FILLER      PIC X(13) VALUE '150170   0011'.
123100         10  FILLER      PIC X(13) VALUE '150172   0053'.
123200         10  FILLER      PIC X(13) VALUE '150174   0014'.
123300         10  FILLER      PIC X(13) VALUE '150175   0492'.
123400         10  FILLER      PIC X(13) VALUE '150176   0005'.
123500         10  FILLER      PIC X(13) VALUE '160001   1344'.
123600         10  FILLER      PIC X(13) VALUE '160005   1057'.
123700         10  FILLER      PIC X(13) VALUE '160008   1372'.
123800         10  FILLER      PIC X(13) VALUE '160013   0695'.
123900         10  FILLER      PIC X(13) VALUE '160032   1049'.
124000         10  FILLER      PIC X(13) VALUE '160040   0645'.
124100         10  FILLER      PIC X(13) VALUE '160101   0381'.
124200         10  FILLER      PIC X(13) VALUE '160104   1516'.
124300         10  FILLER      PIC X(13) VALUE '160112   1460'.
124400         10  FILLER      PIC X(13) VALUE '160122   0975'.
124500         10  FILLER      PIC X(13) VALUE '160124   0772'.
124600         10  FILLER      PIC X(13) VALUE '160147   0892'.
124700         10  FILLER      PIC X(13) VALUE '160156   0030'.
124800         10  FILLER      PIC X(13) VALUE '170001   1542'.
124900         10  FILLER      PIC X(13) VALUE '170009   0906'.
125000         10  FILLER      PIC X(13) VALUE '170010   0597'.
125100         10  FILLER      PIC X(13) VALUE '170014   0768'.
125200         10  FILLER      PIC X(13) VALUE '170017   0810'.
125300         10  FILLER      PIC X(13) VALUE '170023   1009'.
125400         10  FILLER      PIC X(13) VALUE '170027   0898'.
125500         10  FILLER      PIC X(13) VALUE '170033   0693'.
125600         10  FILLER      PIC X(13) VALUE '170039   0364'.
125700         10  FILLER      PIC X(13) VALUE '170058   1112'.
125800         10  FILLER      PIC X(13) VALUE '170068   0749'.
125900         10  FILLER      PIC X(13) VALUE '170074   0687'.
126000         10  FILLER      PIC X(13) VALUE '170075   0191'.
126100         10  FILLER      PIC X(13) VALUE '170094   0688'.
126200         10  FILLER      PIC X(13) VALUE '170105   0637'.
126300         10  FILLER      PIC X(13) VALUE '170109   0388'.
126400         10  FILLER      PIC X(13) VALUE '170110   0213'.
126500         10  FILLER      PIC X(13) VALUE '170120   1301'.
126600         10  FILLER      PIC X(13) VALUE '170133   0660'.
126700         10  FILLER      PIC X(13) VALUE '170150   0498'.
126800         10  FILLER      PIC X(13) VALUE '170166   0605'.
126900         10  FILLER      PIC X(13) VALUE '170175   1073'.
127000         10  FILLER      PIC X(13) VALUE '170183   0652'.
127100         10  FILLER      PIC X(13) VALUE '170186   1473'.
127200         10  FILLER      PIC X(13) VALUE '170187   0305'.
127300         10  FILLER      PIC X(13) VALUE '170188   0260'.
127400         10  FILLER      PIC X(13) VALUE '170190   0081'.
127500         10  FILLER      PIC X(13) VALUE '170191   0288'.
127600         10  FILLER      PIC X(13) VALUE '170194   0389'.
127700         10  FILLER      PIC X(13) VALUE '170195   0340'.
127800         10  FILLER      PIC X(13) VALUE '170196   0590'.
127900         10  FILLER      PIC X(13) VALUE '170198   0093'.
128000         10  FILLER      PIC X(13) VALUE '170199   0002'.
128100         10  FILLER      PIC X(13) VALUE '180004   1184'.
128200         10  FILLER      PIC X(13) VALUE '180016   1586'.
128300         10  FILLER      PIC X(13) VALUE '180019   1482'.
128400         10  FILLER      PIC X(13) VALUE '180020   1184'.
128500         10  FILLER      PIC X(13) VALUE '180024   0901'.
128600         10  FILLER      PIC X(13) VALUE '180025   1299'.
128700         10  FILLER      PIC X(13) VALUE '180043   1443'.
128800         10  FILLER      PIC X(13) VALUE '180046   0501'.
128900         10  FILLER      PIC X(13) VALUE '180049   1287'.
129000         10  FILLER      PIC X(13) VALUE '180053   0927'.
129100         10  FILLER      PIC X(13) VALUE '180064   0836'.
129200         10  FILLER      PIC X(13) VALUE '180066   1103'.
129300         10  FILLER      PIC X(13) VALUE '180070   0960'.
129400         10  FILLER      PIC X(13) VALUE '180079   0860'.
129500         10  FILLER      PIC X(13) VALUE '180087   1387'.
129600         10  FILLER      PIC X(13) VALUE '180092   0863'.
129700         10  FILLER      PIC X(13) VALUE '180095   1110'.
129800         10  FILLER      PIC X(13) VALUE '180101   0946'.
129900         10  FILLER      PIC X(13) VALUE '180105   1232'.
130000         10  FILLER      PIC X(13) VALUE '180106   1235'.
130100         10  FILLER      PIC X(13) VALUE '180115   0822'.
130200         10  FILLER      PIC X(13) VALUE '180117   0632'.
130300         10  FILLER      PIC X(13) VALUE '180128   1496'.
130400         10  FILLER      PIC X(13) VALUE '180138   1402'.
130500         10  FILLER      PIC X(13) VALUE '180149   1123'.
130600         10  FILLER      PIC X(13) VALUE '190001   0926'.
130700         10  FILLER      PIC X(13) VALUE '190003   1164'.
130800         10  FILLER      PIC X(13) VALUE '190005   1268'.
130900         10  FILLER      PIC X(13) VALUE '190006   0640'.
131000         10  FILLER      PIC X(13) VALUE '190007   1241'.
131100         10  FILLER      PIC X(13) VALUE '190009   0203'.
131200         10  FILLER      PIC X(13) VALUE '190011   0717'.
131300         10  FILLER      PIC X(13) VALUE '190014   1086'.
131400         10  FILLER      PIC X(13) VALUE '190025   1080'.
131500         10  FILLER      PIC X(13) VALUE '190034   1044'.
131600         10  FILLER      PIC X(13) VALUE '190037   0001'.
131700         10  FILLER      PIC X(13) VALUE '190044   1524'.
131800         10  FILLER      PIC X(13) VALUE '190050   1229'.
131900         10  FILLER      PIC X(13) VALUE '190078   0995'.
132000         10  FILLER      PIC X(13) VALUE '190079   0413'.
132100         10  FILLER      PIC X(13) VALUE '190081   0794'.
132200         10  FILLER      PIC X(13) VALUE '190088   0674'.
132300         10  FILLER      PIC X(13) VALUE '190090   0681'.
132400         10  FILLER      PIC X(13) VALUE '190099   0916'.
132500         10  FILLER      PIC X(13) VALUE '190106   0642'.
132600         10  FILLER      PIC X(13) VALUE '190114   1034'.
132700         10  FILLER      PIC X(13) VALUE '190116   0784'.
132800         10  FILLER      PIC X(13) VALUE '190118   0736'.
132900         10  FILLER      PIC X(13) VALUE '190122   0455'.
133000         10  FILLER      PIC X(13) VALUE '190128   0295'.
133100         10  FILLER      PIC X(13) VALUE '190131   0108'.
133200         10  FILLER      PIC X(13) VALUE '190133   0193'.
133300         10  FILLER      PIC X(13) VALUE '190135   1153'.
133400         10  FILLER      PIC X(13) VALUE '190140   0814'.
133500         10  FILLER      PIC X(13) VALUE '190145   0747'.
133600         10  FILLER      PIC X(13) VALUE '190151   0584'.
133700         10  FILLER      PIC X(13) VALUE '190161   0138'.
133800         10  FILLER      PIC X(13) VALUE '190167   1498'.
133900         10  FILLER      PIC X(13) VALUE '190175   1311'.
134000         10  FILLER      PIC X(13) VALUE '190183   0711'.
134100         10  FILLER      PIC X(13) VALUE '190184   0380'.
134200         10  FILLER      PIC X(13) VALUE '190190   0490'.
134300         10  FILLER      PIC X(13) VALUE '190191   0486'.
134400         10  FILLER      PIC X(13) VALUE '190196   0055'.
134500         10  FILLER      PIC X(13) VALUE '190199   0019'.
134600         10  FILLER      PIC X(13) VALUE '190201   0261'.
134700         10  FILLER      PIC X(13) VALUE '190208   0452'.
134800         10  FILLER      PIC X(13) VALUE '190218   0675'.
134900         10  FILLER      PIC X(13) VALUE '190241   0070'.
135000         10  FILLER      PIC X(13) VALUE '190242   1010'.
135100         10  FILLER      PIC X(13) VALUE '190245   0118'.
135200         10  FILLER      PIC X(13) VALUE '190246   0239'.
135300         10  FILLER      PIC X(13) VALUE '190250   1329'.
135400         10  FILLER      PIC X(13) VALUE '190251   0065'.
135500         10  FILLER      PIC X(13) VALUE '190255   0012'.
135600         10  FILLER      PIC X(13) VALUE '190256   0023'.
135700         10  FILLER      PIC X(13) VALUE '190257   0213'.
135800         10  FILLER      PIC X(13) VALUE '190258   0035'.
135900         10  FILLER      PIC X(13) VALUE '190259   0220'.
136000         10  FILLER      PIC X(13) VALUE '190261   0011'.
136100         10  FILLER      PIC X(13) VALUE '190263   1372'.
136200         10  FILLER      PIC X(13) VALUE '190266   0157'.
136300         10  FILLER      PIC X(13) VALUE '190267   0079'.
136400         10  FILLER      PIC X(13) VALUE '190268   0038'.
136500         10  FILLER      PIC X(13) VALUE '190270   0304'.
136600         10  FILLER      PIC X(13) VALUE '190272   0155'.
136700         10  FILLER      PIC X(13) VALUE '190273   0049'.
136800         10  FILLER      PIC X(13) VALUE '190278   0208'.
136900         10  FILLER      PIC X(13) VALUE '190297   0246'.
137000         10  FILLER      PIC X(13) VALUE '200002   0926'.
137100         10  FILLER      PIC X(13) VALUE '200018   1146'.
137200         10  FILLER      PIC X(13) VALUE '200025   0814'.
137300         10  FILLER      PIC X(13) VALUE '200031   1074'.
137400         10  FILLER      PIC X(13) VALUE '200032   1199'.
137500         10  FILLER      PIC X(13) VALUE '200037   1406'.
137600         10  FILLER      PIC X(13) VALUE '200040   1369'.
137700         10  FILLER      PIC X(13) VALUE '200041   0719'.
137800         10  FILLER      PIC X(13) VALUE '200050   1591'.
137900         10  FILLER      PIC X(13) VALUE '200052   0783'.
138000         10  FILLER      PIC X(13) VALUE '210017   1242'.
138100         10  FILLER      PIC X(13) VALUE '210045   0440'.
138200         10  FILLER      PIC X(13) VALUE '210060   1251'.
138300         10  FILLER      PIC X(13) VALUE '220019   1158'.
138400         10  FILLER      PIC X(13) VALUE '220025   0226'.
138500         10  FILLER      PIC X(13) VALUE '220050   0846'.
138600         10  FILLER      PIC X(13) VALUE '220051   1325'.
138700         10  FILLER      PIC X(13) VALUE '220058   0469'.
138800         10  FILLER      PIC X(13) VALUE '220075   0378'.
138900         10  FILLER      PIC X(13) VALUE '220083   1481'.
139000         10  FILLER      PIC X(13) VALUE '220095   1524'.
139100         10  FILLER      PIC X(13) VALUE '220098   0969'.
139200         10  FILLER      PIC X(13) VALUE '220162   0276'.
139300         10  FILLER      PIC X(13) VALUE '220177   0168'.
139400         10  FILLER      PIC X(13) VALUE '230003   1057'.
139500         10  FILLER      PIC X(13) VALUE '230013   1077'.
139600         10  FILLER      PIC X(13) VALUE '230015   0779'.
139700         10  FILLER      PIC X(13) VALUE '230034   0866'.
139800         10  FILLER      PIC X(13) VALUE '230035   1315'.
139900         10  FILLER      PIC X(13) VALUE '230037   1505'.
140000         10  FILLER      PIC X(13) VALUE '230040   1513'.
140100         10  FILLER      PIC X(13) VALUE '230055   1520'.
140200         10  FILLER      PIC X(13) VALUE '230060   0745'.
140300         10  FILLER      PIC X(13) VALUE '230071   0386'.
140400         10  FILLER      PIC X(13) VALUE '230078   0450'.
140500         10  FILLER      PIC X(13) VALUE '230080   1538'.
140600         10  FILLER      PIC X(13) VALUE '230085   0365'.
140700         10  FILLER      PIC X(13) VALUE '230093   0856'.
140800         10  FILLER      PIC X(13) VALUE '230095   1573'.
140900         10  FILLER      PIC X(13) VALUE '230096   0865'.
141000         10  FILLER      PIC X(13) VALUE '230100   1398'.
141100         10  FILLER      PIC X(13) VALUE '230101   1269'.
141200         10  FILLER      PIC X(13) VALUE '230106   1362'.
141300         10  FILLER      PIC X(13) VALUE '230108   0773'.
141400         10  FILLER      PIC X(13) VALUE '230110   1283'.
141500         10  FILLER      PIC X(13) VALUE '230118   0747'.
141600         10  FILLER      PIC X(13) VALUE '230133   0753'.
141700         10  FILLER      PIC X(13) VALUE '230135   0223'.
141800         10  FILLER      PIC X(13) VALUE '230174   0905'.
141900         10  FILLER      PIC X(13) VALUE '230180   1281'.
142000         10  FILLER      PIC X(13) VALUE '230208   0627'.
142100         10  FILLER      PIC X(13) VALUE '230212   0636'.
142200         10  FILLER      PIC X(13) VALUE '230217   1400'.
142300         10  FILLER      PIC X(13) VALUE '230239   1262'.
142400         10  FILLER      PIC X(13) VALUE '230241   1231'.
142500         10  FILLER      PIC X(13) VALUE '230257   0151'.
142600         10  FILLER      PIC X(13) VALUE '230259   1135'.
142700         10  FILLER      PIC X(13) VALUE '230264   0018'.
142800         10  FILLER      PIC X(13) VALUE '230275   0074'.
142900         10  FILLER      PIC X(13) VALUE '230279   0174'.
143000         10  FILLER      PIC X(13) VALUE '230297   1370'.
143100         10  FILLER      PIC X(13) VALUE '230301   0217'.
143200         10  FILLER      PIC X(13) VALUE '240006   0479'.
143300         10  FILLER      PIC X(13) VALUE '240014   0739'.
143400         10  FILLER      PIC X(13) VALUE '240018   0710'.
143500         10  FILLER      PIC X(13) VALUE '240019   1118'.
143600         10  FILLER      PIC X(13) VALUE '240020   1352'.
143700         10  FILLER      PIC X(13) VALUE '240022   0529'.
143800         10  FILLER      PIC X(13) VALUE '240040   1516'.
143900         10  FILLER      PIC X(13) VALUE '240043   1467'.
144000         10  FILLER      PIC X(13) VALUE '240044   1399'.
144100         10  FILLER      PIC X(13) VALUE '240050   1322'.
144200         10  FILLER      PIC X(13) VALUE '240052   1318'.
144300         10  FILLER      PIC X(13) VALUE '240059   0805'.
144400         10  FILLER      PIC X(13) VALUE '240064   0929'.
144500         10  FILLER      PIC X(13) VALUE '240069   0921'.
144600         10  FILLER      PIC X(13) VALUE '240071   0739'.
144700         10  FILLER      PIC X(13) VALUE '240076   1164'.
144800         10  FILLER      PIC X(13) VALUE '240084   1015'.
144900         10  FILLER      PIC X(13) VALUE '240088   1532'.
145000         10  FILLER      PIC X(13) VALUE '240101   0861'.
145100         10  FILLER      PIC X(13) VALUE '240117   1458'.
145200         10  FILLER      PIC X(13) VALUE '240141   0863'.
145300         10  FILLER      PIC X(13) VALUE '240166   1038'.
145400         10  FILLER      PIC X(13) VALUE '240187   1009'.
145500         10  FILLER      PIC X(13) VALUE '240196   0177'.
145600         10  FILLER      PIC X(13) VALUE '240206   0097'.
145700         10  FILLER      PIC X(13) VALUE '240211   0002'.
145800         10  FILLER      PIC X(13) VALUE '250002   0976'.
145900         10  FILLER      PIC X(13) VALUE '250006   1310'.
146000         10  FILLER      PIC X(13) VALUE '250010   0520'.
146100         10  FILLER      PIC X(13) VALUE '250012   0420'.
146200         10  FILLER      PIC X(13) VALUE '250017   0668'.
146300         10  FILLER      PIC X(13) VALUE '250018   0020'.
146400         10  FILLER      PIC X(13) VALUE '250020   1121'.
146500         10  FILLER      PIC X(13) VALUE '250023   0050'.
146600         10  FILLER      PIC X(13) VALUE '250027   0354'.
146700         10  FILLER      PIC X(13) VALUE '250035   0233'.
146800         10  FILLER      PIC X(13) VALUE '250036   0957'.
146900         10  FILLER      PIC X(13) VALUE '250038   0538'.
147000         10  FILLER      PIC X(13) VALUE '250043   0588'.
147100         10  FILLER      PIC X(13) VALUE '250044   0902'.
147200         10  FILLER      PIC X(13) VALUE '250049   0771'.
147300         10  FILLER      PIC X(13) VALUE '250050   1051'.
147400         10  FILLER      PIC X(13) VALUE '250051   0174'.
147500         10  FILLER      PIC X(13) VALUE '250057   1429'.
147600         10  FILLER      PIC X(13) VALUE '250059   0933'.
147700         10  FILLER      PIC X(13) VALUE '250060   0273'.
147800         10  FILLER      PIC X(13) VALUE '250061   0641'.
147900         10  FILLER      PIC X(13) VALUE '250067   0934'.
148000         10  FILLER      PIC X(13) VALUE '250077   1071'.
148100         10  FILLER      PIC X(13) VALUE '250079   0204'.
148200         10  FILLER      PIC X(13) VALUE '250081   1384'.
148300         10  FILLER      PIC X(13) VALUE '250084   1319'.
148400         10  FILLER      PIC X(13) VALUE '250085   0871'.
148500         10  FILLER      PIC X(13) VALUE '250095   0744'.
148600         10  FILLER      PIC X(13) VALUE '250112   0145'.
148700         10  FILLER      PIC X(13) VALUE '250117   1006'.
148800         10  FILLER      PIC X(13) VALUE '250124   1133'.
148900         10  FILLER      PIC X(13) VALUE '250126   0700'.
149000         10  FILLER      PIC X(13) VALUE '250127   0030'.
149100         10  FILLER      PIC X(13) VALUE '250128   0947'.
149200         10  FILLER      PIC X(13) VALUE '250134   0136'.
149300         10  FILLER      PIC X(13) VALUE '250136   0096'.
149400         10  FILLER      PIC X(13) VALUE '250149   0358'.
149500         10  FILLER      PIC X(13) VALUE '250151   0120'.
149600         10  FILLER      PIC X(13) VALUE '250152   0010'.
149700         10  FILLER      PIC X(13) VALUE '250162   0826'.
149800         10  FILLER      PIC X(13) VALUE '250163   0002'.
149900         10  FILLER      PIC X(13) VALUE '260004   0241'.
150000         10  FILLER      PIC X(13) VALUE '260015   1464'.
150100         10  FILLER      PIC X(13) VALUE '260021   1003'.
150200         10  FILLER      PIC X(13) VALUE '260024   0555'.
150300         10  FILLER      PIC X(13) VALUE '260034   0889'.
150400         10  FILLER      PIC X(13) VALUE '260050   0690'.
150500         10  FILLER      PIC X(13) VALUE '260057   0885'.
150600         10  FILLER      PIC X(13) VALUE '260059   1335'.
150700         10  FILLER      PIC X(13) VALUE '260061   0528'.
150800         10  FILLER      PIC X(13) VALUE '260070   1348'.
150900         10  FILLER      PIC X(13) VALUE '260074   1305'.
151000         10  FILLER      PIC X(13) VALUE '260080   0586'.
151100         10  FILLER      PIC X(13) VALUE '260097   1114'.
151200         10  FILLER      PIC X(13) VALUE '260102   0902'.
151300         10  FILLER      PIC X(13) VALUE '260115   0790'.
151400         10  FILLER      PIC X(13) VALUE '260116   1507'.
151500         10  FILLER      PIC X(13) VALUE '260142   0933'.
151600         10  FILLER      PIC X(13) VALUE '260147   0437'.
151700         10  FILLER      PIC X(13) VALUE '260160   0834'.
151800         10  FILLER      PIC X(13) VALUE '260175   1317'.
151900         10  FILLER      PIC X(13) VALUE '260178   1065'.
152000         10  FILLER      PIC X(13) VALUE '260195   1365'.
152100         10  FILLER      PIC X(13) VALUE '260207   0616'.
152200         10  FILLER      PIC X(13) VALUE '260209   0393'.
152300         10  FILLER      PIC X(13) VALUE '260211   0461'.
152400         10  FILLER      PIC X(13) VALUE '260214   1001'.
152500         10  FILLER      PIC X(13) VALUE '260219   0799'.
152600         10  FILLER      PIC X(13) VALUE '260221   0013'.
152700         10  FILLER      PIC X(13) VALUE '260222   0036'.
152800         10  FILLER      PIC X(13) VALUE '260223   0048'.
152900         10  FILLER      PIC X(13) VALUE '270002   0726'.
153000         10  FILLER      PIC X(13) VALUE '270032   0873'.
153100         10  FILLER      PIC X(13) VALUE '270074   0241'.
153200         10  FILLER      PIC X(13) VALUE '270086   0232'.
153300         10  FILLER      PIC X(13) VALUE '270087   0301'.
153400         10  FILLER      PIC X(13) VALUE '280105   1449'.
153500         10  FILLER      PIC X(13) VALUE '280111   1149'.
153600         10  FILLER      PIC X(13) VALUE '280119   0069'.
153700         10  FILLER      PIC X(13) VALUE '280127   0314'.
153800         10  FILLER      PIC X(13) VALUE '280129   0568'.
153900         10  FILLER      PIC X(13) VALUE '280131   0211'.
154000         10  FILLER      PIC X(13) VALUE '290002   0140'.
154100         10  FILLER      PIC X(13) VALUE '290006   0907'.
154200         10  FILLER      PIC X(13) VALUE '290008   0758'.
154300         10  FILLER      PIC X(13) VALUE '290020   0064'.
154400         10  FILLER      PIC X(13) VALUE '290027   0080'.
154500         10  FILLER      PIC X(13) VALUE '290032   1337'.
154600         10  FILLER      PIC X(13) VALUE '290049   1504'.
154700         10  FILLER      PIC X(13) VALUE '290051   0383'.
154800         10  FILLER      PIC X(13) VALUE '290055   0032'.
154900         10  FILLER      PIC X(13) VALUE '310058   0781'.
155000         10  FILLER      PIC X(13) VALUE '310088   0700'.
155100         10  FILLER      PIC X(13) VALUE '310118   1323'.
155200         10  FILLER      PIC X(13) VALUE '310120   0770'.
155300         10  FILLER      PIC X(13) VALUE '320003   0906'.
155400         10  FILLER      PIC X(13) VALUE '320011   0747'.
155500         10  FILLER      PIC X(13) VALUE '320013   0980'.
155600         10  FILLER      PIC X(13) VALUE '320014   1012'.
155700         10  FILLER      PIC X(13) VALUE '320016   1173'.
155800         10  FILLER      PIC X(13) VALUE '320017   1278'.
155900         10  FILLER      PIC X(13) VALUE '320022   1569'.
156000         10  FILLER      PIC X(13) VALUE '320030   0403'.
156100         10  FILLER      PIC X(13) VALUE '320033   0461'.
156200         10  FILLER      PIC X(13) VALUE '320037   0260'.
156300         10  FILLER      PIC X(13) VALUE '320038   1072'.
156400         10  FILLER      PIC X(13) VALUE '320057   0076'.
156500         10  FILLER      PIC X(13) VALUE '320058   0037'.
156600         10  FILLER      PIC X(13) VALUE '320059   0772'.
156700         10  FILLER      PIC X(13) VALUE '320060   0126'.
156800         10  FILLER      PIC X(13) VALUE '320061   0681'.
156900         10  FILLER      PIC X(13) VALUE '320062   0194'.
157000         10  FILLER      PIC X(13) VALUE '320065   1068'.
157100         10  FILLER      PIC X(13) VALUE '320067   0114'.
157200         10  FILLER      PIC X(13) VALUE '320069   0560'.
157300         10  FILLER      PIC X(13) VALUE '320070   0127'.
157400         10  FILLER      PIC X(13) VALUE '320074   1302'.
157500         10  FILLER      PIC X(13) VALUE '320084   0559'.
157600         10  FILLER      PIC X(13) VALUE '320086   0624'.
157700         10  FILLER      PIC X(13) VALUE '320087   0087'.
157800         10  FILLER      PIC X(13) VALUE '320088   0053'.
157900         10  FILLER      PIC X(13) VALUE '330008   0706'.
158000         10  FILLER      PIC X(13) VALUE '330010   0010'.
158100         10  FILLER      PIC X(13) VALUE '330025   0377'.
158200         10  FILLER      PIC X(13) VALUE '330029   0112'.
158300         10  FILLER      PIC X(13) VALUE '330033   1064'.
158400         10  FILLER      PIC X(13) VALUE '330036   0496'.
158500         10  FILLER      PIC X(13) VALUE '330037   0724'.
158600         10  FILLER      PIC X(13) VALUE '330041   0102'.
158700         10  FILLER      PIC X(13) VALUE '330049   1429'.
158800         10  FILLER      PIC X(13) VALUE '330053   0931'.
158900         10  FILLER      PIC X(13) VALUE '330075   0421'.
159000         10  FILLER      PIC X(13) VALUE '330079   1233'.
159100         10  FILLER      PIC X(13) VALUE '330084   1214'.
159200         10  FILLER      PIC X(13) VALUE '330088   1014'.
159300         10  FILLER      PIC X(13) VALUE '330096   1036'.
159400         10  FILLER      PIC X(13) VALUE '330100   0200'.
159500         10  FILLER      PIC X(13) VALUE '330111   0771'.
159600         10  FILLER      PIC X(13) VALUE '330115   1252'.
159700         10  FILLER      PIC X(13) VALUE '330132   1419'.
159800         10  FILLER      PIC X(13) VALUE '330144   0619'.
159900         10  FILLER      PIC X(13) VALUE '330151   1188'.
160000         10  FILLER      PIC X(13) VALUE '330166   0070'.
160100         10  FILLER      PIC X(13) VALUE '330177   0488'.
160200         10  FILLER      PIC X(13) VALUE '330189   0004'.
160300         10  FILLER      PIC X(13) VALUE '330197   1552'.
160400         10  FILLER      PIC X(13) VALUE '330205   1186'.
160500         10  FILLER      PIC X(13) VALUE '330211   1551'.
160600         10  FILLER      PIC X(13) VALUE '330213   0743'.
160700         10  FILLER      PIC X(13) VALUE '330223   1379'.
160800         10  FILLER      PIC X(13) VALUE '330229   0948'.
160900         10  FILLER      PIC X(13) VALUE '330238   1024'.
161000         10  FILLER      PIC X(13) VALUE '330249   1192'.
161100         10  FILLER      PIC X(13) VALUE '330263   0541'.
161200         10  FILLER      PIC X(13) VALUE '330268   0418'.
161300         10  FILLER      PIC X(13) VALUE '330276   1401'.
161400         10  FILLER      PIC X(13) VALUE '330385   1201'.
161500         10  FILLER      PIC X(13) VALUE '330403   0004'.
161600         10  FILLER      PIC X(13) VALUE '330404   0743'.
161700         10  FILLER      PIC X(13) VALUE '330405   0497'.
161800         10  FILLER      PIC X(13) VALUE '330406   0369'.
161900         10  FILLER      PIC X(13) VALUE '340011   1379'.
162000         10  FILLER      PIC X(13) VALUE '340012   0281'.
162100         10  FILLER      PIC X(13) VALUE '340035   1250'.
162200         10  FILLER      PIC X(13) VALUE '340036   0862'.
162300         10  FILLER      PIC X(13) VALUE '340037   1023'.
162400         10  FILLER      PIC X(13) VALUE '340038   1496'.
162500         10  FILLER      PIC X(13) VALUE '340049   0513'.
162600         10  FILLER      PIC X(13) VALUE '340055   1323'.
162700         10  FILLER      PIC X(13) VALUE '340084   0607'.
162800         10  FILLER      PIC X(13) VALUE '340085   1592'.
162900         10  FILLER      PIC X(13) VALUE '340087   0895'.
163000         10  FILLER      PIC X(13) VALUE '340120   0806'.
163100         10  FILLER      PIC X(13) VALUE '340121   0691'.
163200         10  FILLER      PIC X(13) VALUE '340127   1044'.
163300         10  FILLER      PIC X(13) VALUE '340133   1512'.
163400         10  FILLER      PIC X(13) VALUE '340138   0036'.
163500         10  FILLER      PIC X(13) VALUE '340148   0372'.
163600         10  FILLER      PIC X(13) VALUE '340156   0221'.
163700         10  FILLER      PIC X(13) VALUE '340159   0887'.
163800         10  FILLER      PIC X(13) VALUE '340160   1576'.
163900         10  FILLER      PIC X(13) VALUE '340166   1576'.
164000         10  FILLER      PIC X(13) VALUE '340168   0036'.
164100         10  FILLER      PIC X(13) VALUE '350003   0680'.
164200         10  FILLER      PIC X(13) VALUE '350009   0287'.
164300         10  FILLER      PIC X(13) VALUE '350063   0042'.
164400         10  FILLER      PIC X(13) VALUE '350064   0006'.
164500         10  FILLER      PIC X(13) VALUE '360002   1405'.
164600         10  FILLER      PIC X(13) VALUE '360013   1347'.
164700         10  FILLER      PIC X(13) VALUE '360014   1236'.
164800         10  FILLER      PIC X(13) VALUE '360029   1581'.
164900         10  FILLER      PIC X(13) VALUE '360032   1453'.
165000         10  FILLER      PIC X(13) VALUE '360038   0871'.
165100         10  FILLER      PIC X(13) VALUE '360044   1501'.
165200         10  FILLER      PIC X(13) VALUE '360046   1081'.
165300         10  FILLER      PIC X(13) VALUE '360058   0815'.
165400         10  FILLER      PIC X(13) VALUE '360071   1100'.
165500         10  FILLER      PIC X(13) VALUE '360080   1437'.
165600         10  FILLER      PIC X(13) VALUE '360089   1309'.
165700         10  FILLER      PIC X(13) VALUE '360092   0470'.
165800         10  FILLER      PIC X(13) VALUE '360107   0932'.
165900         10  FILLER      PIC X(13) VALUE '360109   1356'.
166000         10  FILLER      PIC X(13) VALUE '360116   0712'.
166100         10  FILLER      PIC X(13) VALUE '360130   0489'.
166200         10  FILLER      PIC X(13) VALUE '360148   0555'.
166300         10  FILLER      PIC X(13) VALUE '360153   0426'.
166400         10  FILLER      PIC X(13) VALUE '360156   0909'.
166500         10  FILLER      PIC X(13) VALUE '360170   1076'.
166600         10  FILLER      PIC X(13) VALUE '360189   0470'.
166700         10  FILLER      PIC X(13) VALUE '360197   1304'.
166800         10  FILLER      PIC X(13) VALUE '360210   0868'.
166900         10  FILLER      PIC X(13) VALUE '360245   0359'.
167000         10  FILLER      PIC X(13) VALUE '360247   0140'.
167100         10  FILLER      PIC X(13) VALUE '360261   0019'.
167200         10  FILLER      PIC X(13) VALUE '360263   0286'.
167300         10  FILLER      PIC X(13) VALUE '360266   1487'.
167400         10  FILLER      PIC X(13) VALUE '360269   0101'.
167500         10  FILLER      PIC X(13) VALUE '360270   0821'.
167600         10  FILLER      PIC X(13) VALUE '360271   0023'.
167700         10  FILLER      PIC X(13) VALUE '360274   0176'.
167800         10  FILLER      PIC X(13) VALUE '360347   0383'.
167900         10  FILLER      PIC X(13) VALUE '360348   0943'.
168000         10  FILLER      PIC X(13) VALUE '360349   0012'.
168100         10  FILLER      PIC X(13) VALUE '360350   0091'.
168200         10  FILLER      PIC X(13) VALUE '360351   0346'.
168300         10  FILLER      PIC X(13) VALUE '360352   0019'.
168400         10  FILLER      PIC X(13) VALUE '360354   0428'.
168500         10  FILLER      PIC X(13) VALUE '360355   0020'.
168600         10  FILLER      PIC X(13) VALUE '360356   0001'.
168700         10  FILLER      PIC X(13) VALUE '370002   0970'.
168800         10  FILLER      PIC X(13) VALUE '370004   1586'.
168900         10  FILLER      PIC X(13) VALUE '370007   0316'.
169000         10  FILLER      PIC X(13) VALUE '370011   0440'.
169100         10  FILLER      PIC X(13) VALUE '370015   0562'.
169200         10  FILLER      PIC X(13) VALUE '370019   1025'.
169300         10  FILLER      PIC X(13) VALUE '370029   0726'.
169400         10  FILLER      PIC X(13) VALUE '370030   0555'.
169500         10  FILLER      PIC X(13) VALUE '370036   0436'.
169600         10  FILLER      PIC X(13) VALUE '370039   1306'.
169700         10  FILLER      PIC X(13) VALUE '370040   1241'.
169800         10  FILLER      PIC X(13) VALUE '370041   0190'.
169900         10  FILLER      PIC X(13) VALUE '370048   0982'.
170000         10  FILLER      PIC X(13) VALUE '370049   1552'.
170100         10  FILLER      PIC X(13) VALUE '370051   0376'.
170200         10  FILLER      PIC X(13) VALUE '370054   1122'.
170300         10  FILLER      PIC X(13) VALUE '370057   0554'.
170400         10  FILLER      PIC X(13) VALUE '370065   1013'.
170500         10  FILLER      PIC X(13) VALUE '370072   0431'.
170600         10  FILLER      PIC X(13) VALUE '370080   0361'.
170700         10  FILLER      PIC X(13) VALUE '370083   0629'.
170800         10  FILLER      PIC X(13) VALUE '370084   0499'.
170900         10  FILLER      PIC X(13) VALUE '370097   1546'.
171000         10  FILLER      PIC X(13) VALUE '370099   1191'.
171100         10  FILLER      PIC X(13) VALUE '370100   1136'.
171200         10  FILLER      PIC X(13) VALUE '370103   0400'.
171300         10  FILLER      PIC X(13) VALUE '370105   0161'.
171400         10  FILLER      PIC X(13) VALUE '370112   0420'.
171500         10  FILLER      PIC X(13) VALUE '370113   1519'.
171600         10  FILLER      PIC X(13) VALUE '370138   0349'.
171700         10  FILLER      PIC X(13) VALUE '370139   0381'.
171800         10  FILLER      PIC X(13) VALUE '370148   1262'.
171900         10  FILLER      PIC X(13) VALUE '370153   0557'.
172000         10  FILLER      PIC X(13) VALUE '370156   0786'.
172100         10  FILLER      PIC X(13) VALUE '370158   0697'.
172200         10  FILLER      PIC X(13) VALUE '370166   0806'.
172300         10  FILLER      PIC X(13) VALUE '370169   0086'.
172400         10  FILLER      PIC X(13) VALUE '370170   0062'.
172500         10  FILLER      PIC X(13) VALUE '370171   0458'.
172600         10  FILLER      PIC X(13) VALUE '370172   0252'.
172700         10  FILLER      PIC X(13) VALUE '370173   0205'.
172800         10  FILLER      PIC X(13) VALUE '370178   0992'.
172900         10  FILLER      PIC X(13) VALUE '370180   0435'.
173000         10  FILLER      PIC X(13) VALUE '370183   0501'.
173100         10  FILLER      PIC X(13) VALUE '370190   0263'.
173200         10  FILLER      PIC X(13) VALUE '370192   0153'.
173300         10  FILLER      PIC X(13) VALUE '370199   0014'.
173400         10  FILLER      PIC X(13) VALUE '370201   0108'.
173500         10  FILLER      PIC X(13) VALUE '370203   0648'.
173600         10  FILLER      PIC X(13) VALUE '370206   0310'.
173700         10  FILLER      PIC X(13) VALUE '370210   1245'.
173800         10  FILLER      PIC X(13) VALUE '370211   1117'.
173900         10  FILLER      PIC X(13) VALUE '370212   0097'.
174000         10  FILLER      PIC X(13) VALUE '370214   0033'.
174100         10  FILLER      PIC X(13) VALUE '370216   0664'.
174200         10  FILLER      PIC X(13) VALUE '370218   0854'.
174300         10  FILLER      PIC X(13) VALUE '370220   0122'.
174400         10  FILLER      PIC X(13) VALUE '370222   1530'.
174500         10  FILLER      PIC X(13) VALUE '370225   0006'.
174600         10  FILLER      PIC X(13) VALUE '370227   0470'.
174700         10  FILLER      PIC X(13) VALUE '370228   0491'.
174800         10  FILLER      PIC X(13) VALUE '370229   0432'.
174900         10  FILLER      PIC X(13) VALUE '370231   0015'.
175000         10  FILLER      PIC X(13) VALUE '370232   0172'.
175100         10  FILLER      PIC X(13) VALUE '380001   1020'.
175200         10  FILLER      PIC X(13) VALUE '380005   0550'.
175300         10  FILLER      PIC X(13) VALUE '380021   1331'.
175400         10  FILLER      PIC X(13) VALUE '380022   0852'.
175500         10  FILLER      PIC X(13) VALUE '380029   0428'.
175600         10  FILLER      PIC X(13) VALUE '380033   0619'.
175700         10  FILLER      PIC X(13) VALUE '380037   0815'.
175800         10  FILLER      PIC X(13) VALUE '380038   1447'.
175900         10  FILLER      PIC X(13) VALUE '380040   1083'.
176000         10  FILLER      PIC X(13) VALUE '380052   1374'.
176100         10  FILLER      PIC X(13) VALUE '380056   0438'.
176200         10  FILLER      PIC X(13) VALUE '380082   1314'.
176300         10  FILLER      PIC X(13) VALUE '390003   0979'.
176400         10  FILLER      PIC X(13) VALUE '390008   1310'.
176500         10  FILLER      PIC X(13) VALUE '390019   1180'.
176600         10  FILLER      PIC X(13) VALUE '390025   0048'.
176700         10  FILLER      PIC X(13) VALUE '390035   1054'.
176800         10  FILLER      PIC X(13) VALUE '390043   1114'.
176900         10  FILLER      PIC X(13) VALUE '390056   1030'.
177000         10  FILLER      PIC X(13) VALUE '390061   1442'.
177100         10  FILLER      PIC X(13) VALUE '390062   0809'.
177200         10  FILLER      PIC X(13) VALUE '390068   1043'.
177300         10  FILLER      PIC X(13) VALUE '390071   1022'.
177400         10  FILLER      PIC X(13) VALUE '390084   1439'.
177500         10  FILLER      PIC X(13) VALUE '390095   1289'.
177600         10  FILLER      PIC X(13) VALUE '390104   0671'.
177700         10  FILLER      PIC X(13) VALUE '390112   0813'.
177800         10  FILLER      PIC X(13) VALUE '390117   1171'.
177900         10  FILLER      PIC X(13) VALUE '390122   1040'.
178000         10  FILLER      PIC X(13) VALUE '390130   0593'.
178100         10  FILLER      PIC X(13) VALUE '390131   0812'.
178200         10  FILLER      PIC X(13) VALUE '390146   1366'.
178300         10  FILLER      PIC X(13) VALUE '390150   1216'.
178400         10  FILLER      PIC X(13) VALUE '390169   0727'.
178500         10  FILLER      PIC X(13) VALUE '390176   0023'.
178600         10  FILLER      PIC X(13) VALUE '390183   1232'.
178700         10  FILLER      PIC X(13) VALUE '390184   0748'.
178800         10  FILLER      PIC X(13) VALUE '390189   1598'.
178900         10  FILLER      PIC X(13) VALUE '390192   1155'.
179000         10  FILLER      PIC X(13) VALUE '390194   1353'.
179100         10  FILLER      PIC X(13) VALUE '390198   1124'.
179200         10  FILLER      PIC X(13) VALUE '390199   1235'.
179300         10  FILLER      PIC X(13) VALUE '390236   0684'.
179400         10  FILLER      PIC X(13) VALUE '390266   0968'.
179500         10  FILLER      PIC X(13) VALUE '390272   0144'.
179600         10  FILLER      PIC X(13) VALUE '390278   0594'.
179700         10  FILLER      PIC X(13) VALUE '390307   0050'.
179800         10  FILLER      PIC X(13) VALUE '390312   0233'.
179900         10  FILLER      PIC X(13) VALUE '390313   0716'.
180000         10  FILLER      PIC X(13) VALUE '390314   0398'.
180100         10  FILLER      PIC X(13) VALUE '390316   0227'.
180200         10  FILLER      PIC X(13) VALUE '390317   0002'.
180300         10  FILLER      PIC X(13) VALUE '390318   0178'.
180400         10  FILLER      PIC X(13) VALUE '390319   0130'.
180500         10  FILLER      PIC X(13) VALUE '390320   0025'.
180600         10  FILLER      PIC X(13) VALUE '390321   0019'.
180700         10  FILLER      PIC X(13) VALUE '410010   0684'.
180800         10  FILLER      PIC X(13) VALUE '420005   1240'.
180900         10  FILLER      PIC X(13) VALUE '420006   0001'.
181000         10  FILLER      PIC X(13) VALUE '420011   0574'.
181100         10  FILLER      PIC X(13) VALUE '420016   0339'.
181200         10  FILLER      PIC X(13) VALUE '420019   0906'.
181300         10  FILLER      PIC X(13) VALUE '420033   1418'.
181400         10  FILLER      PIC X(13) VALUE '420037   0775'.
181500         10  FILLER      PIC X(13) VALUE '420038   1276'.
181600         10  FILLER      PIC X(13) VALUE '420039   1123'.
181700         10  FILLER      PIC X(13) VALUE '420053   0998'.
181800         10  FILLER      PIC X(13) VALUE '420054   0639'.
181900         10  FILLER      PIC X(13) VALUE '420056   0526'.
182000         10  FILLER      PIC X(13) VALUE '420057   0327'.
182100         10  FILLER      PIC X(13) VALUE '420062   1271'.
182200         10  FILLER      PIC X(13) VALUE '420066   0516'.
182300         10  FILLER      PIC X(13) VALUE '420069   0943'.
182400         10  FILLER      PIC X(13) VALUE '420072   0483'.
182500         10  FILLER      PIC X(13) VALUE '420089   1598'.
182600         10  FILLER      PIC X(13) VALUE '420101   0453'.
182700         10  FILLER      PIC X(13) VALUE '420102   0557'.
182800         10  FILLER      PIC X(13) VALUE '420103   0302'.
182900         10  FILLER      PIC X(13) VALUE '430008   0585'.
183000         10  FILLER      PIC X(13) VALUE '430013   1442'.
183100         10  FILLER      PIC X(13) VALUE '430015   0837'.
183200         10  FILLER      PIC X(13) VALUE '430048   0663'.
183300         10  FILLER      PIC X(13) VALUE '430060   0021'.
183400         10  FILLER      PIC X(13) VALUE '430064   0030'.
183500         10  FILLER      PIC X(13) VALUE '430081   0144'.
183600         10  FILLER      PIC X(13) VALUE '430082   0006'.
183700         10  FILLER      PIC X(13) VALUE '430083   0028'.
183800         10  FILLER      PIC X(13) VALUE '430084   0165'.
183900         10  FILLER      PIC X(13) VALUE '430089   0382'.
184000         10  FILLER      PIC X(13) VALUE '430090   0358'.
184100         10  FILLER      PIC X(13) VALUE '430091   0504'.
184200         10  FILLER      PIC X(13) VALUE '430092   0206'.
184300         10  FILLER      PIC X(13) VALUE '430093   0080'.
184400         10  FILLER      PIC X(13) VALUE '430094   0032'.
184500         10  FILLER      PIC X(13) VALUE '430096   0156'.
184600         10  FILLER      PIC X(13) VALUE '440001   0907'.
184700         10  FILLER      PIC X(13) VALUE '440007   0851'.
184800         10  FILLER      PIC X(13) VALUE '440008   1059'.
184900         10  FILLER      PIC X(13) VALUE '440010   0541'.
185000         10  FILLER      PIC X(13) VALUE '440016   0613'.
185100         10  FILLER      PIC X(13) VALUE '440020   0973'.
185200         10  FILLER      PIC X(13) VALUE '440031   1278'.
185300         10  FILLER      PIC X(13) VALUE '440032   0764'.
185400         10  FILLER      PIC X(13) VALUE '440040   0711'.
185500         10  FILLER      PIC X(13) VALUE '440047   0410'.
185600         10  FILLER      PIC X(13) VALUE '440050   0987'.
185700         10  FILLER      PIC X(13) VALUE '440051   1080'.
185800         10  FILLER      PIC X(13) VALUE '440052   0647'.
185900         10  FILLER      PIC X(13) VALUE '440054   0891'.
186000         10  FILLER      PIC X(13) VALUE '440056   1301'.
186100         10  FILLER      PIC X(13) VALUE '440057   1249'.
186200         10  FILLER      PIC X(13) VALUE '440060   0265'.
186300         10  FILLER      PIC X(13) VALUE '440061   1507'.
186400         10  FILLER      PIC X(13) VALUE '440064   1088'.
186500         10  FILLER      PIC X(13) VALUE '440067   1374'.
186600         10  FILLER      PIC X(13) VALUE '440068   1236'.
186700         10  FILLER      PIC X(13) VALUE '440070   0740'.
186800         10  FILLER      PIC X(13) VALUE '440081   1260'.
186900         10  FILLER      PIC X(13) VALUE '440083   1567'.
187000         10  FILLER      PIC X(13) VALUE '440084   1573'.
187100         10  FILLER      PIC X(13) VALUE '440102   0820'.
187200         10  FILLER      PIC X(13) VALUE '440105   0051'.
187300         10  FILLER      PIC X(13) VALUE '440109   0703'.
187400         10  FILLER      PIC X(13) VALUE '440110   1068'.
187500         10  FILLER      PIC X(13) VALUE '440111   0642'.
187600         10  FILLER      PIC X(13) VALUE '440115   0510'.
187700         10  FILLER      PIC X(13) VALUE '440130   1254'.
187800         10  FILLER      PIC X(13) VALUE '440131   0701'.
187900         10  FILLER      PIC X(13) VALUE '440137   1586'.
188000         10  FILLER      PIC X(13) VALUE '440141   0541'.
188100         10  FILLER      PIC X(13) VALUE '440148   0858'.
188200         10  FILLER      PIC X(13) VALUE '440153   0950'.
188300         10  FILLER      PIC X(13) VALUE '440159   0891'.
188400         10  FILLER      PIC X(13) VALUE '440168   0395'.
188500         10  FILLER      PIC X(13) VALUE '440174   0756'.
188600         10  FILLER      PIC X(13) VALUE '440180   0945'.
188700         10  FILLER      PIC X(13) VALUE '440181   0352'.
188800         10  FILLER      PIC X(13) VALUE '440182   0683'.
188900         10  FILLER      PIC X(13) VALUE '440184   0746'.
189000         10  FILLER      PIC X(13) VALUE '440186   0948'.
189100         10  FILLER      PIC X(13) VALUE '440192   0780'.
189200         10  FILLER      PIC X(13) VALUE '440200   0399'.
189300         10  FILLER      PIC X(13) VALUE '440218   0494'.
189400         10  FILLER      PIC X(13) VALUE '440225   0011'.
189500         10  FILLER      PIC X(13) VALUE '440227   1450'.
189600         10  FILLER      PIC X(13) VALUE '450005   0829'.
189700         10  FILLER      PIC X(13) VALUE '450008   0486'.
189800         10  FILLER      PIC X(13) VALUE '450018   1362'.
189900         10  FILLER      PIC X(13) VALUE '450032   1457'.
190000         10  FILLER      PIC X(13) VALUE '450052   0540'.
190100         10  FILLER      PIC X(13) VALUE '450055   0749'.
190200         10  FILLER      PIC X(13) VALUE '450073   0516'.
190300         10  FILLER      PIC X(13) VALUE '450078   0455'.
190400         10  FILLER      PIC X(13) VALUE '450080   1469'.
190500         10  FILLER      PIC X(13) VALUE '450082   0832'.
190600         10  FILLER      PIC X(13) VALUE '450085   0540'.
190700         10  FILLER      PIC X(13) VALUE '450090   1093'.
190800         10  FILLER      PIC X(13) VALUE '450099   1045'.
190900         10  FILLER      PIC X(13) VALUE '450108   0625'.
191000         10  FILLER      PIC X(13) VALUE '450123   0626'.
191100         10  FILLER      PIC X(13) VALUE '450143   0507'.
191200         10  FILLER      PIC X(13) VALUE '450144   0282'.
191300         10  FILLER      PIC X(13) VALUE '450154   1119'.
191400         10  FILLER      PIC X(13) VALUE '450155   0234'.
191500         10  FILLER      PIC X(13) VALUE '450162   0674'.
191600         10  FILLER      PIC X(13) VALUE '450165   1139'.
191700         10  FILLER      PIC X(13) VALUE '450177   0954'.
191800         10  FILLER      PIC X(13) VALUE '450178   0391'.
191900         10  FILLER      PIC X(13) VALUE '450187   0746'.
192000         10  FILLER      PIC X(13) VALUE '450188   1109'.
192100         10  FILLER      PIC X(13) VALUE '450191   0084'.
192200         10  FILLER      PIC X(13) VALUE '450192   0974'.
192300         10  FILLER      PIC X(13) VALUE '450194   0991'.
192400         10  FILLER      PIC X(13) VALUE '450210   0656'.
192500         10  FILLER      PIC X(13) VALUE '450214   1163'.
192600         10  FILLER      PIC X(13) VALUE '450219   0602'.
192700         10  FILLER      PIC X(13) VALUE '450221   0472'.
192800         10  FILLER      PIC X(13) VALUE '450224   0502'.
192900         10  FILLER      PIC X(13) VALUE '450234   0862'.
193000         10  FILLER      PIC X(13) VALUE '450235   0550'.
193100         10  FILLER      PIC X(13) VALUE '450236   1354'.
193200         10  FILLER      PIC X(13) VALUE '450239   0502'.
193300         10  FILLER      PIC X(13) VALUE '450241   0262'.
193400         10  FILLER      PIC X(13) VALUE '450243   0190'.
193500         10  FILLER      PIC X(13) VALUE '450253   0428'.
193600         10  FILLER      PIC X(13) VALUE '450270   0577'.
193700         10  FILLER      PIC X(13) VALUE '450283   0509'.
193800         10  FILLER      PIC X(13) VALUE '450292   1320'.
193900         10  FILLER      PIC X(13) VALUE '450293   0259'.
194000         10  FILLER      PIC X(13) VALUE '450296   1110'.
194100         10  FILLER      PIC X(13) VALUE '450306   0172'.
194200         10  FILLER      PIC X(13) VALUE '450315   0039'.
194300         10  FILLER      PIC X(13) VALUE '450347   1426'.
194400         10  FILLER      PIC X(13) VALUE '450348   0448'.
194500         10  FILLER      PIC X(13) VALUE '450351   1194'.
194600         10  FILLER      PIC X(13) VALUE '450369   0549'.
194700         10  FILLER      PIC X(13) VALUE '450370   0573'.
194800         10  FILLER      PIC X(13) VALUE '450372   1513'.
194900         10  FILLER      PIC X(13) VALUE '450373   0326'.
195000         10  FILLER      PIC X(13) VALUE '450379   0829'.
195100         10  FILLER      PIC X(13) VALUE '450395   1439'.
195200         10  FILLER      PIC X(13) VALUE '450399   0500'.
195300         10  FILLER      PIC X(13) VALUE '450400   1056'.
195400         10  FILLER      PIC X(13) VALUE '450411   0747'.
195500         10  FILLER      PIC X(13) VALUE '450419   0816'.
195600         10  FILLER      PIC X(13) VALUE '450422   0007'.
195700         10  FILLER      PIC X(13) VALUE '450438   0607'.
195800         10  FILLER      PIC X(13) VALUE '450446   0474'.
195900         10  FILLER      PIC X(13) VALUE '450451   0453'.
196000         10  FILLER      PIC X(13) VALUE '450460   0517'.
196100         10  FILLER      PIC X(13) VALUE '450465   1116'.
196200         10  FILLER      PIC X(13) VALUE '450475   0946'.
196300         10  FILLER      PIC X(13) VALUE '450488   0036'.
196400         10  FILLER      PIC X(13) VALUE '450489   0236'.
196500         10  FILLER      PIC X(13) VALUE '450497   0589'.
196600         10  FILLER      PIC X(13) VALUE '450498   0373'.
196700         10  FILLER      PIC X(13) VALUE '450539   0661'.
196800         10  FILLER      PIC X(13) VALUE '450547   0729'.
196900         10  FILLER      PIC X(13) VALUE '450565   0903'.
197000         10  FILLER      PIC X(13) VALUE '450573   0779'.
197100         10  FILLER      PIC X(13) VALUE '450578   0095'.
197200         10  FILLER      PIC X(13) VALUE '450580   1180'.
197300         10  FILLER      PIC X(13) VALUE '450584   0386'.
197400         10  FILLER      PIC X(13) VALUE '450586   0420'.
197500         10  FILLER      PIC X(13) VALUE '450591   0811'.
197600         10  FILLER      PIC X(13) VALUE '450596   1124'.
197700         10  FILLER      PIC X(13) VALUE '450597   1160'.
197800         10  FILLER      PIC X(13) VALUE '450605   0411'.
197900         10  FILLER      PIC X(13) VALUE '450615   0964'.
198000         10  FILLER      PIC X(13) VALUE '450620   0257'.
198100         10  FILLER      PIC X(13) VALUE '450641   0453'.
198200         10  FILLER      PIC X(13) VALUE '450653   1238'.
198300         10  FILLER      PIC X(13) VALUE '450654   0900'.
198400         10  FILLER      PIC X(13) VALUE '450658   0520'.
198500         10  FILLER      PIC X(13) VALUE '450661   1388'.
198600         10  FILLER      PIC X(13) VALUE '450674   0199'.
198700         10  FILLER      PIC X(13) VALUE '450683   0911'.
198800         10  FILLER      PIC X(13) VALUE '450690   1511'.
198900         10  FILLER      PIC X(13) VALUE '450694   0474'.
199000         10  FILLER      PIC X(13) VALUE '450698   0358'.
199100         10  FILLER      PIC X(13) VALUE '450730   1409'.
199200         10  FILLER      PIC X(13) VALUE '450746   0119'.
199300         10  FILLER      PIC X(13) VALUE '450749   0302'.
199400         10  FILLER      PIC X(13) VALUE '450754   0973'.
199500         10  FILLER      PIC X(13) VALUE '450755   0408'.
199600         10  FILLER      PIC X(13) VALUE '450770   0602'.
199700         10  FILLER      PIC X(13) VALUE '450774   0147'.
199800         10  FILLER      PIC X(13) VALUE '450780   0141'.
199900         10  FILLER      PIC X(13) VALUE '450795   0155'.
200000         10  FILLER      PIC X(13) VALUE '450796   0057'.
200100         10  FILLER      PIC X(13) VALUE '450797   0007'.
200200         10  FILLER      PIC X(13) VALUE '450803   1298'.
200300         10  FILLER      PIC X(13) VALUE '450804   1018'.
200400         10  FILLER      PIC X(13) VALUE '450808   0181'.
200500         10  FILLER      PIC X(13) VALUE '450813   0408'.
200600         10  FILLER      PIC X(13) VALUE '450822   0925'.
200700         10  FILLER      PIC X(13) VALUE '450825   0310'.
200800         10  FILLER      PIC X(13) VALUE '450827   1008'.
200900         10  FILLER      PIC X(13) VALUE '450830   0017'.
201000         10  FILLER      PIC X(13) VALUE '450831   0078'.
201100         10  FILLER      PIC X(13) VALUE '450833   0988'.
201200         10  FILLER      PIC X(13) VALUE '450834   0198'.
201300         10  FILLER      PIC X(13) VALUE '450839   0468'.
201400         10  FILLER      PIC X(13) VALUE '450840   1000'.
201500         10  FILLER      PIC X(13) VALUE '450841   0364'.
201600         10  FILLER      PIC X(13) VALUE '450845   0416'.
201700         10  FILLER      PIC X(13) VALUE '450848   1156'.
201800         10  FILLER      PIC X(13) VALUE '450851   1215'.
201900         10  FILLER      PIC X(13) VALUE '450853   0473'.
202000         10  FILLER      PIC X(13) VALUE '450856   0308'.
202100         10  FILLER      PIC X(13) VALUE '450860   0101'.
202200         10  FILLER      PIC X(13) VALUE '450864   0748'.
202300         10  FILLER      PIC X(13) VALUE '450865   0144'.
202400         10  FILLER      PIC X(13) VALUE '450867   1599'.
202500         10  FILLER      PIC X(13) VALUE '450871   0358'.
202600         10  FILLER      PIC X(13) VALUE '450872   0582'.
202700         10  FILLER      PIC X(13) VALUE '450874   0052'.
202800         10  FILLER      PIC X(13) VALUE '450875   0521'.
202900         10  FILLER      PIC X(13) VALUE '450877   1103'.
203000         10  FILLER      PIC X(13) VALUE '450880   0320'.
203100         10  FILLER      PIC X(13) VALUE '450883   0051'.
203200         10  FILLER      PIC X(13) VALUE '450884   0516'.
203300         10  FILLER      PIC X(13) VALUE '450886   0037'.
203400         10  FILLER      PIC X(13) VALUE '450888   0192'.
203500         10  FILLER      PIC X(13) VALUE '450889   0025'.
203600         10  FILLER      PIC X(13) VALUE '450891   0089'.
203700         10  FILLER      PIC X(13) VALUE '450893   0143'.
203800         10  FILLER      PIC X(13) VALUE '450894   0129'.
203900         10  FILLER      PIC X(13) VALUE '460003   1451'.
204000         10  FILLER      PIC X(13) VALUE '460007   0888'.
204100         10  FILLER      PIC X(13) VALUE '460011   0664'.
204200         10  FILLER      PIC X(13) VALUE '460013   1060'.
204300         10  FILLER      PIC X(13) VALUE '460014   0577'.
204400         10  FILLER      PIC X(13) VALUE '460015   1373'.
204500         10  FILLER      PIC X(13) VALUE '460017   0247'.
204600         10  FILLER      PIC X(13) VALUE '460018   0038'.
204700         10  FILLER      PIC X(13) VALUE '460019   0306'.
204800         10  FILLER      PIC X(13) VALUE '460023   1310'.
204900         10  FILLER      PIC X(13) VALUE '460026   0316'.
205000         10  FILLER      PIC X(13) VALUE '460030   0364'.
205100         10  FILLER      PIC X(13) VALUE '460033   0113'.
205200         10  FILLER      PIC X(13) VALUE '460035   0187'.
205300         10  FILLER      PIC X(13) VALUE '460039   0135'.
205400         10  FILLER      PIC X(13) VALUE '460041   1256'.
205500         10  FILLER      PIC X(13) VALUE '460042   1561'.
205600         10  FILLER      PIC X(13) VALUE '460043   0005'.
205700         10  FILLER      PIC X(13) VALUE '460044   1358'.
205800         10  FILLER      PIC X(13) VALUE '460049   0671'.
205900         10  FILLER      PIC X(13) VALUE '460052   1138'.
206000         10  FILLER      PIC X(13) VALUE '460054   0268'.
206100         10  FILLER      PIC X(13) VALUE '460056   0012'.
206200         10  FILLER      PIC X(13) VALUE '470001   1397'.
206300         10  FILLER      PIC X(13) VALUE '470011   0833'.
206400         10  FILLER      PIC X(13) VALUE '470024   0925'.
206500         10  FILLER      PIC X(13) VALUE '480001   0917'.
206600         10  FILLER      PIC X(13) VALUE '480002   0893'.
206700         10  FILLER      PIC X(13) VALUE '490002   1463'.
206800         10  FILLER      PIC X(13) VALUE '490012   1596'.
206900         10  FILLER      PIC X(13) VALUE '490027   1168'.
207000         10  FILLER      PIC X(13) VALUE '490033   1006'.
207100         10  FILLER      PIC X(13) VALUE '490038   1251'.
207200         10  FILLER      PIC X(13) VALUE '490084   1068'.
207300         10  FILLER      PIC X(13) VALUE '490088   1006'.
207400         10  FILLER      PIC X(13) VALUE '490089   1185'.
207500         10  FILLER      PIC X(13) VALUE '490092   1319'.
207600         10  FILLER      PIC X(13) VALUE '490094   1126'.
207700         10  FILLER      PIC X(13) VALUE '490097   1409'.
207800         10  FILLER      PIC X(13) VALUE '490104   0019'.
207900         10  FILLER      PIC X(13) VALUE '490105   0021'.
208000         10  FILLER      PIC X(13) VALUE '490106   0002'.
208100         10  FILLER      PIC X(13) VALUE '490108   0362'.
208200         10  FILLER      PIC X(13) VALUE '490109   0093'.
208300         10  FILLER      PIC X(13) VALUE '490111   1193'.
208400         10  FILLER      PIC X(13) VALUE '490114   1349'.
208500         10  FILLER      PIC X(13) VALUE '490117   0572'.
208600         10  FILLER      PIC X(13) VALUE '490123   1219'.
208700         10  FILLER      PIC X(13) VALUE '490127   1126'.
208800         10  FILLER      PIC X(13) VALUE '490134   0016'.
208900         10  FILLER      PIC X(13) VALUE '490135   0192'.
209000         10  FILLER      PIC X(13) VALUE '490140   0495'.
209100         10  FILLER      PIC X(13) VALUE '500007   1316'.
209200         10  FILLER      PIC X(13) VALUE '500033   0938'.
209300         10  FILLER      PIC X(13) VALUE '500037   0409'.
209400         10  FILLER      PIC X(13) VALUE '500049   0720'.
209500         10  FILLER      PIC X(13) VALUE '500052   0003'.
209600         10  FILLER      PIC X(13) VALUE '500060   0811'.
209700         10  FILLER      PIC X(13) VALUE '500084   0619'.
209800         10  FILLER      PIC X(13) VALUE '500138   0120'.
209900         10  FILLER      PIC X(13) VALUE '500143   0110'.
210000         10  FILLER      PIC X(13) VALUE '500148   0290'.
210100         10  FILLER      PIC X(13) VALUE '500151   0876'.
210200         10  FILLER      PIC X(13) VALUE '510018   1139'.
210300         10  FILLER      PIC X(13) VALUE '510026   0750'.
210400         10  FILLER      PIC X(13) VALUE '510038   1496'.
210500         10  FILLER      PIC X(13) VALUE '510053   0521'.
210600         10  FILLER      PIC X(13) VALUE '510072   0742'.
210700         10  FILLER      PIC X(13) VALUE '510077   1193'.
210800         10  FILLER      PIC X(13) VALUE '510082   1018'.
210900         10  FILLER      PIC X(13) VALUE '510085   1430'.
211000         10  FILLER      PIC X(13) VALUE '510086   0328'.
211100         10  FILLER      PIC X(13) VALUE '520011   1347'.
211200         10  FILLER      PIC X(13) VALUE '520017   0965'.
211300         10  FILLER      PIC X(13) VALUE '520019   1531'.
211400         10  FILLER      PIC X(13) VALUE '520028   1406'.
211500         10  FILLER      PIC X(13) VALUE '520033   0951'.
211600         10  FILLER      PIC X(13) VALUE '520034   1319'.
211700         10  FILLER      PIC X(13) VALUE '520038   1213'.
211800         10  FILLER      PIC X(13) VALUE '520041   0900'.
211900         10  FILLER      PIC X(13) VALUE '520044   1276'.
212000         10  FILLER      PIC X(13) VALUE '520057   0915'.
212100         10  FILLER      PIC X(13) VALUE '520063   1408'.
212200         10  FILLER      PIC X(13) VALUE '520064   0743'.
212300         10  FILLER      PIC X(13) VALUE '520071   1366'.
212400         10  FILLER      PIC X(13) VALUE '520076   1072'.
212500         10  FILLER      PIC X(13) VALUE '520091   1322'.
212600         10  FILLER      PIC X(13) VALUE '520095   0931'.
212700         10  FILLER      PIC X(13) VALUE '520109   0900'.
212800         10  FILLER      PIC X(13) VALUE '520116   1289'.
212900         10  FILLER      PIC X(13) VALUE '520194   0037'.
213000         10  FILLER      PIC X(13) VALUE '520196   0161'.
213100         10  FILLER      PIC X(13) VALUE '520199   1017'.
213200         10  FILLER      PIC X(13) VALUE '520204   0186'.
213300         10  FILLER      PIC X(13) VALUE '520205   0010'.
213400         10  FILLER      PIC X(13) VALUE '530002   0813'.
213500         10  FILLER      PIC X(13) VALUE '530006   1062'.
213600         10  FILLER      PIC X(13) VALUE '530008   0611'.
213700         10  FILLER      PIC X(13) VALUE '530009   0449'.
213800         10  FILLER      PIC X(13) VALUE '530010   0642'.
213900         10  FILLER      PIC X(13) VALUE '530011   0565'.
214000         10  FILLER      PIC X(13) VALUE '530015   0657'.
214100         10  FILLER      PIC X(13) VALUE '530017   0029'.
214200         10  FILLER      PIC X(13) VALUE '530025   0735'.
214300         10  FILLER      PIC X(13) VALUE '530032   0291'.
214400         10  FILLER      PIC X(13) VALUE '530033   0300'.
214500         10  FILLER      PIC X(13) VALUE '640001   0277'.
214600         10  FILLER      PIC X(13) VALUE '650001   1587'.
214700         10  FILLER      PIC X(13) VALUE '660001   0356'.
214800         10  FILLER      PIC X(13) VALUE '670002   0858'.
214900         10  FILLER      PIC X(13) VALUE '670004   0934'.
215000         10  FILLER      PIC X(13) VALUE '670005   0022'.
215100         10  FILLER      PIC X(13) VALUE '670006   0461'.
215200         10  FILLER      PIC X(13) VALUE '670008   0215'.
215300         10  FILLER      PIC X(13) VALUE '670010   0004'.
215400         10  FILLER      PIC X(13) VALUE '670011   0421'.
215500         10  FILLER      PIC X(13) VALUE '670012   0798'.
215600         10  FILLER      PIC X(13) VALUE '670018   0126'.
215700         10  FILLER      PIC X(13) VALUE '670019   0557'.
215800         10  FILLER      PIC X(13) VALUE '670025   1531'.
215900         10  FILLER      PIC X(13) VALUE '670027   0037'.
216000         10  FILLER      PIC X(13) VALUE '670029   0099'.
216100         10  FILLER      PIC X(13) VALUE '670031   1485'.
216200         10  FILLER      PIC X(13) VALUE '670033   0006'.
216300         10  FILLER      PIC X(13) VALUE '670034   1582'.
216400         10  FILLER      PIC X(13) VALUE '670040   0003'.
216500         10  FILLER      PIC X(13) VALUE '670041   1568'.
216600         10  FILLER      PIC X(13) VALUE '670042   0002'.
216700         10  FILLER      PIC X(13) VALUE '670043   1069'.
216800         10  FILLER      PIC X(13) VALUE '670044   1120'.
216900         10  FILLER      PIC X(13) VALUE '670046   0198'.
217000         10  FILLER      PIC X(13) VALUE '670048   0097'.
217100         10  FILLER      PIC X(13) VALUE '670049   0142'.
217200         10  FILLER      PIC X(13) VALUE '670050   0186'.
217300         10  FILLER      PIC X(13) VALUE '670051   0025'.
217400         10  FILLER      PIC X(13) VALUE '670052   0502'.
217500         10  FILLER      PIC X(13) VALUE '670053   0877'.
217600         10  FILLER      PIC X(13) VALUE '670054   0101'.
217700         10  FILLER      PIC X(13) VALUE '670055   0987'.
217800         10  FILLER      PIC X(13) VALUE '         1600'.
217900         10  FILLER      PIC X(13) VALUE '         1600'.
218000         10  FILLER      PIC X(13) VALUE '         1600'.
218100      02  WK-LOWVOL-DATA2 REDEFINES LOWVOL-PROV-DISCHG-DATA.
218200         05  LOWVOL-TAB OCCURS 1335
218300                        ASCENDING KEY IS WK-LOWVOL-PROV
218400                        INDEXED BY LOWVOL-IDX.
218500           10  WK-LOWVOL-COUNT-ALL.
218600              15  WK-LOWVOL-PROV           PIC X(6).
218700              15  FILLER                   PIC XXX.
218800              15  WK-LOWVOL-PROV-DISCHG    PIC 9999.
218900
219000
219100*****YEARCHANGE 2010.0 ************************************
219200
219300
219400 01  MES-ADD-PROV                   PIC X(53) VALUE SPACES.
219500 01  MES-CHG-PROV                   PIC X(53) VALUE SPACES.
219600 01  MES-PPS-PROV                   PIC X(06).
219700 01  MES-PPS-STATE                  PIC X(02).
219800 01  MES-INTRO                      PIC X(53) VALUE SPACES.
219900 01  MES-TOT-PAY                    PIC 9(07)V9(02) VALUE 0.
220000 01  MES-SSRFBN.
220100     05 MES-SSRFBN-STATE PIC 99.
220200     05 FILLER           PIC XX.
220300     05 MES-SSRFBN-RATE  PIC 9(1)V9(5).
220400     05 FILLER           PIC XX.
220500     05 MES-SSRFBN-CODE2 PIC 99.
220600     05 FILLER           PIC XX.
220700     05 MES-SSRFBN-STNAM PIC X(20).
220800     05 MES-SSRFBN-REST  PIC X(22).
220900
221000
221100 01  MES-LOWVOL.
221200     05  MES-LOWVOL-PROV             PIC X(6).
221300     05  FILLER                      PIC XXX.
221400     05  MESWK-LOWVOL-PROV-DISCHG    PIC 9999.
221500
221600
221700 01  HOLD-AREA.
221800     02  HOLD-PPS-COMPONENTS.
221900         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
222000         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
222100
222200         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
222300         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
222400
222500         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
222600         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
222700         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
222800
222900         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
223000         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
223100         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
223200
223300         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
223400         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
223500
223600         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
223700         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
223800
223900         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
224000         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
224100
224200         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
224300         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
224400         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
224500         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
224600         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
224700         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
224800         05  H-CAPI-COLA                  PIC 9(01)V9(03).
224900         05  H-CAPI-SCH                   PIC 9(05)V9(02).
225000         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
225100         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
225200         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
225300         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
225400         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
225500         05  H-CAPI-GAF                   PIC 9(05)V9(04).
225600         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
225700         05  H-BLEND-GAF                  PIC 9(05)V9(04).
225800         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
225900         05  H-COV-DAYS                   PIC 9(3).
226000         05  H-PERDIEM-DAYS               PIC 9(3).
226100         05  H-REG-DAYS                   PIC 9(3).
226200         05  H-LTR-DAYS                   PIC 9(3).
226300         05  H-DSCHG-FRCTN                PIC 9(3)V9999.
226400         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
226500         05  H-ALOS                       PIC 9(02)V9(01).
226600         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
226700         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
226800         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
226900         05  H-CST-THRESH                 PIC 9(05)V9(02).
227000         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
227100         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
227200         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
227300         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
227400         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
227500         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
227600         05  H-BUDG-NUTR06                PIC 9(01)V9(06).
227700         05  H-BUDG-NUTR07                PIC 9(01)V9(06).
227800         05  H-BUDG-NUTR08                PIC 9(01)V9(06).
227900         05  H-BUDG-NUTR09                PIC 9(01)V9(06).
228000         05  H-BUDG-NUTR10                PIC 9(01)V9(06).
228100         05  H-BUDG-NUTR109               PIC 9(01)V9(06).
228200         05  H-BUDG-NUTR113               PIC 9(01)V9(06).
228300         05  H-CASE-MIX-ADJ               PIC 9(01)V9(04).
228400         05  H-UPDATE-01                  PIC 9(01)V9(04).
228500         05  H-UPDATE-02                  PIC 9(01)V9(04).
228600         05  H-UPDATE-03                  PIC 9(01)V9(04).
228700         05  H-UPDATE-04                  PIC 9(01)V9(04).
228800         05  H-UPDATE-05                  PIC 9(01)V9(04).
228900         05  H-UPDATE-06                  PIC 9(01)V9(04).
229000         05  H-UPDATE-07                  PIC 9(01)V9(04).
229100         05  H-UPDATE-08                  PIC 9(01)V9(04).
229200         05  H-UPDATE-09                  PIC 9(01)V9(04).
229300         05  H-UPDATE-10                  PIC 9(01)V9(04).
229400         05  H-UPDATE-109                 PIC 9(01)V9(04).
229500         05  H-UPDATE-113                 PIC 9(01)V9(04).
229600         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
229700         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
229800         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
229900         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
230000         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
230100         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
230200         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
230300         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
230400         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
230500         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
230600         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
230700         05  H-LABOR-PCT                  PIC 9(01)V9(04).
230800         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
230900         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
231000         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
231100         05  H-HSP-RATE                   PIC 9(08)V9(09).
231200         05  H-FSP-RATE                   PIC 9(08)V9(09).
231300         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
231400         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
231500         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
231600         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
231700         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
231800         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
231900         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
232000         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
232100         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
232200         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
232300         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
232400         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.
232500         05  H-NEW-TECH-ADDON-HRTIMP-STOP PIC S9(07)V99.
232600         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.
232700         05  H-NEW-TECH-ADDON-SPIRAT-STOP PIC S9(07)V99.
232800         05  H-NEW-TECH-ADDON-AUTOLITT-STOP PIC S9(07)V99.
232900         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).
233000         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).
233100
233200         05  H-LESSER-NEURO-1             PIC S9(07)V99.
233300         05  H-LESSER-NEURO-2             PIC S9(07)V99.
233400
233500         05  H-LESSER-GRAFT-1             PIC S9(07)V99.
233600         05  H-LESSER-GRAFT-2             PIC S9(07)V99.
233700
233800         05  H-LESSER-X-STOP-1            PIC S9(07)V99.
233900         05  H-LESSER-X-STOP-2            PIC S9(07)V99.
234000
234100         05  H-LESSER-HRTIMP-STOP-1       PIC S9(07)V99.
234200         05  H-LESSER-HRTIMP-STOP-2       PIC S9(07)V99.
234300
234400         05  H-LESSER-SPIRAT-STOP-1       PIC S9(07)V99.
234500         05  H-LESSER-SPIRAT-STOP-2       PIC S9(07)V99.
234600
234700         05  H-LESSER-AUTOLITT-STOP-1     PIC S9(07)V99.
234800         05  H-LESSER-AUTOLITT-STOP-2     PIC S9(07)V99.
234900
235000         05  H-CSTMED-NEURO               PIC S9(07)V99.
235100         05  H-CSTMED-GRAFT               PIC S9(07)V99.
235200         05  H-CSTMED-X-STOP              PIC S9(07)V99.
235300         05  H-CSTMED-HRTIMP-STOP         PIC S9(07)V99.
235400         05  H-CSTMED-SPIRAT-STOP         PIC S9(07)V99.
235500         05  H-CSTMED-AUTOLITT-STOP       PIC S9(07)V99.
235600
235700
235800     02  HOLD-ADDITIONAL-VARIABLES.
235900         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
236000         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
236100         05  H-NAT-PCT                    PIC 9(01)V9(02).
236200         05  H-REG-PCT                    PIC 9(01)V9(02).
236300         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
236400         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
236500         05  H-DRG-WT                     PIC 9(02)V9(04).
236600         05  H-NAT-LABOR                  PIC 9(05)V9(02).
236700         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
236800         05  H-REG-LABOR                  PIC 9(05)V9(02).
236900         05  H-REG-NONLABOR               PIC 9(05)V9(02).
237000         05  H-OPER-COLA                  PIC 9(01)V9(03).
237100         05  H-INTERN-RATIO               PIC 9(01)V9(04).
237200         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
237300         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
237400         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
237500
237600     02  HOLD-CAPITAL-VARIABLES.
237700         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
237800         05  H-CAPI-HSP                   PIC 9(07)V9(02).
237900         05  H-CAPI-FSP                   PIC 9(07)V9(02).
238000         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
238100         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
238200         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
238300         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
238400         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
238500
238600     02  HOLD-CAPITAL2-VARIABLES.
238700         05  H-CAPI2-PAY-CODE             PIC X(1).
238800         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
238900         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
239000
239100     02  HOLD-OTHER-VARIABLES.
239200         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
239300         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
239400         05  H-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
239500         05  H-HVBP-HRR-DATA.
239600             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
239700             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
239800             10  H-HOSP-READMISS-REDUCTN      PIC X.
239900             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
240000         05  H-OPERATNG-DATA.
240100             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
240200             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
240300             10  H-OPER-HSP-AMT              PIC 9(08)V99.
240400
240500     02  HOLD-PC-OTH-VARIABLES.
240600         05  H-OPER-DSH                   PIC 9(01)V9(04).
240700         05  H-CAPI-DSH                   PIC 9(01)V9(04).
240800         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
240900         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
241000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
241100         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
241200         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
241300         05  H-PC-HMO-FLAG                PIC X(01).
241400         05  H-PC-COT-FLAG                PIC X(01).
241500         05  H-FILLER                     PIC X(0998).
241600
241700 01  HLD-PPS-DATA.
241800         10  HLD-PPS-RTC                PIC 9(02).
241900         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
242000         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
242100         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
242200         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
242300         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
242400         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
242500         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
242600         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
242700         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
242800         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
242900         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
243000         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
243100         10  HLD-PPS-CALC-VERS          PIC X(05).
243200
243300 LINKAGE SECTION.
243400***************************************************************
243500*                 * * * * * * * * *                           *
243600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
243700*    IN HOW TO PAY THE BILL.                                  *
243800*                         *****                               *
243900*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
244000*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
244100*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
244200*                 OUTLIER COMPUTATION.                        *
244300*                         *****                               *
244400*         REVIEW-CODE:                                        *
244500*            00 = PAY-WITH-OUTLIER.                           *
244600*                 WILL CALCULATE THE STANDARD PAYMENT.        *
244700*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
244800*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
244900*            03 = PAY-PERDIEM-DAYS.                           *
245000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
245100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
245200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
245300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
245400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
245500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
245600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
245700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
245800*                 BILL EXCEED THE COST THRESHOLD.             *
245900*            06 = PAY-XFER-NO-COST                            *
246000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
246100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
246200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
246300*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
246400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
246500*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
246600*                 CALCULATE ANY COST OUTLIER PORTION          *
246700*                 OF THE PAYMENT.                             *
246800*            07 = PAY-WITHOUT-COST.                           *
246900*                 WILL CALCULATE THE STANDARD PAYMENT         *
247000*                 WITHOUT COST PORTION.                       *
247100*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
247200*                 50-50> 28  29  30  40  41  42  219
247300*                        220 221 477 478 479 480 481
247400*                        482 492 493 494 500 501 502
247500*                        515 516 517 495 496 497
247600* =======================================================
247700* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
247800* =======================================================
247900*
248000*
248100*     FULL PERDIEM >   3   4   25  26  27  28          31
248200*                      32  33              54  55  56  57
248300*                      64  65  66  70  71  72  85  86  87
248400*                      91  92  93  100 101 163 164 165 166
248500*                      167 168 175 176 177 178 179 186 187
248600*                      188 190 191 192 193 194 195 196 197
248700*                      198 205 206 207 216 217 218
248800*                          228 229 230 233 234 235 236 239
248900*                      240 241 242 243 244 255 256 257 264
249000*                      280 281 282 288 289 290 291 292 293
249100*                      299 300 301 314 315 316 326 327 328
249200*                      329 330 331 332 333 334 335 336 337
249300*                      356 357 358 371 372 373 374 375 376
249400*                      377 378 379 380 381 382 388 389 390
249500*                      405 406 407 414 415 416 441 442 443
249600*                      459 460 463 464 465 466 467 468 469
249700*                      470 474 475 476
249800*                          483 484 488 489
249900*                                          510 511 512
250000*                              533 534 535 536 539 540 541
250100*                      542 543 544 545 546 547 551 552 557
250200*                      558 559 560 561 562 563 573 574 575
250300*                      579 580 581 592 593 594 602 603 616
250400*                      617 618 622 623 624 628 629 630 637
250500*                      638 639 640 641 643 644 645 653 654
250600*                      655 659 660 661 682 683 684 689 690
250700*                      698 699 700 840 841 842 853 854 855
250800*                      856 857 858 862 863 867 868 869 870
250900*                      871 872 884 896 897 907 908 909 917
251000*                      918 945 946 947 948 956 981 982 983
251100*                      987 988 989
251200*
251300*                               POST-ACUTE TRANSFERS          *
251400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
251500*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
251600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
251700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
251800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
251900*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
252000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
252100*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
252200*                 BILL EXCEED THE COST THRESHOLD.             *
252300*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
252400*                 POST-ACUTE TRANSFERS                        *
252500*                 50-50> 28  29  30  40  41  42  219
252600*                        220 221 477 478 479 480 481
252700*                        482 492 493 494 500 501 502
252800*                        515 516 517 495 496 497
252900*
253000* =======================================================
253100* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
253200* =======================================================
253300*
253400*     FULL PERDIEM >     3   4   25  26  27              31
253500*                        32  33              54  55  56  57
253600*                        64  65  66  70  71  72  85  86  87
253700*                        91  92  93  100 101 163 164 165 166
253800*                        167 168 175 176 177 178 179 186 187
253900*                        188 190 191 192 193 194 195 196 197
254000*                        198 205 206 207 216 217 218
254100*                            228 229 230 233 234 235 236 239
254200*                        240 241 242 243 244 255 256 257 264
254300*                        280 281 282 288 289 290 291 292 293
254400*                        299 300 301 314 315 316 326 327 328
254500*                        329 330 331 332 333 334 335 336 337
254600*                        356 357 358 371 372 373 374 375 376
254700*                        377 378 379 380 381 382 388 389 390
254800*                        405 406 407 414 415 416 441 442 443
254900*                        459 460 463 464 465 466 467 468 469
255000*                        470 474 475 476
255100*                            483 484 488 489
255200*                                            510 511 512
255300*                                533 534 535 536 539 540 541
255400*                        542 543 544 545 546 547 551 552 557
255500*                        558 559 560 561 562 563 573 574 575
255600*                        579 580 581 592 593 594 602 603 616
255700*                        617 618 622 623 624 628 629 630 637
255800*                        638 639 640 641 643 644 645 653 654
255900*                        655 659 660 661 682 683 684 689 690
256000*                        698 699 700 840 841 842 853 854 855
256100*                        856 857 858 862 863 867 868 869 870
256200*                        871 872 884 896 897 907 908 909 917
256300*                        918 945 946 947 948 956 981 982 983
256400*                        987 988 989
256500*
256600*
256700*                               POST-ACUTE TRANSFERS          *
256800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
256900*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
257000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
257100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
257200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
257300*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
257400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
257500*                 PAYMENT.                                    *
257600***************************************************************
257700
257800**************************************************************
257900*      MILLINNIUM COMPATIBLE                                 *
258000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
258100*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
258200*      IN THE NEW FORMAT                                     *
258300**************************************************************
258400 01  BILL-NEW-DATA.
258500         10  B-NPI10.
258600             15  B-NPI8             PIC X(08).
258700             15  B-NPI-FILLER       PIC X(02).
258800         10  B-PROVIDER-NO          PIC X(06).
258900         10  B-REVIEW-CODE          PIC 9(02).
259000             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
259100             88  PAY-WITH-OUTLIER     VALUE 00 07.
259200             88  PAY-PERDIEM-DAYS     VALUE 03.
259300             88  PAY-XFER-NO-COST     VALUE 06.
259400             88  PAY-WITHOUT-COST     VALUE 07.
259500             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
259600             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
259700         10  B-DRG                  PIC 9(03).
259800             88  B-DRG-POSTACUTE-50-50
259900                   VALUE 28  29  30  40  41  42  219
260000                         220 221 477 478 479 480 481
260100                         482 492 493 494 495 496 497
260200                         500 501 502 515 516 517.
260300
260400             88  B-DRG-SPIRATN-DRG
260500                   VALUE 163 164 165.
260600
260700             88  B-DRG-SPIRATN-DRG11
260800                   VALUE 199 200 201.
260900
261000
261100             88  B-DRG-AUTOLITT-DRG
261200                   VALUE 25 26 27.
261300
261400* =======================================================
261500* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
261600* =======================================================
261700*
261800             88  B-DRG-POSTACUTE-PERDIEM
261900                   VALUE 3   4   25  26  27              31
262000                         32  33              54  55  56  57
262100                         64  65  66  70  71  72  85  86  87
262200                         91  92  93  100 101 163 164 165 166
262300                         167 168 175 176 177 178 179 186 187
262400                         188 190 191 192 193 194 195 196 197
262500                         198 205 206 207 216 217 218
262600                             228 229 230 233 234 235 236 239
262700                         240 241 242 243 244 255 256 257 264
262800                         280 281 282 288 289 290 291 292 293
262900                         299 300 301 314 315 316 326 327 328
263000                         329 330 331 332 333 334 335 336 337
263100                         356 357 358 371 372 373 374 375 376
263200                         377 378 379 380 381 382 388 389 390
263300                         405 406 407 414 415 416 441 442 443
263400                         459 460 463 464 465 466 467 468 469
263500                         470 474 475 476
263600                             483 484 488 489
263700                                             510 511 512
263800                                 533 534 535 536 539 540 541
263900                         542 543 544 545 546 547 551 552 557
264000                         558 559 560 561 562 563 573 574 575
264100                         579 580 581 592 593 594 602 603 616
264200                         617 618 622 623 624 628 629 630 637
264300                         638 639 640 641 643 644 645 653 654
264400                         655 659 660 661 682 683 684 689 690
264500                         698 699 700 840 841 842 853 854 855
264600                         856 857 858 862 863 867 868 869 870
264700                         871 872 884 896 897 907 908 909 917
264800                         918 945 946 947 948 956 981 982 983
264900                         987 988 989.
265000
265100         10  B-LOS                  PIC 9(03).
265200         10  B-COVERED-DAYS         PIC 9(03).
265300         10  B-LTR-DAYS             PIC 9(02).
265400         10  B-DISCHARGE-DATE.
265500             15  B-DISCHG-CC        PIC 9(02).
265600             15  B-DISCHG-YY        PIC 9(02).
265700             15  B-DISCHG-MM        PIC 9(02).
265800             15  B-DISCHG-DD        PIC 9(02).
265900         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
266000         10  B-PRIN-PROC-CODE       PIC X(07).
266100         10  B-OTHER-PROC-CODE1     PIC X(07).
266200         10  B-OTHER-PROC-CODE2     PIC X(07).
266300         10  B-OTHER-PROC-CODE3     PIC X(07).
266400         10  B-OTHER-PROC-CODE4     PIC X(07).
266500         10  B-OTHER-PROC-CODE5     PIC X(07).
266600         10  B-OTHER-PROC-CODE6     PIC X(07).
266700         10  B-OTHER-PROC-CODE7     PIC X(07).
266800         10  B-OTHER-PROC-CODE8     PIC X(07).
266900         10  B-OTHER-PROC-CODE9     PIC X(07).
267000         10  B-OTHER-PROC-CODE10    PIC X(07).
267100         10  B-OTHER-PROC-CODE11    PIC X(07).
267200         10  B-OTHER-PROC-CODE12    PIC X(07).
267300         10  B-OTHER-PROC-CODE13    PIC X(07).
267400         10  B-OTHER-PROC-CODE14    PIC X(07).
267500         10  B-OTHER-PROC-CODE15    PIC X(07).
267600         10  B-OTHER-PROC-CODE16    PIC X(07).
267700         10  B-OTHER-PROC-CODE17    PIC X(07).
267800         10  B-OTHER-PROC-CODE18    PIC X(07).
267900         10  B-OTHER-PROC-CODE19    PIC X(07).
268000         10  B-OTHER-PROC-CODE20    PIC X(07).
268100         10  B-OTHER-PROC-CODE21    PIC X(07).
268200         10  B-OTHER-PROC-CODE22    PIC X(07).
268300         10  B-OTHER-PROC-CODE23    PIC X(07).
268400         10  B-OTHER-PROC-CODE24    PIC X(07).
268500         10  B-OTHER-DIAG-CODE1     PIC X(07).
268600         10  B-OTHER-DIAG-CODE2     PIC X(07).
268700         10  B-OTHER-DIAG-CODE3     PIC X(07).
268800         10  B-OTHER-DIAG-CODE4     PIC X(07).
268900         10  B-OTHER-DIAG-CODE5     PIC X(07).
269000         10  B-OTHER-DIAG-CODE6     PIC X(07).
269100         10  B-OTHER-DIAG-CODE7     PIC X(07).
269200         10  B-OTHER-DIAG-CODE8     PIC X(07).
269300         10  B-OTHER-DIAG-CODE9     PIC X(07).
269400         10  B-OTHER-DIAG-CODE10    PIC X(07).
269500         10  B-OTHER-DIAG-CODE11    PIC X(07).
269600         10  B-OTHER-DIAG-CODE12    PIC X(07).
269700         10  B-OTHER-DIAG-CODE13    PIC X(07).
269800         10  B-OTHER-DIAG-CODE14    PIC X(07).
269900         10  B-OTHER-DIAG-CODE15    PIC X(07).
270000         10  B-OTHER-DIAG-CODE16    PIC X(07).
270100         10  B-OTHER-DIAG-CODE17    PIC X(07).
270200         10  B-OTHER-DIAG-CODE18    PIC X(07).
270300         10  B-OTHER-DIAG-CODE19    PIC X(07).
270400         10  B-OTHER-DIAG-CODE20    PIC X(07).
270500         10  B-OTHER-DIAG-CODE21    PIC X(07).
270600         10  B-OTHER-DIAG-CODE22    PIC X(07).
270700         10  B-OTHER-DIAG-CODE23    PIC X(07).
270800         10  B-OTHER-DIAG-CODE24    PIC X(07).
270900         10  B-OTHER-DIAG-CODE25    PIC X(07).
271000         10  B-DEMO-DATA.
271100             15  B-DEMO-CODE1           PIC X(02).
271200             15  B-DEMO-CODE2           PIC X(02).
271300             15  B-DEMO-CODE3           PIC X(02).
271400             15  B-DEMO-CODE4           PIC X(02).
271500         10  B-NDC-DATA.
271600             15  B-NDC-NUMBER           PIC X(11).
271700         10  FILLER                     PIC X(73).
271800
271900
272000
272100***************************************************************
272200*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
272300*    AND PASSED BACK TO THE CALLING PROGRAM                   *
272400*            RETURN CODE VALUES (PPS-RTC)                     *
272500*                                                             *
272600*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
272700*                                                             *
272800*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
272900*                                                             *
273000*           30,00 = PAID NORMAL DRG PAYMENT                   *
273100*                                                             *
273200*              01 = PAID AS A DAY-OUTLIER.                    *
273300*                   NOTE:                                     *
273400*                     DAY-OUTLIER NO LONGER BEING PAID        *
273500*                         AS OF 10/01/97                      *
273600*                                                             *
273700*              02 = PAID AS A COST-OUTLIER.                   *
273800*                                                             *
273900*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
274000*                   AND INCLUDING THE FULL DRG.               *
274100*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
274200*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
274300*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
274400*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
274500*                   AND INCLUDING THE FULL DRG. PROVIDER      *
274600*                   REFUSED COST OUTLIER.                     *
274700*           40,10 = POST-ACUTE TRANSFER                       *
274800*                   DRG = 28  29  30  40  41  42  219
274900*                         220 221 477 478 479 480 481
275000*                         482 492 493 494 500 501 502
275100*                         515 516 517
275200*
275300* =======================================================
275400* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
275500* =======================================================
275600*
275700*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
275800*                       THE FOLLOWING DRG'S                   *
275900*                   DRG = 3   4   25  26  27              31
276000*                         32  33              54  55  56  57
276100*                         64  65  66  70  71  72  85  86  87
276200*                         91  92  93  100 101 163 164 165 166
276300*                         167 168 175 176 177 178 179 186 187
276400*                         188 190 191 192 193 194 195 196 197
276500*                         198 205 206 207 216 217 218
276600*                             228 229 230 233 234 235 236 239
276700*                         240 241 242 243 244 255 256 257 264
276800*                         280 281 282 288 289 290 291 292 293
276900*                         299 300 301 314 315 316 326 327 328
277000*                         329 330 331 332 333 334 335 336 337
277100*                         356 357 358 371 372 373 374 375 376
277200*                         377 378 379 380 381 382 388 389 390
277300*                         405 406 407 414 415 416 441 442 443
277400*                         459 460 463 464 465 466 467 468 469
277500*                         470 474 475 476
277600*                             483 484 488 489             495
277700*                         496 497             510 511 512
277800*                                 533 534 535 536 539 540 541
277900*                         542 543 544 545 546 547 551 552 557
278000*                         558 559 560 561 562 563 573 574 575
278100*                         579 580 581 592 593 594 602 603 616
278200*                         617 618 622 623 624 628 629 630 637
278300*                         638 639 640 641 643 644 645 653 654
278400*                         655 659 660 661 682 683 684 689 690
278500*                         698 699 700 840 841 842 853 854 855
278600*                         856 857 858 862 863 867 868 869 870
278700*                         871 872 884 896 897 907 908 909 917
278800*                         918 945 946 947 948 956 981 982 983
278900*                         987 988 989
279000*
279100*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
279200*                    PERDIEM DAYS = OR > GM  ALOS             *
279300*              16 = PAID AS A COST-OUTLIER WITH               *
279400*                    PERDIEM DAYS = OR > GM  ALOS             *
279500*                                                             *
279600*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
279700*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
279800*              52 = INVALID CBSA# IN PROVIDER FILE            *
279900*                   OR INVALID WAGE INDEX                     *
280000*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
280100*              54 = INVALID DRG                               *
280200*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
280300*                                      OR                     *
280400*                   DISCHARGE DATE < CBSA EFF START DATE      *
280500*                   FOR PPS                                   *
280600*                                      OR                     *
280700*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
280800*                   DISCHARGE DATE                            *
280900*              56 = INVALID LENGTH OF STAY                    *
281000*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
281100*                                        NOT 11)              *
281200*              58 = TOTAL CHARGES NOT NUMERIC                 *
281300*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
281400*                   OR BILL-LTR-DAYS > 60                     *
281500*              62 = INVALID NUMBER OF COVERED DAYS            *
281600*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
281700*                   SPECIFIC FILE FOR CAPITAL                 *
281800*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
281900*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
282000*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
282100***************************************************************
282200 01  PPS-DATA.
282300         10  PPS-RTC                PIC 9(02).
282400         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
282500         10  PPS-OUTLIER-DAYS       PIC 9(03).
282600         10  PPS-AVG-LOS            PIC 9(02)V9(01).
282700         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
282800         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
282900         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
283000         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
283100         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
283200         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
283300         10  PPS-REG-DAYS-USED      PIC 9(03).
283400         10  PPS-LTR-DAYS-USED      PIC 9(02).
283500         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
283600         10  PPS-CALC-VERS          PIC X(05).
283700
283800******************************************************************
283900*            THESE ARE THE VERSIONS OF THE PPCAL
284000*           PROGRAMS THAT WILL BE PASSED BACK----
284100*          ASSOCIATED WITH THE BILL BEING PROCESSED
284200******************************************************************
284300 01  PRICER-OPT-VERS-SW.
284400     02  PRICER-OPTION-SW          PIC X(01).
284500         88  ALL-TABLES-PASSED          VALUE 'A'.
284600         88  PROV-RECORD-PASSED         VALUE 'P'.
284700         88  ADDITIONAL-VARIABLES       VALUE 'M'.
284800         88  PC-PRICER                  VALUE 'C'.
284900     02  PPS-VERSIONS.
285000         10  PPDRV-VERSION         PIC X(05).
285100
285200******************************************************************
285300*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
285400*          ASSOCIATED WITH THE BILL BEING PROCESSED
285500******************************************************************
285600 01  PPS-ADDITIONAL-VARIABLES.
285700     05  PPS-HSP-PCT                PIC 9(01)V9(02).
285800     05  PPS-FSP-PCT                PIC 9(01)V9(02).
285900     05  PPS-NAT-PCT                PIC 9(01)V9(02).
286000     05  PPS-REG-PCT                PIC 9(01)V9(02).
286100     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
286200     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
286300     05  PPS-DRG-WT                 PIC 9(02)V9(04).
286400     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
286500     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
286600     05  PPS-REG-LABOR              PIC 9(05)V9(02).
286700     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
286800     05  PPS-OPER-COLA              PIC 9(01)V9(03).
286900     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
287000     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
287100     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
287200     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
287300     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
287400     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
287500     05  PPS-CAPITAL-VARIABLES.
287600         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
287700         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
287800         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
287900         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
288000         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
288100         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
288200         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
288300         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
288400     05  PPS-CAPITAL2-VARIABLES.
288500         10  PPS-CAPI2-PAY-CODE             PIC X(1).
288600         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
288700         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
288800
288900     05  PPS-OTHER-VARIABLES.
289000         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
289100         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
289200         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
289300         10  PPS-HVBP-HRR-DATA.
289400             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
289500             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
289600             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
289700             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
289800         10  PPS-OPERATNG-DATA.
289900             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
290000             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
290100             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
290200
290300     05  PPS-PC-OTH-VARIABLES.
290400         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
290500         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
290600         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
290700         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
290800         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
290900         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
291000         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
291100         10  PPS-PC-HMO-FLAG                PIC X(01).
291200         10  PPS-PC-COT-FLAG                PIC X(01).
291300         10  PPS-FILLER                     PIC X(0998).
291400
291500 01  PROV-NEW-HOLD.
291600     02  PROV-NEWREC-HOLD1.
291700         05  P-NEW-NPI10.
291800             10  P-NEW-NPI8             PIC X(08).
291900             10  P-NEW-NPI-FILLER       PIC X(02).
292000         05  P-NEW-PROVIDER-NO.
292100             88  P-NEW-DSH-ADJ-PROVIDERS
292200                             VALUE '180049' '190044' '190144'
292300                                   '190191' '330047' '340085'
292400                                   '370016' '370149' '420043'.
292500             10  P-NEW-STATE            PIC 9(02).
292600             10  FILLER                 PIC X(04).
292700         05  P-NEW-DATE-DATA.
292800             10  P-NEW-EFF-DATE.
292900                 15  P-NEW-EFF-DT-CC    PIC 9(02).
293000                 15  P-NEW-EFF-DT-YY    PIC 9(02).
293100                 15  P-NEW-EFF-DT-MM    PIC 9(02).
293200                 15  P-NEW-EFF-DT-DD    PIC 9(02).
293300             10  P-NEW-FY-BEGIN-DATE.
293400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
293500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
293600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
293700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
293800             10  P-NEW-REPORT-DATE.
293900                 15  P-NEW-REPORT-DT-CC PIC 9(02).
294000                 15  P-NEW-REPORT-DT-YY PIC 9(02).
294100                 15  P-NEW-REPORT-DT-MM PIC 9(02).
294200                 15  P-NEW-REPORT-DT-DD PIC 9(02).
294300             10  P-NEW-TERMINATION-DATE.
294400                 15  P-NEW-TERM-DT-CC   PIC 9(02).
294500                 15  P-NEW-TERM-DT-YY   PIC 9(02).
294600                 15  P-NEW-TERM-DT-MM   PIC 9(02).
294700                 15  P-NEW-TERM-DT-DD   PIC 9(02).
294800         05  P-NEW-WAIVER-CODE          PIC X(01).
294900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
295000         05  P-NEW-INTER-NO             PIC 9(05).
295100         05  P-NEW-PROVIDER-TYPE        PIC X(02).
295200             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
295300             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
295400                                                  '15' '17'
295500                                                  '22'.
295600             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
295700             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
295800             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
295900             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
296000             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
296100             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
296200             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
296300             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
296400             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
296500             88  P-N-EACH                   VALUE '21' '22'.
296600             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
296700             88  P-N-NHCMQ-II-SNF           VALUE '32'.
296800             88  P-N-NHCMQ-III-SNF          VALUE '33'.
296900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
297000             88  P-N-NEW-ENGLAND            VALUE  1.
297100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
297200             88  P-N-SOUTH-ATLANTIC         VALUE  3.
297300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
297400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
297500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
297600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
297700             88  P-N-MOUNTAIN               VALUE  8.
297800             88  P-N-PACIFIC                VALUE  9.
297900         05  P-NEW-CURRENT-DIV   REDEFINES
298000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
298100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
298200         05  P-NEW-MSA-DATA.
298300             10  P-NEW-CHG-CODE-INDEX       PIC X.
298400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
298500             10  P-NEW-GEO-LOC-MSA9   REDEFINES
298600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
298700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
298800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
298900             10  P-NEW-STAND-AMT-LOC-MSA9
299000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
299100                 15  P-NEW-RURAL-1ST.
299200                     20  P-NEW-STAND-RURAL  PIC XX.
299300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
299400                 15  P-NEW-RURAL-2ND        PIC XX.
299500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
299600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
299700                 88  P-NEW-SCH-YR82       VALUE   '82'.
299800                 88  P-NEW-SCH-YR87       VALUE   '87'.
299900         05  P-NEW-LUGAR                    PIC X.
300000         05  P-NEW-TEMP-RELIEF-IND          PIC X.
300100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
300200         05  FILLER                         PIC X(05).
300300     02  PROV-NEWREC-HOLD2.
300400         05  P-NEW-VARIABLES.
300500             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
300600             10  P-NEW-COLA              PIC  9(01)V9(03).
300700             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
300800             10  P-NEW-BED-SIZE          PIC  9(05).
300900             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
301000             10  P-NEW-CMI               PIC  9(01)V9(04).
301100             10  P-NEW-SSI-RATIO         PIC  V9(04).
301200             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
301300             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
301400             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
301500             10  P-NEW-DSH-PERCENT       PIC  V9(04).
301600             10  P-NEW-FYE-DATE          PIC  X(08).
301700         05  P-NEW-CBSA-DATA.
301800             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
301900             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
302000             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
302100             10  P-NEW-CBSA-GEO-RURAL REDEFINES
302200                 P-NEW-CBSA-GEO-LOC.
302300                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
302400                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
302500                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
302600
302700             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
302800             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
302900             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
303000     02  PROV-NEWREC-HOLD3.
303100         05  P-NEW-PASS-AMT-DATA.
303200             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
303300             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
303400             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
303500             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
303600         05  P-NEW-CAPI-DATA.
303700             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
303800             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
303900             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
304000             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
304100             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
304200             15  P-NEW-CAPI-NEW-HOSP       PIC X.
304300             15  P-NEW-CAPI-IME            PIC 9V9999.
304400             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
304500         05  P-HVBP-HRR-DATA.
304600             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
304700             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
304800             15  P-HOSP-READMISSION-REDUCTN PIC X.
304900             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
305000         05  P-MODEL1-BUNDLE-DATA.
305100             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
305200             15  P-HAC-REDUC-IND            PIC X.
305300             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
305400             15  P-EHR-REDUC-IND            PIC X.
305500         05  FILLER                         PIC X(09).
305600
305700******************************************************************
305800 01  WAGE-NEW-CBSA-INDEX-RECORD.
305900     05  W-CBSA                        PIC X(5).
306000     05  W-CBSA-SIZE                   PIC X.
306100         88  LARGE-URBAN       VALUE 'L'.
306200         88  OTHER-URBAN       VALUE 'O'.
306300         88  ALL-RURAL         VALUE 'R'.
306400     05  W-CBSA-EFF-DATE               PIC X(8).
306500     05  FILLER                        PIC X.
306600     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
306700     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
306800
306900
307000 PROCEDURE DIVISION  USING BILL-NEW-DATA
307100                           PPS-DATA
307200                           PRICER-OPT-VERS-SW
307300                           PPS-ADDITIONAL-VARIABLES
307400                           PROV-NEW-HOLD
307500                           WAGE-NEW-CBSA-INDEX-RECORD.
307600
307700***************************************************************
307800*    PROCESSING:                                              *
307900*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
308000*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
308100*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
308200*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
308300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
308400*           GOBACK.                                           *
308500*        D. ASSEMBLE PRICING COMPONENTS.                      *
308600*        E. CALCULATE THE PRICE.                              *
308700***************************************************************
308800
308900     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
309000     MOVE 'N' TO TEMP-RELIEF-FLAG.
309100     MOVE 'N' TO OUTLIER-RECON-FLAG.
309200
309300     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
309400
309500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
309600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
309700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
309800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
309900     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
310000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
310100     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
310200     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
310300
310400     IF (PPS-RTC = '00' OR '03' OR '10' OR
310500                   '12' OR '14')
310600        MOVE 'Y' TO OUTLIER-RECON-FLAG
310700        MOVE PPS-DATA TO HLD-PPS-DATA
310800        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
310900        MOVE HLD-PPS-DATA TO PPS-DATA.
311000
311100     GOBACK.
311200
311300 0200-MAINLINE-CONTROL.
311400
311500     MOVE 'N' TO HMO-TAG.
311600
311700     IF PPS-PC-HMO-FLAG = 'Y' OR
311800               HMO-FLAG = 'Y'
311900        MOVE 'Y' TO HMO-TAG.
312000
312100     IF P-NEW-STATE NOT = 40
312200        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
312300
312400     MOVE ALL '0' TO PPS-DATA
312500                     H-OPER-DSH-SCH
312600                     H-OPER-DSH-RRC
312700                     HOLD-PPS-COMPONENTS
312800                     HOLD-PPS-COMPONENTS
312900                     HOLD-ADDITIONAL-VARIABLES
313000                     HOLD-CAPITAL-VARIABLES
313100                     HOLD-CAPITAL2-VARIABLES
313200                     HOLD-OTHER-VARIABLES
313300                     HOLD-PC-OTH-VARIABLES.
313400
313500     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
313600        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
313700
313800     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
313900        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
314000
314100     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
314200        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
314300
314400     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
314500        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
314600
314700
314800     PERFORM 1000-EDIT-THE-BILL-INFO.
314900
315000     IF  PPS-RTC = 00
315100         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
315200         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
315300
315400     IF OUTLIER-RECON-FLAG = 'Y'
315500        MOVE 'N' TO OUTLIER-RECON-FLAG
315600        GO TO 0200-EXIT.
315700
315800     IF PPS-RTC = 00
315900        IF H-PERDIEM-DAYS = H-ALOS OR
316000           H-PERDIEM-DAYS > H-ALOS
316100           MOVE 14 TO PPS-RTC.
316200
316300     IF PPS-RTC = 02
316400        IF H-PERDIEM-DAYS = H-ALOS OR
316500           H-PERDIEM-DAYS > H-ALOS
316600           MOVE 16 TO PPS-RTC.
316700
316800 0200-EXIT.   EXIT.
316900
317000 1000-EDIT-THE-BILL-INFO.
317100
317200     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
317300     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
317400
317500     IF  PPS-RTC = 00
317600         IF  P-NEW-WAIVER-STATE
317700             MOVE 53 TO PPS-RTC.
317800
317900     IF  PPS-RTC = 00
318000         IF  B-DRG < 001
318100               OR = 009 OR = 016 OR = 017
318200               OR = 018 OR = 019 OR = 043 OR = 044
318300               OR = 045 OR = 046 OR = 047 OR = 048
318400               OR = 049 OR = 050 OR = 051 OR = 104
318500               OR = 105 OR = 106 OR = 107 OR = 108
318600               OR = 109 OR = 110 OR = 111 OR = 112
318700               OR = 118 OR = 119 OR = 120 OR = 126
318800               OR = 127 OR = 128 OR = 140 OR = 141
318900               OR = 142 OR = 143 OR = 144 OR = 145
319000               OR = 160 OR = 161 OR = 162 OR = 169
319100               OR = 170 OR = 171 OR = 172 OR = 173
319200               OR = 174 OR = 209 OR = 210 OR = 211
319300               OR = 212 OR = 213 OR = 214
319400               OR = 266 OR = 267 OR = 268 OR = 269
319500               OR = 270 OR = 271 OR = 272 OR = 273
319600               OR = 274 OR = 275 OR = 276 OR = 277
319700               OR = 278 OR = 279 OR = 317 OR = 318
319800               OR = 319 OR = 320 OR = 321 OR = 322
319900               OR = 323 OR = 324 OR = 325 OR = 359
320000               OR = 360 OR = 361 OR = 362 OR = 363
320100               OR = 364 OR = 365 OR = 366 OR = 367
320200               OR = 396 OR = 397 OR = 398 OR = 399
320300               OR = 400 OR = 401 OR = 402 OR = 403
320400               OR = 404 OR = 426 OR = 427 OR = 428
320500               OR = 429 OR = 430 OR = 431 OR = 447
320600               OR = 448 OR = 449 OR = 450 OR = 451
320700               OR = 452 OR = 518 OR = 519 OR = 520
320800               OR = 521 OR = 522 OR = 523 OR = 524
320900               OR = 525 OR = 526 OR = 527 OR = 528
321000               OR = 529 OR = 530 OR = 531 OR = 532
321100               OR = 567 OR = 568 OR = 569 OR = 570
321200               OR = 571 OR = 572 OR = 586 OR = 587
321300               OR = 588 OR = 589 OR = 590 OR = 591
321400               OR = 608 OR = 609 OR = 610 OR = 611
321500               OR = 612 OR = 613 OR = 631 OR = 632
321600               OR = 633 OR = 634 OR = 635 OR = 636
321700               OR = 646 OR = 647 OR = 648 OR = 649
321800               OR = 650 OR = 651 OR = 676 OR = 677
321900               OR = 678 OR = 679 OR = 680 OR = 681
322000               OR = 701 OR = 702 OR = 703 OR = 704
322100               OR = 705 OR = 706 OR = 719 OR = 720
322200               OR = 721 OR = 731 OR = 732 OR = 733
322300               OR = 751 OR = 752 OR = 753 OR = 762
322400               OR = 763 OR = 764 OR = 771 OR = 772
322500               OR = 773 OR = 783 OR = 784 OR = 785
322600               OR = 786 OR = 787 OR = 788 OR = 796
322700               OR = 797 OR = 798 OR = 805 OR = 806
322800               OR = 807 OR = 817 OR = 818 OR = 819
322900               OR = 831 OR = 832 OR = 833 OR = 850
323000               OR = 851 OR = 852 OR = 859 OR = 860
323100               OR = 861 OR = 873 OR = 874 OR = 875
323200               OR = 877 OR = 878 OR = 879
323300               OR = 888 OR = 889 OR = 890
323400               OR = 891 OR = 892 OR = 893
323500               OR = 893 OR = 898 OR = 899 OR = 900
323600               OR = 910 OR = 911 OR = 912 OR = 924
323700               OR = 925 OR = 926 OR = 930 OR = 931
323800               OR = 932 OR = 936 OR = 937 OR = 938
323900               OR = 942 OR = 943 OR = 944 OR = 952
324000               OR = 953 OR = 954 OR = 960 OR = 961
324100               OR = 962 OR = 966 OR = 967 OR = 968
324200               OR = 971 OR = 972 OR = 973 OR = 978
324300               OR = 979 OR = 980 OR = 990 OR = 991
324400               OR = 992 OR = 993 OR = 994 OR = 995
324500               OR = 996 OR = 997
324600             MOVE 54 TO PPS-RTC.
324700
324800     IF  PPS-RTC = 00
324900            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
325000                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
325100                MOVE 55 TO PPS-RTC.
325200
325300     IF  PPS-RTC = 00
325400         IF P-NEW-TERMINATION-DATE > 00000000
325500            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
325600                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
325700                  MOVE 55 TO PPS-RTC.
325800
325900     IF  PPS-RTC = 00
326000         IF  B-LOS NOT NUMERIC
326100             MOVE 56 TO PPS-RTC
326200         ELSE
326300         IF  B-LOS = 0
326400             IF B-REVIEW-CODE NOT = 00 AND
326500                              NOT = 03 AND
326600                              NOT = 06 AND
326700                              NOT = 07 AND
326800                              NOT = 09 AND
326900                              NOT = 11
327000             MOVE 56 TO PPS-RTC.
327100
327200     IF  PPS-RTC = 00
327300         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
327400             MOVE 61 TO PPS-RTC
327500         ELSE
327600             MOVE B-LTR-DAYS TO H-LTR-DAYS.
327700
327800     IF  PPS-RTC = 00
327900         IF  B-COVERED-DAYS NOT NUMERIC
328000             MOVE 62 TO PPS-RTC
328100         ELSE
328200         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
328300             MOVE 62 TO PPS-RTC
328400         ELSE
328500             MOVE B-COVERED-DAYS TO H-COV-DAYS.
328600
328700     IF  PPS-RTC = 00
328800         IF  H-LTR-DAYS  > H-COV-DAYS
328900             MOVE 62 TO PPS-RTC
329000         ELSE
329100             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
329200
329300     IF  PPS-RTC = 00
329400         IF  NOT VALID-REVIEW-CODE
329500             MOVE 57 TO PPS-RTC.
329600
329700     IF  PPS-RTC = 00
329800         IF  B-CHARGES-CLAIMED NOT NUMERIC
329900             MOVE 58 TO PPS-RTC.
330000
330100     IF PPS-RTC = 00
330200           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
330300                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
330400                                            NOT = 'B' AND
330500                                            NOT = 'C'
330600                 MOVE 65 TO PPS-RTC.
330700
330800 2000-ASSEMBLE-PPS-VARIABLES.
330900***  GET THE PROVIDER SPECIFIC VARIABLES.
331000***  GET THE PROVIDER SPECIFIC VARIABLES.
331100
331200     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
331300     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
331400
331500     IF  (P-NEW-STATE = 02 OR 12)
331600         MOVE P-NEW-COLA TO H-OPER-COLA
331700     ELSE
331800         MOVE 1.000  TO H-OPER-COLA.
331900
332000***************************************************************
332100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
332200***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
332300
332400     PERFORM 2600-GET-DRG-WEIGHT
332500             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
332600
332700***************************************************************
332800***  GET THE WAGE-INDEX
332900***  GET THE WAGE-INDEX
333000
333100     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
333200     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
333300     MOVE P-NEW-STATE            TO MES-PPS-STATE.
333400*****YEARCHANGE 2011.0 ************************************
333500** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
333600** FOR FY 2011
333700***************************************************************
333800*    PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
333900*****YEARCHANGE 2011.0 ************************************
334000
334100*    IF  P-NEW-CBSA-SPEC-PAY-IND = '1' OR '2'
334200       COMPUTE H-WAGE-INDEX ROUNDED =
334300                         H-WAGE-INDEX * 1
334400*    ELSE
334500*      COMPUTE H-WAGE-INDEX ROUNDED =
334600*                        H-WAGE-INDEX * MES-SSRFBN-RATE.
334700
334800*****YEARCHANGE 2011.0 ************************************
334900
335000***************************************************************
335100***  GET THE LABOR, NON-LABOR STANDARD RATES
335200
335300     IF  P-NEW-STATE = 40
335400         MOVE 2 TO R2
335500         MOVE 3 TO R4
335600     ELSE
335700         MOVE 1 TO R2
335800         MOVE 1 TO R4.
335900
336000     IF  LARGE-URBAN
336100         MOVE 1 TO R3
336200     ELSE
336300         MOVE 2 TO R3.
336400
336500     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
336600        (H-WAGE-INDEX > 01.0000))
336700        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
336800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
336900
337000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
337100         (H-WAGE-INDEX > 01.0000))
337200        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
337300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
337400
337500     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
337600         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
337700        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
337800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
337900
338000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
338100         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
338200        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
338300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
338400
338500     IF P-NEW-STATE = 40
338600        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
338700            (H-PR-WAGE-INDEX > 01.0000))
338800             PERFORM 2300-GET-PR-LAB-TB1-RATES
338900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
339000
339100
339200     IF P-NEW-STATE = 40
339300        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
339400             (H-PR-WAGE-INDEX > 01.0000))
339500              PERFORM 2300-GET-PR-LAB-TB2-RATES
339600                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
339700
339800     IF P-NEW-STATE = 40
339900        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
340000         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
340100          PERFORM 2300-GET-PR-LAB-TB3-RATES
340200              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
340300
340400     IF P-NEW-STATE = 40
340500        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
340600         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
340700          PERFORM 2300-GET-PR-LAB-TB4-RATES
340800              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
340900
341000***************************************************************
341100***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
341200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
341300
341400     MOVE 0.00  TO H-OPER-HSP-PCT.
341500     MOVE 1.00  TO H-OPER-FSP-PCT.
341600
341700***************************************************************
341800***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
341900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
342000
342100      MOVE 1.00 TO H-NAT-PCT.
342200      MOVE 0.00 TO H-REG-PCT.
342300
342400     IF  P-NEW-STATE = 40
342500         MOVE 0.75 TO H-NAT-PCT
342600         MOVE 0.25 TO H-REG-PCT.
342700
342800     IF  P-N-SCH-REBASED-FY90 OR
342900         P-N-EACH OR
343000         P-N-MDH-REBASED-FY90
343100         MOVE 1.00 TO H-OPER-HSP-PCT.
343200
343300 2300-GET-LAB-NONLAB-TB1-RATES.
343400
343500     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
343600         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
343700         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
343800         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
343900         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
344000
344100 2300-GET-LAB-NONLAB-TB2-RATES.
344200
344300     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
344400         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
344500         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
344600         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
344700         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
344800
344900 2300-GET-LAB-NONLAB-TB3-RATES.
345000
345100     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
345200         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
345300         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
345400         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
345500         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
345600
345700 2300-GET-LAB-NONLAB-TB4-RATES.
345800
345900     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
346000         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
346100         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
346200         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
346300         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
346400
346500 2300-GET-PR-LAB-TB1-RATES.
346600
346700     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
346800         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
346900         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
347000
347100 2300-GET-PR-LAB-TB2-RATES.
347200
347300     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
347400         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
347500         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
347600
347700 2300-GET-PR-LAB-TB3-RATES.
347800
347900     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
348000         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
348100         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
348200
348300 2300-GET-PR-LAB-TB4-RATES.
348400
348500     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
348600         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
348700         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
348800
348900
349000 2600-GET-DRG-WEIGHT.
349100
349200     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
349300         SET DX6 TO B-DRG
349400         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
349500         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
349600         MOVE ZEROES                   TO H-DAYS-CUTOFF
349700         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
349800
349900 3000-CALC-PAYMENT.
350000***************************************************************
350100
350200     PERFORM 3100-CALC-STAY-UTILIZATION.
350300     PERFORM 3300-CALC-OPER-FSP-AMT.
350400     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
350500
350600***********************************************************
350700***  OPERATING IME CALCULATION
350800***  OPERATING IME CALCULATION
350900
351000     COMPUTE H-OPER-IME-TEACH ROUNDED =
351100            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
351200
351300***********************************************************
351400*
351500*    IF P-N-SCH-REBASED-FY90 OR
351600*       P-N-EACH OR
351700*       P-N-MDH-REBASED-FY90
351800*        PERFORM 3450-CALC-ADDITIONAL-HSP.
351900*
352000     MOVE 00                 TO  PPS-RTC.
352100     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
352200     MOVE H-ALOS             TO  PPS-AVG-LOS.
352300     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
352400
352500     MOVE B-LOS TO H-PERDIEM-DAYS.
352600     IF H-PERDIEM-DAYS < 1
352700         MOVE 1 TO H-PERDIEM-DAYS.
352800     ADD 1 TO H-PERDIEM-DAYS.
352900
353000     MOVE 1 TO H-DSCHG-FRCTN.
353100
353200     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
353300
353400     IF (PAY-PERDIEM-DAYS  OR
353500         PAY-XFER-NO-COST) OR
353600        (PAY-XFER-SPEC-DRG AND
353700         B-DRG-POSTACUTE-PERDIEM)
353800         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
353900         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
354000         IF H-DSCHG-FRCTN > 1
354100              MOVE 1 TO H-DSCHG-FRCTN
354200              MOVE 1 TO H-TRANSFER-ADJ
354300         ELSE
354400              COMPUTE H-DRG-WT-FRCTN ROUNDED =
354500                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
354600
354700     IF (PAY-XFER-SPEC-DRG AND
354800         B-DRG-POSTACUTE-50-50)
354900         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
355000         COMPUTE H-DSCHG-FRCTN  ROUNDED =
355100                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
355200         IF H-DSCHG-FRCTN > 1
355300              MOVE 1 TO H-DSCHG-FRCTN
355400              MOVE 1 TO H-TRANSFER-ADJ
355500         ELSE
355600              COMPUTE H-DRG-WT-FRCTN ROUNDED =
355700            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
355800
355900
356000***********************************************************
356100***  CAPITAL DSH CALCULATION
356200***  CAPITAL DSH CALCULATION
356300
356400     MOVE 0 TO H-CAPI-DSH.
356500
356600     IF P-NEW-BED-SIZE NOT NUMERIC
356700         MOVE 0 TO P-NEW-BED-SIZE.
356800
356900     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
357000         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
357100                  (.2025 * (P-NEW-SSI-RATIO
357200                          + P-NEW-MEDICAID-RATIO)) - 1.
357300
357400***********************************************************
357500***  CAPITAL IME TEACH CALCULATION
357600***  CAPITAL IME TEACH CALCULATION
357700
357800     MOVE 0 TO H-WK-CAPI-IME-TEACH.
357900
358000     IF P-NEW-CAPI-IME NUMERIC
358100        IF P-NEW-CAPI-IME > 1.5000
358200           MOVE 1.5000 TO P-NEW-CAPI-IME.
358300
358400*****YEARCHANGE 2009.5 ****************************************
358500***
358600***  PER POLICY, WE REMOVED THE .5 MULTIPLER
358700***
358800***********************************************************
358900     IF P-NEW-CAPI-IME NUMERIC
359000        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
359100         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
359200
359300*****YEARCHANGE 2009.5 ****************************************
359400***********************************************************
359500     MOVE 0.00 TO H-DAYOUT-PCT.
359600     MOVE 0.80 TO H-CSTOUT-PCT.
359700
359800******************************************************************
359900**
360000** BURN DRGS FOR FY09 ARE 927, 928, 929, 933, 934 AND 935.
360100**
360200******************************************************************
360300
360400     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
360500             MOVE 0.90 TO H-CSTOUT-PCT.
360600
360700***     NATIONAL PERCENTAGE
360800     MOVE 0.6880   TO H-LABOR-PCT.
360900     MOVE 0.3120   TO H-NONLABOR-PCT.
361000
361100***     PUERTO RICO PERCENTAGE
361200     MOVE 0.6210   TO H-PR-LABOR-PCT.
361300     MOVE 0.3790   TO H-PR-NONLABOR-PCT.
361400
361500     IF (H-WAGE-INDEX < 01.0000 OR
361600         H-WAGE-INDEX = 01.0000)
361700        MOVE 0.6200 TO H-LABOR-PCT
361800        MOVE 0.3800 TO H-NONLABOR-PCT.
361900***       ??????????
362000     IF P-NEW-STATE = 40
362100       IF (H-PR-WAGE-INDEX < 01.0000 OR
362200           H-PR-WAGE-INDEX = 01.0000)
362300          MOVE 0.6200 TO H-PR-LABOR-PCT
362400          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
362500
362600
362700     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
362800             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
362900     ELSE
363000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
363100
363200     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
363300             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
363400     ELSE
363500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
363600
363700***********************************************************
363800*****YEARCHANGE 2010.0 ************************************
363900***  CAPITAL PAYMENT METHOD B - YEARCHNG
364000***  CAPITAL PAYMENT METHOD B
364100
364200     IF W-CBSA-SIZE = 'L'
364300        MOVE 1.00 TO H-CAPI-LARG-URBAN
364400     ELSE
364500        MOVE 1.00 TO H-CAPI-LARG-URBAN.
364600
364700     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
364800     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
364900
365000*****YEARCHANGE 2011.0 ************************************
365100     COMPUTE H-FEDERAL-RATE ROUNDED =
365200                                 (0420.01 * H-CAPI-GAF).
365300     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
365400                                 (0197.66 * H-PR-CAPI-GAF).
365500*****YEARCHANGE 2011.0 ************************************
365600
365700     COMPUTE H-CAPI-COLA ROUNDED =
365800                     (.3152 * (H-OPER-COLA - 1) + 1).
365900
366000     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
366100
366200     IF P-NEW-STATE = 40
366300        COMPUTE  H-CAPI-FED-RATE ROUNDED =
366400                 (H-NAT-PCT * H-FEDERAL-RATE) +
366500                 (H-REG-PCT * H-PUERTO-RICO-RATE).
366600***********************************************************
366700***  CAPITAL FSP CALCULATION
366800***  CAPITAL FSP CALCULATION
366900
367000     COMPUTE H-CAPI-FSP-PART ROUNDED =
367100                               H-DRG-WT * H-CAPI-FED-RATE *
367200                               H-CAPI-COLA *
367300                               H-CAPI-LARG-URBAN.
367400
367500***********************************************************
367600***  CAPITAL PAYMENT METHOD A
367700***  CAPITAL PAYMENT METHOD A
367800
367900     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
368000        MOVE 1.00 TO H-CAPI-SCH
368100     ELSE
368200        MOVE 0.85 TO H-CAPI-SCH.
368300
368400***********************************************************
368500***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
368600***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
368700
368800     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
368900                    (P-NEW-CAPI-OLD-HARM-RATE *
369000                    H-CAPI-SCH).
369100
369200***********************************************************
369300        IF PAY-PERDIEM-DAYS
369400            IF  H-PERDIEM-DAYS < H-ALOS
369500                IF  NOT (B-DRG = 789)
369600                    PERFORM 3500-CALC-PERDIEM-AMT
369700                    MOVE 03 TO PPS-RTC.
369800
369900        IF PAY-XFER-SPEC-DRG
370000            IF  H-PERDIEM-DAYS < H-ALOS
370100                IF  NOT (B-DRG = 789)
370200                    PERFORM 3550-CALC-PERDIEM-AMT.
370300
370400        IF  PAY-XFER-NO-COST
370500            MOVE 00 TO PPS-RTC
370600            IF H-PERDIEM-DAYS < H-ALOS
370700               IF  NOT (B-DRG = 789)
370800                   PERFORM 3500-CALC-PERDIEM-AMT
370900                   MOVE 06 TO PPS-RTC.
371000
371100     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
371200
371300     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
371400
371500     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
371600
371700     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
371800
371900        IF PAY-XFER-SPEC-DRG
372000            IF  H-PERDIEM-DAYS < H-ALOS
372100                IF  NOT (B-DRG = 789)
372200                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
372300
372400
372500        IF  PAY-PERDIEM-DAYS
372600            IF  H-OPER-OUTCST-PART > 0
372700                MOVE H-OPER-OUTCST-PART TO
372800                     H-OPER-OUTLIER-PART
372900                MOVE 05 TO PPS-RTC
373000            ELSE
373100            IF  PPS-RTC NOT = 03
373200                MOVE 00 TO PPS-RTC
373300                MOVE 0  TO H-OPER-OUTLIER-PART.
373400
373500        IF  PAY-PERDIEM-DAYS
373600            IF  H-CAPI-OUTCST-PART > 0
373700                MOVE H-CAPI-OUTCST-PART TO
373800                     H-CAPI-OUTLIER-PART
373900                MOVE 05 TO PPS-RTC
374000            ELSE
374100            IF  PPS-RTC NOT = 03
374200                MOVE 0  TO H-CAPI-OUTLIER-PART.
374300
374400
374500     IF P-N-SCH-REBASED-FY90 OR
374600        P-N-EACH OR
374700        P-N-MDH-REBASED-FY90
374800         PERFORM 3450-CALC-ADDITIONAL-HSP.
374900
375000
375100 3000-CONTINUE.
375200
375300***********************************************************
375400***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
375500***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
375600
375700     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
375800
375900***********************************************************
376000
376100     IF  PPS-RTC = 67
376200         MOVE H-OPER-DOLLAR-THRESHOLD TO
376300              WK-H-OPER-DOLLAR-THRESHOLD.
376400
376500     IF  PPS-RTC < 50
376600         PERFORM 3800-CALC-TOT-AMT THRU 3800-EXIT
376700     ELSE
376800         MOVE ALL '0' TO PPS-OPER-HSP-PART
376900                         PPS-OPER-FSP-PART
377000                         PPS-OPER-OUTLIER-PART
377100                         PPS-OUTLIER-DAYS
377200                         PPS-REG-DAYS-USED
377300                         PPS-LTR-DAYS-USED
377400                         PPS-TOTAL-PAYMENT
377500                         PPS-OPER-DSH-ADJ
377600                         PPS-OPER-IME-ADJ
377700                         H-DSCHG-FRCTN
377800                         H-DRG-WT-FRCTN
377900                         HOLD-ADDITIONAL-VARIABLES
378000                         HOLD-CAPITAL-VARIABLES
378100                         HOLD-CAPITAL2-VARIABLES
378200                         HOLD-OTHER-VARIABLES
378300                         HOLD-PC-OTH-VARIABLES.
378400
378500     IF  PPS-RTC = 67
378600         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
378700                 H-OPER-DOLLAR-THRESHOLD.
378800
378900 3000-EXIT.  EXIT.
379000
379100 3100-CALC-STAY-UTILIZATION.
379200
379300     MOVE 0 TO PPS-REG-DAYS-USED.
379400     MOVE 0 TO PPS-LTR-DAYS-USED.
379500
379600     IF H-REG-DAYS > 0
379700        IF H-REG-DAYS > B-LOS
379800           MOVE B-LOS TO PPS-REG-DAYS-USED
379900        ELSE
380000           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
380100     ELSE
380200        IF H-LTR-DAYS > B-LOS
380300           MOVE B-LOS TO PPS-LTR-DAYS-USED
380400        ELSE
380500           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
380600
380700
380800
380900 3300-CALC-OPER-FSP-AMT.
381000***********************************************************
381100***  OPERATING FSP CALCULATION
381200***  OPERATING FSP CALCULATION
381300
381400     COMPUTE H-OPER-FSP-PART ROUNDED =
381500           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
381600            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
381700                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
381800
381900     IF P-NEW-STATE = 40
382000       COMPUTE H-OPER-FSP-PART ROUNDED =
382100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
382200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
382300                           +
382400           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
382500            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
382600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
382700
382800
382900 3500-CALC-PERDIEM-AMT.
383000***********************************************************
383100***  REVIEW CODE = 03 OR 06
383200***  OPERATING PERDIEM-AMT CALCULATION
383300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
383400
383500        COMPUTE H-OPER-FSP-PART ROUNDED =
383600        H-OPER-FSP-PART * H-TRANSFER-ADJ
383700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
383800
383900***********************************************************
384000***********************************************************
384100***  REVIEW CODE = 03 OR 06
384200***  CAPITAL   PERDIEM-AMT CALCULATION
384300***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
384400
384500        COMPUTE H-CAPI-FSP-PART ROUNDED =
384600        H-CAPI-FSP-PART * H-TRANSFER-ADJ
384700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
384800
384900***********************************************************
385000***  REVIEW CODE = 03 OR 06
385100***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
385200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
385300
385400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
385500        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
385600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
385700
385800 3550-CALC-PERDIEM-AMT.
385900***********************************************************
386000***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
386100***  OPERATING PERDIEM-AMT CALCULATION
386200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
386300
386400     IF (B-DRG-POSTACUTE-50-50)
386500        MOVE 10 TO PPS-RTC
386600        COMPUTE H-OPER-FSP-PART ROUNDED =
386700        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
386800        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
386900
387000     IF (B-DRG-POSTACUTE-PERDIEM)
387100        MOVE 12 TO PPS-RTC
387200        COMPUTE H-OPER-FSP-PART ROUNDED =
387300        H-OPER-FSP-PART *  H-TRANSFER-ADJ
387400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
387500
387600***********************************************************
387700***  CAPITAL PERDIEM-AMT CALCULATION
387800***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
387900
388000     IF (B-DRG-POSTACUTE-50-50)
388100        MOVE 10 TO PPS-RTC
388200        COMPUTE H-CAPI-FSP-PART ROUNDED =
388300        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
388400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
388500
388600     IF (B-DRG-POSTACUTE-PERDIEM)
388700        MOVE 12 TO PPS-RTC
388800        COMPUTE H-CAPI-FSP-PART ROUNDED =
388900        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
389000        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
389100
389200***********************************************************
389300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
389400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
389500
389600     IF (B-DRG-POSTACUTE-50-50)
389700        MOVE 10 TO PPS-RTC
389800        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
389900        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
390000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
390100
390200     IF (B-DRG-POSTACUTE-PERDIEM)
390300        MOVE 12 TO PPS-RTC
390400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
390500        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
390600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
390700
390800 3560-CHECK-RTN-CODE.
390900
391000     IF (B-DRG-POSTACUTE-50-50)
391100        MOVE 10 TO PPS-RTC.
391200     IF (B-DRG-POSTACUTE-PERDIEM)
391300        MOVE 12 TO PPS-RTC.
391400
391500 3560-EXIT.    EXIT.
391600
391700 3600-CALC-OUTLIER.
391800***********************************************************
391900***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
392000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
392100
392200     IF OUTLIER-RECON-FLAG = 'Y'
392300        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
392400               (H-OPER-CSTCHG-RATIO + .2).
392500
392600     IF H-CAPI-CSTCHG-RATIO > 0 OR
392700       H-OPER-CSTCHG-RATIO > 0
392800        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
392900                H-OPER-CSTCHG-RATIO /
393000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
393100        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
393200                H-CAPI-CSTCHG-RATIO /
393300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
393400     ELSE
393500         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
393600                   H-CAPI-SHARE-DOLL-THRESHOLD.
393700
393800***********************************************************
393900*****YEARCHANGE 2010.0 ************************************
394000***  OUTLIER THRESHOLD AMOUNTS
394100***  OUTLIER THRESHOLD AMOUNTS
394200
394300*****YEARCHANGE 2011.0 ************************************
394400
394500     MOVE 23075.00 TO H-CST-THRESH.
394600
394700*****YEARCHANGE 2011.0 ************************************
394800
394900     IF (B-REVIEW-CODE = '03') AND
395000         H-PERDIEM-DAYS < H-ALOS
395100        COMPUTE H-CST-THRESH ROUNDED =
395200                      (H-CST-THRESH * H-TRANSFER-ADJ)
395300                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
395400
395500     IF ((B-REVIEW-CODE = '09') AND
395600         (H-PERDIEM-DAYS < H-ALOS))
395700         IF (B-DRG-POSTACUTE-PERDIEM)
395800            COMPUTE H-CST-THRESH ROUNDED =
395900                      (H-CST-THRESH * H-TRANSFER-ADJ)
396000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
396100
396200     IF ((B-REVIEW-CODE = '09') AND
396300         (H-PERDIEM-DAYS < H-ALOS))
396400         IF (B-DRG-POSTACUTE-50-50)
396500           COMPUTE H-CST-THRESH ROUNDED =
396600          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
396700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
396800
396900     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
397000        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
397100         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
397200          H-OPER-SHARE-DOLL-THRESHOLD.
397300
397400     IF P-NEW-STATE = 40
397500        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
397600           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
397700            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
397800             H-OPER-SHARE-DOLL-THRESHOLD
397900        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
398000               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
398100               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
398200
398300***********************************************************
398400
398500     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
398600          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
398700          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
398800
398900
399000     IF P-NEW-STATE = 40
399100        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
399200           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
399300           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
399400        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
399500               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
399600               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
399700
399800
399900     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
400000      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
400100                       +
400200             H-OPER-DOLLAR-THRESHOLD
400300                       +
400400                 H-NEW-TECH-PAY-ADD-ON.
400500
400600     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
400700      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
400800                       +
400900             H-CAPI-DOLLAR-THRESHOLD.
401000
401100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
401200         MOVE 0 TO H-CAPI-COST-OUTLIER.
401300
401400
401500***********************************************************
401600***  OPERATING COST CALCULATION
401700***  OPERATING COST CALCULATION
401800
401900     COMPUTE H-OPER-BILL-COSTS ROUNDED =
402000         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
402100         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
402200
402300
402400     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
402500         COMPUTE H-OPER-OUTCST-PART ROUNDED =
402600         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
402700                         H-OPER-COST-OUTLIER).
402800
402900     IF PAY-WITHOUT-COST OR
403000        PAY-XFER-NO-COST OR
403100        PAY-XFER-SPEC-DRG-NO-COST
403200         MOVE 0 TO H-OPER-OUTCST-PART.
403300
403400***********************************************************
403500***  CAPITAL COST CALCULATION
403600***  CAPITAL COST CALCULATION
403700
403800     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
403900             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
404000         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
404100
404200     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
404300         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
404400         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
404500                         H-CAPI-COST-OUTLIER).
404600
404700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
404800       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
404900              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
405000
405100     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
405200        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
405300               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
405400
405500     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
405600        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
405700        MOVE 0 TO H-CAPI-OUTCST-PART
405800                  H-OPER-OUTCST-PART.
405900
406000     IF PAY-WITHOUT-COST OR
406100        PAY-XFER-NO-COST OR
406200        PAY-XFER-SPEC-DRG-NO-COST
406300         MOVE 0 TO H-CAPI-OUTCST-PART.
406400
406500***********************************************************
406600***  DETERMINES THE BILL TO BE COST  OUTLIER
406700
406800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
406900         MOVE 0 TO H-CAPI-OUTDAY-PART
407000                   H-CAPI-OUTCST-PART.
407100
407200     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
407300                 MOVE H-OPER-OUTCST-PART TO
407400                      H-OPER-OUTLIER-PART
407500                 MOVE H-CAPI-OUTCST-PART TO
407600                      H-CAPI-OUTLIER-PART
407700                 MOVE 02 TO PPS-RTC.
407800
407900     IF OUTLIER-RECON-FLAG = 'Y'
408000        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
408100           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
408200           GO TO 3600-EXIT
408300        ELSE
408400           GO TO 3600-EXIT
408500     ELSE
408600        NEXT SENTENCE.
408700
408800
408900***********************************************************
409000***  DETERMINES IF COST OUTLIER
409100***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
409200***         RETURN CODE OF 02
409300
409400     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
409500
409600     IF PPS-RTC = 02
409700             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
409800                     (H-CAPI-COST-OUTLIER  +
409900                      H-OPER-COST-OUTLIER)
410000                             /
410100                    (H-CAPI-CSTCHG-RATIO  +
410200                     H-OPER-CSTCHG-RATIO)
410300             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
410400
410500***********************************************************
410600***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
410700***         RETURN CODE OF 67
410800
410900     IF PPS-RTC = 02
411000         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
411100            PPS-PC-COT-FLAG = 'Y'
411200             MOVE 67 TO PPS-RTC.
411300***********************************************************
411400
411500***********************************************************
411600***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
411700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
411800
411900     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
412000        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
412100                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
412200         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
412300
412400     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
412500        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
412600                H-CAPI-OUTLIER-PART.
412700
412800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
412900        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
413000                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
413100         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
413200
413300 3600-EXIT.   EXIT.
413400
413500 3450-CALC-ADDITIONAL-HSP.
413600***********************************************************
413700*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
413800*    SOLE COMMUNITY
413900*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
414000*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
414100***********************************************************
414200*****YEARCHANGE 2010.0 ****************************************
414300***         GET THE UPDATING FACTOR
414400***         GET THE UPDATING FACTOR
414500
414600     MOVE 0.995743 TO H-BUDG-NUTR08.
414700     MOVE 0.998795 TO H-BUDG-NUTR09.
414800*****YEARCHANGE 2010.0 ****************************************
414900     MOVE 0.997941 TO H-BUDG-NUTR10.
415000*****YEARCHANGE 2010.9 ****************************************
415100     MOVE 0.997935 TO H-BUDG-NUTR109.
415200*****YEARCHANGE 2011.0 ****************************************
415300     MOVE 0.996731 TO H-BUDG-NUTR113.
415400*****YEARCHANGE 2011.0 ****************************************
415500
415600     MOVE 1.0330 TO H-UPDATE-08.
415700
415800*****YEARCHANGE 2009.0 ****************************************
415900     MOVE 1.0360 TO H-UPDATE-09.
416000*****YEARCHANGE 2009.0 ****************************************
416100*****YEARCHANGE 2010.0 ****************************************
416200        MOVE 1.0210 TO H-UPDATE-10
416300*****YEARCHANGE 2010.0 ****************************************
416400*****YEARCHANGE 2010.9 ****************************************
416500        MOVE 1.0185 TO H-UPDATE-109
416600*****YEARCHANGE 2010.9 ****************************************
416700
416800     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
416900*****YEARCHANGE 2011.0 ****************************************
417000        MOVE 1.0235 TO H-UPDATE-113
417100     ELSE
417200        MOVE 1.0025 TO H-UPDATE-113.
417300*****YEARCHANGE 2011.0 ****************************************
417400
417500     IF P-NEW-STATE = 40
417600*****YEARCHANGE 2010.96****************************************
417700        MOVE 1.0210 TO H-UPDATE-109.
417800*****YEARCHANGE 2010.9 ****************************************
417900
418000     IF P-NEW-STATE = 40
418100*****YEARCHANGE 2011.0 ****************************************
418200        MOVE 1.0235 TO H-UPDATE-113.
418300*****YEARCHANGE 2011.0 ****************************************
418400
418500********YEARCHANGE 2011.0 *************************************
418600***         CASE MIX ADJUSTMENT - BROUGHT BACK FOR 2011
418700***         CASE MIX ADJUSTMENT - BROUGHT BACK FOR 2011
418800     MOVE 0.9718 TO H-CASE-MIX-ADJ.
418900
419000     COMPUTE H-UPDATE-FACTOR ROUNDED =
419100                       (H-UPDATE-08 * H-UPDATE-09 *
419200                        H-UPDATE-109 * H-UPDATE-113 *
419300                        H-BUDG-NUTR08 * H-BUDG-NUTR09 *
419400                        H-BUDG-NUTR109 * H-BUDG-NUTR113 *
419500                        H-CASE-MIX-ADJ).
419600
419700     COMPUTE H-HSP-RATE ROUNDED =
419800         H-FAC-SPEC-RATE * H-UPDATE-FACTOR * H-DRG-WT.
419900***************************************************************
420000*
420100*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
420200*       COMPUTE H-HSP-RATE ROUNDED =
420300*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
420400*    ELSE
420500*       COMPUTE H-HSP-RATE ROUNDED =
420600*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
420700*
420800***************************************************************
420900********YEARCHANGE 2011.0 *************************************
421000***     OUTLIER OFFSETS
421100***     OPERATING NATIONAL
421200***     OPERATING PUERTO RICO BLEND
421300
421400********YEARCHANGE 2011.0 *************************************
421500
421600      MOVE 0.948999 TO H-OUTLIER-OFFSET-NAT
421700      MOVE 0.948079 TO H-OUTLIER-OFFSET-PR.
421800
421900********YEARCHANGE 2011.0 *************************************
422000***************************************************************
422100     COMPUTE H-FSP-RATE ROUNDED =
422200        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
422300         H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT)
422400                           *
422500     (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
422600                         H-OPER-OUTLIER-PART
422700                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
422800
422900     IF P-NEW-STATE = 40
423000       COMPUTE H-FSP-RATE ROUNDED =
423100         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
423200         H-NAT-NONLABOR * H-OPER-COLA))  * H-DRG-WT)
423300                           *
423400         (1 + H-OPER-IME-TEACH + H-OPER-DSH) +
423500                            H-OPER-OUTLIER-PART
423600                               +
423700        ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
423800         H-REG-NONLABOR * H-OPER-COLA)) * H-DRG-WT)
423900                           *
424000       (1 + H-OPER-IME-TEACH + H-OPER-DSH)
424100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
424200
424300
424400     IF  H-HSP-RATE > H-FSP-RATE
424500           COMPUTE H-OPER-HSP-PART ROUNDED =
424600             (H-HSP-RATE - H-FSP-RATE)
424700                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
424800     ELSE
424900         MOVE 0 TO H-OPER-HSP-PART.
425000
425100***************************************************************
425200***         GET THE MDH REBASE
425300
425400     IF  H-HSP-RATE > H-FSP-RATE
425500         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
425600           COMPUTE H-OPER-HSP-PART ROUNDED =
425700             (H-HSP-RATE - H-FSP-RATE) * .75
425800                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
425900
426000***********************************************************
426100 3800-CALC-TOT-AMT.
426200***********************************************************
426300***  CALCULATE TOTALS FOR CAPITAL
426400***  CALCULATE TOTALS FOR CAPITAL
426500
426600     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
426700
426800     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
426900        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
427000        MOVE 0.00 TO H-CAPI-HSP-PCT.
427100
427200     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
427300        MOVE 0    TO H-CAPI-OLD-HARMLESS
427400        MOVE 1.00 TO H-CAPI-FSP-PCT
427500        MOVE 0.00 TO H-CAPI-HSP-PCT.
427600
427700     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
427800        MOVE 0    TO H-CAPI-OLD-HARMLESS
427900        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
428000        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
428100
428200     COMPUTE H-CAPI-HSP ROUNDED =
428300         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
428400
428500     COMPUTE H-CAPI-FSP ROUNDED =
428600         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
428700
428800     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
428900
429000     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
429100
429200     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
429300             H-CAPI-FSP
429400              * H-CAPI-DSH.
429500
429600     COMPUTE H-CAPI-IME-ADJ ROUNDED =
429700          H-CAPI-FSP *
429800                 H-WK-CAPI-IME-TEACH.
429900
430000     COMPUTE H-CAPI-OUTLIER ROUNDED =
430100             1.00 * H-CAPI-OUTLIER-PART.
430200
430300     COMPUTE H-CAPI2-B-FSP ROUNDED =
430400             1.00 * H-CAPI2-B-FSP-PART.
430500
430600     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
430700             1.00 * H-CAPI2-B-OUTLIER-PART.
430800***********************************************************
430900***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
431000***        THIS ZEROES OUT ALL CAPITAL DATA
431100
431200     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
431300        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
431400***********************************************************
431500
431600***********************************************************
431700***  CALCULATE FINAL TOTALS FOR OPERATING
431800***  CALCULATE FINAL TOTALS FOR OPERATING
431900
432000     IF (H-CAPI-OUTLIER > 0 AND
432100         PPS-OPER-OUTLIER-PART = 0)
432200            COMPUTE PPS-OPER-OUTLIER-PART =
432300                    PPS-OPER-OUTLIER-PART + .01.
432400
432500     MOVE 01.000 TO WK-LOW-VOL25PCT.
432600
432700     IF P-NEW-TEMP-RELIEF-IND = 'Y'
432800     MOVE P-NEW-PROVIDER-NO      TO MES-PPS-PROV
432900     PERFORM 4400-LOWVOL-CODE-RTN THRU 4400-EXIT.
433000
433100*****SET THE LOW-VOLUME DISCHARGE PERCENT
433200**   ADD ON TO 25% FOR DISCHARGES
433300
433400     IF P-NEW-TEMP-RELIEF-IND = 'Y'
433500     AND MESWK-LOWVOL-PROV-DISCHG <= 200
433600            MOVE 00.250 TO WK-LOW-VOL25PCT
433700            GO TO LOW-VOL-CALC.
433800
433900***  CALCULATE THE LOW VOLUME DISCHARGE PERCENT
434000***  SLIDING SCALE ADD ON FOR
434100
434200     IF P-NEW-TEMP-RELIEF-IND = 'Y'
434300        AND MESWK-LOWVOL-PROV-DISCHG > 200
434400        AND MESWK-LOWVOL-PROV-DISCHG < 1600
434500            COMPUTE  WK-LOW-VOL25PCT ROUNDED =
434600            ((4 / 14) - (MESWK-LOWVOL-PROV-DISCHG / 5600))
434700            GO TO LOW-VOL-CALC
434800     ELSE
434900           MOVE 01.000 TO WK-LOW-VOL25PCT.
435000
435100 LOW-VOL-CALC.
435200
435300     MOVE ZERO TO PPS-OPER-DSH-ADJ.
435400
435500     IF  H-OPER-DSH NUMERIC
435600         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
435700                          PPS-OPER-FSP-PART  * H-OPER-DSH.
435800
435900     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
436000                         PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
436100
436200
436300     COMPUTE PPS-OPER-FSP-PART ROUNDED =
436400                           H-OPER-FSP-PART * H-OPER-FSP-PCT.
436500
436600     COMPUTE PPS-OPER-HSP-PART ROUNDED =
436700                           H-OPER-HSP-PART * H-OPER-HSP-PCT.
436800
436900     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
437000                         H-OPER-OUTLIER-PART * H-OPER-FSP-PCT.
437100
437200     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
437300                                H-NEW-TECH-PAY-ADD-ON.
437400
437500     IF  WK-LOW-VOL25PCT < 1.000000
437600     COMPUTE WK-LOW-VOL-ADDON  ROUNDED =
437700              (PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
437800               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
437900                      PPS-OPER-IME-ADJ
438000                           +
438100             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
438200             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
438300             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM +
438400                 PPS-NEW-TECH-PAY-ADD-ON) *  WK-LOW-VOL25PCT
438500     ELSE
438600     COMPUTE WK-LOW-VOL-ADDON  ROUNDED = 0.000000.
438700
438800     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
438900
439000     IF HMO-TAG  = 'Y'
439100        PERFORM 3850-HMO-IME-ADJ.
439200
439300***********************************************************
439400***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
439500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
439600
439700     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
439800             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
439900             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
440000             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
440100
440200     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
440300               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
440400               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
440500                      PPS-OPER-IME-ADJ
440600                           +
440700                 PPS-NEW-TECH-PAY-ADD-ON
440800                           +
440900                  WK-LOW-VOL-ADDON
441000                           +
441100                 H-WK-PASS-AMT-PLUS-MISC
441200                           +
441300                   H-CAPI-TOTAL-PAY.
441400
441500 3800-EXIT.   EXIT.
441600
441700 3850-HMO-IME-ADJ.
441800***********************************************************
441900***  HMO CALC FOR PASS-THRU ADDON
442000***  HMO CALC FOR PASS-THRU ADDON
442100
442200     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
442300          (P-NEW-PASS-AMT-PLUS-MISC -
442400          (P-NEW-PASS-AMT-ORGAN-ACQ +
442500           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
442600
442700***********************************************************
442800***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
442900
443000     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
443100                   PPS-OPER-IME-ADJ * .0.
443200
443300***********************************************************
443400
443500
443600 3900A-CALC-OPER-DSH.
443700
443800***  OPERATING DSH CALCULATION
443900***  OPERATING DSH CALCULATION
444000
444100      MOVE 0.0000 TO H-OPER-DSH.
444200
444300      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
444400                                     + P-NEW-MEDICAID-RATIO).
444500
444600***********************************************************
444700**1**    0-99 BEDS
444800***  NOT TO EXCEED 12%
444900
445000      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
445100                               AND H-WK-OPER-DSH > .1499
445200                               AND H-WK-OPER-DSH < .2020
445300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
445400                                      * .65 + .025
445500        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
445600
445700      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
445800                               AND H-WK-OPER-DSH > .2019
445900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
446000                                      * .825 + .0588
446100        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
446200
446300***********************************************************
446400**2**   100 + BEDS
446500***  NO CAP >> CAN EXCEED 12%
446600
446700      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
446800                               AND H-WK-OPER-DSH > .1499
446900                               AND H-WK-OPER-DSH < .2020
447000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
447100                                      * .65 + .025.
447200
447300      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
447400                               AND H-WK-OPER-DSH > .2019
447500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
447600                                      * .825 + .0588.
447700
447800***********************************************************
447900**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
448000***  NOT TO EXCEED 12%
448100
448200      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
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
448800              MOVE .1200 TO H-OPER-DSH.
448900
449000      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
449100                               AND H-WK-OPER-DSH > .2019
449200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
449300                                 * .825 + .0588
449400        IF H-OPER-DSH > .1200
449500                 MOVE .1200 TO H-OPER-DSH.
449600***********************************************************
449700**4**   OTHER RURAL HOSPITALS 500 BEDS +
449800***  NO CAP >> CAN EXCEED 12%
449900
450000      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
450100                               AND H-WK-OPER-DSH > .1499
450200                               AND H-WK-OPER-DSH < .2020
450300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
450400                                 * .65 + .025.
450500
450600      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
450700                               AND H-WK-OPER-DSH > .2019
450800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
450900                                 * .825 + .0588.
451000
451100***********************************************************
451200**7**   RURAL HOSPITALS SCH
451300***  NOT TO EXCEED 12%
451400
451500      IF W-CBSA-SIZE = 'R'
451600         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
451700                               AND H-WK-OPER-DSH > .1499
451800                               AND H-WK-OPER-DSH < .2020
451900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
452000                                 * .65 + .025
452100        IF H-OPER-DSH > .1200
452200                 MOVE .1200 TO H-OPER-DSH.
452300
452400      IF W-CBSA-SIZE = 'R'
452500         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
452600                               AND H-WK-OPER-DSH > .2019
452700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
452800                                 * .825 + .0588
452900        IF H-OPER-DSH > .1200
453000                 MOVE .1200 TO H-OPER-DSH.
453100
453200***********************************************************
453300**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
453400***  RRC OVERRIDES SCH CAP
453500***  NO CAP >> CAN EXCEED 12%
453600
453700         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
453800                                   '17' OR '22')
453900                               AND H-WK-OPER-DSH > .1499
454000                               AND H-WK-OPER-DSH < .2020
454100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
454200                                 * .65 + .025.
454300
454400         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
454500                                   '17' OR '22')
454600                               AND H-WK-OPER-DSH > .2019
454700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
454800                                 * .825 + .0588.
454900
455000      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
455100
455200 3900A-EXIT.   EXIT.
455300
455400 4000-CALC-TECH-ADDON.
455500
455600***********************************************************
455700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
455800***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
455900
456000     COMPUTE PPS-OPER-HSP-PART ROUNDED =
456100         H-OPER-HSP-PCT * H-OPER-HSP-PART.
456200
456300     COMPUTE PPS-OPER-FSP-PART ROUNDED =
456400         H-OPER-FSP-PCT * H-OPER-FSP-PART.
456500
456600     MOVE ZERO TO PPS-OPER-DSH-ADJ.
456700
456800     IF  H-OPER-DSH NUMERIC
456900             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
457000              PPS-OPER-FSP-PART
457100              * H-OPER-DSH.
457200
457300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
457400             PPS-OPER-FSP-PART *
457500             H-OPER-IME-TEACH.
457600
457700     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
457800             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
457900             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
458000
458100***********************************************************
458200****      NEUROSTIMULATOR CASES
458300***********************************************************
458400*
458500*    IF '8698   ' =  B-PRIN-PROC-CODE   OR
458600*                    B-OTHER-PROC-CODE1 OR
458700*                    B-OTHER-PROC-CODE2 OR
458800*                    B-OTHER-PROC-CODE3 OR
458900*                    B-OTHER-PROC-CODE4 OR
459000*                    B-OTHER-PROC-CODE5
459100*          NEXT SENTENCE
459200*    ELSE
459300*          MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO
459400*          GO TO 4000-CHECK-GRAFT-CASES.
459500*
459600*    MOVE 18640.00 TO H-CSTMED-NEURO.
459700*
459800*    COMPUTE H-LESSER-NEURO-1 ROUNDED =
459900*            .5   H-CSTMED-NEURO.
460000*
460100*    COMPUTE H-LESSER-NEURO-2 ROUNDED =
460200*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
460300*                    H-BASE-DRG-PAYMENT)   .5.
460400*
460500*    IF H-LESSER-NEURO-2 > 0
460600*       IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2
460700*          MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO
460800*       ELSE
460900*          MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO
461000*    ELSE
461100*       MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.
461200*
461300*4000-CHECK-GRAFT-CASES.
461400*
461500***********************************************************
461600***      GRAFT*(GORE*TAG)*CASES
461700***********************************************************
461800*
461900*    IF '3973   ' =  B-PRIN-PROC-CODE   OR
462000*                    B-OTHER-PROC-CODE1 OR
462100*                    B-OTHER-PROC-CODE2 OR
462200*                    B-OTHER-PROC-CODE3 OR
462300*                    B-OTHER-PROC-CODE4 OR
462400*                    B-OTHER-PROC-CODE5
462500*          NEXT SENTENCE
462600*    ELSE
462700*          MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT
462800*          GO TO 4000-CHECK-X-STOP.
462900*
463000*    MOVE 21198.00 TO H-CSTMED-GRAFT.
463100*
463200*    COMPUTE H-LESSER-GRAFT-1 ROUNDED =
463300*            .5   H-CSTMED-GRAFT.
463400*
463500*    COMPUTE H-LESSER-GRAFT-2 ROUNDED =
463600*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
463700*                    H-BASE-DRG-PAYMENT)   .5.
463800*
463900*    IF H-LESSER-GRAFT-2 > 0
464000*       IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2
464100*          MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT
464200*       ELSE
464300*          MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT
464400*    ELSE
464500*       MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.
464600*
464700*4000-CHECK-X-STOP.
464800*
464900***********************************************************
465000*****    X-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
465100***********************************************************
465200*
465300*    IF '8458   ' =  B-PRIN-PROC-CODE   OR
465400*                    B-OTHER-PROC-CODE1 OR
465500*                    B-OTHER-PROC-CODE2 OR
465600*                    B-OTHER-PROC-CODE3 OR
465700*                    B-OTHER-PROC-CODE4 OR
465800*                    B-OTHER-PROC-CODE5
465900*          NEXT SENTENCE
466000*    ELSE
466100*          MOVE ZEROES TO H-NEW-TECH-ADDON-X-STOP
466200*          GO TO 4000-ADD-TECH-CASES.
466300*
466400*    MOVE 8800.00 TO H-CSTMED-X-STOP.
466500*
466600*    COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =
466700*            .5   H-CSTMED-X-STOP.
466800*
466900*    COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =
467000*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
467100*                    H-BASE-DRG-PAYMENT)   .5.
467200*
467300*    IF H-LESSER-HRTIMP-STOP-2 > 0
467400*       IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2
467500*        MOVE H-LESSER-HRTIMP-STOP-1 TO H-NEW-TECH-ADDON-X-STOP
467600*       ELSE
467700*        MOVE H-LESSER-HRTIMP-STOP-2 TO H-NEW-TECH-ADDON-X-STOP
467800*    ELSE
467900*       MOVE ZEROES          TO H-NEW-TECH-ADDON-X-STOP.
468000*
468100*
468200*4000-ADD-TECH-CASES.
468300*
468400*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
468500*            H-NEW-TECH-ADDON-NEURO  +
468600*            H-NEW-TECH-ADDON-GRAFT +
468700*            H-NEW-TECH-ADDON-X-STOP.
468800*
468900***********************************************************
469000***** HRTIMP-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
469100***********************************************************
469200
469300     IF '3752   ' =  B-PRIN-PROC-CODE     OR
469400                     B-OTHER-PROC-CODE1   OR
469500                     B-OTHER-PROC-CODE2   OR
469600                     B-OTHER-PROC-CODE3   OR
469700                     B-OTHER-PROC-CODE4   OR
469800                     B-OTHER-PROC-CODE5   OR
469900                     B-OTHER-PROC-CODE6   OR
470000                     B-OTHER-PROC-CODE7   OR
470100                     B-OTHER-PROC-CODE8   OR
470200                     B-OTHER-PROC-CODE9   OR
470300                     B-OTHER-PROC-CODE10  OR
470400                     B-OTHER-PROC-CODE11  OR
470500                     B-OTHER-PROC-CODE12  OR
470600                     B-OTHER-PROC-CODE13  OR
470700                     B-OTHER-PROC-CODE14  OR
470800                     B-OTHER-PROC-CODE15  OR
470900                     B-OTHER-PROC-CODE16  OR
471000                     B-OTHER-PROC-CODE17  OR
471100                     B-OTHER-PROC-CODE18  OR
471200                     B-OTHER-PROC-CODE19  OR
471300                     B-OTHER-PROC-CODE20  OR
471400                     B-OTHER-PROC-CODE21  OR
471500                     B-OTHER-PROC-CODE22  OR
471600                     B-OTHER-PROC-CODE23  OR
471700                     B-OTHER-PROC-CODE24
471800           NEXT SENTENCE
471900     ELSE
472000           MOVE ZEROES TO H-NEW-TECH-ADDON-HRTIMP-STOP
472100           GO TO 4000-ADD-TECH-CASES.
472200
472300     MOVE 53000.00 TO H-CSTMED-HRTIMP-STOP.
472400
472500     COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =
472600                  H-CSTMED-HRTIMP-STOP.
472700
472800     COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =
472900          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
473000                     H-BASE-DRG-PAYMENT)) * .5.
473100
473200     IF H-LESSER-HRTIMP-STOP-2 > 0
473300        IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2
473400         MOVE H-LESSER-HRTIMP-STOP-1 TO
473500                                  H-NEW-TECH-ADDON-HRTIMP-STOP
473600        ELSE
473700         MOVE H-LESSER-HRTIMP-STOP-2 TO
473800                                  H-NEW-TECH-ADDON-HRTIMP-STOP
473900     ELSE
474000        MOVE ZEROES          TO H-NEW-TECH-ADDON-HRTIMP-STOP.
474100
474200
474300 4000-ADD-TECH-CASES.
474400
474500     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
474600             H-NEW-TECH-ADDON-HRTIMP-STOP.
474700*
474800***********************************************************
474900* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
475000
475100     IF   H-NEW-TECH-PAY-ADD-ON = 0
475200     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
475300
475400     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
475500             H-NEW-TECH-PAY-ADD-ON.
475600
475700     IF   H-NEW-TECH-PAY-ADD-ON = 0 AND
475800          B-DRG-SPIRATN-DRG
475900        PERFORM 4300-SPIRAT-TECH-ADD-ON THRU 4300-EXIT.
476000
476100     IF   H-NEW-TECH-PAY-ADD-ON = 0 AND
476200          B-DRG-SPIRATN-DRG11
476300        PERFORM 4310-SPIRAT-TECH-ADD-ON THRU 4310-EXIT.
476400
476500     IF   H-NEW-TECH-PAY-ADD-ON = 0 AND
476600          B-DRG-AUTOLITT-DRG
476700        PERFORM 4500-AUTOLIT-TECH-ADD-ON THRU 4500-EXIT.
476800
476900     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
477000             H-NEW-TECH-PAY-ADD-ON.
477100
477200*
477300 4000-EXIT.    EXIT.
477400***********************************************************
477500
477600 4100-ISLET-ISOLATION-ADD-ON.
477700***********************************************************
477800***  TECHNICAL TRANSPLANTATION OF CELLS
477900***
478000*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
478100*** ISLETS OF LANGERHAUS) AND
478200*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
478300*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
478400*** TIMES IN ANY OTHER PROC-CODE
478500***********************************************************
478600*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
478700*** V70.7
478800***********************************************************
478900
479000     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
479100               H-TECH-ADDON-ISLET-CNTR2.
479200
479300*    IF 'V707   ' =  B-PRIN-PROC-CODE   OR
479400*                    B-OTHER-PROC-CODE1 OR
479500*                    B-OTHER-PROC-CODE2 OR
479600*                    B-OTHER-PROC-CODE3 OR
479700*                    B-OTHER-PROC-CODE4 OR
479800*                    B-OTHER-PROC-CODE5
479900*          NEXT SENTENCE
480000*    ELSE
480100*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
480200*          GO TO 4100-ADD-TECH-CASES.
480300
480400     IF '5285   ' =  B-PRIN-PROC-CODE     OR
480500                     B-OTHER-PROC-CODE1   OR
480600                     B-OTHER-PROC-CODE2   OR
480700                     B-OTHER-PROC-CODE3   OR
480800                     B-OTHER-PROC-CODE4   OR
480900                     B-OTHER-PROC-CODE5   OR
481000                     B-OTHER-PROC-CODE6   OR
481100                     B-OTHER-PROC-CODE7   OR
481200                     B-OTHER-PROC-CODE8   OR
481300                     B-OTHER-PROC-CODE9   OR
481400                     B-OTHER-PROC-CODE10  OR
481500                     B-OTHER-PROC-CODE11  OR
481600                     B-OTHER-PROC-CODE12  OR
481700                     B-OTHER-PROC-CODE13  OR
481800                     B-OTHER-PROC-CODE14  OR
481900                     B-OTHER-PROC-CODE15  OR
482000                     B-OTHER-PROC-CODE16  OR
482100                     B-OTHER-PROC-CODE17  OR
482200                     B-OTHER-PROC-CODE18  OR
482300                     B-OTHER-PROC-CODE19  OR
482400                     B-OTHER-PROC-CODE20  OR
482500                     B-OTHER-PROC-CODE21  OR
482600                     B-OTHER-PROC-CODE22  OR
482700                     B-OTHER-PROC-CODE23  OR
482800                     B-OTHER-PROC-CODE24
482900           NEXT SENTENCE
483000     ELSE
483100           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
483200           GO TO 4100-ADD-TECH-CASES.
483300
483400     IF '5285   ' =  B-PRIN-PROC-CODE
483500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
483600                       H-TECH-ADDON-ISLET-CNTR + 1.
483700
483800     IF '5285   ' =  B-OTHER-PROC-CODE1
483900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
484000                       H-TECH-ADDON-ISLET-CNTR + 1.
484100
484200     IF '5285   ' =  B-OTHER-PROC-CODE2
484300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
484400                       H-TECH-ADDON-ISLET-CNTR + 1.
484500
484600     IF '5285   ' =  B-OTHER-PROC-CODE3
484700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
484800                       H-TECH-ADDON-ISLET-CNTR + 1.
484900
485000     IF '5285   ' =  B-OTHER-PROC-CODE4
485100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
485200                       H-TECH-ADDON-ISLET-CNTR + 1.
485300
485400
485500     IF '5285   ' =  B-OTHER-PROC-CODE5
485600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
485700                       H-TECH-ADDON-ISLET-CNTR + 1.
485800
485900     IF '5285   ' =  B-OTHER-PROC-CODE6
486000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
486100                       H-TECH-ADDON-ISLET-CNTR + 1.
486200
486300     IF '5285   ' =  B-OTHER-PROC-CODE7
486400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
486500                       H-TECH-ADDON-ISLET-CNTR + 1.
486600
486700     IF '5285   ' =  B-OTHER-PROC-CODE8
486800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
486900                       H-TECH-ADDON-ISLET-CNTR + 1.
487000
487100     IF '5285   ' =  B-OTHER-PROC-CODE9
487200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
487300                       H-TECH-ADDON-ISLET-CNTR + 1.
487400
487500     IF '5285   ' =  B-OTHER-PROC-CODE10
487600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
487700                       H-TECH-ADDON-ISLET-CNTR + 1.
487800
487900     IF '5285   ' =  B-OTHER-PROC-CODE11
488000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
488100                       H-TECH-ADDON-ISLET-CNTR + 1.
488200
488300     IF '5285   ' =  B-OTHER-PROC-CODE12
488400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
488500                       H-TECH-ADDON-ISLET-CNTR + 1.
488600
488700     IF '5285   ' =  B-OTHER-PROC-CODE13
488800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
488900                       H-TECH-ADDON-ISLET-CNTR + 1.
489000
489100     IF '5285   ' =  B-OTHER-PROC-CODE14
489200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
489300                       H-TECH-ADDON-ISLET-CNTR + 1.
489400
489500     IF '5285   ' =  B-OTHER-PROC-CODE15
489600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
489700                       H-TECH-ADDON-ISLET-CNTR + 1.
489800
489900     IF '5285   ' =  B-OTHER-PROC-CODE16
490000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
490100                       H-TECH-ADDON-ISLET-CNTR + 1.
490200
490300     IF '5285   ' =  B-OTHER-PROC-CODE17
490400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
490500                       H-TECH-ADDON-ISLET-CNTR + 1.
490600
490700     IF '5285   ' =  B-OTHER-PROC-CODE18
490800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
490900                       H-TECH-ADDON-ISLET-CNTR + 1.
491000
491100     IF '5285   ' =  B-OTHER-PROC-CODE19
491200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
491300                       H-TECH-ADDON-ISLET-CNTR + 1.
491400
491500     IF '5285   ' =  B-OTHER-PROC-CODE20
491600      COMPUTE H-TECH-ADDON-ISLET-CNTR =
491700                       H-TECH-ADDON-ISLET-CNTR + 1.
491800
491900     IF '5285   ' =  B-OTHER-PROC-CODE21
492000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
492100                       H-TECH-ADDON-ISLET-CNTR + 1.
492200
492300     IF '5285   ' =  B-OTHER-PROC-CODE22
492400      COMPUTE H-TECH-ADDON-ISLET-CNTR =
492500                       H-TECH-ADDON-ISLET-CNTR + 1.
492600
492700     IF '5285   ' =  B-OTHER-PROC-CODE23
492800      COMPUTE H-TECH-ADDON-ISLET-CNTR =
492900                       H-TECH-ADDON-ISLET-CNTR + 1.
493000
493100     IF '5285   ' =  B-OTHER-PROC-CODE24
493200      COMPUTE H-TECH-ADDON-ISLET-CNTR =
493300                       H-TECH-ADDON-ISLET-CNTR + 1.
493400
493500
493600*    IF 'V707   ' =  B-PRIN-PROC-CODE
493700*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
493800*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
493900*
494000*    IF 'V707   ' =  B-OTHER-PROC-CODE1
494100*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
494200*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
494300*
494400*    IF 'V707   ' =  B-OTHER-PROC-CODE2
494500*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
494600*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
494700*
494800*    IF 'V707   ' =  B-OTHER-PROC-CODE3
494900*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
495000*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
495100*
495200*    IF 'V707   ' =  B-OTHER-PROC-CODE4
495300*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
495400*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
495500*
495600*    IF 'V707   ' =  B-OTHER-PROC-CODE5
495700*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
495800*                    H-TECH-ADDON-ISLET-CNTR2 + 1.
495900*
496000*    IF  H-TECH-ADDON-ISLET-CNTR2 > 0
496100*          NEXT SENTENCE
496200*    ELSE
496300*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
496400*          GO TO 4100-ADD-TECH-CASES.
496500
496600     IF  H-TECH-ADDON-ISLET-CNTR = 1
496700     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
496800           GO TO 4100-ADD-TECH-CASES.
496900
497000     IF  H-TECH-ADDON-ISLET-CNTR > 1
497100     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
497200           GO TO 4100-ADD-TECH-CASES.
497300
497400     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
497500
497600
497700 4100-ADD-TECH-CASES.
497800
497900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
498000             H-NEW-TECH-ADDON-ISLET.
498100
498200 4100-EXIT.    EXIT.
498300
498400*
498500*4200-SSRFBN-CODE-RTN.
498600*    SET SSRFBN-IDX TO 1.
498700*    SEARCH SSRFBN-TAB VARYING SSRFBN-IDX
498800*        AT END
498900*          MOVE ' NO SSRFBN MESSAGE FOUND' TO MES-SSRFBN
499000*      WHEN WK-SSRFBN-STATE(SSRFBN-IDX) = MES-PPS-STATE
499100*        MOVE WK-SSRFBN-REASON-ALL (SSRFBN-IDX) TO MES-SSRFBN.
499200*
499300*4200-EXIT.   EXIT.
499400*
499500 4300-SPIRAT-TECH-ADD-ON.
499600***********************************************************
499700***** SPIRAT-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
499800***********************************************************
499900
500000     IF '3371   ' =  B-PRIN-PROC-CODE     OR
500100                     B-OTHER-PROC-CODE1   OR
500200                     B-OTHER-PROC-CODE2   OR
500300                     B-OTHER-PROC-CODE3   OR
500400                     B-OTHER-PROC-CODE4   OR
500500                     B-OTHER-PROC-CODE5   OR
500600                     B-OTHER-PROC-CODE6   OR
500700                     B-OTHER-PROC-CODE7   OR
500800                     B-OTHER-PROC-CODE8   OR
500900                     B-OTHER-PROC-CODE9   OR
501000                     B-OTHER-PROC-CODE10  OR
501100                     B-OTHER-PROC-CODE11  OR
501200                     B-OTHER-PROC-CODE12  OR
501300                     B-OTHER-PROC-CODE13  OR
501400                     B-OTHER-PROC-CODE14  OR
501500                     B-OTHER-PROC-CODE15  OR
501600                     B-OTHER-PROC-CODE16  OR
501700                     B-OTHER-PROC-CODE17  OR
501800                     B-OTHER-PROC-CODE18  OR
501900                     B-OTHER-PROC-CODE19  OR
502000                     B-OTHER-PROC-CODE20  OR
502100                     B-OTHER-PROC-CODE21  OR
502200                     B-OTHER-PROC-CODE22  OR
502300                     B-OTHER-PROC-CODE23  OR
502400                     B-OTHER-PROC-CODE24
502500        IF '3222   ' =  B-PRIN-PROC-CODE     OR
502600                        B-OTHER-PROC-CODE1   OR
502700                        B-OTHER-PROC-CODE2   OR
502800                        B-OTHER-PROC-CODE3   OR
502900                        B-OTHER-PROC-CODE4   OR
503000                        B-OTHER-PROC-CODE5   OR
503100                        B-OTHER-PROC-CODE6   OR
503200                        B-OTHER-PROC-CODE7   OR
503300                        B-OTHER-PROC-CODE8   OR
503400                        B-OTHER-PROC-CODE9   OR
503500                        B-OTHER-PROC-CODE10  OR
503600                        B-OTHER-PROC-CODE11  OR
503700                        B-OTHER-PROC-CODE12  OR
503800                        B-OTHER-PROC-CODE13  OR
503900                        B-OTHER-PROC-CODE14  OR
504000                        B-OTHER-PROC-CODE15  OR
504100                        B-OTHER-PROC-CODE16  OR
504200                        B-OTHER-PROC-CODE17  OR
504300                        B-OTHER-PROC-CODE18  OR
504400                        B-OTHER-PROC-CODE19  OR
504500                        B-OTHER-PROC-CODE20  OR
504600                        B-OTHER-PROC-CODE21  OR
504700                        B-OTHER-PROC-CODE22  OR
504800                        B-OTHER-PROC-CODE23  OR
504900                        B-OTHER-PROC-CODE24
505000           GO TO 4300-COMPUTE-SPIRAT
505100        ELSE
505200        IF '3230   ' =  B-PRIN-PROC-CODE     OR
505300                        B-OTHER-PROC-CODE1   OR
505400                        B-OTHER-PROC-CODE2   OR
505500                        B-OTHER-PROC-CODE3   OR
505600                        B-OTHER-PROC-CODE4   OR
505700                        B-OTHER-PROC-CODE5   OR
505800                        B-OTHER-PROC-CODE6   OR
505900                        B-OTHER-PROC-CODE7   OR
506000                        B-OTHER-PROC-CODE8   OR
506100                        B-OTHER-PROC-CODE9   OR
506200                        B-OTHER-PROC-CODE10  OR
506300                        B-OTHER-PROC-CODE11  OR
506400                        B-OTHER-PROC-CODE12  OR
506500                        B-OTHER-PROC-CODE13  OR
506600                        B-OTHER-PROC-CODE14  OR
506700                        B-OTHER-PROC-CODE15  OR
506800                        B-OTHER-PROC-CODE16  OR
506900                        B-OTHER-PROC-CODE17  OR
507000                        B-OTHER-PROC-CODE18  OR
507100                        B-OTHER-PROC-CODE19  OR
507200                        B-OTHER-PROC-CODE20  OR
507300                        B-OTHER-PROC-CODE21  OR
507400                        B-OTHER-PROC-CODE22  OR
507500                        B-OTHER-PROC-CODE23  OR
507600                        B-OTHER-PROC-CODE24
507700           GO TO 4300-COMPUTE-SPIRAT
507800        ELSE
507900        IF '3239   ' =  B-PRIN-PROC-CODE     OR
508000                        B-OTHER-PROC-CODE1   OR
508100                        B-OTHER-PROC-CODE2   OR
508200                        B-OTHER-PROC-CODE3   OR
508300                        B-OTHER-PROC-CODE4   OR
508400                        B-OTHER-PROC-CODE5   OR
508500                        B-OTHER-PROC-CODE6   OR
508600                        B-OTHER-PROC-CODE7   OR
508700                        B-OTHER-PROC-CODE8   OR
508800                        B-OTHER-PROC-CODE9   OR
508900                        B-OTHER-PROC-CODE10  OR
509000                        B-OTHER-PROC-CODE11  OR
509100                        B-OTHER-PROC-CODE12  OR
509200                        B-OTHER-PROC-CODE13  OR
509300                        B-OTHER-PROC-CODE14  OR
509400                        B-OTHER-PROC-CODE15  OR
509500                        B-OTHER-PROC-CODE16  OR
509600                        B-OTHER-PROC-CODE17  OR
509700                        B-OTHER-PROC-CODE18  OR
509800                        B-OTHER-PROC-CODE19  OR
509900                        B-OTHER-PROC-CODE20  OR
510000                        B-OTHER-PROC-CODE21  OR
510100                        B-OTHER-PROC-CODE22  OR
510200                        B-OTHER-PROC-CODE23  OR
510300                        B-OTHER-PROC-CODE24
510400           GO TO 4300-COMPUTE-SPIRAT
510500        ELSE
510600        IF '3241   ' =  B-PRIN-PROC-CODE     OR
510700                        B-OTHER-PROC-CODE1   OR
510800                        B-OTHER-PROC-CODE2   OR
510900                        B-OTHER-PROC-CODE3   OR
511000                        B-OTHER-PROC-CODE4   OR
511100                        B-OTHER-PROC-CODE5   OR
511200                        B-OTHER-PROC-CODE6   OR
511300                        B-OTHER-PROC-CODE7   OR
511400                        B-OTHER-PROC-CODE8   OR
511500                        B-OTHER-PROC-CODE9   OR
511600                        B-OTHER-PROC-CODE10  OR
511700                        B-OTHER-PROC-CODE11  OR
511800                        B-OTHER-PROC-CODE12  OR
511900                        B-OTHER-PROC-CODE13  OR
512000                        B-OTHER-PROC-CODE14  OR
512100                        B-OTHER-PROC-CODE15  OR
512200                        B-OTHER-PROC-CODE16  OR
512300                        B-OTHER-PROC-CODE17  OR
512400                        B-OTHER-PROC-CODE18  OR
512500                        B-OTHER-PROC-CODE19  OR
512600                        B-OTHER-PROC-CODE20  OR
512700                        B-OTHER-PROC-CODE21  OR
512800                        B-OTHER-PROC-CODE22  OR
512900                        B-OTHER-PROC-CODE23  OR
513000                        B-OTHER-PROC-CODE24
513100           GO TO 4300-COMPUTE-SPIRAT
513200        ELSE
513300        IF '3249   ' =  B-PRIN-PROC-CODE     OR
513400                        B-OTHER-PROC-CODE1   OR
513500                        B-OTHER-PROC-CODE2   OR
513600                        B-OTHER-PROC-CODE3   OR
513700                        B-OTHER-PROC-CODE4   OR
513800                        B-OTHER-PROC-CODE5   OR
513900                        B-OTHER-PROC-CODE6   OR
514000                        B-OTHER-PROC-CODE7   OR
514100                        B-OTHER-PROC-CODE8   OR
514200                        B-OTHER-PROC-CODE9   OR
514300                        B-OTHER-PROC-CODE10  OR
514400                        B-OTHER-PROC-CODE11  OR
514500                        B-OTHER-PROC-CODE12  OR
514600                        B-OTHER-PROC-CODE13  OR
514700                        B-OTHER-PROC-CODE14  OR
514800                        B-OTHER-PROC-CODE15  OR
514900                        B-OTHER-PROC-CODE16  OR
515000                        B-OTHER-PROC-CODE17  OR
515100                        B-OTHER-PROC-CODE18  OR
515200                        B-OTHER-PROC-CODE19  OR
515300                        B-OTHER-PROC-CODE20  OR
515400                        B-OTHER-PROC-CODE21  OR
515500                        B-OTHER-PROC-CODE22  OR
515600                        B-OTHER-PROC-CODE23  OR
515700                        B-OTHER-PROC-CODE24
515800           GO TO 4300-COMPUTE-SPIRAT
515900     ELSE
516000           NEXT SENTENCE.
516100
516200     IF '3373   ' =  B-PRIN-PROC-CODE     OR
516300                     B-OTHER-PROC-CODE1   OR
516400                     B-OTHER-PROC-CODE2   OR
516500                     B-OTHER-PROC-CODE3   OR
516600                     B-OTHER-PROC-CODE4   OR
516700                     B-OTHER-PROC-CODE5   OR
516800                     B-OTHER-PROC-CODE6   OR
516900                     B-OTHER-PROC-CODE7   OR
517000                     B-OTHER-PROC-CODE8   OR
517100                     B-OTHER-PROC-CODE9   OR
517200                     B-OTHER-PROC-CODE10  OR
517300                     B-OTHER-PROC-CODE11  OR
517400                     B-OTHER-PROC-CODE12  OR
517500                     B-OTHER-PROC-CODE13  OR
517600                     B-OTHER-PROC-CODE14  OR
517700                     B-OTHER-PROC-CODE15  OR
517800                     B-OTHER-PROC-CODE16  OR
517900                     B-OTHER-PROC-CODE17  OR
518000                     B-OTHER-PROC-CODE18  OR
518100                     B-OTHER-PROC-CODE19  OR
518200                     B-OTHER-PROC-CODE20  OR
518300                     B-OTHER-PROC-CODE21  OR
518400                     B-OTHER-PROC-CODE22  OR
518500                     B-OTHER-PROC-CODE23  OR
518600                     B-OTHER-PROC-CODE24
518700        IF '3222   ' =  B-PRIN-PROC-CODE     OR
518800                        B-OTHER-PROC-CODE1   OR
518900                        B-OTHER-PROC-CODE2   OR
519000                        B-OTHER-PROC-CODE3   OR
519100                        B-OTHER-PROC-CODE4   OR
519200                        B-OTHER-PROC-CODE5   OR
519300                        B-OTHER-PROC-CODE6   OR
519400                        B-OTHER-PROC-CODE7   OR
519500                        B-OTHER-PROC-CODE8   OR
519600                        B-OTHER-PROC-CODE9   OR
519700                        B-OTHER-PROC-CODE10  OR
519800                        B-OTHER-PROC-CODE11  OR
519900                        B-OTHER-PROC-CODE12  OR
520000                        B-OTHER-PROC-CODE13  OR
520100                        B-OTHER-PROC-CODE14  OR
520200                        B-OTHER-PROC-CODE15  OR
520300                        B-OTHER-PROC-CODE16  OR
520400                        B-OTHER-PROC-CODE17  OR
520500                        B-OTHER-PROC-CODE18  OR
520600                        B-OTHER-PROC-CODE19  OR
520700                        B-OTHER-PROC-CODE20  OR
520800                        B-OTHER-PROC-CODE21  OR
520900                        B-OTHER-PROC-CODE22  OR
521000                        B-OTHER-PROC-CODE23  OR
521100                        B-OTHER-PROC-CODE24
521200           GO TO 4300-COMPUTE-SPIRAT
521300        ELSE
521400        IF '3230   ' =  B-PRIN-PROC-CODE     OR
521500                        B-OTHER-PROC-CODE1   OR
521600                        B-OTHER-PROC-CODE2   OR
521700                        B-OTHER-PROC-CODE3   OR
521800                        B-OTHER-PROC-CODE4   OR
521900                        B-OTHER-PROC-CODE5   OR
522000                        B-OTHER-PROC-CODE6   OR
522100                        B-OTHER-PROC-CODE7   OR
522200                        B-OTHER-PROC-CODE8   OR
522300                        B-OTHER-PROC-CODE9   OR
522400                        B-OTHER-PROC-CODE10  OR
522500                        B-OTHER-PROC-CODE11  OR
522600                        B-OTHER-PROC-CODE12  OR
522700                        B-OTHER-PROC-CODE13  OR
522800                        B-OTHER-PROC-CODE14  OR
522900                        B-OTHER-PROC-CODE15  OR
523000                        B-OTHER-PROC-CODE16  OR
523100                        B-OTHER-PROC-CODE17  OR
523200                        B-OTHER-PROC-CODE18  OR
523300                        B-OTHER-PROC-CODE19  OR
523400                        B-OTHER-PROC-CODE20  OR
523500                        B-OTHER-PROC-CODE21  OR
523600                        B-OTHER-PROC-CODE22  OR
523700                        B-OTHER-PROC-CODE23  OR
523800                        B-OTHER-PROC-CODE24
523900           GO TO 4300-COMPUTE-SPIRAT
524000        ELSE
524100        IF '3239   ' =  B-PRIN-PROC-CODE     OR
524200                        B-OTHER-PROC-CODE1   OR
524300                        B-OTHER-PROC-CODE2   OR
524400                        B-OTHER-PROC-CODE3   OR
524500                        B-OTHER-PROC-CODE4   OR
524600                        B-OTHER-PROC-CODE5   OR
524700                        B-OTHER-PROC-CODE6   OR
524800                        B-OTHER-PROC-CODE7   OR
524900                        B-OTHER-PROC-CODE8   OR
525000                        B-OTHER-PROC-CODE9   OR
525100                        B-OTHER-PROC-CODE10  OR
525200                        B-OTHER-PROC-CODE11  OR
525300                        B-OTHER-PROC-CODE12  OR
525400                        B-OTHER-PROC-CODE13  OR
525500                        B-OTHER-PROC-CODE14  OR
525600                        B-OTHER-PROC-CODE15  OR
525700                        B-OTHER-PROC-CODE16  OR
525800                        B-OTHER-PROC-CODE17  OR
525900                        B-OTHER-PROC-CODE18  OR
526000                        B-OTHER-PROC-CODE19  OR
526100                        B-OTHER-PROC-CODE20  OR
526200                        B-OTHER-PROC-CODE21  OR
526300                        B-OTHER-PROC-CODE22  OR
526400                        B-OTHER-PROC-CODE23  OR
526500                        B-OTHER-PROC-CODE24
526600           GO TO 4300-COMPUTE-SPIRAT
526700        ELSE
526800        IF '3241   ' =  B-PRIN-PROC-CODE     OR
526900                        B-OTHER-PROC-CODE1   OR
527000                        B-OTHER-PROC-CODE2   OR
527100                        B-OTHER-PROC-CODE3   OR
527200                        B-OTHER-PROC-CODE4   OR
527300                        B-OTHER-PROC-CODE5   OR
527400                        B-OTHER-PROC-CODE6   OR
527500                        B-OTHER-PROC-CODE7   OR
527600                        B-OTHER-PROC-CODE8   OR
527700                        B-OTHER-PROC-CODE9   OR
527800                        B-OTHER-PROC-CODE10  OR
527900                        B-OTHER-PROC-CODE11  OR
528000                        B-OTHER-PROC-CODE12  OR
528100                        B-OTHER-PROC-CODE13  OR
528200                        B-OTHER-PROC-CODE14  OR
528300                        B-OTHER-PROC-CODE15  OR
528400                        B-OTHER-PROC-CODE16  OR
528500                        B-OTHER-PROC-CODE17  OR
528600                        B-OTHER-PROC-CODE18  OR
528700                        B-OTHER-PROC-CODE19  OR
528800                        B-OTHER-PROC-CODE20  OR
528900                        B-OTHER-PROC-CODE21  OR
529000                        B-OTHER-PROC-CODE22  OR
529100                        B-OTHER-PROC-CODE23  OR
529200                        B-OTHER-PROC-CODE24
529300           GO TO 4300-COMPUTE-SPIRAT
529400        ELSE
529500        IF '3249   ' =  B-PRIN-PROC-CODE     OR
529600                        B-OTHER-PROC-CODE1   OR
529700                        B-OTHER-PROC-CODE2   OR
529800                        B-OTHER-PROC-CODE3   OR
529900                        B-OTHER-PROC-CODE4   OR
530000                        B-OTHER-PROC-CODE5   OR
530100                        B-OTHER-PROC-CODE6   OR
530200                        B-OTHER-PROC-CODE7   OR
530300                        B-OTHER-PROC-CODE8   OR
530400                        B-OTHER-PROC-CODE9   OR
530500                        B-OTHER-PROC-CODE10  OR
530600                        B-OTHER-PROC-CODE11  OR
530700                        B-OTHER-PROC-CODE12  OR
530800                        B-OTHER-PROC-CODE13  OR
530900                        B-OTHER-PROC-CODE14  OR
531000                        B-OTHER-PROC-CODE15  OR
531100                        B-OTHER-PROC-CODE16  OR
531200                        B-OTHER-PROC-CODE17  OR
531300                        B-OTHER-PROC-CODE18  OR
531400                        B-OTHER-PROC-CODE19  OR
531500                        B-OTHER-PROC-CODE20  OR
531600                        B-OTHER-PROC-CODE21  OR
531700                        B-OTHER-PROC-CODE22  OR
531800                        B-OTHER-PROC-CODE23  OR
531900                        B-OTHER-PROC-CODE24
532000           GO TO 4300-COMPUTE-SPIRAT.
532100
532200           MOVE ZEROES TO H-NEW-TECH-ADDON-SPIRAT-STOP.
532300           GO TO 4300-ADD-TECH-CASES.
532400
532500 4300-COMPUTE-SPIRAT.
532600
532700     MOVE  3437.50 TO H-CSTMED-SPIRAT-STOP.
532800
532900     COMPUTE H-LESSER-SPIRAT-STOP-1 ROUNDED =
533000                  H-CSTMED-SPIRAT-STOP.
533100
533200     COMPUTE H-LESSER-SPIRAT-STOP-2 ROUNDED =
533300          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
533400                     H-BASE-DRG-PAYMENT)) * .5.
533500
533600     IF H-LESSER-SPIRAT-STOP-2 > 0
533700        IF H-LESSER-SPIRAT-STOP-1 < H-LESSER-SPIRAT-STOP-2
533800         MOVE H-LESSER-SPIRAT-STOP-1 TO
533900                                  H-NEW-TECH-ADDON-SPIRAT-STOP
534000        ELSE
534100         MOVE H-LESSER-SPIRAT-STOP-2 TO
534200                                  H-NEW-TECH-ADDON-SPIRAT-STOP
534300     ELSE
534400        MOVE ZEROES          TO H-NEW-TECH-ADDON-SPIRAT-STOP.
534500
534600
534700 4300-ADD-TECH-CASES.
534800
534900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
535000             H-NEW-TECH-ADDON-SPIRAT-STOP.
535100*
535200 4300-EXIT.    EXIT.
535300
535400 4310-SPIRAT-TECH-ADD-ON.
535500***********************************************************
535600***** SPIRAT-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
535700***********************************************************
535800
535900     IF '3371   ' =  B-PRIN-PROC-CODE     OR
536000                     B-OTHER-PROC-CODE1   OR
536100                     B-OTHER-PROC-CODE2   OR
536200                     B-OTHER-PROC-CODE3   OR
536300                     B-OTHER-PROC-CODE4   OR
536400                     B-OTHER-PROC-CODE5   OR
536500                     B-OTHER-PROC-CODE6   OR
536600                     B-OTHER-PROC-CODE7   OR
536700                     B-OTHER-PROC-CODE8   OR
536800                     B-OTHER-PROC-CODE9   OR
536900                     B-OTHER-PROC-CODE10  OR
537000                     B-OTHER-PROC-CODE11  OR
537100                     B-OTHER-PROC-CODE12  OR
537200                     B-OTHER-PROC-CODE13  OR
537300                     B-OTHER-PROC-CODE14  OR
537400                     B-OTHER-PROC-CODE15  OR
537500                     B-OTHER-PROC-CODE16  OR
537600                     B-OTHER-PROC-CODE17  OR
537700                     B-OTHER-PROC-CODE18  OR
537800                     B-OTHER-PROC-CODE19  OR
537900                     B-OTHER-PROC-CODE20  OR
538000                     B-OTHER-PROC-CODE21  OR
538100                     B-OTHER-PROC-CODE22  OR
538200                     B-OTHER-PROC-CODE23  OR
538300                     B-OTHER-PROC-CODE24
538400           GO TO 4320-COMPUTE-SPIRAT.
538500
538600
538700      IF '3373   ' =  B-PRIN-PROC-CODE     OR
538800                      B-OTHER-PROC-CODE1   OR
538900                      B-OTHER-PROC-CODE2   OR
539000                      B-OTHER-PROC-CODE3   OR
539100                      B-OTHER-PROC-CODE4   OR
539200                      B-OTHER-PROC-CODE5   OR
539300                      B-OTHER-PROC-CODE6   OR
539400                      B-OTHER-PROC-CODE7   OR
539500                      B-OTHER-PROC-CODE8   OR
539600                      B-OTHER-PROC-CODE9   OR
539700                      B-OTHER-PROC-CODE10  OR
539800                      B-OTHER-PROC-CODE11  OR
539900                      B-OTHER-PROC-CODE12  OR
540000                      B-OTHER-PROC-CODE13  OR
540100                      B-OTHER-PROC-CODE14  OR
540200                      B-OTHER-PROC-CODE15  OR
540300                      B-OTHER-PROC-CODE16  OR
540400                      B-OTHER-PROC-CODE17  OR
540500                      B-OTHER-PROC-CODE18  OR
540600                      B-OTHER-PROC-CODE19  OR
540700                      B-OTHER-PROC-CODE20  OR
540800                      B-OTHER-PROC-CODE21  OR
540900                      B-OTHER-PROC-CODE22  OR
541000                      B-OTHER-PROC-CODE23  OR
541100                      B-OTHER-PROC-CODE24
541200           GO TO 4320-COMPUTE-SPIRAT.
541300
541400      MOVE ZEROES TO H-NEW-TECH-ADDON-SPIRAT-STOP.
541500         GO TO 4320-ADD-TECH-CASES.
541600
541700 4320-COMPUTE-SPIRAT.
541800
541900     MOVE  3437.50 TO H-CSTMED-SPIRAT-STOP.
542000
542100     COMPUTE H-LESSER-SPIRAT-STOP-1 ROUNDED =
542200                  H-CSTMED-SPIRAT-STOP.
542300
542400     COMPUTE H-LESSER-SPIRAT-STOP-2 ROUNDED =
542500          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
542600                     H-BASE-DRG-PAYMENT)) * .5.
542700
542800     IF H-LESSER-SPIRAT-STOP-2 > 0
542900        IF H-LESSER-SPIRAT-STOP-1 < H-LESSER-SPIRAT-STOP-2
543000         MOVE H-LESSER-SPIRAT-STOP-1 TO
543100                                  H-NEW-TECH-ADDON-SPIRAT-STOP
543200        ELSE
543300         MOVE H-LESSER-SPIRAT-STOP-2 TO
543400                                  H-NEW-TECH-ADDON-SPIRAT-STOP
543500     ELSE
543600        MOVE ZEROES          TO H-NEW-TECH-ADDON-SPIRAT-STOP.
543700
543800
543900 4320-ADD-TECH-CASES.
544000
544100     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
544200             H-NEW-TECH-ADDON-SPIRAT-STOP.
544300*
544400 4310-EXIT.    EXIT.
544500
544600***********************************************************
544700* THIS IS A SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
544800* DISCHARGE COUNTS.
544900***********************************************************
545000 4400-LOWVOL-CODE-RTN.
545100
545200     SET LOWVOL-IDX TO 1.
545300     SEARCH LOWVOL-TAB VARYING LOWVOL-IDX
545400         AT END
545500           MOVE ' NO LOWVOL PROVIDER FOUND' TO MES-LOWVOL
545600           MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG
545700       WHEN WK-LOWVOL-PROV (LOWVOL-IDX) = MES-PPS-PROV
545800         MOVE WK-LOWVOL-PROV-DISCHG(LOWVOL-IDX)
545900                            TO MESWK-LOWVOL-PROV-DISCHG.
546000
546100 4400-EXIT.   EXIT.
546200
546300
546400 4500-AUTOLIT-TECH-ADD-ON.
546500***********************************************************
546600***** CASES INVOLVING AUTOLITT PROCESS DECOMPRESSION SYSTEM
546700***********************************************************
546800
546900     IF '1761   ' =  B-PRIN-PROC-CODE     OR
547000                     B-OTHER-PROC-CODE1   OR
547100                     B-OTHER-PROC-CODE2   OR
547200                     B-OTHER-PROC-CODE3   OR
547300                     B-OTHER-PROC-CODE4   OR
547400                     B-OTHER-PROC-CODE5   OR
547500                     B-OTHER-PROC-CODE6   OR
547600                     B-OTHER-PROC-CODE7   OR
547700                     B-OTHER-PROC-CODE8   OR
547800                     B-OTHER-PROC-CODE9   OR
547900                     B-OTHER-PROC-CODE10  OR
548000                     B-OTHER-PROC-CODE11  OR
548100                     B-OTHER-PROC-CODE12  OR
548200                     B-OTHER-PROC-CODE13  OR
548300                     B-OTHER-PROC-CODE14  OR
548400                     B-OTHER-PROC-CODE15  OR
548500                     B-OTHER-PROC-CODE16  OR
548600                     B-OTHER-PROC-CODE17  OR
548700                     B-OTHER-PROC-CODE18  OR
548800                     B-OTHER-PROC-CODE19  OR
548900                     B-OTHER-PROC-CODE20  OR
549000                     B-OTHER-PROC-CODE21  OR
549100                     B-OTHER-PROC-CODE22  OR
549200                     B-OTHER-PROC-CODE23  OR
549300                     B-OTHER-PROC-CODE24
549400           GO TO 4500-COMPUTE-AUTOLITT
549500     ELSE
549600           NEXT SENTENCE.
549700
549800           MOVE ZEROES TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
549900           GO TO 4500-ADD-TECH-CASES.
550000
550100 4500-COMPUTE-AUTOLITT.
550200
550300     MOVE  5300.00 TO H-CSTMED-AUTOLITT-STOP.
550400
550500     COMPUTE H-LESSER-AUTOLITT-STOP-1 ROUNDED =
550600                  H-CSTMED-AUTOLITT-STOP.
550700
550800     COMPUTE H-LESSER-AUTOLITT-STOP-2 ROUNDED =
550900          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
551000                     H-BASE-DRG-PAYMENT)) * .5.
551100
551200     IF H-LESSER-AUTOLITT-STOP-2 > 0
551300        IF H-LESSER-AUTOLITT-STOP-1 < H-LESSER-AUTOLITT-STOP-2
551400         MOVE H-LESSER-AUTOLITT-STOP-1 TO
551500                                H-NEW-TECH-ADDON-AUTOLITT-STOP
551600        ELSE
551700         MOVE H-LESSER-AUTOLITT-STOP-2 TO
551800                                H-NEW-TECH-ADDON-AUTOLITT-STOP
551900     ELSE
552000        MOVE ZEROES          TO H-NEW-TECH-ADDON-AUTOLITT-STOP.
552100
552200
552300 4500-ADD-TECH-CASES.
552400
552500     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
552600             H-NEW-TECH-ADDON-AUTOLITT-STOP.
552700*
552800 4500-EXIT.    EXIT.
552900
553000***********************************************************
553100******        L A S T   S O U R C E   S T A T E M E N T   *****
