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