000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           PPCAL09D.                                  00020000
000300*AUTHOR.            DDS TEAM    .                                 00030000
000400*REMARKS.                CMS.                                     00040000
000500 DATE-COMPILED.                                                   00050000
000600 ENVIRONMENT DIVISION.                                            00060000
000700 CONFIGURATION SECTION.                                           00070000
000800 SOURCE-COMPUTER.            IBM-370.                             00080000
000900 OBJECT-COMPUTER.            IBM-370.                             00090000
001000 INPUT-OUTPUT  SECTION.                                           00100000
001100 FILE-CONTROL.                                                    00110000
001200                                                                  00120000
001300 DATA DIVISION.                                                   00130000
001400 FILE SECTION.                                                    00140000
001500                                                                  00150000
001600 WORKING-STORAGE SECTION.                                         00160000
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE              00170000
001800     'PPCAL09D      - W O R K I N G   S T O R A G E'.             00180000
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C09.D'.     00190000
002000 01  HMO-FLAG                       PIC X      VALUE 'N'.         00200000
002100 01  HMO-TAG                        PIC X      VALUE SPACE.       00210000
002200 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.         00220000
002300 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.         00230000
002400 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES. 00240000
002500 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES. 00250000
002600 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.      00260000
002700 01  R1                             PIC S9(04) COMP SYNC.         00270000
002800 01  R2                             PIC S9(04) COMP SYNC.         00280000
002900 01  R3                             PIC S9(04) COMP SYNC.         00290000
003000 01  R4                             PIC S9(04) COMP SYNC.         00300000
003100 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).              00310000
003200 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).              00320000
003300                                                                  00330000
003400***************************************************************   00340000
003500**************YEARCHANGE 2009.2 *******************************   00341001
003600* TABLE 1                                                     *   00350000
003700*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *   00360000
003800*    (FULL UPDATE (.697)                                      *   00370000
003900*    (QUALITY = 1 WAGE INDEX > 1)                             *   00380000
004000***************************************************************   00390000
004100 01  TB1-RATE-TABLE.                                              00400000
004200     02  TB1-RATE-WORK.                                           00410000
004300*RATE 20081001 REGION  LABOR AND NON-LABOR RATES                  00420000
004400*                  R3=1     /     R3=2                            00430000
004500*               LARGE URBAN / OTHER URBAN                         00440000
004600*               LABOR / NON / LABOR / NON                         00450000
004700*                     /LABOR/       /LABOR                        00460000
004800*             --------------------------------------------        00470000
004900         05  FILLER PIC X(08) VALUE '20081001'.                   00480000
005000         05  TB1-NAT    PIC X(30) VALUE                           00490000
005100            ' 0357450 155391 0357450 155391'.                     00500000
005200         05  TB1-PR     PIC X(30) VALUE                           00510000
005300            ' 0150782 092415 0150782 092415'.                     00520000
005400         05  TB1-NATPR  PIC X(30) VALUE                           00530000
005500            ' 0357450 155391 0357450 155391'.                     00540000
005600***************************************************************   00550000
005700     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.                    00560000
005800         05  TB1-RATE-PERIOD            OCCURS 1.                 00570000
005900             10  TB1-RATE-EFF-DATE      PIC X(08).                00580000
006000             10  TB1-REG-NAT            OCCURS 3.                 00590000
006100                 15  TB1-LARGE-OTHER    OCCURS 2.                 00600000
006200                     20  FILLER         PIC X(01).                00610000
006300                     20  TB1-REG-LABOR  PIC 9(05)V9(02).          00620000
006400                     20  FILLER         PIC X(01).                00630000
006500                     20  TB1-REG-NLABOR PIC 9(04)V9(02).          00640000
006600                                                                  00650000
006700***************************************************************   00660000
006800************YEARCHANGE 2009.2 *********************************   00670000
006900* TABLE 2                                                     *   00680000
007000*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *   00690000
007100*    (REDUCED UPDATE (.697)                                   *   00700000
007200*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *   00710000
007300***************************************************************   00720000
007400 01  TB2-RATE-TABLE.                                              00730000
007500     02  TB2-RATE-WORK.                                           00740000
007600*RATE 20081001 REGION  LABOR AND NON-LABOR RATES                  00750000
007700*                  R3=1     /     R3=2                            00760000
007800*               LARGE URBAN / OTHER URBAN                         00770000
007900*               LABOR / NON / LABOR / NON                         00780000
008000*                     /LABOR/       /LABOR                        00790000
008100*             --------------------------------------------        00800000
008200         05  FILLER PIC X(08) VALUE '20081001'.                   00810000
008300         05  TB2-NAT    PIC X(30) VALUE                           00820000
008400            ' 0350549 152391 0350549 152391'.                     00830000
008500         05  TB2-PR     PIC X(30) VALUE                           00840000
008600            ' 0150782 092415 0150782 092415'.                     00850000
008700         05  TB2-NATPR  PIC X(30) VALUE                           00860000
008800            ' 0357450 155391 0357450 155391'.                     00870000
008900***************************************************************   00880000
009000     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.                    00890000
009100         05  TB2-RATE-PERIOD             OCCURS 1.                00900000
009200             10  TB2-RATE-EFF-DATE       PIC X(08).               00910000
009300             10  TB2-REG-NAT             OCCURS 3.                00920000
009400                 15  TB2-LARGE-OTHER     OCCURS 2.                00930000
009500                     20  FILLER          PIC X(01).               00940000
009600                     20  TB2-REG-LABOR   PIC 9(05)V9(02).         00950000
009700                     20  FILLER          PIC X(01).               00960000
009800                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).         00970000
009900***************************************************************   00990000
010000************YEARCHANGE 2009.1 *********************************   00991000
010100* TABLE 3                                                     *   01000000
010200*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *   01010000
010300*    (FULL UPDATE (.62%)                                      *   01020000
010400*    (QUALITY = 1 WAGE INDEX <= 1)                            *   01030000
010500***************************************************************   01040000
010600 01  TB3-RATE-TABLE.                                              01050000
010700     02  TB3-RATE-WORK.                                           01060000
010800*RATE 20081001 REGION  LABOR AND NON-LABOR RATES                  01070000
010900*                  R3=1     /     R3=2                            01080000
011000*               LARGE URBAN / OTHER URBAN                         01090000
011100*               LABOR / NON / LABOR / NON                         01100000
011200*                     /LABOR/       /LABOR                        01110000
011300*             --------------------------------------------        01120000
011400         05  FILLER PIC X(08) VALUE '20081001'.                   01130000
011500         05  TB3-NAT    PIC X(30) VALUE                           01140000
011600            ' 0317961 194880 0317961 194880'.                     01150000
011700         05  TB3-PR     PIC X(30) VALUE                           01160000
011800            ' 0142757 100440 0142757 100440'.                           00
011900         05  TB3-NATPR  PIC X(30) VALUE                                 00
012000            ' 0317961 194880 0317961 194880'.                     01200000
012100****************************************************************  01210000
012200     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.                    01210000
012300         05  TB3-RATE-PERIOD            OCCURS 1.                 01220000
012400             10  TB3-RATE-EFF-DATE      PIC X(08).                01230000
012500             10  TB3-REG-NAT            OCCURS 3.                 01240000
012600                 15  TB3-LARGE-OTHER    OCCURS 2.                 01250000
012700                     20  FILLER         PIC X(01).                01260000
012800                     20  TB3-REG-LABOR  PIC 9(05)V9(02).          01270000
012900                     20  FILLER         PIC X(01).                01280000
013000                     20  TB3-REG-NLABOR PIC 9(04)V9(02).          01290000
013100                                                                  01300000
013200***************************************************************   01310000
013300**********YEARCHANGE 2009.1 ***********************************   01320001
013400* TABLE 4                                                     *   01330000
013500*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *   01340000
013600*    (REDUCED UPDATE (.62%)                                   *   01350000
013700*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *   01360000
013800***************************************************************   01370000
013900 01  TB4-RATE-TABLE.                                              01380000
014000     02  TB4-RATE-WORK.                                           01390000
014100*RATE 20081001 REGION  LABOR AND NON-LABOR RATES                  01400000
014200*                  R3=1     /     R3=2                            01410000
014300*               LARGE URBAN / OTHER URBAN                         01420000
014400*               LABOR / NON / LABOR / NON                         01430000
014500*                     /LABOR/       /LABOR                        01440000
014600*             --------------------------------------------        01450000
014700         05  FILLER PIC X(08) VALUE '20081001'.                   01460000
014800         05  TB4-NAT    PIC X(30) VALUE                           01470000
014900            ' 0311823 191117 0311823 191117'.                     01480001
015000         05  TB4-PR     PIC X(30) VALUE                           01490000
015100            ' 0142757 100440 0142757 100440'.                     01500000
015200         05  TB4-NATPR  PIC X(30) VALUE                           01510000
015300            ' 0317961 194880 0317961 194880'.                     01520001
015400***************************************************************   01530000
015500     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.                    01540000
015600         05  TB4-RATE-PERIOD             OCCURS 1.                01550000
015700             10  TB4-RATE-EFF-DATE       PIC X(08).               01560000
015800             10  TB4-REG-NAT             OCCURS 3.                01570000
015900                 15  TB4-LARGE-OTHER     OCCURS 2.                01580000
016000                     20  FILLER          PIC X(01).               01590000
016100                     20  TB4-REG-LABOR   PIC 9(05)V9(02).         01600000
016200                     20  FILLER          PIC X(01).               01610000
016300                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).         01620000
016400                                                                  01630000
016500 01  DRG-TABLE.                                                   01640000
016600     05  D-TAB.                                                   01650000
016700       10  FILLER                  PIC X(08) VALUE
016800     '20081001'.
016900       10  FILLER                  PIC X(56) VALUE
017000     '23670129600411128157187002531836943260039811136623500289'.
017100       10  FILLER                  PIC X(56) VALUE
017200     '10818016100215048839090001050959981580019604881110100119'.
017300       10  FILLER                  PIC X(56) VALUE
017400     '06641118300220037246091001080488341310016703052708800107'.
017500       10  FILLER                  PIC X(56) VALUE
017600     '01896605900069000000000000000000000000000000000000000000'.
017700       10  FILLER                  PIC X(56) VALUE
017800     '00000000000000000000000000000000000000000008292014800183'.
017900       10  FILLER                  PIC X(56) VALUE
018000     '06359613700155041535076000930505840890012703459706200090'.
018100       10  FILLER                  PIC X(56) VALUE
018200     '05010909900130030058064000820210290350004505191910700143'.
018300       10  FILLER                  PIC X(56) VALUE
018400     '02794305100071015385028000370438610930013101951804000060'.
018500       10  FILLER                  PIC X(56) VALUE
018600     '01328902300030032220046000730202270210003301567301300016'.
018700       10  FILLER                  PIC X(56) VALUE
018800     '03026305900086015525025000380100050150001803964509700133'.
018900       10  FILLER                  PIC X(56) VALUE
019000     '02151805300072016759025000360000000000000000000000000000'.
019100       10  FILLER                  PIC X(56) VALUE
019200     '00000000000000000000000000000000000000000000000000000000'.
019300       10  FILLER                  PIC X(56) VALUE
019400     '00000000000000000000000000000000000000000001621604800067'.
019500       10  FILLER                  PIC X(56) VALUE
019600     '00866903300040015860052000700108280380005101634905700078'.
019700       10  FILLER                  PIC X(56) VALUE
019800     '00880203900050015706057000770094440420005100699403400040'.
019900       10  FILLER                  PIC X(56) VALUE
020000     '02871706800089019537053000630151430390004501845005500075'.
020100       10  FILLER                  PIC X(56) VALUE
020200     '01176004300052008439031000370138730440005800845702700034'.
020300       10  FILLER                  PIC X(56) VALUE
020400     '00715702400030018246060000790113610440005600765002800035'.
020500       10  FILLER                  PIC X(56) VALUE
020600     '01308204700062008423034000430167300570007300859503400041'.
020700       10  FILLER                  PIC X(56) VALUE
020800     '01623305200067010082036000440073980280003401103203800051'.
020900       10  FILLER                  PIC X(56) VALUE
021000     '00710402700035020201037000640129930370004900875302400031'.
021100       10  FILLER                  PIC X(56) VALUE
021200     '02090805500076012072039000500080110260003301582904200059'.
021300       10  FILLER                  PIC X(56) VALUE
021400     '00918603000037006751020000250157470460006400921803500045'.
021500       10  FILLER                  PIC X(56) VALUE
021600     '00677702600032033505092001180219350690008601821705000062'.
021700       10  FILLER                  PIC X(56) VALUE
021800     '03207309900126018504067000830125930470005901506904700063'.
021900       10  FILLER                  PIC X(56) VALUE
022000     '00761702900037009584033000450062390250003100000000000000'.
022100       10  FILLER                  PIC X(56) VALUE
022200     '00000000000000000000000000000000000000000000000000000000'.
022300       10  FILLER                  PIC X(56) VALUE
022400     '00000000000000000000000000000000000000000000000000000000'.
022500       10  FILLER                  PIC X(56) VALUE
022600     '01578703800056008289019000260106750330004301134602600041'.
022700       10  FILLER                  PIC X(56) VALUE
022800     '00669901600022000000000000000000000000000000000000000000'.
022900       10  FILLER                  PIC X(56) VALUE
023000     '00959004300055006148033000400068760230002901064203900053'.
023100       10  FILLER                  PIC X(56) VALUE
023200     '00668902800035000000000000000000000000000000000000000000'.
023300       10  FILLER                  PIC X(56) VALUE
023400     '02010903700052011513023000290199330400005801098102100026'.
023500       10  FILLER                  PIC X(56) VALUE
023600     '01555203600053008213017000220168320380005900897401700023'.
023700       10  FILLER                  PIC X(56) VALUE
023800     '01261903800054007366019000250081470140001800000000000000'.
023900       10  FILLER                  PIC X(56) VALUE
024000     '00000000000000000000000000000000000000000000000000000000'.
024100       10  FILLER                  PIC X(56) VALUE
024200     '00000000000000020472066000940124500430006100820602700038'.
024300       10  FILLER                  PIC X(56) VALUE
024400     '00610902200027012254037000520060340230002900899403400045'.
024500       10  FILLER                  PIC X(56) VALUE
024600     '00597402600032013776046000630087840350004400631202500032'.
024700       10  FILLER                  PIC X(56) VALUE
024800     '01474604600066008615034000450059660240003000000000000000'.
024900       10  FILLER                  PIC X(56) VALUE
025000     '00000000000000000000000000000499781220015002595306700081'.
025100       10  FILLER                  PIC X(56) VALUE
025200     '01803604300051036912100001290202640630008001343303900052'.
025300       10  FILLER                  PIC X(56) VALUE
025400     '00000000000000000000000000000000000000000000000000000000'.
025500       10  FILLER                  PIC X(56) VALUE
025600     '00000000000000000000000000000157960600007301071304600053'.
025700       10  FILLER                  PIC X(56) VALUE
025800     '02039307200091014983060000740104190450005601695006000079'.
025900       10  FILLER                  PIC X(56) VALUE
026000     '01231604500059008736032000420153460580007200945803800046'.
026100       10  FILLER                  PIC X(56) VALUE
026200     '00681102900034016252057000740109420410005300813303100040'.
026300       10  FILLER                  PIC X(56) VALUE
026400     '01348804800061013030050000630097570410005000725403300040'.
026500       10  FILLER                  PIC X(56) VALUE
026600     '01432705400067010056044000530073160350004101602205800073'.
026700       10  FILLER                  PIC X(56) VALUE
026800     '01099204400054008198033000410174010640008301010703900051'.
026900       10  FILLER                  PIC X(56) VALUE
027000     '00740303100041008157035000430059560280003400654802200029'.
027100       10  FILLER                  PIC X(56) VALUE
027200     '01236304000055007289027000340510551280015102180105200072'.
027300       10  FILLER                  PIC X(56) VALUE
027400     '00000000000000000000000000000000000000000000000000000000'.
027500       10  FILLER                  PIC X(56) VALUE
027600     '00000000000000000000000000001225160760014010094315700184'.
027700       10  FILLER                  PIC X(56) VALUE
027800     '06990010900123054211083000910803291140014005279907600086'.
027900       10  FILLER                  PIC X(56) VALUE
028000     '04386906000064086466107001310628650460006307952109200114'.
028100       10  FILLER                  PIC X(56) VALUE
028200     '05900604500056067117062000930499610180002807786312100147'.
028300       10  FILLER                  PIC X(56) VALUE
028400     '05021307900091040573056000650764381120013405529108200092'.
028500       10  FILLER                  PIC X(56) VALUE
028600     '07014412400142046075083000890567120950011203594506100066'.
028700       10  FILLER                  PIC X(56) VALUE
028800     '05074107500108028874032000460450441200015402667408300104'.
028900       10  FILLER                  PIC X(56) VALUE
029000     '01572205600068037029067000880258870380005102005902200029'.
029100       10  FILLER                  PIC X(56) VALUE
029200     '03984202100032031468036000530191270170002202804604200060'.
029300       10  FILLER                  PIC X(56) VALUE
029400     '01639501900025029915054000780160380210002802955005500086'.
029500       10  FILLER                  PIC X(56) VALUE
029600     '02254504100060015426020000270241100710009701592005800075'.
029700       10  FILLER                  PIC X(56) VALUE
029800     '01025703700049028325054000740168990200002803410108100112'.
029900       10  FILLER                  PIC X(56) VALUE
030000     '01438003000042010152020000260154150340005402532905800089'.
030100       10  FILLER                  PIC X(56) VALUE
030200     '02209502200035000000000000000000000000000000000000000000'.
030300       10  FILLER                  PIC X(56) VALUE
030400     '00000000000000000000000000000000000000000000000000000000'.
030500       10  FILLER                  PIC X(56) VALUE
030600     '00000000000000000000000000000000000000000000000000000000'.
030700       10  FILLER                  PIC X(56) VALUE
030800     '00000000000000000000000000000000000000000001940405800073'.
030900       10  FILLER                  PIC X(56) VALUE
031000     '01221303900048008696026000320169250330005400911102200032'.
031100       10  FILLER                  PIC X(56) VALUE
031200     '00605301700022019769052000690102520240003103083909200118'.
031300       10  FILLER                  PIC X(56) VALUE
031400     '01958807000087014465051000650146010500006501006904100050'.
031500       10  FILLER                  PIC X(56) VALUE
031600     '00722003100037009595046000550064080370004301194702000031'.
031700       10  FILLER                  PIC X(56) VALUE
031800     '00647601400018004447011000130143700500006700928604100050'.
031900       10  FILLER                  PIC X(56) VALUE
032000     '00660603000037010294032000440056680200002501086503900052'.
032100       10  FILLER                  PIC X(56) VALUE
032200     '00591802300029015703044000630075020270003501299204100055'.
032300       10  FILLER                  PIC X(56) VALUE
032400     '00833603100039005843023000280049720190002300709702500031'.
032500       10  FILLER                  PIC X(56) VALUE
032600     '00531401700021017552050000700099360350004600652802400030'.
032700       10  FILLER                  PIC X(56) VALUE
032800     '00000000000000000000000000000000000000000000000000000000'.
032900       10  FILLER                  PIC X(56) VALUE
033000     '00000000000000000000000000000000000000000000000000000000'.
033100       10  FILLER                  PIC X(56) VALUE
033200     '00000000000000057896132001710283630780010001453003200044'.
033300       10  FILLER                  PIC X(56) VALUE
033400     '05166612800160025589083000970162240520005904524312000144'.
033500       10  FILLER                  PIC X(56) VALUE
033600     '02445207700088016221047000550408681160014102236907500091'.
033700       10  FILLER                  PIC X(56) VALUE
033800     '01451704400056031760088001070185640600007001225903500042'.
033900       10  FILLER                  PIC X(56) VALUE
034000     '02159805300071013098032000410090420180002203067209200117'.
034100       10  FILLER                  PIC X(56) VALUE
034200     '01634606100072011881044000490220470650008801288304400057'.
034300       10  FILLER                  PIC X(56) VALUE
034400     '00767902400031022608058000800125970340004500811702000025'.
034500       10  FILLER                  PIC X(56) VALUE
034600     '02485906400084014020040000510096480240002903856909500129'.
034700       10  FILLER                  PIC X(56) VALUE
034800     '02170906200081013474033000450000000000000000000000000000'.
034900       10  FILLER                  PIC X(56) VALUE
035000     '00000000000000000000000000000000000000000000000000000000'.
035100       10  FILLER                  PIC X(56) VALUE
035200     '00000000000000000000000000000000000000000001628905100066'.
035300       10  FILLER                  PIC X(56) VALUE
035400     '01071503800048007819028000340191360670008701307205600068'.
035500       10  FILLER                  PIC X(56) VALUE
035600     '00868404200049019075063000860125430450006000882003200042'.
035700       10  FILLER                  PIC X(56) VALUE
035800     '01607304900064010043037000440075650290003401800605600073'.
035900       10  FILLER                  PIC X(56) VALUE
036000     '01113704200052008218031000370117440440005500783803100038'.
036100       10  FILLER                  PIC X(56) VALUE
036200     '01856806500088010616045000570077860350004301540805400073'.
036300       10  FILLER                  PIC X(56) VALUE
036400     '00926504000050006351030000350108560390005200670302800035'.
036500       10  FILLER                  PIC X(56) VALUE
036600     '01540904900069009519038000480067650260003300000000000000'.
036700       10  FILLER                  PIC X(56) VALUE
036800     '00000000000000000000000000000000000000000000000000000000'.
036900       10  FILLER                  PIC X(56) VALUE
037000     '00000000000000000000000000000000000000000000000000000000'.
037100       10  FILLER                  PIC X(56) VALUE
037200     '05640512400170027858070000910183880420005504258512200151'.
037300       10  FILLER                  PIC X(56) VALUE
037400     '02564908300098016467055000650374961040012402364107500086'.
037500       10  FILLER                  PIC X(56) VALUE
037600     '01687705000059035699097001170203380650007601328904100048'.
037700       10  FILLER                  PIC X(56) VALUE
037800     '02476506500084016507045000560112640250003204108709900138'.
037900       10  FILLER                  PIC X(56) VALUE
038000     '01895905600077012284032000430458121190016002518807900104'.
038100       10  FILLER                  PIC X(56) VALUE
038200     '01375204000054000000000000000000000000000000000000000000'.
038300       10  FILLER                  PIC X(56) VALUE
038400     '00000000000000000000000000000000000000000001679005200070'.
038500       10  FILLER                  PIC X(56) VALUE
038600     '00939403800049006550029000370172050570007601192104500058'.
038700       10  FILLER                  PIC X(56) VALUE
038800     '00953103200042017013055000750102410420005300697703200038'.
038900       10  FILLER                  PIC X(56) VALUE
039000     '01663905100070009830039000510069820300003801558305000066'.
039100       10  FILLER                  PIC X(56) VALUE
039200     '01038903800047007231026000330000000000000000000000000000'.
039300       10  FILLER                  PIC X(56) VALUE
039400     '00000000000000000000000000000000000000000000000000000000'.
039500       10  FILLER                  PIC X(56) VALUE
039600     '09825312000156069914065000800514760370004408491011600147'.
039700       10  FILLER                  PIC X(56) VALUE
039800     '05645906200075046762040000450595870760009503560703600042'.
039900       10  FILLER                  PIC X(56) VALUE
040000     '04541906800084031438039000420469471200016602616707700102'.
040100       10  FILLER                  PIC X(56) VALUE
040200     '01496604400058045431074000920306300480005502450003600039'.
040300       10  FILLER                  PIC X(56) VALUE
040400     '03290106900082020077036000390441220700009802608402800041'.
040500       10  FILLER                  PIC X(56) VALUE
040600     '01914001600020034491096001260197870650008401099903700048'.
040700       10  FILLER                  PIC X(56) VALUE
040800     '03278108900119021226046000660147420190002802899807800093'.
040900       10  FILLER                  PIC X(56) VALUE
041000     '01817505400059014949045000480225080340004201744302100024'.
041100       10  FILLER                  PIC X(56) VALUE
041200     '03295909800121021592067000800155380490005701680504100052'.
041300       10  FILLER                  PIC X(56) VALUE
041400     '01160102600030017202030000430093830180002202763906800085'.
041500       10  FILLER                  PIC X(56) VALUE
041600     '01762004300053012353028000340317410810010901772204600060'.
041700       10  FILLER                  PIC X(56) VALUE
041800     '01124902300030020238055000790090900230003002841507800108'.
041900       10  FILLER                  PIC X(56) VALUE
042000     '01470004500060009573023000290230470720009401469605100064'.
042100       10  FILLER                  PIC X(56) VALUE
042200     '00986002600034010237025000340171660370005101114301700020'.
042300       10  FILLER                  PIC X(56) VALUE
042400     '01171802000031019947049000640133920320004000950901800022'.
042500       10  FILLER                  PIC X(56) VALUE
042600     '01293203600051008060021000280306690790010501808304500060'.
042700       10  FILLER                  PIC X(56) VALUE
042800     '01329302100030000000000000000000000000000000000000000000'.
042900       10  FILLER                  PIC X(56) VALUE
043000     '00000000000000000000000000000000000000000000000000000000'.
043100       10  FILLER                  PIC X(56) VALUE
043200     '00000000000000000000000000000000000000000000000000000000'.
043300       10  FILLER                  PIC X(56) VALUE
043400     '00000000000000000000000000000000000000000000000000000000'.
043500       10  FILLER                  PIC X(56) VALUE
043600     '01424304800067007339033000400134090480006200696303300039'.
043700       10  FILLER                  PIC X(56) VALUE
043800     '00892403600045005808027000320202870750009801348105700071'.
043900       10  FILLER                  PIC X(56) VALUE
044000     '00926504200053019045067000880113020480005900769803700044'.
044100       10  FILLER                  PIC X(56) VALUE
044200     '02349906400091010969044000550072310310003801876906700089'.
044300       10  FILLER                  PIC X(56) VALUE
044400     '01161805100064008073037000450153230540007100765703400041'.
044500       10  FILLER                  PIC X(56) VALUE
044600     '01106804700060006352030000370100740360004800576702500031'.
044700       10  FILLER                  PIC X(56) VALUE
044800     '01429505200066008036035000430170540530007500955503600047'.
044900       10  FILLER                  PIC X(56) VALUE
045000     '00580502100028013961049000640067830310003701411105200070'.
045100       10  FILLER                  PIC X(56) VALUE
045200     '00888203900050006694030000370000000000000000000000000000'.
045300       10  FILLER                  PIC X(56) VALUE
045400     '00000000000000000000000000000000000000000000000000000000'.
045500       10  FILLER                  PIC X(56) VALUE
045600     '03193209600132019517072000940112160470005803438408400129'.
045700       10  FILLER                  PIC X(56) VALUE
045800     '01577504200061009782024000330279460780010701411003700055'.
045900       10  FILLER                  PIC X(56) VALUE
046000     '00859501900026009649021000280074800160001801432904000060'.
046100       10  FILLER                  PIC X(56) VALUE
046200     '00803601700022000000000000000000000000000000000000000000'.
046300       10  FILLER                  PIC X(56) VALUE
046400     '00000000000000000000000000000000000000000001751506600089'.
046500       10  FILLER                  PIC X(56) VALUE
046600     '01108005200065007910041000510182060620008300822503800047'.
046700       10  FILLER                  PIC X(56) VALUE
046800     '01606106000082010808043000570073100270003700948504100051'.
046900       10  FILLER                  PIC X(56) VALUE
047000     '00658603100039014033055000700080270390004701191504300057'.
047100       10  FILLER                  PIC X(56) VALUE
047200     '00676902800035012458044000630064620290003800000000000000'.
047300       10  FILLER                  PIC X(56) VALUE
047400     '00000000000000000000000000000000000000000000000000000000'.
047500       10  FILLER                  PIC X(56) VALUE
047600     '00000000000000024984051000700137220270003204706813300171'.
047700       10  FILLER                  PIC X(56) VALUE
047800     '02103307000088013333051000640330490520008201864102900037'.
047900       10  FILLER                  PIC X(56) VALUE
048000     '01419101900022031728094001320188780670008601094604800060'.
048100       10  FILLER                  PIC X(56) VALUE
048200     '02124404700071011332021000310073440130001503267007500111'.
048300       10  FILLER                  PIC X(56) VALUE
048400     '02287306800087015075040000550000000000000000000000000000'.
048500       10  FILLER                  PIC X(56) VALUE
048600     '00000000000000000000000000000000000000000000000000000000'.
048700       10  FILLER                  PIC X(56) VALUE
048800     '01359604500061008164034000430055980250003001113803900054'.
048900       10  FILLER                  PIC X(56) VALUE
049000     '00682003100038010168037000520164640580007601046004400055'.
049100       10  FILLER                  PIC X(56) VALUE
049200     '00718803100039000000000000000000000000000000000000000000'.
049300       10  FILLER                  PIC X(56) VALUE
049400     '00000000000000000000000000000000000000000002955606600077'.
049500       10  FILLER                  PIC X(56) VALUE
049600     '05815213600169029415087000980202470580006503278208000101'.
049700       10  FILLER                  PIC X(56) VALUE
049800     '01862605000060013765033000370333510800011201891904800065'.
049900       10  FILLER                  PIC X(56) VALUE
050000     '01256302600033027108074001030144290360005300992201600021'.
050100       10  FILLER                  PIC X(56) VALUE
050200     '02558208200110015536043000630082360210002902238906200085'.
050300       10  FILLER                  PIC X(56) VALUE
050400     '01203103100044007683019000250142230410006000794401900025'.
050500       10  FILLER                  PIC X(56) VALUE
050600     '02770405800098021587046000720130910150002100000000000000'.
050700       10  FILLER                  PIC X(56) VALUE
050800     '00000000000000000000000000000000000000000000000000000000'.
050900       10  FILLER                  PIC X(56) VALUE
051000     '00000000000000016413052000720113040450005600730503200039'.
051100       10  FILLER                  PIC X(56) VALUE
051200     '00857802500035016234056000760107480410005300682202500032'.
051300       10  FILLER                  PIC X(56) VALUE
051400     '01230104900062007581035000420145340290004001156301900024'.
051500       10  FILLER                  PIC X(56) VALUE
051600     '01193903600048006565020000260117110420005500632202600033'.
051700       10  FILLER                  PIC X(56) VALUE
051800     '00693102400031014718050000660097250370004800682802800035'.
051900       10  FILLER                  PIC X(56) VALUE
052000     '00000000000000000000000000000000000000000000000000000000'.
052100       10  FILLER                  PIC X(56) VALUE
052200     '00000000000000000000000000000161990340004401177801800021'.
052300       10  FILLER                  PIC X(56) VALUE
052400     '01886403800066012521014000180202380550008100806402200030'.
052500       10  FILLER                  PIC X(56) VALUE
052600     '01118302900042006325017000190170720390006200963601200014'.
052700       10  FILLER                  PIC X(56) VALUE
052800     '01808705100072007809022000280000000000000000000000000000'.
052900       10  FILLER                  PIC X(56) VALUE
053000     '00000000000000015686057000760099220400005300597102400031'.
053100       10  FILLER                  PIC X(56) VALUE
053200     '01049204200055006696027000350128970510006400694403300040'.
053300       10  FILLER                  PIC X(56) VALUE
053400     '01099504000056005968024000310000000000000000000000000000'.
053500       10  FILLER                  PIC X(56) VALUE
053600     '00000000000000023472060000800112730290003404178311200138'.
053700       10  FILLER                  PIC X(56) VALUE
053800     '01956806000072011572035000390300480780010201464104300052'.
053900       10  FILLER                  PIC X(56) VALUE
054000     '00998302700030013429035000450084370200002301392304100058'.
054100       10  FILLER                  PIC X(56) VALUE
054200     '00744802100026012643030000420083700160001900816201500017'.
054300       10  FILLER                  PIC X(56) VALUE
054400     '02483406700093009614025000310000000000000000000000000000'.
054500       10  FILLER                  PIC X(56) VALUE
054600     '00000000000000017546062000830107800430005700633702500031'.
054700       10  FILLER                  PIC X(56) VALUE
054800     '01580306500081010640049000610076640360004500793403000040'.
054900       10  FILLER                  PIC X(56) VALUE
055000     '00502401900024000000000000000000000000000000000000000000'.
055100       10  FILLER                  PIC X(56) VALUE
055200     '01053604000050007427030000320095230260003301731904700058'.
055300       10  FILLER                  PIC X(56) VALUE
055400     '01274003200046006627016000230000000000000000000000000000'.
055500       10  FILLER                  PIC X(56) VALUE
055600     '00000000000000006511026000320048000200002200621502500033'.
055700       10  FILLER                  PIC X(56) VALUE
055800     '00767901800022004388019000300049210160002100197801300015'.
055900       10  FILLER                  PIC X(56) VALUE
056000     '00617002600037003944017000250000000000000000000000000000'.
056100       10  FILLER                  PIC X(56) VALUE
056200     '00000000000000000000000000000000000000000000000000000000'.
056300       10  FILLER                  PIC X(56) VALUE
056400     '01422601800018046911179001790320391330013301933208600086'.
056500       10  FILLER                  PIC X(56) VALUE
056600     '03291104700047011648034000340015770310003100000000000000'.
056700       10  FILLER                  PIC X(56) VALUE
056800     '00000000000000000000000000000476141080014102562406200078'.
056900       10  FILLER                  PIC X(56) VALUE
057000     '01640003800049034208090001230176520470006701052602500034'.
057100       10  FILLER                  PIC X(56) VALUE
057200     '00000000000000000000000000000000000000000001988606300082'.
057300       10  FILLER                  PIC X(56) VALUE
057400     '01174404200053008980032000400127530400005700763002800037'.
057500       10  FILLER                  PIC X(56) VALUE
057600     '01353203700051014920050000670099590380005000699402800035'.
057700       10  FILLER                  PIC X(56) VALUE
057800     '00000000000000000000000000000000000000000005631313200177'.
057900       10  FILLER                  PIC X(56) VALUE
058000     '02251405500079012343026000350409461200015402179706600087'.
058100       10  FILLER                  PIC X(56) VALUE
058200     '01207303000043046021111001510227120590007901299903000038'.
058300       10  FILLER                  PIC X(56) VALUE
058400     '02892907000106010798025000370000000000000000000000000000'.
058500       10  FILLER                  PIC X(56) VALUE
058600     '00000000000000045869095001550258140620010401211703400052'.
058700       10  FILLER                  PIC X(56) VALUE
058800     '06377417600231029436079001220141540500006402596507600104'.
058900       10  FILLER                  PIC X(56) VALUE
059000     '01553005200069010258034000450182300620008501203604500061'.
059100       10  FILLER                  PIC X(56) VALUE
059200     '00823003300044021272058000840094210270003400797002500031'.
059300       10  FILLER                  PIC X(56) VALUE
059400     '01209404400060000000000000000000000000000000000000000000'.
059500       10  FILLER                  PIC X(56) VALUE
059600     '05432812700167029172091001110181400560007104752211500154'.
059700       10  FILLER                  PIC X(56) VALUE
059800     '02052206600085013595045000570000000000000000000000000000'.
059900       10  FILLER                  PIC X(56) VALUE
060000     '00000000000000019142061000820096050420005200825703200041'.
060100       10  FILLER                  PIC X(56) VALUE
060200     '01504904700067006708028000350234410700009601078604500058'.
060300       10  FILLER                  PIC X(56) VALUE
060400     '00765003500043057258129001550182220550007501120904700057'.
060500       10  FILLER                  PIC X(56) VALUE
060600     '00000000000000000000000000000000000000000002483407800121'.
060700       10  FILLER                  PIC X(56) VALUE
060800     '00000000000000000000000000000000000000000000589702400032'.
060900       10  FILLER                  PIC X(56) VALUE
061000     '00582803100042006115031000440102340440007400899204100055'.
061100       10  FILLER                  PIC X(56) VALUE
061200     '00847705500076007549040000600073030300004600000000000000'.
061300       10  FILLER                  PIC X(56) VALUE
061400     '00000000000000000000000000000000000000000000000000000000'.
061500       10  FILLER                  PIC X(56) VALUE
061600     '00000000000000003878021000290089020810010501382704800066'.
061700       10  FILLER                  PIC X(56) VALUE
061800     '00619803300041000000000000000000000000000000000000000000'.
061900       10  FILLER                  PIC X(56) VALUE
062000     '03988810000153017006055000780100090340004602927507100114'.
062100       10  FILLER                  PIC X(56) VALUE
062200     '01115103400047010086021000320368040800011601909404900068'.
062300       10  FILLER                  PIC X(56) VALUE
062400     '01134202700036000000000000000000000000000000000000000000'.
062500       10  FILLER                  PIC X(56) VALUE
062600     '01230404200057006650027000340122980330004700442301700021'.
062700       10  FILLER                  PIC X(56) VALUE
062800     '01415503700052005812021000270152230450006400923403300044'.
062900       10  FILLER                  PIC X(56) VALUE
063000     '00610902300030013572041000600061570240003200000000000000'.
063100       10  FILLER                  PIC X(56) VALUE
063200     '00000000000000000000000000001385012340031105015611600159'.
063300       10  FILLER                  PIC X(56) VALUE
063400     '02144405300077000000000000000000000000000000000000000000'.
063500       10  FILLER                  PIC X(56) VALUE
063600     '02116502300044012921044000610122130360005400000000000000'.
063700       10  FILLER                  PIC X(56) VALUE
063800     '00000000000000000000000000000265700670010101635203600054'.
063900       10  FILLER                  PIC X(56) VALUE
064000     '01073102100027000000000000000000000000000000000000000000'.
064100       10  FILLER                  PIC X(56) VALUE
064200     '01302208600105010995069000790105750380005000650002800035'.
064300       10  FILLER                  PIC X(56) VALUE
064400     '00805002600041005614025000350076160220004800000000000000'.
064500       10  FILLER                  PIC X(56) VALUE
064600     '00000000000000000000000000000509850850012303541707600093'.
064700       10  FILLER                  PIC X(56) VALUE
064800     '05990410100147035803079001030239130490006400000000000000'.
064900       10  FILLER                  PIC X(56) VALUE
065000     '00000000000000000000000000000288850660009601611404900062'.
065100       10  FILLER                  PIC X(56) VALUE
065200     '00995503400042000000000000000000000000000000000000000000'.
065300       10  FILLER                  PIC X(56) VALUE
065400     '05382612900189025403067001030000000000000000000000000000'.
065500       10  FILLER                  PIC X(56) VALUE
065600     '00000000000000025656073001040136120530007000895103800049'.
065700       10  FILLER                  PIC X(56) VALUE
065800     '01095403900053000000000000000000000000000000000000000000'.
065900       10  FILLER                  PIC X(56) VALUE
066000     '05023811800152030783076000970199480390005403317711800146'.
066100       10  FILLER                  PIC X(56) VALUE
066200     '02203507300096012775035000530344060980013001879205800078'.
066300       10  FILLER                  PIC X(56) VALUE
066400     '01100902900041000000000000000000000000000000000000000000'.
066500       10  FILLER                  PIC X(56) VALUE
066600     '00000000000000000000000000000000000000000000000000000000'.
066700       10  FILLER                  PIC X(56) VALUE
066800     '00000000000000000000000000000000000000000000000000000000'.
066900     05  DRGX-TAB REDEFINES D-TAB.                                04619000
067000         10  DRGX-PERIOD               OCCURS 1                   04619100
067100                                        INDEXED BY DX5.           04619200
067200             15  DRGX-EFF-DATE         PIC X(08).                 04619300
067300             15  DRG-DATA              OCCURS 1000                04619400
067400                                        INDEXED BY DX6.           04619500
067500                 20  DRG-WT            PIC 9(02)V9(04).           04619600
067600                 20  DRG-ALOS          PIC 9(02)V9(01).           04619700
067700                 20  DRG-DAYS-TRIM     PIC 9(02).                 04619800
067800                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           04619900
067900
068000*****YEARCHANGE 2009.1 ************************************       20110000
068100
068200 01  PPS-SSRFBN-TABLE.
068300     02  WK-SSRFBN-DATA.
068400         05  FILLER   PIC X(58)  VALUE
068500     '01  099680  01 ALABAMA                                   '.
068600         05  FILLER   PIC X(58)  VALUE
068700     '02  099513  02 ALASKA                                    '.
068800         05  FILLER   PIC X(58)  VALUE
068900     '03  099680  03 ARIZONA                                   '.
069000         05  FILLER   PIC X(58)  VALUE
069100     '04  099680  04 ARKANSAS                                  '.
069200         05  FILLER   PIC X(58)  VALUE
069300     '05  099311  05 CALIFORNIA                                '.
069400          05  FILLER   PIC X(58)  VALUE
069500     '06  099615  06 COLORADO                                  '.
069600         05  FILLER   PIC X(58)  VALUE
069700     '07  099000  07 CONNECTICUT                               '.
069800         05  FILLER   PIC X(58)  VALUE
069900     '08  099680  08 DELAWARE                                  '.
070000         05  FILLER   PIC X(58)  VALUE
070100     '09  099680  09 DISTRICT OF CO                            '.
070200         05  FILLER   PIC X(58)  VALUE
070300     '10  099636  10 FLORIDA                                   '.
070400         05  FILLER   PIC X(58)  VALUE
070500     '11  099680  11 GEORGIA                                   '.
070600         05  FILLER   PIC X(58)  VALUE
070700     '12  099680  12 HAWAII                                    '.
070800         05  FILLER   PIC X(58)  VALUE
070900     '13  099680  13 IDAHO                                     '.
071000         05  FILLER   PIC X(58)  VALUE
071100     '14  099679  14 ILLINOIS                                  '.
071200         05  FILLER   PIC X(58)  VALUE
071300     '15  099666  15 INDIANA                                   '.
071400         05  FILLER   PIC X(58)  VALUE
071500     '16  099435  16 IOWA                                      '.
071600         05  FILLER   PIC X(58)  VALUE
071700     '17  099680  17 KANSAS                                    '.
071800         05  FILLER   PIC X(58)  VALUE
071900     '18  099678  18 KENTUCKY                                  '.
072000         05  FILLER   PIC X(58)  VALUE
072100     '19  099670  19 LOUISIANA                                 '.
072200         05  FILLER   PIC X(58)  VALUE
072300     '20  099680  20 MAINE                                     '.
072400         05  FILLER   PIC X(58)  VALUE
072500     '21  100000  21 MARYLAND                                  '.
072600         05  FILLER   PIC X(58)  VALUE
072700     '22  099680  22 MASSACHUSETTS                             '.
072800         05  FILLER   PIC X(58)  VALUE
072900     '23  099680  23 MICHIGAN                                  '.
073000         05  FILLER   PIC X(58)  VALUE
073100     '24  099680  24 MINNESOTA                                 '.
073200         05  FILLER   PIC X(58)  VALUE
073300     '25  099680  25 MISSISSIPPI                               '.
073400         05  FILLER   PIC X(58)  VALUE
073500     '26  099680  26 MISSOURI                                  '.
073600         05  FILLER   PIC X(58)  VALUE
073700     '27  099680  27 MONTANA                                   '.
073800         05  FILLER   PIC X(58)  VALUE
073900     '28  099680  28 NEBRASKA                                  '.
074000          05  FILLER   PIC X(58)  VALUE
074100     '29  099680  29 NEVADA                                    '.
074200          05  FILLER   PIC X(58)  VALUE
074300     '30  099236  30 NEW HAMPSHIRE                             '.
074400          05  FILLER   PIC X(58)  VALUE
074500     '31  099455  31 NEW JERSEY                                '.
074600          05  FILLER   PIC X(58)  VALUE
074700     '32  099657  32 NEW MEXICO                                '.
074800          05  FILLER   PIC X(58)  VALUE
074900     '33  099680  33 NEW YORK                                  '.
075000          05  FILLER   PIC X(58)  VALUE
075100     '34  099677  34 NORTH CAROLINA                            '.
075200          05  FILLER   PIC X(58)  VALUE
075300     '35  099680  35 NORTH DAKOTA                              '.
075400          05  FILLER   PIC X(58)  VALUE
075500     '36  099663  36 OHIO                                      '.
075600          05  FILLER   PIC X(58)  VALUE
075700     '37  099679  37 OKLAHOMA                                  '.
075800          05  FILLER   PIC X(58)  VALUE
075900     '38  099539  38 OREGON                                    '.
076000          05  FILLER   PIC X(58)  VALUE
076100     '39  099679  39 PENNSYLVANIA                              '.
076200          05  FILLER   PIC X(58)  VALUE
076300     '40  099680  40 PUERTO RICO                               '.
076400          05  FILLER   PIC X(58)  VALUE
076500     '41  099680  41 RHODE ISLAND                              '.
076600          05  FILLER   PIC X(58)  VALUE
076700     '42  099637  42 SOUTH CAROLINA                            '.
076800          05  FILLER   PIC X(58)  VALUE
076900     '43  099680  43 SOUTH DAKOTA                              '.
077000          05  FILLER   PIC X(58)  VALUE
077100     '44  099627  44 TENNESSEE                                 '.
077200          05  FILLER   PIC X(58)  VALUE
077300     '45  099677  45 TEXAS                                     '.
077400          05  FILLER   PIC X(58)  VALUE
077500     '46  099680  46 UTAH                                      '.
077600         05  FILLER   PIC X(58)  VALUE
077700     '47  099680  47 VERMONT                                   '.
077800          05  FILLER   PIC X(58)  VALUE
077900     '48  100000  48 VIRGIN ISLANDS                            '.
078000          05  FILLER   PIC X(58)  VALUE
078100     '49  099679  49 VIRGINIA                                  '.
078200          05  FILLER   PIC X(58)  VALUE
078300     '50  099639  50 WASHINGTON                                '.
078400          05  FILLER   PIC X(58)  VALUE
078500     '51  099637  51 WEST VIRGINIA                             '.
078600          05  FILLER   PIC X(58)  VALUE
078700     '52  099657  52 WISCONSIN                                 '.
078800          05  FILLER   PIC X(58)  VALUE
078900     '53  099680  53 WYOMING                                   '.
079000          05  FILLER   PIC X(58)  VALUE
079100     '55  099311  55 CALIFORNIA                                '.
079200          05  FILLER   PIC X(58)  VALUE
079300     '56  100000  56 CANADA                                    '.
079400          05  FILLER   PIC X(58)  VALUE
079500     '59  100000  59 MEXICO                                    '.
079600          05  FILLER   PIC X(58)  VALUE
079700     '64  100000  64 AMERICAN SAMOA                            '.
079800          05  FILLER   PIC X(58)  VALUE
079900     '65  100000  65 GUAM                                      '.
080000          05  FILLER   PIC X(58)  VALUE
080100     '66  100000  66 MARIANAS ISLANDS                          '.
080200          05  FILLER   PIC X(58)  VALUE
080300     '67  099677  67 TEXAS                                     '.
080400          05  FILLER   PIC X(58)  VALUE
080500     '68  099636  68 FLORIDA                                   '.
080600          05  FILLER   PIC X(58)  VALUE
080700     '69  099636  69 FLORIDA                                   '.
080800          05  FILLER   PIC X(58)  VALUE
080900     '70  099680  70 KANSAS                                    '.
081000          05  FILLER   PIC X(58)  VALUE
081100     '71  099670  71 LOUISIANA                                 '.
081200          05  FILLER   PIC X(58)  VALUE
081300     '72  099663  72 OHIO                                      '.
081400          05  FILLER   PIC X(58)  VALUE
081500     '73  099679  73 PENNSYLVANIA                              '.
081600          05  FILLER   PIC X(58)  VALUE
081700     '74  099677  74 TEXAS                                     '.
081800          05  FILLER   PIC X(58)  VALUE
081900     '75  099311  75 CALIFORNIA                                '.
082000          05  FILLER   PIC X(58)  VALUE
082100     '76  099435  76 IOWA                                      '.
082200          05  FILLER   PIC X(58)  VALUE
082300     '77  099680  77 MINNESOTA                                 '.
082400          05  FILLER   PIC X(58)  VALUE
082500     '78  099679  78 ILLINOIS                                  '.
082600          05  FILLER   PIC X(58)  VALUE
082700     '80  100000  80 MARYLAND                                  '.
082800      02  WK-SSRFBN-DATA2 REDEFINES WK-SSRFBN-DATA.
082900         05  SSRFBN-TAB OCCURS 72 ASCENDING KEY IS WK-SSRFBN-STATE
083000                               INDEXED BY SSRFBN-IDX.
083100           10  WK-SSRFBN-REASON-ALL.
083200              15 WK-SSRFBN-STATE  PIC 99.
083300              15 FILLER           PIC XX.
083400              15 WK-SSRFBN-RATE   PIC 9(1)V9(5).
083500              15 FILLER           PIC XX.
083600              15 WK-SSRFBN-CODE2  PIC 99.
083700              15 FILLER           PIC XX.
083800              15 WK-SSRFBN-STNAM  PIC X(20).
083900              15 WK-SSRFBN-REST   PIC X(22).
084000
084100*****YEARCHANGE 2009.1 ************************************       20110000
084200
084300
084400 01  MES-ADD-PROV                   PIC X(53) VALUE SPACES.
084500 01  MES-CHG-PROV                   PIC X(53) VALUE SPACES.
084600 01  MES-PPS-STATE                  PIC X(02).
084700 01  MES-INTRO                      PIC X(53) VALUE SPACES.
084800 01  MES-TOT-PAY                    PIC 9(07)V9(02) VALUE 0.
084900 01  MES-SSRFBN.
085000     05 MES-SSRFBN-STATE PIC 99.
085100     05 FILLER           PIC XX.
085200     05 MES-SSRFBN-RATE  PIC 9(1)V9(5).
085300     05 FILLER           PIC XX.
085400     05 MES-SSRFBN-CODE2 PIC 99.
085500     05 FILLER           PIC XX.
085600     05 MES-SSRFBN-STNAM PIC X(20).
085700     05 MES-SSRFBN-REST  PIC X(22).
085800
085900                                                                  04620000
086000 01  HOLD-AREA.                                                   04630000
086100     02  HOLD-PPS-COMPONENTS.                                     04640000
086200         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        04650000
086300         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        04660000
086400                                                                  04670000
086500         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        04680000
086600         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        04690000
086700                                                                  04700000
086800         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        04710000
086900         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        04720000
087000         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        04730000
087100                                                                  04740000
087200         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        04750000
087300         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        04760000
087400         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        04770000
087500                                                                  04780000
087600         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        04790000
087700         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        04800000
087800                                                                  04810000
087900         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        04820000
088000         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        04830000
088100                                                                  04840000
088200         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        04850000
088300         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        04860000
088400                                                                  04870000
088500         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        04880000
088600         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        04890000
088700         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        04900000
088800         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        04910000
088900         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        04920000
089000         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        04930000
089100         05  H-CAPI-COLA                  PIC 9(01)V9(03).        04940000
089200         05  H-CAPI-SCH                   PIC 9(05)V9(02).        04950000
089300         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        04960000
089400         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        04970000
089500         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        04980000
089600         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        04990000
089700         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        05000000
089800         05  H-CAPI-GAF                   PIC 9(05)V9(04).        05010000
089900         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).        05020000
090000         05  H-BLEND-GAF                  PIC 9(05)V9(04).        05030000
090100         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        05040000
090200         05  H-COV-DAYS                   PIC 9(3).               05050000
090300         05  H-PERDIEM-DAYS               PIC 9(3).               05060000
090400         05  H-REG-DAYS                   PIC 9(3).               05070000
090500         05  H-LTR-DAYS                   PIC 9(3).               05080000
090600         05  H-DSCHG-FRCTN                PIC 9(3)V9999.          05090000
090700         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          05100000
090800         05  H-ALOS                       PIC 9(02)V9(01).        05110000
090900         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        05120000
091000         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        05130000
091100         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        05140000
091200         05  H-CST-THRESH                 PIC 9(05)V9(02).        05150000
091300         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).        05160000
091400         05  H-BUDG-NUTR01                PIC 9(01)V9(06).        05170000
091500         05  H-BUDG-NUTR02                PIC 9(01)V9(06).        05180000
091600         05  H-BUDG-NUTR03                PIC 9(01)V9(06).        05190000
091700         05  H-BUDG-NUTR04                PIC 9(01)V9(06).        05200000
091800         05  H-BUDG-NUTR05                PIC 9(01)V9(06).        05210000
091900         05  H-BUDG-NUTR06                PIC 9(01)V9(06).        05220000
092000         05  H-BUDG-NUTR07                PIC 9(01)V9(06).        05230000
092100         05  H-BUDG-NUTR08                PIC 9(01)V9(06).        05240000
092200         05  H-BUDG-NUTR09                PIC 9(01)V9(06).        05240000
092300         05  H-CASE-MIX-ADJ               PIC 9(01)V9(03).        05250000
092400         05  H-UPDATE-01                  PIC 9(01)V9(04).        05250000
092500         05  H-UPDATE-02                  PIC 9(01)V9(04).        05260000
092600         05  H-UPDATE-03                  PIC 9(01)V9(04).        05270000
092700         05  H-UPDATE-04                  PIC 9(01)V9(04).        05280000
092800         05  H-UPDATE-05                  PIC 9(01)V9(04).        05290000
092900         05  H-UPDATE-06                  PIC 9(01)V9(04).        05300000
093000         05  H-UPDATE-07                  PIC 9(01)V9(04).        05310000
093100         05  H-UPDATE-08                  PIC 9(01)V9(04).        05320000
093200         05  H-UPDATE-09                  PIC 9(01)V9(04).        05320000
093300         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).        05330000
093400         05  H-HSP-UPDATE94               PIC 9(01)V9(04).        05340000
093500         05  H-HSP-UPDATE95               PIC 9(01)V9(04).        05350000
093600         05  H-HSP-UPDATE96               PIC 9(01)V9(04).        05360000
093700         05  H-HSP-UPDATE97               PIC 9(01)V9(04).        05370000
093800         05  H-HSP-UPDATE98               PIC 9(01)V9(04).        05380000
093900         05  H-HSP-UPDATE99               PIC 9(01)V9(04).        05390000
094000         05  H-HSP-UPDATE00               PIC 9(01)V9(04).        05400000
094100         05  H-HSP-UPDATE01               PIC 9(01)V9(04).        05410000
094200         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).        05420000
094300         05  H-FEDERAL-RATE               PIC 9(04)V9(02).        05430000
094400         05  H-LABOR-PCT                  PIC 9(01)V9(04).        05440000
094500         05  H-NONLABOR-PCT               PIC 9(01)V9(04).        05450000
094600         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).        05460000
094700         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).        05470000
094800         05  H-HSP-RATE                   PIC 9(06)V9(09).        05480000
094900         05  H-FSP-RATE                   PIC 9(06)V9(09).        05490000
095000         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).        05500000
095100         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).        05510000
095200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        05520000
095300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        05530000
095400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        05540000
095500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        05550000
095600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).        05560000
095700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.           05570000
095800         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.          05580000
095900         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.          05590000
096000         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.          05600000
096100         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.          05610000
096200         05  H-NEW-TECH-ADDON-HRTIMP-STOP PIC S9(07)V99.          05610000
096300         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.          05620000
096400         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).             05630000
096500         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).             05631000
096600                                                                  05632000
096700         05  H-LESSER-NEURO-1             PIC S9(07)V99.          05633000
096800         05  H-LESSER-NEURO-2             PIC S9(07)V99.          05634000
096900                                                                  05635000
097000         05  H-LESSER-GRAFT-1             PIC S9(07)V99.          05636000
097100         05  H-LESSER-GRAFT-2             PIC S9(07)V99.          05637000
097200                                                                  05638000
097300         05  H-LESSER-X-STOP-1            PIC S9(07)V99.          05639000
097400         05  H-LESSER-X-STOP-2            PIC S9(07)V99.          05640000
097500                                                                  05650000
097600
097700         05  H-LESSER-HRTIMP-STOP-1       PIC S9(07)V99.
097800         05  H-LESSER-HRTIMP-STOP-2       PIC S9(07)V99.
097900
098000                                                                  05660000
098100         05  H-CSTMED-NEURO               PIC S9(07)V99.          05670000
098200         05  H-CSTMED-GRAFT               PIC S9(07)V99.          05680000
098300         05  H-CSTMED-X-STOP              PIC S9(07)V99.          05690000
098400         05  H-CSTMED-HRTIMP-STOP         PIC S9(07)V99.          05690000
098500                                                                  05700000
098600                                                                  05710000
098700     02  HOLD-ADDITIONAL-VARIABLES.                               05720000
098800         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        05730000
098900         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        05740000
099000         05  H-NAT-PCT                    PIC 9(01)V9(02).        05750000
099100         05  H-REG-PCT                    PIC 9(01)V9(02).        05760000
099200         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).        05770000
099300         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        05780000
099400         05  H-DRG-WT                     PIC 9(02)V9(04).        05790000
099500         05  H-NAT-LABOR                  PIC 9(05)V9(02).        05800000
099600         05  H-NAT-NONLABOR               PIC 9(05)V9(02).        05810000
099700         05  H-REG-LABOR                  PIC 9(05)V9(02).        05820000
099800         05  H-REG-NONLABOR               PIC 9(05)V9(02).        05830000
099900         05  H-OPER-COLA                  PIC 9(01)V9(03).        05840000
100000         05  H-INTERN-RATIO               PIC 9(01)V9(04).        05850000
100100         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        05860000
100200         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        05870000
100300         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        05880000
100400                                                                  05890000
100500     02  HOLD-CAPITAL-VARIABLES.                                  05900000
100600         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        05910000
100700         05  H-CAPI-HSP                   PIC 9(07)V9(02).        05920000
100800         05  H-CAPI-FSP                   PIC 9(07)V9(02).        05930000
100900         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        05940000
101000         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        05950000
101100         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        05960000
101200         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        05970000
101300         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        05980000
101400                                                                  05990000
101500     02  HOLD-CAPITAL2-VARIABLES.                                 06000000
101600         05  H-CAPI2-PAY-CODE             PIC X(1).               06010000
101700         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        06020000
101800         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        06030000
101900                                                                  06040000
102000     02  HOLD-OTHER-VARIABLES.                                    06050000
102100         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).        06060000
102200         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).        06070000
102300         05  FILLER                       PIC X(21).              06080000
102400                                                                  06090000
102500     02  HOLD-PC-OTH-VARIABLES.                                   06100000
102600         05  H-OPER-DSH                   PIC 9(01)V9(04).        06110000
102700         05  H-CAPI-DSH                   PIC 9(01)V9(04).        06120000
102800         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        06130000
102900         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        06140000
103000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        06150000
103100         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).        06160000
103200         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).        06170000
103300         05  H-PC-HMO-FLAG                PIC X(01).              06180000
103400         05  H-PC-COT-FLAG                PIC X(01).              06190000
103500         05  H-FILLER                     PIC X(09).              06200000
103600                                                                  06210000
103700 01  HLD-PPS-DATA.                                                06220000
103800         10  HLD-PPS-RTC                PIC 9(02).                06230000
103900         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).          06240000
104000         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).                06250000
104100         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).          06260000
104200         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).          06270000
104300         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).          06280000
104400         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).          06290000
104500         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).          06300000
104600         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).          06310000
104700         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).          06320000
104800         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).                06330000
104900         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).                06340000
105000         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).          06350000
105100         10  HLD-PPS-CALC-VERS          PIC X(05).                06360000
105200                                                                  06370000
105300 LINKAGE SECTION.                                                 06380000
105400***************************************************************   06390000
105500*                 * * * * * * * * *                           *   06400000
105600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   06410000
105700*    IN HOW TO PAY THE BILL.                                  *   06420000
105800*                         *****                               *   06430000
105900*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *   06440000
106000*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *   06450000
106100*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *   06460000
106200*                 OUTLIER COMPUTATION.                        *   06470000
106300*                         *****                               *   06480000
106400*         REVIEW-CODE:                                        *   06490000
106500*            00 = PAY-WITH-OUTLIER.                           *   06500000
106600*                 WILL CALCULATE THE STANDARD PAYMENT.        *   06510000
106700*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *   06520000
106800*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *   06530000
106900*            03 = PAY-PERDIEM-DAYS.                           *   06540000
107000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06550000
107100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   06560000
107200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06570000
107300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   06580000
107400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06590000
107500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   06600000
107600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   06610000
107700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   06620000
107800*                 BILL EXCEED THE COST THRESHOLD.             *   06630000
107900*            06 = PAY-XFER-NO-COST                            *   06640000
108000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06650000
108100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   06660000
108200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06670000
108300*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   06680000
108400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06690000
108500*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   06700000
108600*                 CALCULATE ANY COST OUTLIER PORTION          *   06710000
108700*                 OF THE PAYMENT.                             *   06720000
108800*            07 = PAY-WITHOUT-COST.                           *   06730000
108900*                 WILL CALCULATE THE STANDARD PAYMENT         *   06740000
109000*                 WITHOUT COST PORTION.                       *   06750000
109100*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *   06760000
109200*                 50-50> 28  29  30  40  41  42  219              06770000
109300*                        220 221 477 478 479 480 481              06780000
109400*                        482 492 493 494 500 501 502              06790000
109500*                        515 516 517                              06800000
109600* =======================================================         06801000
109700* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S       06801000
109800* =======================================================         06801000
109900*                                                                 06801000
110000*                                                                 06801000
110100*     FULL PERDIEM >   3   4   25  26  27  28          31         06802000
110200*                      32  33              54  55  56  57         06803000
110300*                      64  65  66  70  71  72  85  86  87         06804000
110400*                      91  92  93  100 101 163 164 165 166        06805000
110500*                      167 168 175 176 177 178 179 186 187        06806000
110600*                      188 190 191 192 193 194 195 196 197        06807000
110700*                      198 205 206 207 216 217 218                06808000
110800*                          228 229 230 233 234 235 236 239        06809000
110900*                      240 241 242 243 244 255 256 257 264        06809100
111000*                      280 281 282 288 289 290 291 292 293        06809200
111100*                      299 300 301 314 315 316 326 327 328        06809300
111200*                      329 330 331 332 333 334 335 336 337        06809400
111300*                      356 357 358 371 372 373 374 375 376        06809500
111400*                      377 378 379 380 381 382 388 389 390        06809600
111500*                      405 406 407 414 415 416 441 442 443        06809700
111600*                      459 460 463 464 465 466 467 468 469        06809800
111700*                      470 474 475 476                            06809900
111800*                          483 484 488 489             495        06810000
111900*                      496 497             510 511 512            06810100
112000*                              533 534 535 536 539 540 541        06810200
112100*                      542 543 544 545 546 547 551 552 557        06810300
112200*                      558 559 560 561 562 563 573 574 575        06810400
112300*                      579 580 581 592 593 594 602 603 616        06810500
112400*                      617 618 622 623 624 628 629 630 637        06810600
112500*                      638 639 640 641 643 644 645 653 654        06810700
112600*                      655 659 660 661 682 683 684 689 690        06810800
112700*                      698 699 700 840 841 842 853 854 855        06810900
112800*                      856 857 858 862 863 867 868 869 870        06811000
112900*                      871 872 884 896 897 907 908 909 917        06811100
113000*                      918 945 946 947 948 956 981 982 983        06811200
113100*                      987 988 989                                06811300
113200*                                                                 06811400
113300*                               POST-ACUTE TRANSFERS          *   06811500
113400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   06811600
113500*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   06811700
113600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   06811800
113700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   06811900
113800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   06812000
113900*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   06813000
114000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   06814000
114100*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   06815000
114200*                 BILL EXCEED THE COST THRESHOLD.             *   06816000
114300*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *   06817000
114400*                 POST-ACUTE TRANSFERS                        *   06818000
114500*                 50-50> 28  29  30  40  41  42  219              06819000
114600*                        220 221 477 478 479 480 481              06820000
114700*                        482 492 493 494 500 501 502              06830000
114800*                        515 516 517                              06840000
114900*                                                                 06850000
115000* =======================================================         06801000
115100* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S       06801000
115200* =======================================================         06801000
115300*                                                                 06860000
115400*     FULL PERDIEM >     3   4   25  26  27              31       06870000
115500*                        32  33              54  55  56  57       06880000
115600*                        64  65  66  70  71  72  85  86  87       06890000
115700*                        91  92  93  100 101 163 164 165 166      06900000
115800*                        167 168 175 176 177 178 179 186 187      06910000
115900*                        188 190 191 192 193 194 195 196 197      06920000
116000*                        198 205 206 207 216 217 218              06930000
116100*                            228 229 230 233 234 235 236 239      06940000
116200*                        240 241 242 243 244 255 256 257 264      06950000
116300*                        280 281 282 288 289 290 291 292 293      06960000
116400*                        299 300 301 314 315 316 326 327 328      06970000
116500*                        329 330 331 332 333 334 335 336 337      06980000
116600*                        356 357 358 371 372 373 374 375 376      06990000
116700*                        377 378 379 380 381 382 388 389 390      07000000
116800*                        405 406 407 414 415 416 441 442 443      07010000
116900*                        459 460 463 464 465 466 467 468 469      07020000
117000*                        470 474 475 476                          07030000
117100*                            483 484 488 489             495      07040000
117200*                        496 497             510 511 512          07050000
117300*                                533 534 535 536 539 540 541      07060000
117400*                        542 543 544 545 546 547 551 552 557      07070000
117500*                        558 559 560 561 562 563 573 574 575      07080000
117600*                        579 580 581 592 593 594 602 603 616      07090000
117700*                        617 618 622 623 624 628 629 630 637      07100000
117800*                        638 639 640 641 643 644 645 653 654      07110000
117900*                        655 659 660 661 682 683 684 689 690      07120000
118000*                        698 699 700 840 841 842 853 854 855      07130000
118100*                        856 857 858 862 863 867 868 869 870      07140000
118200*                        871 872 884 896 897 907 908 909 917      07150000
118300*                        918 945 946 947 948 956 981 982 983      07160000
118400*                        987 988 989                              07170000
118500*                                                                 07180000
118600*                                                                 07190000
118700*                               POST-ACUTE TRANSFERS          *   07200000
118800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   07210000
118900*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   07220000
119000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   07230000
119100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   07240000
119200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   07250000
119300*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   07260000
119400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   07270000
119500*                 PAYMENT.                                    *   07280000
119600***************************************************************   07290000
119700                                                                  07300000
119800**************************************************************    07310000
119900*      MILLINNIUM COMPATIBLE                                 *    07320000
120000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *    07330000
120100*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *    07340000
120200*      IN THE NEW FORMAT                                     *    07350000
120300**************************************************************    07360000
120400 01  BILL-NEW-DATA.                                               07370000
120500         10  B-NPI10.                                             07380000
120600             15  B-NPI8             PIC X(08).                    07390000
120700             15  B-NPI-FILLER       PIC X(02).                    07400000
120800         10  B-PROVIDER-NO          PIC X(06).                    07410000
120900         10  B-REVIEW-CODE          PIC 9(02).                    07420000
121000             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.    07430000
121100             88  PAY-WITH-OUTLIER     VALUE 00 07.                07440000
121200             88  PAY-PERDIEM-DAYS     VALUE 03.                   07450000
121300             88  PAY-XFER-NO-COST     VALUE 06.                   07460000
121400             88  PAY-WITHOUT-COST     VALUE 07.                   07470000
121500             88  PAY-XFER-SPEC-DRG    VALUE 09 11.                07480000
121600             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.              07490000
121700         10  B-DRG                  PIC 9(03).                    07500000
121800             88  B-DRG-POSTACUTE-50-50                            07510000
121900                   VALUE 28  29  30  40  41  42  219              07520000
122000                         220 221 477 478 479 480 481              07530000
122100                         482 492 493 494 500 501 502              07540000
122200                         515 516 517.                             07550000
122300                                                                  07560000
122400* =======================================================         06801000
122500* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S         06801000
122600* =======================================================         06801000
122700*                                                                 06860000
122800             88  B-DRG-POSTACUTE-PERDIEM                          07570000
122900                   VALUE 3   4   25  26  27              31       07580000
123000                         32  33              54  55  56  57       07590000
123100                         64  65  66  70  71  72  85  86  87       07600000
123200                         91  92  93  100 101 163 164 165 166      07610000
123300                         167 168 175 176 177 178 179 186 187      07620000
123400                         188 190 191 192 193 194 195 196 197      07630000
123500                         198 205 206 207 216 217 218              07640000
123600                             228 229 230 233 234 235 236 239      07650000
123700                         240 241 242 243 244 255 256 257 264      07660000
123800                         280 281 282 288 289 290 291 292 293      07670000
123900                         299 300 301 314 315 316 326 327 328      07680000
124000                         329 330 331 332 333 334 335 336 337      07690000
124100                         356 357 358 371 372 373 374 375 376      07700000
124200                         377 378 379 380 381 382 388 389 390      07710000
124300                         405 406 407 414 415 416 441 442 443      07720000
124400                         459 460 463 464 465 466 467 468 469      07730000
124500                         470 474 475 476                          07740000
124600                             483 484 488 489             495      07750000
124700                         496 497             510 511 512          07760000
124800                                 533 534 535 536 539 540 541      07770000
124900                         542 543 544 545 546 547 551 552 557      07780000
125000                         558 559 560 561 562 563 573 574 575      07790000
125100                         579 580 581 592 593 594 602 603 616      07800000
125200                         617 618 622 623 624 628 629 630 637      07810000
125300                         638 639 640 641 643 644 645 653 654      07820000
125400                         655 659 660 661 682 683 684 689 690      07830000
125500                         698 699 700 840 841 842 853 854 855      07840000
125600                         856 857 858 862 863 867 868 869 870      07850000
125700                         871 872 884 896 897 907 908 909 917      07860000
125800                         918 945 946 947 948 956 981 982 983      07870000
125900                         987 988 989.                             07880000
126000                                                                  07890000
126100         10  B-LOS                  PIC 9(03).                    07900000
126200         10  B-COVERED-DAYS         PIC 9(03).                    07910000
126300         10  B-LTR-DAYS             PIC 9(02).                    07920000
126400         10  B-DISCHARGE-DATE.                                    07930000
126500             15  B-DISCHG-CC        PIC 9(02).                    07940000
126600             15  B-DISCHG-YY        PIC 9(02).                    07950000
126700             15  B-DISCHG-MM        PIC 9(02).                    07960000
126800             15  B-DISCHG-DD        PIC 9(02).                    07970000
126900         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              07980000
127000         10  B-PRIN-PROC-CODE       PIC X(07).                    07990000
127100         10  B-OTHER-PROC-CODE1     PIC X(07).                    08000000
127200         10  B-OTHER-PROC-CODE2     PIC X(07).                    08010000
127300         10  B-OTHER-PROC-CODE3     PIC X(07).                    08020000
127400         10  B-OTHER-PROC-CODE4     PIC X(07).                    08030000
127500         10  B-OTHER-PROC-CODE5     PIC X(07).                    08040000
127600         10  B-OTHER-PROC-CODE6     PIC X(07).
127700         10  B-OTHER-PROC-CODE7     PIC X(07).
127800         10  B-OTHER-PROC-CODE8     PIC X(07).
127900         10  B-OTHER-PROC-CODE9     PIC X(07).
128000         10  B-OTHER-PROC-CODE10    PIC X(07).
128100         10  B-OTHER-PROC-CODE11    PIC X(07).
128200         10  B-OTHER-PROC-CODE12    PIC X(07).
128300         10  B-OTHER-PROC-CODE13    PIC X(07).
128400         10  B-OTHER-PROC-CODE14    PIC X(07).
128500         10  B-OTHER-PROC-CODE15    PIC X(07).
128600         10  B-OTHER-PROC-CODE16    PIC X(07).
128700         10  B-OTHER-PROC-CODE17    PIC X(07).
128800         10  B-OTHER-PROC-CODE18    PIC X(07).
128900         10  B-OTHER-PROC-CODE19    PIC X(07).
129000         10  B-OTHER-PROC-CODE20    PIC X(07).
129100         10  B-OTHER-PROC-CODE21    PIC X(07).
129200         10  B-OTHER-PROC-CODE22    PIC X(07).
129300         10  B-OTHER-PROC-CODE23    PIC X(07).
129400         10  B-OTHER-PROC-CODE24    PIC X(07).
129500         10  B-OTHER-DIAG-CODE1     PIC X(07).                    06012000
129600         10  B-OTHER-DIAG-CODE2     PIC X(07).                    06013000
129700         10  B-OTHER-DIAG-CODE3     PIC X(07).                    06014000
129800         10  B-OTHER-DIAG-CODE4     PIC X(07).                    06015000
129900         10  B-OTHER-DIAG-CODE5     PIC X(07).                    06016000
130000         10  B-OTHER-DIAG-CODE6     PIC X(07).                    06017000
130100         10  B-OTHER-DIAG-CODE7     PIC X(07).                    06018000
130200         10  B-OTHER-DIAG-CODE8     PIC X(07).                    06019000
130300         10  B-OTHER-DIAG-CODE9     PIC X(07).                    06019100
130400         10  B-OTHER-DIAG-CODE10    PIC X(07).                    06019200
130500         10  B-OTHER-DIAG-CODE11    PIC X(07).                    06019300
130600         10  B-OTHER-DIAG-CODE12    PIC X(07).                    06019400
130700         10  B-OTHER-DIAG-CODE13    PIC X(07).                    06019500
130800         10  B-OTHER-DIAG-CODE14    PIC X(07).                    06019600
130900         10  B-OTHER-DIAG-CODE15    PIC X(07).                    06019700
131000         10  B-OTHER-DIAG-CODE16    PIC X(07).                    06019800
131100         10  B-OTHER-DIAG-CODE17    PIC X(07).                    06019900
131200         10  B-OTHER-DIAG-CODE18    PIC X(07).                    06020000
131300         10  B-OTHER-DIAG-CODE19    PIC X(07).                    06020100
131400         10  B-OTHER-DIAG-CODE20    PIC X(07).                    06020200
131500         10  B-OTHER-DIAG-CODE21    PIC X(07).                    06020300
131600         10  B-OTHER-DIAG-CODE22    PIC X(07).                    06020400
131700         10  B-OTHER-DIAG-CODE23    PIC X(07).                    06020500
131800         10  B-OTHER-DIAG-CODE24    PIC X(07).                    06020600
131900         10  B-OTHER-DIAG-CODE25    PIC X(07).                    06020700
132000         10  BILL-DEMO-DATA.
132100             15  BILL-DEMO-CODE1        PIC X(02).
132200             15  BILL-DEMO-CODE2        PIC X(02).
132300             15  BILL-DEMO-CODE3        PIC X(02).
132400             15  BILL-DEMO-CODE4        PIC X(02).
132500         10  BILL-NDC-DATA.
132600             15  BILL-NDC-NUMBER        PIC X(11).
132700         10  FILLER                     PIC X(73).
132800                                                                  06020800
132900                                                                  06020800
133000                                                                  08050000
133100***************************************************************   08060000
133200*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   08070000
133300*    AND PASSED BACK TO THE CALLING PROGRAM                   *   08080000
133400*            RETURN CODE VALUES (PPS-RTC)                     *   08090000
133500*                                                             *   08100000
133600*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   08110000
133700*                                                             *   08120000
133800*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *   08130000
133900*                                                             *   08140000
134000*           30,00 = PAID NORMAL DRG PAYMENT                   *   08150000
134100*                                                             *   08160000
134200*              01 = PAID AS A DAY-OUTLIER.                    *   08170000
134300*                   NOTE:                                     *   08180000
134400*                     DAY-OUTLIER NO LONGER BEING PAID        *   08190000
134500*                         AS OF 10/01/97                      *   08200000
134600*                                                             *   08210000
134700*              02 = PAID AS A COST-OUTLIER.                   *   08220000
134800*                                                             *   08230000
134900*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08240000
135000*                   AND INCLUDING THE FULL DRG.               *   08250000
135100*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08260000
135200*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   08270000
135300*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   08280000
135400*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   08290000
135500*                   AND INCLUDING THE FULL DRG. PROVIDER      *   08300000
135600*                   REFUSED COST OUTLIER.                     *   08310000
135700*           40,10 = POST-ACUTE TRANSFER                       *   08320000
135800*                   DRG = 28  29  30  40  41  42  219             08330000
135900*                         220 221 477 478 479 480 481             08340000
136000*                         482 492 493 494 500 501 502             08350000
136100*                         515 516 517                             08360000
136200*                                                                 08370000
136300* =======================================================         06801000
136400* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S         06801000
136500* =======================================================         06801000
136600*                                                                 06860000
136700*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *   08380000
136800*                       THE FOLLOWING DRG'S                   *   08390000
136900*                   DRG = 3   4   25  26  27              31      08400000
137000*                         32  33              54  55  56  57      08410000
137100*                         64  65  66  70  71  72  85  86  87      08420000
137200*                         91  92  93  100 101 163 164 165 166     08430000
137300*                         167 168 175 176 177 178 179 186 187     08440000
137400*                         188 190 191 192 193 194 195 196 197     08450000
137500*                         198 205 206 207 216 217 218             08460000
137600*                             228 229 230 233 234 235 236 239     08470000
137700*                         240 241 242 243 244 255 256 257 264     08480000
137800*                         280 281 282 288 289 290 291 292 293     08490000
137900*                         299 300 301 314 315 316 326 327 328     08500000
138000*                         329 330 331 332 333 334 335 336 337     08510000
138100*                         356 357 358 371 372 373 374 375 376     08520000
138200*                         377 378 379 380 381 382 388 389 390     08530000
138300*                         405 406 407 414 415 416 441 442 443     08540000
138400*                         459 460 463 464 465 466 467 468 469     08550000
138500*                         470 474 475 476                         08560000
138600*                             483 484 488 489             495     08570000
138700*                         496 497             510 511 512         08580000
138800*                                 533 534 535 536 539 540 541     08590000
138900*                         542 543 544 545 546 547 551 552 557     08600000
139000*                         558 559 560 561 562 563 573 574 575     08610000
139100*                         579 580 581 592 593 594 602 603 616     08620000
139200*                         617 618 622 623 624 628 629 630 637     08630000
139300*                         638 639 640 641 643 644 645 653 654     08640000
139400*                         655 659 660 661 682 683 684 689 690     08650000
139500*                         698 699 700 840 841 842 853 854 855     08660000
139600*                         856 857 858 862 863 867 868 869 870     08670000
139700*                         871 872 884 896 897 907 908 909 917     08680000
139800*                         918 945 946 947 948 956 981 982 983     08690000
139900*                         987 988 989                             08700000
140000*                                                                 08710000
140100*           44,14 = PAID NORMAL DRG PAYMENT WITH              *   08720000
140200*                    PERDIEM DAYS = OR > GM  ALOS             *   08730000
140300*              16 = PAID AS A COST-OUTLIER WITH               *   08740000
140400*                    PERDIEM DAYS = OR > GM  ALOS             *   08750000
140500*                                                             *   08760000
140600*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   08770000
140700*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   08780000
140800*              52 = INVALID CBSA# IN PROVIDER FILE            *   08790000
140900*                   OR INVALID WAGE INDEX                     *   08800000
141000*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   08810000
141100*              54 = INVALID DRG                               *   08820000
141200*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   08830000
141300*                                      OR                     *   08840000
141400*                   DISCHARGE DATE < CBSA EFF START DATE      *   08850000
141500*                   FOR PPS                                   *   08860000
141600*                                      OR                     *   08870000
141700*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *   08880000
141800*                   DISCHARGE DATE                            *   08890000
141900*              56 = INVALID LENGTH OF STAY                    *   08900000
142000*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *   08910000
142100*                                        NOT 11)              *   08920000
142200*              58 = TOTAL CHARGES NOT NUMERIC                 *   08930000
142300*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   08940000
142400*                   OR BILL-LTR-DAYS > 60                     *   08950000
142500*              62 = INVALID NUMBER OF COVERED DAYS            *   08960000
142600*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   08970000
142700*                   SPECIFIC FILE FOR CAPITAL                 *   08980000
142800*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   08990000
142900*                   OR COST OUTLIER THRESHOLD CALUCULATION    *   09000000
143000*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   09010000
143100***************************************************************   09020000
143200 01  PPS-DATA.                                                    09030000
143300         10  PPS-RTC                PIC 9(02).                    09040000
143400         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              09050000
143500         10  PPS-OUTLIER-DAYS       PIC 9(03).                    09060000
143600         10  PPS-AVG-LOS            PIC 9(02)V9(01).              09070000
143700         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              09080000
143800         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              09090000
143900         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              09100000
144000         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              09110000
144100         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              09120000
144200         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              09130000
144300         10  PPS-REG-DAYS-USED      PIC 9(03).                    09140000
144400         10  PPS-LTR-DAYS-USED      PIC 9(02).                    09150000
144500         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              09160000
144600         10  PPS-CALC-VERS          PIC X(05).                    09170000
144700                                                                  09180000
144800******************************************************************09190000
144900*            THESE ARE THE VERSIONS OF THE PPCAL                  09200000
145000*           PROGRAMS THAT WILL BE PASSED BACK----                 09210000
145100*          ASSOCIATED WITH THE BILL BEING PROCESSED               09220000
145200******************************************************************09230000
145300 01  PRICER-OPT-VERS-SW.                                          09240000
145400     02  PRICER-OPTION-SW          PIC X(01).                     09250000
145500         88  ALL-TABLES-PASSED          VALUE 'A'.                09260000
145600         88  PROV-RECORD-PASSED         VALUE 'P'.                09270000
145700         88  ADDITIONAL-VARIABLES       VALUE 'M'.                09280000
145800         88  PC-PRICER                  VALUE 'C'.                09290000
145900     02  PPS-VERSIONS.                                            09300000
146000         10  PPDRV-VERSION         PIC X(05).                     09310000
146100                                                                  09320000
146200******************************************************************09330000
146300*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           09340000
146400*          ASSOCIATED WITH THE BILL BEING PROCESSED               09350000
146500******************************************************************09360000
146600 01  PPS-ADDITIONAL-VARIABLES.                                    09370000
146700     05  PPS-HSP-PCT                PIC 9(01)V9(02).              09380000
146800     05  PPS-FSP-PCT                PIC 9(01)V9(02).              09390000
146900     05  PPS-NAT-PCT                PIC 9(01)V9(02).              09400000
147000     05  PPS-REG-PCT                PIC 9(01)V9(02).              09410000
147100     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).              09420000
147200     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              09430000
147300     05  PPS-DRG-WT                 PIC 9(02)V9(04).              09440000
147400     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              09450000
147500     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              09460000
147600     05  PPS-REG-LABOR              PIC 9(05)V9(02).              09470000
147700     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              09480000
147800     05  PPS-OPER-COLA              PIC 9(01)V9(03).              09490000
147900     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              09500000
148000     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              09510000
148100     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              09520000
148200     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              09530000
148300     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                09540000
148400     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                09550000
148500     05  PPS-CAPITAL-VARIABLES.                                   09560000
148600         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        09570000
148700         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        09580000
148800         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        09590000
148900         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        09600000
149000         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        09610000
149100         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        09620000
149200         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        09630000
149300         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        09640000
149400     05  PPS-CAPITAL2-VARIABLES.                                  09650000
149500         10  PPS-CAPI2-PAY-CODE             PIC X(1).             09660000
149600         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      09670000
149700         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      09680000
149800                                                                  09690000
149900     05  PPS-OTHER-VARIABLES.                                     09700000
150000         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).      09710000
150100         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).      09720000
150200         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
150300         10  PPS-HVBP-HRR-DATA.
150400             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
150500             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
150600             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
150700             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
150800         10  PPS-OPERATNG-DATA.
150900             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
151000             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
151100             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
151200                                                                  09740000
151300     05  PPS-PC-OTH-VARIABLES.                                    09750000
151400         10  PPS-OPER-DSH                   PIC 9(01)V9(04).      09760000
151500         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).      09770000
151600         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).      09780000
151700         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).      09790000
151800         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).      09800000
151900         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).      09810000
152000         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).      09820000
152100         10  PPS-PC-HMO-FLAG                PIC X(01).            09830000
152200         10  PPS-PC-COT-FLAG                PIC X(01).            09840000
152300         10  PPS-FILLER                      PIC X(0998).
152400                                                                  09860000
152500 01  PROV-NEW-HOLD.                                               09870000
152600     02  PROV-NEWREC-HOLD1.                                       09880000
152700         05  P-NEW-NPI10.                                         09890000
152800             10  P-NEW-NPI8             PIC X(08).                09900000
152900             10  P-NEW-NPI-FILLER       PIC X(02).                09910000
153000         05  P-NEW-PROVIDER-NO.                                   09920000
153100             88  P-NEW-DSH-ADJ-PROVIDERS                          09930000
153200                             VALUE '180049' '190044' '190144'     09940000
153300                                   '190191' '330047' '340085'     09950000
153400                                   '370016' '370149' '420043'.    09960000
153500             10  P-NEW-STATE            PIC 9(02).                09970000
153600             10  FILLER                 PIC X(04).                09980000
153700         05  P-NEW-DATE-DATA.                                     09990000
153800             10  P-NEW-EFF-DATE.                                  10000000
153900                 15  P-NEW-EFF-DT-CC    PIC 9(02).                10010000
154000                 15  P-NEW-EFF-DT-YY    PIC 9(02).                10020000
154100                 15  P-NEW-EFF-DT-MM    PIC 9(02).                10030000
154200                 15  P-NEW-EFF-DT-DD    PIC 9(02).                10040000
154300             10  P-NEW-FY-BEGIN-DATE.                             10050000
154400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                10060000
154500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                10070000
154600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                10080000
154700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                10090000
154800             10  P-NEW-REPORT-DATE.                               10100000
154900                 15  P-NEW-REPORT-DT-CC PIC 9(02).                10110000
155000                 15  P-NEW-REPORT-DT-YY PIC 9(02).                10120000
155100                 15  P-NEW-REPORT-DT-MM PIC 9(02).                10130000
155200                 15  P-NEW-REPORT-DT-DD PIC 9(02).                10140000
155300             10  P-NEW-TERMINATION-DATE.                          10150000
155400                 15  P-NEW-TERM-DT-CC   PIC 9(02).                10160000
155500                 15  P-NEW-TERM-DT-YY   PIC 9(02).                10170000
155600                 15  P-NEW-TERM-DT-MM   PIC 9(02).                10180000
155700                 15  P-NEW-TERM-DT-DD   PIC 9(02).                10190000
155800         05  P-NEW-WAIVER-CODE          PIC X(01).                10200000
155900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              10210000
156000         05  P-NEW-INTER-NO             PIC 9(05).                10220000
156100         05  P-NEW-PROVIDER-TYPE        PIC X(02).                10230000
156200             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      10240000
156300             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       10250000
156400                                                  '15' '17'       10260000
156500                                                  '22'.           10270000
156600             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           10280000
156700             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           10290000
156800             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           10300000
156900             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           10310000
157000             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      10320000
157100             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           10330000
157200             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      10340000
157300             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           10350000
157400             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           10360000
157500             88  P-N-EACH                   VALUE '21' '22'.      10370000
157600             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           10380000
157700             88  P-N-NHCMQ-II-SNF           VALUE '32'.           10390000
157800             88  P-N-NHCMQ-III-SNF          VALUE '33'.           10400000
157900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                10410000
158000             88  P-N-NEW-ENGLAND            VALUE  1.             10420000
158100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             10430000
158200             88  P-N-SOUTH-ATLANTIC         VALUE  3.             10440000
158300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             10450000
158400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             10460000
158500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             10470000
158600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             10480000
158700             88  P-N-MOUNTAIN               VALUE  8.             10490000
158800             88  P-N-PACIFIC                VALUE  9.             10500000
158900         05  P-NEW-CURRENT-DIV   REDEFINES                        10510000
159000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         10520000
159100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          10530000
159200         05  P-NEW-MSA-DATA.                                      10540000
159300             10  P-NEW-CHG-CODE-INDEX       PIC X.                10550000
159400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 10560000
159500             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   10570000
159600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       10580000
159700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 10590000
159800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 10600000
159900             10  P-NEW-STAND-AMT-LOC-MSA9                         10610000
160000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         10620000
160100                 15  P-NEW-RURAL-1ST.                             10630000
160200                     20  P-NEW-STAND-RURAL  PIC XX.               10640000
160300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    10650000
160400                 15  P-NEW-RURAL-2ND        PIC XX.               10660000
160500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    10670000
160600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           10680000
160700                 88  P-NEW-SCH-YR82       VALUE   '82'.           10690000
160800                 88  P-NEW-SCH-YR87       VALUE   '87'.           10700000
160900         05  P-NEW-LUGAR                    PIC X.                10710000
161000         05  P-NEW-TEMP-RELIEF-IND          PIC X.                10720000
161100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                10730000
161200         05  FILLER                         PIC X(05).            10740000
161300     02  PROV-NEWREC-HOLD2.                                       10750000
161400         05  P-NEW-VARIABLES.                                     10760000
161500             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        10770000
161600             10  P-NEW-COLA              PIC  9(01)V9(03).        10780000
161700             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        10790000
161800             10  P-NEW-BED-SIZE          PIC  9(05).              10800000
161900             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        10810000
162000             10  P-NEW-CMI               PIC  9(01)V9(04).        10820000
162100             10  P-NEW-SSI-RATIO         PIC  V9(04).             10830000
162200             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             10840000
162300             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              10850000
162400             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        10860000
162500             10  P-NEW-DSH-PERCENT       PIC  V9(04).             10870000
162600             10  P-NEW-FYE-DATE          PIC  X(08).              10880000
162700         05  P-NEW-CBSA-DATA.                                     10890000
162800             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.                10900000
162900             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.                10900000
163000             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT. 10900000
163100             10  P-NEW-CBSA-GEO-RURAL REDEFINES                   10900000
163200                 P-NEW-CBSA-GEO-LOC.                              10900000
163300                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.             10900000
163400                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.    10900000
163500                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.              10900000
163600                                                                  10900000
163700             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT. 10900000
163800             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT. 10900000
163900             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).   10900000
164000     02  PROV-NEWREC-HOLD3.                                       10930000
164100         05  P-NEW-PASS-AMT-DATA.                                 10940000
164200             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          10950000
164300             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          10960000
164400             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          10970000
164500             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          10980000
164600         05  P-NEW-CAPI-DATA.                                     10990000
164700             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 11000000
164800             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          11010000
164900             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          11020000
165000             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        11030000
165100             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             11040000
165200             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 11050000
165300             15  P-NEW-CAPI-IME            PIC 9V9999.            11060000
165400             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          11070000
165500         05  P-HVBP-HRR-DATA.                                     08690000
165600             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.                08690100
165700             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).          08690200
165800             15  P-HOSP-READMISSION-REDUCTN PIC X.                08690300
165900             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).           08690400
166000         05  P-MODEL1-BUNDLE-DATA.                                      08
166100             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.                   08
166200             15  P-HAC-REDUC-IND            PIC X.
166300             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
166400             15  P-EHR-REDUC-IND            PIC X.
166500         05  FILLER                         PIC X(09).
166600
166700******************************************************************11090000
166800 01  WAGE-NEW-CBSA-INDEX-RECORD.                                  11100000
166900     05  W-CBSA                        PIC X(5).                  11110000
167000     05  W-CBSA-SIZE                   PIC X.                     11120000
167100         88  LARGE-URBAN       VALUE 'L'.                         11130000
167200         88  OTHER-URBAN       VALUE 'O'.                         11140000
167300         88  ALL-RURAL         VALUE 'R'.                         11150000
167400     05  W-CBSA-EFF-DATE               PIC X(8).                  11160000
167500     05  FILLER                        PIC X.                     11170000
167600     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).          11180000
167700     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).          11190000
167800                                                                  11200000
167900                                                                  11210000
168000 PROCEDURE DIVISION  USING BILL-NEW-DATA                          11220000
168100                           PPS-DATA                               11230000
168200                           PRICER-OPT-VERS-SW                     11240000
168300                           PPS-ADDITIONAL-VARIABLES               11250000
168400                           PROV-NEW-HOLD                          11260000
168500                           WAGE-NEW-CBSA-INDEX-RECORD.            11270000
168600                                                                  11280000
168700***************************************************************   11290000
168800*    PROCESSING:                                              *   11300000
168900*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            11310000
169000*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   11320000
169100*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   11330000
169200*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   11340000
169300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   11350000
169400*           GOBACK.                                           *   11360000
169500*        D. ASSEMBLE PRICING COMPONENTS.                      *   11370000
169600*        E. CALCULATE THE PRICE.                              *   11380000
169700***************************************************************   11390000
169800                                                                  11400000
169900     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.                      11410000
170000     MOVE 'N' TO TEMP-RELIEF-FLAG.                                11420000
170100     MOVE 'N' TO OUTLIER-RECON-FLAG.                              11430000
170200                                                                  11440000
170300     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                11450000
170400                                                                  11460000
170500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 11470000
170600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          11480000
170700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         11490000
170800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    11500000
170900     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   11510000
171000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            11520000
171100     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.      11530000
171200     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.     11540000
171300                                                                  11550000
171400     IF (PPS-RTC = '00' OR '03' OR '10' OR                        11560000
171500                   '12' OR '14')                                  11570000
171600        MOVE 'Y' TO OUTLIER-RECON-FLAG                            11580000
171700        MOVE PPS-DATA TO HLD-PPS-DATA                             11590000
171800        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT              11600000
171900        MOVE HLD-PPS-DATA TO PPS-DATA.                            11610000
172000                                                                  11620000
172100     GOBACK.                                                      11630000
172200                                                                  11640000
172300 0200-MAINLINE-CONTROL.                                           11650000
172400                                                                  11660000
172500     MOVE 'N' TO HMO-TAG.                                         11670000
172600                                                                  11680000
172700     IF PPS-PC-HMO-FLAG = 'Y' OR                                  11690000
172800               HMO-FLAG = 'Y'                                     11700000
172900        MOVE 'Y' TO HMO-TAG.                                      11710000
173000                                                                  11720000
173100     IF P-NEW-STATE NOT = 40                                      11730000
173200        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.                    11740000
173300                                                                  11750000
173400     MOVE ALL '0' TO PPS-DATA                                     11760000
173500                     H-OPER-DSH-SCH                               11770000
173600                     H-OPER-DSH-RRC                               11780000
173700                     HOLD-PPS-COMPONENTS                          11790000
173800                     HOLD-PPS-COMPONENTS                          11800000
173900                     HOLD-ADDITIONAL-VARIABLES                    11810000
174000                     HOLD-CAPITAL-VARIABLES                       11820000
174100                     HOLD-CAPITAL2-VARIABLES                      11830000
174200                     HOLD-OTHER-VARIABLES                         11840000
174300                     HOLD-PC-OTH-VARIABLES.                       11850000
174400                                                                  11860000
174500     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC                     11870000
174600        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.                      11880000
174700                                                                  11890000
174800     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC                     11900000
174900        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.                       11910000
175000                                                                  11920000
175100     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC                     11930000
175200        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.                      11940000
175300                                                                  11950000
175400     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC                       11960000
175500        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.                        11970000
175600                                                                  11980000
175700                                                                  11990000
175800     PERFORM 1000-EDIT-THE-BILL-INFO.                             12000000
175900                                                                  12010000
176000     IF  PPS-RTC = 00                                             12020000
176100         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      12030000
176200         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.                12040000
176300                                                                  12050000
176400     IF OUTLIER-RECON-FLAG = 'Y'                                  12060000
176500        MOVE 'N' TO OUTLIER-RECON-FLAG                            12070000
176600        GO TO 0200-EXIT.                                          12080000
176700                                                                  12090000
176800     IF PPS-RTC = 00                                              12100000
176900        IF H-PERDIEM-DAYS = H-ALOS OR                             12110000
177000           H-PERDIEM-DAYS > H-ALOS                                12120000
177100           MOVE 14 TO PPS-RTC.                                    12130000
177200                                                                  12140000
177300     IF PPS-RTC = 02                                              12150000
177400        IF H-PERDIEM-DAYS = H-ALOS OR                             12160000
177500           H-PERDIEM-DAYS > H-ALOS                                12170000
177600           MOVE 16 TO PPS-RTC.                                    12180000
177700                                                                  12190000
177800 0200-EXIT.   EXIT.                                               12200000
177900                                                                  12210000
178000 1000-EDIT-THE-BILL-INFO.                                         12220000
178100                                                                  12230000
178200     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.                             12240000
178300     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.                             12250000
178400                                                                  12260000
178500     IF  PPS-RTC = 00                                             12270000
178600         IF  P-NEW-WAIVER-STATE                                   12280000
178700             MOVE 53 TO PPS-RTC.                                  12290000
178800                                                                  12300000
178900     IF  PPS-RTC = 00                                             12310000
179000         IF  B-DRG < 001                                                00
179100               OR = 014 OR = 015 OR = 016 OR = 017                12330000
179200               OR = 018 OR = 019 OR = 043 OR = 044                12340000
179300               OR = 045 OR = 046 OR = 047 OR = 048                12350000
179400               OR = 049 OR = 050 OR = 051 OR = 104                12360000
179500               OR = 105 OR = 106 OR = 107 OR = 108                12370000
179600               OR = 109 OR = 110 OR = 111 OR = 112                12380000
179700               OR = 118 OR = 119 OR = 120 OR = 126                12390000
179800               OR = 127 OR = 128 OR = 140 OR = 141                12400000
179900               OR = 142 OR = 143 OR = 144 OR = 145                12410000
180000               OR = 160 OR = 161 OR = 162 OR = 169                12420000
180100               OR = 170 OR = 171 OR = 172 OR = 173                12430000
180200               OR = 174 OR = 209 OR = 210 OR = 211                12440000
180300               OR = 212 OR = 213 OR = 214                         12450000
180400               OR = 266 OR = 267 OR = 268 OR = 269                12460000
180500               OR = 270 OR = 271 OR = 272 OR = 273                12470000
180600               OR = 274 OR = 275 OR = 276 OR = 277                12480000
180700               OR = 278 OR = 279 OR = 317 OR = 318                12490000
180800               OR = 319 OR = 320 OR = 321 OR = 322                12500000
180900               OR = 323 OR = 324 OR = 325 OR = 359                12510000
181000               OR = 360 OR = 361 OR = 362 OR = 363                12520000
181100               OR = 364 OR = 365 OR = 366 OR = 367                12530000
181200               OR = 396 OR = 397 OR = 398 OR = 399                12540000
181300               OR = 400 OR = 401 OR = 402 OR = 403                12550000
181400               OR = 404 OR = 426 OR = 427 OR = 428                12560000
181500               OR = 429 OR = 430 OR = 431 OR = 447                12570000
181600               OR = 448 OR = 449 OR = 450 OR = 451                12580000
181700               OR = 452 OR = 518 OR = 519 OR = 520                12590000
181800               OR = 521 OR = 522 OR = 523 OR = 524                12600000
181900               OR = 525 OR = 526 OR = 527 OR = 528                12610000
182000               OR = 529 OR = 530 OR = 531 OR = 532                12620000
182100               OR = 567 OR = 568 OR = 569 OR = 570                12630000
182200               OR = 571 OR = 572 OR = 586 OR = 587                12640000
182300               OR = 588 OR = 589 OR = 590 OR = 591                12650000
182400               OR = 608 OR = 609 OR = 610 OR = 611                12660000
182500               OR = 612 OR = 613 OR = 631 OR = 632                12670000
182600               OR = 633 OR = 634 OR = 635 OR = 636                12680000
182700               OR = 646 OR = 647 OR = 648 OR = 649                12690000
182800               OR = 650 OR = 651 OR = 676 OR = 677                12700000
182900               OR = 678 OR = 679 OR = 680 OR = 681                12710000
183000               OR = 701 OR = 702 OR = 703 OR = 704                12720000
183100               OR = 705 OR = 706 OR = 719 OR = 720                12730000
183200               OR = 721 OR = 731 OR = 732 OR = 733                12740000
183300               OR = 751 OR = 752 OR = 753 OR = 762                12750000
183400               OR = 763 OR = 764 OR = 771 OR = 772                12760000
183500               OR = 773 OR = 783 OR = 784 OR = 785                12770000
183600               OR = 786 OR = 787 OR = 788 OR = 796                12780000
183700               OR = 797 OR = 798 OR = 805 OR = 806                12790000
183800               OR = 807 OR = 817 OR = 818 OR = 819                12800000
183900               OR = 831 OR = 832 OR = 833 OR = 850                12810000
184000               OR = 851 OR = 852 OR = 859 OR = 860                12820000
184100               OR = 861 OR = 873 OR = 874 OR = 875                12830000
184200               OR = 877 OR = 878 OR = 879 OR = 891                12840000
184300               OR = 891 OR = 892 OR = 892 OR = 893                12850000
184400               OR = 893 OR = 898 OR = 899 OR = 900                12860000
184500               OR = 910 OR = 911 OR = 912 OR = 924                12870000
184600               OR = 925 OR = 926 OR = 930 OR = 931                12880000
184700               OR = 932 OR = 936 OR = 937 OR = 938                12890000
184800               OR = 942 OR = 943 OR = 944 OR = 952                12900000
184900               OR = 953 OR = 954 OR = 960 OR = 961                12910000
185000               OR = 962 OR = 966 OR = 967 OR = 968                12920000
185100               OR = 971 OR = 972 OR = 973 OR = 978                12930000
185200               OR = 979 OR = 980 OR = 990 OR = 991                12940000
185300               OR = 992 OR = 993 OR = 994 OR = 995                12950000
185400               OR = 996 OR = 997                                  12960000
185500             MOVE 54 TO PPS-RTC.                                  12970000
185600                                                                  12980000
185700     IF  PPS-RTC = 00                                             12990000
185800            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR           13000000
185900                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))            13010000
186000                MOVE 55 TO PPS-RTC.                               13020000
186100                                                                  13030000
186200     IF  PPS-RTC = 00                                             13040000
186300         IF P-NEW-TERMINATION-DATE > 00000000                     13050000
186400            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR   13060000
186500                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))     13070000
186600                  MOVE 55 TO PPS-RTC.                             13080000
186700                                                                  13090000
186800     IF  PPS-RTC = 00                                             13100000
186900         IF  B-LOS NOT NUMERIC                                    13110000
187000             MOVE 56 TO PPS-RTC                                   13120000
187100         ELSE                                                     13130000
187200         IF  B-LOS = 0                                            13140000
187300             IF B-REVIEW-CODE NOT = 00 AND                        13150000
187400                              NOT = 03 AND                        13160000
187500                              NOT = 06 AND                        13170000
187600                              NOT = 07 AND                        13180000
187700                              NOT = 09 AND                        13190000
187800                              NOT = 11                            13200000
187900             MOVE 56 TO PPS-RTC.                                  13210000
188000                                                                  13220000
188100     IF  PPS-RTC = 00                                             13230000
188200         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            13240000
188300             MOVE 61 TO PPS-RTC                                   13250000
188400         ELSE                                                     13260000
188500             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       13270000
188600                                                                  13280000
188700     IF  PPS-RTC = 00                                             13290000
188800         IF  B-COVERED-DAYS NOT NUMERIC                           13300000
188900             MOVE 62 TO PPS-RTC                                   13310000
189000         ELSE                                                     13320000
189100         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     13330000
189200             MOVE 62 TO PPS-RTC                                   13340000
189300         ELSE                                                     13350000
189400             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   13360000
189500                                                                  13370000
189600     IF  PPS-RTC = 00                                             13380000
189700         IF  H-LTR-DAYS  > H-COV-DAYS                             13390000
189800             MOVE 62 TO PPS-RTC                                   13400000
189900         ELSE                                                     13410000
190000             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        13420000
190100                                                                  13430000
190200     IF  PPS-RTC = 00                                             13440000
190300         IF  NOT VALID-REVIEW-CODE                                13450000
190400             MOVE 57 TO PPS-RTC.                                  13460000
190500                                                                  13470000
190600     IF  PPS-RTC = 00                                             13480000
190700         IF  B-CHARGES-CLAIMED NOT NUMERIC                        13490000
190800             MOVE 58 TO PPS-RTC.                                  13500000
190900                                                                  13510000
191000     IF PPS-RTC = 00                                              13520000
191100           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'                       13530000
191200                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND         13540000
191300                                            NOT = 'B' AND         13550000
191400                                            NOT = 'C'             13560000
191500                 MOVE 65 TO PPS-RTC.                              13570000
191600                                                                  13580000
191700 2000-ASSEMBLE-PPS-VARIABLES.                                     13590000
191800***  GET THE PROVIDER SPECIFIC VARIABLES.                         13600000
191900***  GET THE PROVIDER SPECIFIC VARIABLES.                         13610000
192000                                                                  13620000
192100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.                 13630000
192200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.                   13640000
192300                                                                  13650000
192400     IF  (P-NEW-STATE = 02 OR 12)                                 13660000
192500         MOVE P-NEW-COLA TO H-OPER-COLA                           13670000
192600     ELSE                                                         13680000
192700         MOVE 1.000  TO H-OPER-COLA.                              13690000
192800                                                                  13700000
192900***************************************************************   13710000
193000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              13720000
193100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              13730000
193200                                                                  13740000
193300     PERFORM 2600-GET-DRG-WEIGHT                                  13750000
193400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               13760000
193500                                                                  13770000
193600***************************************************************   13780000
193700***  GET THE WAGE-INDEX                                           13790000
193800***  GET THE WAGE-INDEX                                           13800000
193900                                                                  13810000
194000     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.                    13820000
194100     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.              13830000
194200     MOVE P-NEW-STATE            TO MES-PPS-STATE.                13830000
194300                                                                  13840000
194400
194500     PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
194600
194700*****YEARCHANGE 2009.3 ************************************       16570000
194800
194900     IF  P-NEW-CBSA-SPEC-PAY-IND = '1' OR '2'                           00
195000       COMPUTE H-WAGE-INDEX ROUNDED =
195100                         H-WAGE-INDEX * 1
195200     ELSE                                                         13910000
195300       COMPUTE H-WAGE-INDEX ROUNDED =
195400                         H-WAGE-INDEX * MES-SSRFBN-RATE.
195500
195600*****YEARCHANGE 2009.3 ************************************       16570000
195700
195800***************************************************************   13850000
195900***  GET THE LABOR, NON-LABOR STANDARD RATES                      13860000
196000                                                                  13870000
196100     IF  P-NEW-STATE = 40                                         13880000
196200         MOVE 2 TO R2                                             13890000
196300         MOVE 3 TO R4                                             13900000
196400     ELSE                                                         13910000
196500         MOVE 1 TO R2                                             13920000
196600         MOVE 1 TO R4.                                            13930000
196700                                                                  13940000
196800     IF  LARGE-URBAN                                              13950000
196900         MOVE 1 TO R3                                             13960000
197000     ELSE                                                         13970000
197100         MOVE 2 TO R3.                                            13980000
197200                                                                  13990000
197300     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND                     14000000
197400        (H-WAGE-INDEX > 01.0000))                                 14010000
197500        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES                     14020000
197600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14030000
197700                                                                  14040000
197800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND                 14050000
197900         (H-WAGE-INDEX > 01.0000))                                14060000
198000        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES                     14070000
198100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14080000
198200                                                                  14090000
198300     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND                    14100000
198400         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))      14110000
198500        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES                     14120000
198600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14130000
198700                                                                  14140000
198800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND                 14150000
198900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))      14160000
199000        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES                     14170000
199100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14180000
199200                                                                  14190000
199300     IF P-NEW-STATE = 40                                          14200000
199400        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND                  14210000
199500            (H-PR-WAGE-INDEX > 01.0000))                          14220000
199600             PERFORM 2300-GET-PR-LAB-TB1-RATES                    14230000
199700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 14240000
199800                                                                  14250000
199900                                                                  14260000
200000     IF P-NEW-STATE = 40                                          14270000
200100        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND              14280000
200200             (H-PR-WAGE-INDEX > 01.0000))                         14290000
200300              PERFORM 2300-GET-PR-LAB-TB2-RATES                   14300000
200400                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.            14310000
200500                                                                  14320000
200600     IF P-NEW-STATE = 40                                          14330000
200700        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND                 14340000
200800         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))14350000
200900          PERFORM 2300-GET-PR-LAB-TB3-RATES                       14360000
201000              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                14370000
201100                                                                  14380000
201200     IF P-NEW-STATE = 40                                          14390000
201300        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND              14400000
201400         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))14410000
201500          PERFORM 2300-GET-PR-LAB-TB4-RATES                       14420000
201600              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                14430000
201700                                                                  14440000
201800***************************************************************   14450000
201900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               14460000
202000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               14470000
202100                                                                  14480000
202200     MOVE 0.00  TO H-OPER-HSP-PCT.                                14490000
202300     MOVE 1.00  TO H-OPER-FSP-PCT.                                14500000
202400                                                                  14510000
202500***************************************************************   14520000
202600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     14530000
202700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     14540000
202800                                                                  14550000
202900      MOVE 1.00 TO H-NAT-PCT.                                     14560000
203000      MOVE 0.00 TO H-REG-PCT.                                     14570000
203100                                                                  14580000
203200     IF  P-NEW-STATE = 40                                         14590000
203300         MOVE 0.75 TO H-NAT-PCT                                   14600000
203400         MOVE 0.25 TO H-REG-PCT.                                  14610000
203500                                                                  14620000
203600     IF  P-N-SCH-REBASED-FY90 OR                                  14630000
203700         P-N-EACH OR                                              14640000
203800         P-N-MDH-REBASED-FY90                                     14650000
203900         MOVE 1.00 TO H-OPER-HSP-PCT.                             14660000
204000                                                                  14670000
204100 2300-GET-LAB-NONLAB-TB1-RATES.                                   14680000
204200                                                                  14690000
204300     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)            14700000
204400         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14710000
204500         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14720000
204600         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14730000
204700         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14740000
204800                                                                  14750000
204900 2300-GET-LAB-NONLAB-TB2-RATES.                                   14760000
205000                                                                  14770000
205100     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)            14780000
205200         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14790000
205300         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14800000
205400         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14810000
205500         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14820000
205600                                                                  14830000
205700 2300-GET-LAB-NONLAB-TB3-RATES.                                   14840000
205800                                                                  14850000
205900     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)            14860000
206000         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14870000
206100         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14880000
206200         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14890000
206300         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14900000
206400                                                                  14910000
206500 2300-GET-LAB-NONLAB-TB4-RATES.                                   14920000
206600                                                                  14930000
206700     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)            14940000
206800         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            14950000
206900         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR         14960000
207000         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR            14970000
207100         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.        14980000
207200                                                                  14990000
207300 2300-GET-PR-LAB-TB1-RATES.                                       15000000
207400                                                                  15010000
207500     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)            15020000
207600         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15030000
207700         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15040000
207800                                                                  15050000
207900 2300-GET-PR-LAB-TB2-RATES.                                       15060000
208000                                                                  15070000
208100     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)            15080000
208200         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15090000
208300         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15100000
208400                                                                  15110000
208500 2300-GET-PR-LAB-TB3-RATES.                                       15120000
208600                                                                  15130000
208700     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)            15140000
208800         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15150000
208900         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15160000
209000                                                                  15170000
209100 2300-GET-PR-LAB-TB4-RATES.                                       15180000
209200                                                                  15190000
209300     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)            15200000
209400         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR            15210000
209500         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.        15220000
209600                                                                  15230000
209700                                                                  15240000
209800 2600-GET-DRG-WEIGHT.                                             15250000
209900                                                                  15260000
210000     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)               15270000
210100         SET DX6 TO B-DRG                                         15280000
210200         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                15290000
210300         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  15300000
210400         MOVE ZEROES                   TO H-DAYS-CUTOFF           15310000
210500         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           15320000
210600                                                                  15330000
210700 3000-CALC-PAYMENT.                                               15340000
210800***************************************************************   15350000
210900                                                                  15360000
211000     PERFORM 3100-CALC-STAY-UTILIZATION.                          15370000
211100     PERFORM 3300-CALC-OPER-FSP-AMT.                              15380000
211200     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.                 15390000
211300                                                                  15400000
211400***********************************************************       15410000
211500***  OPERATING IME CALCULATION                                    15420000
211600***  OPERATING IME CALCULATION                                    15430000
211700                                                                  15440000
211800     COMPUTE H-OPER-IME-TEACH ROUNDED =                           15450000
211900            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).           15460000
212000                                                                  15470000
212100***********************************************************       15480000
212200                                                                  15490000
212300     IF P-N-SCH-REBASED-FY90 OR                                   15500000
212400        P-N-EACH OR                                               15510000
212500        P-N-MDH-REBASED-FY90                                      15520000
212600         PERFORM 3450-CALC-ADDITIONAL-HSP.                        15530000
212700                                                                  15540000
212800     MOVE 00                 TO  PPS-RTC.                         15550000
212900     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   15560000
213000     MOVE H-ALOS             TO  PPS-AVG-LOS.                     15570000
213100     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 15580000
213200                                                                  15590000
213300     MOVE B-LOS TO H-PERDIEM-DAYS.                                15600000
213400     IF H-PERDIEM-DAYS < 1                                        15610000
213500         MOVE 1 TO H-PERDIEM-DAYS.                                15620000
213600     ADD 1 TO H-PERDIEM-DAYS.                                     15630000
213700                                                                  15640000
213800     MOVE 1 TO H-DSCHG-FRCTN.                                     15650000
213900                                                                  15660000
214000     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.   15670000
214100                                                                  15680000
214200     IF (PAY-PERDIEM-DAYS  OR                                     15690000
214300         PAY-XFER-NO-COST) OR                                     15700000
214400        (PAY-XFER-SPEC-DRG AND                                    15710000
214500         B-DRG-POSTACUTE-PERDIEM)                                 15720000
214600         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 15730000
214700         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS 15740000
214800         IF H-DSCHG-FRCTN > 1                                     15750000
214900              MOVE 1 TO H-DSCHG-FRCTN                             15760000
215000              MOVE 1 TO H-TRANSFER-ADJ                            15770000
215100         ELSE                                                     15780000
215200              COMPUTE H-DRG-WT-FRCTN ROUNDED =                    15790000
215300                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.           15800000
215400                                                                  15810000
215500     IF (PAY-XFER-SPEC-DRG AND                                    15820000
215600         B-DRG-POSTACUTE-50-50)                                   15830000
215700         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 15840000
215800         COMPUTE H-DSCHG-FRCTN  ROUNDED =                         15850000
215900                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)     15860000
216000         IF H-DSCHG-FRCTN > 1                                     15870000
216100              MOVE 1 TO H-DSCHG-FRCTN                             15880000
216200              MOVE 1 TO H-TRANSFER-ADJ                            15890000
216300         ELSE                                                     15900000
216400              COMPUTE H-DRG-WT-FRCTN ROUNDED =                    15910000
216500            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.   15920000
216600                                                                  15930000
216700                                                                  15940000
216800***********************************************************       15950000
216900***  CAPITAL DSH CALCULATION                                      15960000
217000***  CAPITAL DSH CALCULATION                                      15970000
217100                                                                  15980000
217200     MOVE 0 TO H-CAPI-DSH.                                        15990000
217300                                                                  16000000
217400     IF P-NEW-BED-SIZE NOT NUMERIC                                16010000
217500         MOVE 0 TO P-NEW-BED-SIZE.                                16020000
217600                                                                  16030000
217700     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99        16040000
217800         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   16050000
217900                  (.2025 * (P-NEW-SSI-RATIO                       16060000
218000                          + P-NEW-MEDICAID-RATIO)) - 1.           16070000
218100                                                                  16080000
218200***********************************************************       16090000
218300***  CAPITAL IME TEACH CALCULATION                                16100000
218400***  CAPITAL IME TEACH CALCULATION                                16110000
218500                                                                  16120000
218600     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               16130000
218700                                                                  16140000
218800     IF P-NEW-CAPI-IME NUMERIC                                    16150000
218900        IF P-NEW-CAPI-IME > 1.5000                                16160000
219000           MOVE 1.5000 TO P-NEW-CAPI-IME.                         16170000
219100                                                                  16180000
219200*****YEARCHANGE 2009.5 ****************************************   18470000
219300***                                                               16230000
219400***  PER POLICY, WE REMOVED THE .5 MULTIPLER                      16230000
219500***                                                               16230000
219600***********************************************************       16230000
219700     IF P-NEW-CAPI-IME NUMERIC                                    16190000
219800        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =                     16200000
219900         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).              16210000
220000                                                                  16220000
220100*****YEARCHANGE 2009.5 ****************************************   18470000
220200***********************************************************       16230000
220300     MOVE 0.00 TO H-DAYOUT-PCT.                                   16240000
220400     MOVE 0.80 TO H-CSTOUT-PCT.                                   16250000
220500                                                                  16260000
220600******************************************************************16270000
220700**                                                                16280000
220800** BURN DRGS FOR FY09 ARE 927, 928, 929, 933, 934 AND 935.        16281000
220900**                                                                16282000
221000******************************************************************16283000
221100                                                                  16284000
221200     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935           16285000
221300             MOVE 0.90 TO H-CSTOUT-PCT.                           16286000
221400                                                                  16287000
221500***     NATIONAL PERCENTAGE                                       16288000
221600     MOVE 0.6970   TO H-LABOR-PCT.                                16289000
221700     MOVE 0.3030   TO H-NONLABOR-PCT.                             16290000
221800                                                                  16300000
221900***     PUERTO RICO PERCENTAGE                                    16310000
222000     MOVE 0.6200   TO H-PR-LABOR-PCT.                             16320000
222100     MOVE 0.3800   TO H-PR-NONLABOR-PCT.                          16330000
222200                                                                  16340000
222300     IF (H-WAGE-INDEX < 01.0000 OR                                16350000
222400         H-WAGE-INDEX = 01.0000)                                  16360000
222500        MOVE 0.6200 TO H-LABOR-PCT                                16370000
222600        MOVE 0.3800 TO H-NONLABOR-PCT.                            16380000
222700                                                                  16390000
222800     IF P-NEW-STATE = 40                                          16400000
222900       IF (H-PR-WAGE-INDEX < 01.0000 OR                           16410000
223000           H-PR-WAGE-INDEX = 01.0000)                             16420000
223100          MOVE 0.5870 TO H-PR-LABOR-PCT                           16430000
223200          MOVE 0.4130 TO H-PR-NONLABOR-PCT.                       16440000
223300                                                                  16450000
223400                                                                  16460000
223500     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC                          16470000
223600             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO  16480000
223700     ELSE                                                         16490000
223800             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   16500000
223900                                                                  16510000
224000     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC                           16520000
224100             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO  16530000
224200     ELSE                                                         16540000
224300             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   16550000
224400                                                                  16560000
224500***********************************************************       16570000
224600*****YEARCHANGE 2009.1 ************************************       16570000
224700***  CAPITAL PAYMENT METHOD B - YEARCHNG                          16580000
224800***  CAPITAL PAYMENT METHOD B                                     16590000
224900                                                                  16600000
225000     IF W-CBSA-SIZE = 'L'                                         16610000
225100        MOVE 1.00 TO H-CAPI-LARG-URBAN                            16620000
225200     ELSE                                                         16630000
225300        MOVE 1.00 TO H-CAPI-LARG-URBAN.                           16640000
225400                                                                  16650000
225500     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).     16660000
225600     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).  16670000
225700                                                                  16680000
225800*****YEARCHANGE 2009.1 ************************************       16570000
225900     COMPUTE H-FEDERAL-RATE ROUNDED =                             16690000
226000                                 (0424.17 * H-CAPI-GAF).          16700000
226100     COMPUTE H-PUERTO-RICO-RATE ROUNDED =                         16710000
226200                                 (0198.77 * H-PR-CAPI-GAF).       16720000
226300*****YEARCHANGE 2009.1 ************************************       16570000
226400                                                                  16730000
226500     COMPUTE H-CAPI-COLA ROUNDED =                                16740000
226600                     (.3152 * (H-OPER-COLA - 1) + 1).             16750000
226700                                                                  16760000
226800     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.                      16770000
226900                                                                  16780000
227000     IF P-NEW-STATE = 40                                          16790000
227100        COMPUTE  H-CAPI-FED-RATE ROUNDED =                        16800000
227200                 (H-NAT-PCT * H-FEDERAL-RATE) +                   16810000
227300                 (H-REG-PCT * H-PUERTO-RICO-RATE).                16820000
227400***********************************************************       16830000
227500***  CAPITAL FSP CALCULATION                                      16840000
227600***  CAPITAL FSP CALCULATION                                      16850000
227700                                                                  16860000
227800     COMPUTE H-CAPI-FSP-PART ROUNDED =                            16870000
227900                               H-DRG-WT * H-CAPI-FED-RATE *       16880000
228000                               H-CAPI-COLA *                      16890000
228100                               H-CAPI-LARG-URBAN.                 16900000
228200                                                                  16910000
228300***********************************************************       16920000
228400***  CAPITAL PAYMENT METHOD A                                     16930000
228500***  CAPITAL PAYMENT METHOD A                                     16940000
228600                                                                  16950000
228700     IF P-N-SCH-REBASED-FY90 OR P-N-EACH                          16960000
228800        MOVE 1.00 TO H-CAPI-SCH                                   16970000
228900     ELSE                                                         16980000
229000        MOVE 0.85 TO H-CAPI-SCH.                                  16990000
229100                                                                  17000000
229200***********************************************************       17010000
229300***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********    17020000
229400***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********    17030000
229500                                                                  17040000
229600     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        17050000
229700                    (P-NEW-CAPI-OLD-HARM-RATE *                   17060000
229800                    H-CAPI-SCH).                                  17070000
229900                                                                  17080000
230000***********************************************************       17090000
230100        IF PAY-PERDIEM-DAYS                                       17100000
230200            IF  H-PERDIEM-DAYS < H-ALOS                           17110000
230300                IF  NOT (B-DRG = 789)                             17120000
230400                    PERFORM 3500-CALC-PERDIEM-AMT                 17130000
230500                    MOVE 03 TO PPS-RTC.                           17140000
230600                                                                  17150000
230700        IF PAY-XFER-SPEC-DRG                                      17160000
230800            IF  H-PERDIEM-DAYS < H-ALOS                           17170000
230900                IF  NOT (B-DRG = 789)                             17180000
231000                    PERFORM 3550-CALC-PERDIEM-AMT.                17190000
231100                                                                  17200000
231200        IF  PAY-XFER-NO-COST                                      17210000
231300            MOVE 00 TO PPS-RTC                                    17220000
231400            IF H-PERDIEM-DAYS < H-ALOS                            17230000
231500               IF  NOT (B-DRG = 789)                              17240000
231600                   PERFORM 3500-CALC-PERDIEM-AMT                  17250000
231700                   MOVE 06 TO PPS-RTC.                            17260000
231800                                                                  17270000
231900     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.                 17280000
232000                                                                  17290000
232100     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.                    17300000
232200                                                                  17310000
232300     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.                 17320000
232400                                                                  17330000
232500     IF PPS-RTC = 67  GO TO 3000-CONTINUE.                        17340000
232600                                                                  17350000
232700        IF PAY-XFER-SPEC-DRG                                      17360000
232800            IF  H-PERDIEM-DAYS < H-ALOS                           17370000
232900                IF  NOT (B-DRG = 789)                             17380000
233000                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.   17390000
233100                                                                  17400000
233200                                                                  17410000
233300        IF  PAY-PERDIEM-DAYS                                      17420000
233400            IF  H-OPER-OUTCST-PART > 0                            17430000
233500                MOVE H-OPER-OUTCST-PART TO                        17440000
233600                     H-OPER-OUTLIER-PART                          17450000
233700                MOVE 05 TO PPS-RTC                                17460000
233800            ELSE                                                  17470000
233900            IF  PPS-RTC NOT = 03                                  17480000
234000                MOVE 00 TO PPS-RTC                                17490000
234100                MOVE 0  TO H-OPER-OUTLIER-PART.                   17500000
234200                                                                  17510000
234300        IF  PAY-PERDIEM-DAYS                                      17520000
234400            IF  H-CAPI-OUTCST-PART > 0                            17530000
234500                MOVE H-CAPI-OUTCST-PART TO                        17540000
234600                     H-CAPI-OUTLIER-PART                          17550000
234700                MOVE 05 TO PPS-RTC                                17560000
234800            ELSE                                                  17570000
234900            IF  PPS-RTC NOT = 03                                  17580000
235000                MOVE 0  TO H-CAPI-OUTLIER-PART.                   17590000
235100                                                                  17600000
235200                                                                  17610000
235300 3000-CONTINUE.                                                   17620000
235400                                                                  17630000
235500***********************************************************       17640000
235600***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          17650000
235700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          17660000
235800                                                                  17670000
235900     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.        17680000
236000                                                                  17690000
236100***********************************************************       17700000
236200                                                                  17710000
236300     IF  PPS-RTC = 67                                             17720000
236400         MOVE H-OPER-DOLLAR-THRESHOLD TO                          17730000
236500              WK-H-OPER-DOLLAR-THRESHOLD.                         17740000
236600                                                                  17750000
236700     IF  PPS-RTC < 50                                             17760000
236800         PERFORM 3800-CALC-TOT-AMT                                17770000
236900     ELSE                                                         17780000
237000         MOVE ALL '0' TO PPS-OPER-HSP-PART                        17790000
237100                         PPS-OPER-FSP-PART                        17800000
237200                         PPS-OPER-OUTLIER-PART                    17810000
237300                         PPS-OUTLIER-DAYS                         17820000
237400                         PPS-REG-DAYS-USED                        17830000
237500                         PPS-LTR-DAYS-USED                        17840000
237600                         PPS-TOTAL-PAYMENT                        17850000
237700                         PPS-OPER-DSH-ADJ                         17860000
237800                         PPS-OPER-IME-ADJ                         17870000
237900                         H-DSCHG-FRCTN                            17880000
238000                         H-DRG-WT-FRCTN                           17890000
238100                         HOLD-ADDITIONAL-VARIABLES                17900000
238200                         HOLD-CAPITAL-VARIABLES                   17910000
238300                         HOLD-CAPITAL2-VARIABLES                  17920000
238400                         HOLD-OTHER-VARIABLES                     17930000
238500                         HOLD-PC-OTH-VARIABLES.                   17940000
238600                                                                  17950000
238700     IF  PPS-RTC = 67                                             17960000
238800         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO                       17970000
238900                 H-OPER-DOLLAR-THRESHOLD.                         17980000
239000                                                                  17990000
239100 3000-EXIT.  EXIT.                                                18000000
239200                                                                  18010000
239300 3100-CALC-STAY-UTILIZATION.                                      18020000
239400                                                                  18030000
239500     MOVE 0 TO PPS-REG-DAYS-USED.                                 18040000
239600     MOVE 0 TO PPS-LTR-DAYS-USED.                                 18050000
239700                                                                  18060000
239800     IF H-REG-DAYS > 0                                            18070000
239900        IF H-REG-DAYS > B-LOS                                     18080000
240000           MOVE B-LOS TO PPS-REG-DAYS-USED                        18090000
240100        ELSE                                                      18100000
240200           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                   18110000
240300     ELSE                                                         18120000
240400        IF H-LTR-DAYS > B-LOS                                     18130000
240500           MOVE B-LOS TO PPS-LTR-DAYS-USED                        18140000
240600        ELSE                                                      18150000
240700           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.                  18160000
240800                                                                  18170000
240900                                                                  18180000
241000                                                                  18190000
241100 3300-CALC-OPER-FSP-AMT.                                          18200000
241200***********************************************************       18210000
241300***  OPERATING FSP CALCULATION                                    18220000
241400***  OPERATING FSP CALCULATION                                    18230000
241500                                                                  18240000
241600     COMPUTE H-OPER-FSP-PART ROUNDED =                            18250000
241700           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             18260000
241800            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18270000
241900                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       18280000
242000                                                                  18290000
242100     IF P-NEW-STATE = 40                                          18300000
242200       COMPUTE H-OPER-FSP-PART ROUNDED =                          18310000
242300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             18320000
242400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18330000
242500                           +                                      18340000
242600           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +          18350000
242700            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)             18360000
242800                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       18370000
242900                                                                  18380000
243000                                                                  18390000
243100 3450-CALC-ADDITIONAL-HSP.                                        18400000
243200***********************************************************       18410000
243300*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 18420000
243400*    SOLE COMMUNITY                                               18430000
243500*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)              18440000
243600*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              18450000
243700***********************************************************       18460000
243800*****YEARCHANGE 2009.1 ****************************************   18470000
243900***         GET THE UPDATING FACTOR                               18480000
244000***         GET THE UPDATING FACTOR                               18490000
244100                                                                  18500000
244200     MOVE 0.995743 TO H-BUDG-NUTR08.                              18510000
244300*****YEARCHANGE 2009.1 ****************************************   18470000
244400     MOVE 0.998795 TO H-BUDG-NUTR09.                              18510000
244500*****YEARCHANGE 2009.1 ****************************************   18470000
244600                                                                  18520000
244700     MOVE 1.0330 TO H-UPDATE-08.                                  18530000
244800
244900     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
245000*****YEARCHANGE 2009.0 ****************************************   18470000
245100        MOVE 1.0360 TO H-UPDATE-09
245200     ELSE
245300        MOVE 1.0160 TO H-UPDATE-09.
245400*****YEARCHANGE 2009.0 ****************************************   18470000
245500
245600     COMPUTE H-UPDATE-FACTOR ROUNDED =
245700                       (H-UPDATE-08 * H-UPDATE-09 *
245800                        H-BUDG-NUTR08 * H-BUDG-NUTR09).
245900
246000     COMPUTE H-HSP-RATE ROUNDED =
246100         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
246200***************************************************************
246300*
246400*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'                            18537000
246500*       COMPUTE H-HSP-RATE ROUNDED =                              18538000
246600*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR                  18539000
246700*    ELSE                                                         18540000
246800*       COMPUTE H-HSP-RATE ROUNDED =                              18550000
246900*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.   18560000
247000*                                                                 18570000
247100***************************************************************   18580000
247200********YEARCHANGE 2009.1 *************************************   18590000
247300***         CASE MIX ADJUSTMENT - FOR FUTURE USE                  18480000
247400***         CASE MIX ADJUSTMENT - FOR FUTURE USE                  18480000
247500***                                                                     00
247600***  MOVE 0.994 TO H-CASE-MIX-ADJ.                                      00
247700***                                                                     00
247800***  COMPUTE H-HSP-RATE ROUNDED =                                       00
247900***    H-HSP-RATE * H-CASE-MIX-ADJ.                                     00
248000***                                                                     00
248100********YEARCHANGE 2009.1 *************************************   18590000
248200***     OUTLIER OFFSETS                                           18591000
248300***     OPERATING NATIONAL                                        18600000
248400***     OPERATING PUERTO RICO BLEND                               18610000
248500                                                                  18620000
248600********YEARCHANGE 2009.1 *************************************   18590000
248700                                                                  18620000
248800      MOVE 0.948996 TO H-OUTLIER-OFFSET-NAT                       18630000
248900      MOVE 0.954304 TO H-OUTLIER-OFFSET-PR.                       18640000
249000                                                                  18620000
249100********YEARCHANGE 2009.1 *************************************   18590000
249200                                                                  18650000
249300***************************************************************   18660000
249400     COMPUTE H-FSP-RATE ROUNDED =                                 18670000
249500         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               18680000
249600         H-NAT-NONLABOR * H-OPER-COLA))                           18690000
249700                           *                                      18700000
249800     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT) 18710000
249900                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            18720000
250000                                                                  18730000
250100     IF P-NEW-STATE = 40                                          18740000
250200       COMPUTE H-FSP-RATE ROUNDED =                               18750000
250300        (((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +              18760000
250400         H-NAT-NONLABOR * H-OPER-COLA))                           18770000
250500                         *                                        18771000
250600        ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /                    18772000
250700                            H-OUTLIER-OFFSET-NAT) )               18773000
250800                           +                                      18780000
250900          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +           18790000
251000         H-REG-NONLABOR * H-OPER-COLA)))                          18800000
251100                           *                                      18810000
251200      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR) 18820000
251300                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            18830000
251400                                                                  18840000
251500                                                                  18850000
251600     IF  H-HSP-RATE > H-FSP-RATE                                  18860000
251700           COMPUTE H-OPER-HSP-PART ROUNDED =                      18870000
251800             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 18880000
251900                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART        18890000
252000     ELSE                                                         18900000
252100         MOVE 0 TO H-OPER-HSP-PART.                               18910000
252200                                                                  18920000
252300***************************************************************   18930000
252400***         GET THE MDH REBASE                                    18940000
252500                                                                  18950000
252600     IF  H-HSP-RATE > H-FSP-RATE                                  18960000
252700         IF P-NEW-PROVIDER-TYPE = '14' OR '15'                    18970000
252800           COMPUTE H-OPER-HSP-PART ROUNDED =                      18980000
252900             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .75           18990000
253000                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.       19000000
253100                                                                  19010000
253200 3500-CALC-PERDIEM-AMT.                                           19020000
253300***********************************************************       19030000
253400***  REVIEW CODE = 03 OR 06                                       19040000
253500***  OPERATING PERDIEM-AMT CALCULATION                            19050000
253600***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              19060000
253700                                                                  19070000
253800        COMPUTE H-OPER-FSP-PART ROUNDED =                         19080000
253900        H-OPER-FSP-PART * H-TRANSFER-ADJ                          19090000
254000        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  19100000
254100                                                                  19110000
254200***********************************************************       19120000
254300***********************************************************       19130000
254400***  REVIEW CODE = 03 OR 06                                       19140000
254500***  CAPITAL   PERDIEM-AMT CALCULATION                            19150000
254600***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS              19160000
254700                                                                  19170000
254800        COMPUTE H-CAPI-FSP-PART ROUNDED =                         19180000
254900        H-CAPI-FSP-PART * H-TRANSFER-ADJ                          19190000
255000        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  19200000
255100                                                                  19210000
255200***********************************************************       19220000
255300***  REVIEW CODE = 03 OR 06                                       19230000
255400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19240000
255500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19250000
255600                                                                  19260000
255700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     19270000
255800        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ                      19280000
255900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              19290000
256000                                                                  19300000
256100 3550-CALC-PERDIEM-AMT.                                           19310000
256200***********************************************************       19320000
256300***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG            19330000
256400***  OPERATING PERDIEM-AMT CALCULATION                            19340000
256500***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              19350000
256600                                                                  19360000
256700     IF (B-DRG-POSTACUTE-50-50)                                   19370000
256800        MOVE 10 TO PPS-RTC                                        19380000
256900        COMPUTE H-OPER-FSP-PART ROUNDED =                         19390000
257000        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             19400000
257100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  19410000
257200                                                                  19420000
257300     IF (B-DRG-POSTACUTE-PERDIEM)                                 19430000
257400        MOVE 12 TO PPS-RTC                                        19440000
257500        COMPUTE H-OPER-FSP-PART ROUNDED =                         19450000
257600        H-OPER-FSP-PART *  H-TRANSFER-ADJ                         19460000
257700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  19470000
257800                                                                  19480000
257900***********************************************************       19490000
258000***  CAPITAL PERDIEM-AMT CALCULATION                              19500000
258100***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS                19510000
258200                                                                  19520000
258300     IF (B-DRG-POSTACUTE-50-50)                                   19530000
258400        MOVE 10 TO PPS-RTC                                        19540000
258500        COMPUTE H-CAPI-FSP-PART ROUNDED =                         19550000
258600        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             19560000
258700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  19570000
258800                                                                  19580000
258900     IF (B-DRG-POSTACUTE-PERDIEM)                                 19590000
259000        MOVE 12 TO PPS-RTC                                        19600000
259100        COMPUTE H-CAPI-FSP-PART ROUNDED =                         19610000
259200        H-CAPI-FSP-PART *  H-TRANSFER-ADJ                         19620000
259300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  19630000
259400                                                                  19640000
259500***********************************************************       19650000
259600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19660000
259700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                19670000
259800                                                                  19680000
259900     IF (B-DRG-POSTACUTE-50-50)                                   19690000
260000        MOVE 10 TO PPS-RTC                                        19700000
260100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     19710000
260200        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))         19720000
260300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              19730000
260400                                                                  19740000
260500     IF (B-DRG-POSTACUTE-PERDIEM)                                 19750000
260600        MOVE 12 TO PPS-RTC                                        19760000
260700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     19770000
260800        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ                     19780000
260900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              19790000
261000                                                                  19800000
261100 3560-CHECK-RTN-CODE.                                             19810000
261200                                                                  19820000
261300     IF (B-DRG-POSTACUTE-50-50)                                   19830000
261400        MOVE 10 TO PPS-RTC.                                       19840000
261500     IF (B-DRG-POSTACUTE-PERDIEM)                                 19850000
261600        MOVE 12 TO PPS-RTC.                                       19860000
261700                                                                  19870000
261800 3560-EXIT.    EXIT.                                              19880000
261900                                                                  19890000
262000 3600-CALC-OUTLIER.                                               19900000
262100***********************************************************       19910000
262200***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               19920000
262300***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               19930000
262400                                                                  19940000
262500     IF OUTLIER-RECON-FLAG = 'Y'                                  19950000
262600        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =                     19960000
262700               (H-OPER-CSTCHG-RATIO + .2).                        19970000
262800                                                                  19980000
262900     IF H-CAPI-CSTCHG-RATIO > 0 OR                                19990000
263000       H-OPER-CSTCHG-RATIO > 0                                    20000000
263100        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =             20010000
263200                H-OPER-CSTCHG-RATIO /                             20020000
263300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        20030000
263400        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =             20040000
263500                H-CAPI-CSTCHG-RATIO /                             20050000
263600               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        20060000
263700     ELSE                                                         20070000
263800         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    20080000
263900                   H-CAPI-SHARE-DOLL-THRESHOLD.                   20090000
264000                                                                  20100000
264100***********************************************************       20110000
264200*****YEARCHANGE 2009.1 ************************************       20110000
264300***  OUTLIER THRESHOLD AMOUNTS                                    20120000
264400***  OUTLIER THRESHOLD AMOUNTS                                    20130000
264500                                                                  20140000
264600*****YEARCHANGE 2009.1 ************************************       20110000
264700                                                                  20140000
264800     MOVE 20045.00 TO H-CST-THRESH.                               20150000
264900                                                                  20140000
265000*****YEARCHANGE 2009.1 ************************************       20110000
265100                                                                  20160000
265200     IF (B-REVIEW-CODE = '03') AND                                20170000
265300         H-PERDIEM-DAYS < H-ALOS                                  20180000
265400        COMPUTE H-CST-THRESH ROUNDED =                            20190000
265500                      (H-CST-THRESH * H-TRANSFER-ADJ)             20200000
265600                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             20210000
265700                                                                  20220000
265800     IF ((B-REVIEW-CODE = '09') AND                               20230000
265900         (H-PERDIEM-DAYS < H-ALOS))                               20240000
266000         IF (B-DRG-POSTACUTE-PERDIEM)                             20250000
266100            COMPUTE H-CST-THRESH ROUNDED =                        20260000
266200                      (H-CST-THRESH * H-TRANSFER-ADJ)             20270000
266300                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             20280000
266400                                                                  20290000
266500     IF ((B-REVIEW-CODE = '09') AND                               20300000
266600         (H-PERDIEM-DAYS < H-ALOS))                               20310000
266700         IF (B-DRG-POSTACUTE-50-50)                               20320000
266800           COMPUTE H-CST-THRESH ROUNDED =                         20330000
266900          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))            20340000
267000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.             20350000
267100                                                                  20360000
267200     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    20370000
267300        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +            20380000
267400         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *         20390000
267500          H-OPER-SHARE-DOLL-THRESHOLD.                            20400000
267600                                                                  20410000
267700     IF P-NEW-STATE = 40                                          20420000
267800        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              20430000
267900           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +   20440000
268000            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *   20450000
268100             H-OPER-SHARE-DOLL-THRESHOLD                          20460000
268200        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 20470000
268300               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +            20480000
268400               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).          20490000
268500                                                                  20500000
268600***********************************************************       20510000
268700                                                                  20520000
268800     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    20530000
268900          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         20540000
269000          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              20550000
269100                                                                  20560000
269200                                                                  20570000
269300     IF P-NEW-STATE = 40                                          20580000
269400        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =              20590000
269500           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *     20600000
269600           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA              20610000
269700        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                 20620000
269800               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +            20630000
269900               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).          20640000
270000                                                                  20650000
270100                                                                  20660000
270200     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        20670000
270300      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))     20680000
270400                       +                                          20690000
270500             H-OPER-DOLLAR-THRESHOLD                              20700000
270600                       +                                          20710000
270700                 H-NEW-TECH-PAY-ADD-ON.                           20720000
270800                                                                  20730000
270900     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        20740000
271000      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))  20750000
271100                       +                                          20760000
271200             H-CAPI-DOLLAR-THRESHOLD.                             20770000
271300                                                                  20780000
271400     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               20790000
271500         MOVE 0 TO H-CAPI-COST-OUTLIER.                           20800000
271600                                                                  20810000
271700                                                                  20820000
271800***********************************************************       20830000
271900***  OPERATING COST CALCULATION                                   20840000
272000***  OPERATING COST CALCULATION                                   20850000
272100                                                                  20860000
272200     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          20870000
272300         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO                  20880000
272400         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               20890000
272500                                                                  20900000
272600                                                                  20910000
272700     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  20920000
272800         COMPUTE H-OPER-OUTCST-PART ROUNDED =                     20930000
272900         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      20940000
273000                         H-OPER-COST-OUTLIER).                    20950000
273100                                                                  20960000
273200     IF PAY-WITHOUT-COST OR                                       20970000
273300        PAY-XFER-NO-COST OR                                       20980000
273400        PAY-XFER-SPEC-DRG-NO-COST                                 20990000
273500         MOVE 0 TO H-OPER-OUTCST-PART.                            21000000
273600                                                                  21010000
273700***********************************************************       21020000
273800***  CAPITAL COST CALCULATION                                     21030000
273900***  CAPITAL COST CALCULATION                                     21040000
274000                                                                  21050000
274100     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          21060000
274200             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO              21070000
274300         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               21080000
274400                                                                  21090000
274500     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  21100000
274600         COMPUTE H-CAPI-OUTCST-PART ROUNDED =                     21110000
274700         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      21120000
274800                         H-CAPI-COST-OUTLIER).                    21130000
274900                                                                  21140000
275000     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             21150000
275100       COMPUTE H-CAPI-OUTCST-PART ROUNDED =                       21160000
275200              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).   21170000
275300                                                                  21180000
275400     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             21190000
275500        COMPUTE H-CAPI-OUTCST-PART ROUNDED =                      21200000
275600               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         21210000
275700                                                                  21220000
275800     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               21230000
275900        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               21240000
276000        MOVE 0 TO H-CAPI-OUTCST-PART                              21250000
276100                  H-OPER-OUTCST-PART.                             21260000
276200                                                                  21270000
276300     IF PAY-WITHOUT-COST OR                                       21280000
276400        PAY-XFER-NO-COST OR                                       21290000
276500        PAY-XFER-SPEC-DRG-NO-COST                                 21300000
276600         MOVE 0 TO H-CAPI-OUTCST-PART.                            21310000
276700                                                                  21320000
276800***********************************************************       21330000
276900***  DETERMINES THE BILL TO BE COST  OUTLIER                      21340000
277000                                                                  21350000
277100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               21360000
277200         MOVE 0 TO H-CAPI-OUTDAY-PART                             21370000
277300                   H-CAPI-OUTCST-PART.                            21380000
277400                                                                  21390000
277500     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0             21400000
277600                 MOVE H-OPER-OUTCST-PART TO                       21410000
277700                      H-OPER-OUTLIER-PART                         21420000
277800                 MOVE H-CAPI-OUTCST-PART TO                       21430000
277900                      H-CAPI-OUTLIER-PART                         21440000
278000                 MOVE 02 TO PPS-RTC.                              21450000
278100                                                                  21460000
278200     IF OUTLIER-RECON-FLAG = 'Y'                                  21470000
278300        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0          21480000
278400           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30                 21490000
278500           GO TO 3600-EXIT                                        21500000
278600        ELSE                                                      21510000
278700           GO TO 3600-EXIT                                        21520000
278800     ELSE                                                         21530000
278900        NEXT SENTENCE.                                            21540000
279000                                                                  21550000
279100                                                                  21560000
279200***********************************************************       21570000
279300***  DETERMINES IF COST OUTLIER                                   21580000
279400***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH             21590000
279500***         RETURN CODE OF 02                                     21600000
279600                                                                  21610000
279700     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.                           21620000
279800                                                                  21630000
279900     IF PPS-RTC = 02                                              21640000
280000             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =            21650000
280100                     (H-CAPI-COST-OUTLIER  +                      21660000
280200                      H-OPER-COST-OUTLIER)                        21670000
280300                             /                                    21680000
280400                    (H-CAPI-CSTCHG-RATIO  +                       21690000
280500                     H-OPER-CSTCHG-RATIO)                         21700000
280600             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.     21710000
280700                                                                  21720000
280800***********************************************************       21730000
280900***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS       21740000
281000***         RETURN CODE OF 67                                     21750000
281100                                                                  21760000
281200     IF PPS-RTC = 02                                              21770000
281300         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR                21780000
281400            PPS-PC-COT-FLAG = 'Y'                                 21790000
281500             MOVE 67 TO PPS-RTC.                                  21800000
281600***********************************************************       21810000
281700                                                                  21820000
281800***********************************************************       21830000
281900***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          21840000
282000***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          21850000
282100                                                                  21860000
282200     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             21870000
282300        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  21880000
282400                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO   21890000
282500         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          21900000
282600                                                                  21910000
282700     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             21920000
282800        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  21930000
282900                H-CAPI-OUTLIER-PART.                              21940000
283000                                                                  21950000
283100     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             21960000
283200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  21970000
283300                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          21980000
283400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          21990000
283500                                                                  22000000
283600 3600-EXIT.   EXIT.                                               22010000
283700                                                                  22020000
283800***********************************************************       22030000
283900 3800-CALC-TOT-AMT.                                               22040000
284000***********************************************************       22050000
284100***  CALCULATE TOTALS FOR CAPITAL                                 22060000
284200***  CALCULATE TOTALS FOR CAPITAL                                 22070000
284300                                                                  22080000
284400     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.           22090000
284500                                                                  22100000
284600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             22110000
284700        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT          22120000
284800        MOVE 0.00 TO H-CAPI-HSP-PCT.                              22130000
284900                                                                  22140000
285000     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             22150000
285100        MOVE 0    TO H-CAPI-OLD-HARMLESS                          22160000
285200        MOVE 1.00 TO H-CAPI-FSP-PCT                               22170000
285300        MOVE 0.00 TO H-CAPI-HSP-PCT.                              22180000
285400                                                                  22190000
285500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             22200000
285600        MOVE 0    TO H-CAPI-OLD-HARMLESS                          22210000
285700        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 22220000
285800        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                22230000
285900                                                                  22240000
286000     COMPUTE H-CAPI-HSP ROUNDED =                                 22250000
286100         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        22260000
286200                                                                  22270000
286300     COMPUTE H-CAPI-FSP ROUNDED =                                 22280000
286400         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        22290000
286500                                                                  22300000
286600     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.             22310000
286700                                                                  22320000
286800     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 22330000
286900                                                                  22340000
287000     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             22350000
287100             H-CAPI-FSP                                           22360000
287200              * H-CAPI-DSH.                                       22370000
287300                                                                  22380000
287400     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             22390000
287500          H-CAPI-FSP *                                            22400000
287600                 H-WK-CAPI-IME-TEACH.                             22410000
287700                                                                  22420000
287800     COMPUTE H-CAPI-OUTLIER ROUNDED =                             22430000
287900             1.00 * H-CAPI-OUTLIER-PART.                          22440000
288000                                                                  22450000
288100     COMPUTE H-CAPI2-B-FSP ROUNDED =                              22460000
288200             1.00 * H-CAPI2-B-FSP-PART.                           22470000
288300                                                                  22480000
288400     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          22490000
288500             1.00 * H-CAPI2-B-OUTLIER-PART.                       22500000
288600***********************************************************       22510000
288700***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               22520000
288800***        THIS ZEROES OUT ALL CAPITAL DATA                       22530000
288900                                                                  22540000
289000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               22550000
289100        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   22560000
289200***********************************************************       22570000
289300                                                                  22580000
289400***********************************************************       22590000
289500***  CALCULATE FINAL TOTALS FOR OPERATING                         22600000
289600***  CALCULATE FINAL TOTALS FOR OPERATING                         22610000
289700                                                                  22620000
289800     IF (H-CAPI-OUTLIER > 0 AND                                   22630000
289900         PPS-OPER-OUTLIER-PART = 0)                               22640000
290000            COMPUTE PPS-OPER-OUTLIER-PART =                       22650000
290100                    PPS-OPER-OUTLIER-PART + .01.                  22660000
290200                                                                  22670000
290300     MOVE 01.000 TO WK-LOW-VOL25PCT.                              22680000
290400                                                                  22690000
290500     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               22700000
290600        MOVE 01.250 TO WK-LOW-VOL25PCT.                           22710000
290700                                                                  22720000
290800     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               22730000
290900                                                                  22740000
291000     IF  H-OPER-DSH NUMERIC                                       22750000
291100         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                       22760000
291200       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.        22770000
291300                                                                  22780000
291400     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           22790000
291500      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.   22800000
291600                                                                  22810000
291700                                                                  22820000
291800     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          22830000
291900        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.     22840000
292000                                                                  22850000
292100     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          22860000
292200        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.     22870000
292300                                                                  22880000
292400     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      22890000
292500      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.   22900000
292600                                                                  22910000
292700     IF HMO-TAG  = 'Y'                                            22920000
292800        PERFORM 3850-HMO-IME-ADJ.                                 22930000
292900                                                                  22940000
293000***********************************************************       22950000
293100***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             22960000
293200***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             22970000
293300                                                                  22980000
293400     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =                           22990000
293500            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        23000000
293600             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    23010000
293700             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT. 23020000
293800                                                                  23030000
293900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      23040000
294000             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).           23050000
294100                                                                  23060000
294200***********************************************************       23070000
294300* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM                   23080000
294400                                                                  23090000
294500     IF   H-NEW-TECH-PAY-ADD-ON = 0                               23100000
294600                                                                  23110000
294700     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.          23120000
294800                                                                  23130000
294900                                                                  23140000
295000                                                                  23150000
295100     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.       23151000
295200                                                                  23152000
295300     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =                        23153000
295400               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +            23154000
295500               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +         23155000
295600                      PPS-OPER-IME-ADJ                            23156000
295700                           +                                      23157000
295800                 PPS-NEW-TECH-PAY-ADD-ON                          23158000
295900                           +                                      23159000
296000                 H-WK-PASS-AMT-PLUS-MISC                          23160000
296100                           +                                      23170000
296200                   H-CAPI-TOTAL-PAY.                              23180000
296300                                                                  23190000
296400 3850-HMO-IME-ADJ.                                                23200000
296500***********************************************************       23210000
296600***  HMO CALC FOR PASS-THRU ADDON                                 23220000
296700***  HMO CALC FOR PASS-THRU ADDON                                 23230000
296800                                                                  23240000
296900     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                    23250000
297000          (P-NEW-PASS-AMT-PLUS-MISC -                             23260000
297100          (P-NEW-PASS-AMT-ORGAN-ACQ +                             23270000
297200           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.                   23280000
297300                                                                  23290000
297400***********************************************************       23300000
297500***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002       23310000
297600                                                                  23320000
297700     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           23330000
297800                   PPS-OPER-IME-ADJ * .0.                         23340000
297900                                                                  23350000
298000***********************************************************       23360000
298100                                                                  23370000
298200                                                                  23380000
298300 3900A-CALC-OPER-DSH.                                             23390000
298400                                                                  23400000
298500***  OPERATING DSH CALCULATION                                    23410000
298600***  OPERATING DSH CALCULATION                                    23420000
298700                                                                  23430000
298800      MOVE 0.0000 TO H-OPER-DSH.                                  23440000
298900                                                                  23450000
299000      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO           23460000
299100                                     + P-NEW-MEDICAID-RATIO).     23470000
299200                                                                  23480000
299300***********************************************************       23490000
299400**1**    0-99 BEDS                                                23500000
299500***  NOT TO EXCEED 12%                                            23510000
299600                                                                  23520000
299700      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100      23530000
299800                               AND H-WK-OPER-DSH > .1499          23540000
299900                               AND H-WK-OPER-DSH < .2020          23550000
300000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        23560000
300100                                      * .65 + .025                23570000
300200        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.          23580000
300300                                                                  23590000
300400      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100      23600000
300500                               AND H-WK-OPER-DSH > .2019          23610000
300600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       23620000
300700                                      * .825 + .0588              23630000
300800        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.          23640000
300900                                                                  23650000
301000***********************************************************       23660000
301100**2**   100 + BEDS                                                23670000
301200***  NO CAP >> CAN EXCEED 12%                                     23680000
301300                                                                  23690000
301400      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99       23700000
301500                               AND H-WK-OPER-DSH > .1499          23710000
301600                               AND H-WK-OPER-DSH < .2020          23720000
301700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        23730000
301800                                      * .65 + .025.               23740000
301900                                                                  23750000
302000      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99       23760000
302100                               AND H-WK-OPER-DSH > .2019          23770000
302200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       23780000
302300                                      * .825 + .0588.             23790000
302400                                                                  23800000
302500***********************************************************       23810000
302600**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS                  23820000
302700***  NOT TO EXCEED 12%                                            23830000
302800                                                                  23840000
302900      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500           23850000
303000                               AND H-WK-OPER-DSH > .1499          23860000
303100                               AND H-WK-OPER-DSH < .2020          23870000
303200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        23880000
303300                                 * .65 + .025                     23890000
303400        IF H-OPER-DSH > .1200                                     23900000
303500              MOVE .1200 TO H-OPER-DSH.                           23910000
303600                                                                  23920000
303700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500           23930000
303800                               AND H-WK-OPER-DSH > .2019          23940000
303900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       23950000
304000                                 * .825 + .0588                   23960000
304100        IF H-OPER-DSH > .1200                                     23970000
304200                 MOVE .1200 TO H-OPER-DSH.                        23980000
304300***********************************************************       23990000
304400**4**   OTHER RURAL HOSPITALS 500 BEDS +                          24000000
304500***  NO CAP >> CAN EXCEED 12%                                     24010000
304600                                                                  24020000
304700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499           24030000
304800                               AND H-WK-OPER-DSH > .1499          24040000
304900                               AND H-WK-OPER-DSH < .2020          24050000
305000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        24060000
305100                                 * .65 + .025.                    24070000
305200                                                                  24080000
305300      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499           24090000
305400                               AND H-WK-OPER-DSH > .2019          24100000
305500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       24110000
305600                                 * .825 + .0588.                  24120000
305700                                                                  24130000
305800***********************************************************       24140000
305900**7**   RURAL HOSPITALS SCH                                       24150000
306000***  NOT TO EXCEED 12%                                            24160000
306100                                                                  24170000
306200      IF W-CBSA-SIZE = 'R'                                        24180000
306300         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  24190000
306400                               AND H-WK-OPER-DSH > .1499          24200000
306500                               AND H-WK-OPER-DSH < .2020          24210000
306600         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)       24220000
306700                                 * .65 + .025                     24230000
306800        IF H-OPER-DSH > .1200                                     24240000
306900                 MOVE .1200 TO H-OPER-DSH.                        24250000
307000                                                                  24260000
307100      IF W-CBSA-SIZE = 'R'                                        24270000
307200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  24280000
307300                               AND H-WK-OPER-DSH > .2019          24290000
307400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)      24300000
307500                                 * .825 + .0588                   24310000
307600        IF H-OPER-DSH > .1200                                     24320000
307700                 MOVE .1200 TO H-OPER-DSH.                        24330000
307800                                                                  24340000
307900***********************************************************       24350000
308000**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME                     24360000
308100***  RRC OVERRIDES SCH CAP                                        24370000
308200***  NO CAP >> CAN EXCEED 12%                                     24380000
308300                                                                  24390000
308400         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR        24400000
308500                                   '17' OR '22')                  24410000
308600                               AND H-WK-OPER-DSH > .1499          24420000
308700                               AND H-WK-OPER-DSH < .2020          24430000
308800         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)       24440000
308900                                 * .65 + .025.                    24450000
309000                                                                  24450000
309100         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR        24460000
309200                                   '17' OR '22')                  24470000
309300                               AND H-WK-OPER-DSH > .2019          24480000
309400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)      24490000
309500                                 * .825 + .0588.                  24500000
309600                                                                  24510000
309700      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.           24520000
309800                                                                  24530000
309900 3900A-EXIT.   EXIT.                                              24540000
310000                                                                  24550000
310100 4000-CALC-TECH-ADDON.                                            24560000
310200                                                                  24570000
310300***********************************************************       24580000
310400***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH              24590000
310500***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH              24600000
310600                                                                  24610000
310700     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          24620000
310800         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        24630000
310900                                                                  24640000
311000     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          24650000
311100         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        24660000
311200                                                                  24670000
311300     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               24680000
311400                                                                  24690000
311500     IF  H-OPER-DSH NUMERIC                                       24700000
311600             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   24710000
311700              PPS-OPER-FSP-PART                                   24720000
311800              * H-OPER-DSH.                                       24730000
311900                                                                  24740000
312000     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           24750000
312100             PPS-OPER-FSP-PART *                                  24760000
312200             H-OPER-IME-TEACH.                                    24770000
312300                                                                  24780000
312400     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =                         24790000
312500             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              24800000
312600             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.                 24810000
312700                                                                  24820000
312800***********************************************************       24830000
312900****      NEUROSTIMULATOR CASES                                   24840000
313000***********************************************************       24850000
313100*                                                                 24860000
313200*    IF '8698   ' =  B-PRIN-PROC-CODE   OR                        24870000
313300*                    B-OTHER-PROC-CODE1 OR                        24880000
313400*                    B-OTHER-PROC-CODE2 OR                        24890000
313500*                    B-OTHER-PROC-CODE3 OR                        24900000
313600*                    B-OTHER-PROC-CODE4 OR                        24910000
313700*                    B-OTHER-PROC-CODE5                           24920000
313800*          NEXT SENTENCE                                          24930000
313900*    ELSE                                                         24940000
314000*          MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO                  24950000
314100*          GO TO 4000-CHECK-GRAFT-CASES.                          24960000
314200*                                                                 24970000
314300*    MOVE 18640.00 TO H-CSTMED-NEURO.                             24980000
314400*                                                                 24990000
314500*    COMPUTE H-LESSER-NEURO-1 ROUNDED =                           25000000
314600*            .5   H-CSTMED-NEURO.                                 25010000
314700*                                                                 25020000
314800*    COMPUTE H-LESSER-NEURO-2 ROUNDED =                           25030000
314900*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -       25040000
315000*                    H-BASE-DRG-PAYMENT)   .5.                    25050000
315100*                                                                 25060000
315200*    IF H-LESSER-NEURO-2 > 0                                      25070000
315300*       IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2                    25080000
315400*          MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO        25090000
315500*       ELSE                                                      25100000
315600*          MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO        25110000
315700*    ELSE                                                         25120000
315800*       MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.           25130000
315900*                                                                 25140000
316000*4000-CHECK-GRAFT-CASES.                                          25150000
316100*                                                                 25160000
316200***********************************************************       25170000
316300***      GRAFT*(GORE*TAG)*CASES                                   25180000
316400***********************************************************       25190000
316500*                                                                 25200000
316600*    IF '3973   ' =  B-PRIN-PROC-CODE   OR                        25210000
316700*                    B-OTHER-PROC-CODE1 OR                        25220000
316800*                    B-OTHER-PROC-CODE2 OR                        25230000
316900*                    B-OTHER-PROC-CODE3 OR                        25240000
317000*                    B-OTHER-PROC-CODE4 OR                        25250000
317100*                    B-OTHER-PROC-CODE5                           25260000
317200*          NEXT SENTENCE                                          25270000
317300*    ELSE                                                         25280000
317400*          MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT                  25290000
317500*          GO TO 4000-CHECK-X-STOP.                               25300000
317600*                                                                 25310000
317700*    MOVE 21198.00 TO H-CSTMED-GRAFT.                             25320000
317800*                                                                 25330000
317900*    COMPUTE H-LESSER-GRAFT-1 ROUNDED =                           25340000
318000*            .5   H-CSTMED-GRAFT.                                 25350000
318100*                                                                 25360000
318200*    COMPUTE H-LESSER-GRAFT-2 ROUNDED =                           25370000
318300*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -       25380000
318400*                    H-BASE-DRG-PAYMENT)   .5.                    25390000
318500*                                                                 25400000
318600*    IF H-LESSER-GRAFT-2 > 0                                      25410000
318700*       IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2                    25420000
318800*          MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT        25430000
318900*       ELSE                                                      25440000
319000*          MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT        25450000
319100*    ELSE                                                         25460000
319200*       MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.           25470000
319300*                                                                 25480000
319400*4000-CHECK-X-STOP.                                               25490000
319500*                                                                 25500000
319600***********************************************************       25510000
319700*****    X-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM         25520000
319800***********************************************************       25530000
319900*                                                                 25540000
320000*    IF '8458   ' =  B-PRIN-PROC-CODE   OR                        25550000
320100*                    B-OTHER-PROC-CODE1 OR                        25560000
320200*                    B-OTHER-PROC-CODE2 OR                        25570000
320300*                    B-OTHER-PROC-CODE3 OR                        25580000
320400*                    B-OTHER-PROC-CODE4 OR                        25590000
320500*                    B-OTHER-PROC-CODE5                           25600000
320600*          NEXT SENTENCE                                          25610000
320700*    ELSE                                                         25620000
320800*          MOVE ZEROES TO H-NEW-TECH-ADDON-X-STOP                 25630000
320900*          GO TO 4000-ADD-TECH-CASES.                             25640000
321000*                                                                 25650000
321100*    MOVE 8800.00 TO H-CSTMED-X-STOP.                             25660000
321200*                                                                 25670000
321300*    COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =                     25680000
321400*            .5   H-CSTMED-X-STOP.                                25690000
321500*                                                                 25700000
321600*    COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =                     25710000
321700*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -       25720000
321800*                    H-BASE-DRG-PAYMENT)   .5.                    25730000
321900*                                                                 25740000
322000*    IF H-LESSER-HRTIMP-STOP-2 > 0                                25750000
322100*       IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2        25760000
322200*        MOVE H-LESSER-HRTIMP-STOP-1 TO H-NEW-TECH-ADDON-X-STOP   25770000
322300*       ELSE                                                      25780000
322400*        MOVE H-LESSER-HRTIMP-STOP-2 TO H-NEW-TECH-ADDON-X-STOP   25790000
322500*    ELSE                                                         25800000
322600*       MOVE ZEROES          TO H-NEW-TECH-ADDON-X-STOP.          25810000
322700*                                                                 25820000
322800*                                                                 25830000
322900*4000-ADD-TECH-CASES.                                             25840000
323000*                                                                 25850000
323100*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      25860000
323200*            H-NEW-TECH-ADDON-NEURO  +                            25870000
323300*            H-NEW-TECH-ADDON-GRAFT +                             25880000
323400*            H-NEW-TECH-ADDON-X-STOP.                             25890000
323500*                                                                 25900000
323600***********************************************************       25510000
323700***** HRTIMP-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM       25520000
323800***********************************************************       25530000
323900                                                                  25540000
324000     IF '3752   ' =  B-PRIN-PROC-CODE   OR                        25550000
324100                     B-OTHER-PROC-CODE1 OR                        25560000
324200                     B-OTHER-PROC-CODE2 OR                        25570000
324300                     B-OTHER-PROC-CODE3 OR                        25580000
324400                     B-OTHER-PROC-CODE4 OR                        25590000
324500                     B-OTHER-PROC-CODE5                           25600000
324600           NEXT SENTENCE                                          25610000
324700     ELSE                                                         25620000
324800           MOVE ZEROES TO H-NEW-TECH-ADDON-HRTIMP-STOP            25630000
324900           GO TO 4000-ADD-TECH-CASES.                             25640000
325000                                                                  25650000
325100     MOVE 53000.00 TO H-CSTMED-HRTIMP-STOP.                       25660000
325200                                                                  25670000
325300     COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =                     25680000
325400                  H-CSTMED-HRTIMP-STOP.                           25690000
325500                                                                  25700000
325600     COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =                     25710000
325700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -       25720000
325800                     H-BASE-DRG-PAYMENT)) * .5.                   25730000
325900                                                                  25740000
326000     IF H-LESSER-HRTIMP-STOP-2 > 0                                25750000
326100        IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2        25760000
326200         MOVE H-LESSER-HRTIMP-STOP-1 TO
326300                                  H-NEW-TECH-ADDON-HRTIMP-STOP
326400        ELSE                                                      25780000
326500         MOVE H-LESSER-HRTIMP-STOP-2 TO
326600                                  H-NEW-TECH-ADDON-HRTIMP-STOP
326700     ELSE                                                         25800000
326800        MOVE ZEROES          TO H-NEW-TECH-ADDON-HRTIMP-STOP.     25810000
326900                                                                  25820000
327000                                                                  25830000
327100 4000-ADD-TECH-CASES.                                             25840000
327200                                                                  25850000
327300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      25860000
327400             H-NEW-TECH-ADDON-HRTIMP-STOP.                        25890000
327500*                                                                 25900000
327600 4000-EXIT.    EXIT.                                              25910000
327700***********************************************************       25920000
327800                                                                  25930000
327900 4100-ISLET-ISOLATION-ADD-ON.                                     25940000
328000***********************************************************       25950000
328100***  TECHNICAL TRANSPLANTATION OF CELLS                           25960000
328200***                                                               25970000
328300*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF          25980000
328400*** ISLETS OF LANGERHAUS) AND                                     25990000
328500*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).         25991000
328600*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE   25992000
328700*** TIMES IN ANY OTHER PROC-CODE                                  25993000
328800***********************************************************       25994000
328900*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT     25995000
329000*** V70.7                                                         25995100
329100***********************************************************       25995200
329200                                                                  25995300
329300     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR                            25995400
329400               H-TECH-ADDON-ISLET-CNTR2.                          25995500
329500                                                                  25995600
329600*    IF 'V707   ' =  B-PRIN-PROC-CODE   OR                        25995700
329700*                    B-OTHER-PROC-CODE1 OR                        25995800
329800*                    B-OTHER-PROC-CODE2 OR                        25995900
329900*                    B-OTHER-PROC-CODE3 OR                        25996000
330000*                    B-OTHER-PROC-CODE4 OR                        25997000
330100*                    B-OTHER-PROC-CODE5                           25998000
330200*          NEXT SENTENCE                                          25999000
330300*    ELSE                                                         25999100
330400*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET                  25999200
330500*          GO TO 4100-ADD-TECH-CASES.                             25999300
330600                                                                  25999400
330700     IF '5285   ' =  B-PRIN-PROC-CODE   OR                        25999500
330800                     B-OTHER-PROC-CODE1 OR                        25999600
330900                     B-OTHER-PROC-CODE2 OR                        25999700
331000                     B-OTHER-PROC-CODE3 OR                        25999800
331100                     B-OTHER-PROC-CODE4 OR                        25999900
331200                     B-OTHER-PROC-CODE5                           26000000
331300           NEXT SENTENCE                                          26000100
331400     ELSE                                                         26000200
331500           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET                  26000300
331600           GO TO 4100-ADD-TECH-CASES.                             26000400
331700                                                                  26000500
331800     IF '5285   ' =  B-PRIN-PROC-CODE                             26000600
331900      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26000700
332000                       H-TECH-ADDON-ISLET-CNTR + 1.               26000800
332100                                                                  26000900
332200     IF '5285   ' =  B-OTHER-PROC-CODE1                           26001000
332300      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001100
332400                       H-TECH-ADDON-ISLET-CNTR + 1.               26001200
332500                                                                  26001300
332600     IF '5285   ' =  B-OTHER-PROC-CODE2                           26001400
332700      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001500
332800                       H-TECH-ADDON-ISLET-CNTR + 1.               26001600
332900                                                                  26001700
333000     IF '5285   ' =  B-OTHER-PROC-CODE3                           26001800
333100      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26001900
333200                       H-TECH-ADDON-ISLET-CNTR + 1.               26002000
333300                                                                  26002100
333400     IF '5285   ' =  B-OTHER-PROC-CODE4                           26002200
333500      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002300
333600                       H-TECH-ADDON-ISLET-CNTR + 1.               26002400
333700                                                                  26002500
333800                                                                  26002600
333900     IF '5285   ' =  B-OTHER-PROC-CODE5                           26002700
334000      COMPUTE H-TECH-ADDON-ISLET-CNTR =                           26002800
334100                       H-TECH-ADDON-ISLET-CNTR + 1.               26002900
334200                                                                  26003000
334300*    IF 'V707   ' =  B-PRIN-PROC-CODE                             26003100
334400*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26003200
334500*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26003300
334600*                                                                 26003400
334700*    IF 'V707   ' =  B-OTHER-PROC-CODE1                           26003500
334800*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26003600
334900*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26003700
335000*                                                                 26003800
335100*    IF 'V707   ' =  B-OTHER-PROC-CODE2                           26003900
335200*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26004000
335300*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26004100
335400*                                                                 26004200
335500*    IF 'V707   ' =  B-OTHER-PROC-CODE3                           26004300
335600*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26004400
335700*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26004500
335800*                                                                 26004600
335900*    IF 'V707   ' =  B-OTHER-PROC-CODE4                           26004700
336000*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26004800
336100*                      H-TECH-ADDON-ISLET-CNTR2 + 1.              26004900
336200*                                                                 26005000
336300*    IF 'V707   ' =  B-OTHER-PROC-CODE5                           26005100
336400*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =                          26005200
336500*                    H-TECH-ADDON-ISLET-CNTR2 + 1.                26005300
336600*                                                                 26005400
336700*    IF  H-TECH-ADDON-ISLET-CNTR2 > 0                             26005500
336800*          NEXT SENTENCE                                          26005600
336900*    ELSE                                                         26005700
337000*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET                  26005800
337100*          GO TO 4100-ADD-TECH-CASES.                             26005900
337200                                                                  26006000
337300     IF  H-TECH-ADDON-ISLET-CNTR = 1                              26006100
337400     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET                      26006200
337500           GO TO 4100-ADD-TECH-CASES.                             26006300
337600                                                                  26006400
337700     IF  H-TECH-ADDON-ISLET-CNTR > 1                              26006500
337800     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET                      26006600
337900           GO TO 4100-ADD-TECH-CASES.                             26006700
338000                                                                  26006800
338100     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.                            26006900
338200                                                                  26007000
338300                                                                  26008000
338400 4100-ADD-TECH-CASES.                                             26009000
338500                                                                  26009100
338600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =                      26009200
338700             H-NEW-TECH-ADDON-ISLET.                              26009300
338800                                                                  26009400
338900 4100-EXIT.    EXIT.                                              26009500
339000                                                                  26009600
339100
339200 4200-SSRFBN-CODE-RTN.
339300     SET SSRFBN-IDX TO 1.
339400     SEARCH SSRFBN-TAB VARYING SSRFBN-IDX
339500         AT END
339600           MOVE ' NO SSRFBN MESSAGE FOUND' TO MES-SSRFBN
339700       WHEN WK-SSRFBN-STATE(SSRFBN-IDX) = MES-PPS-STATE
339800         MOVE WK-SSRFBN-REASON-ALL (SSRFBN-IDX) TO MES-SSRFBN.
339900
340000 4200-EXIT.   EXIT.
340100
340200******        L A S T   S O U R C E   S T A T E M E N T   *****   26009700
