000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL09D.
000300*AUTHOR.            DDS TEAM    .
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL09D      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C09.D'.
002000 01  HMO-FLAG                       PIC X      VALUE 'N'.
002100 01  HMO-TAG                        PIC X      VALUE SPACE.
002200 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
002300 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
002400 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
002500 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
002600 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.
002700 01  R1                             PIC S9(04) COMP SYNC.
002800 01  R2                             PIC S9(04) COMP SYNC.
002900 01  R3                             PIC S9(04) COMP SYNC.
003000 01  R4                             PIC S9(04) COMP SYNC.
003100 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003200 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003300
003400***************************************************************
003500**************YEARCHANGE 2009.2 *******************************
003600* TABLE 1                                                     *
003700*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
003800*    (FULL UPDATE (.697)                                      *
003900*    (QUALITY = 1 WAGE INDEX > 1)                             *
004000***************************************************************
004100 01  TB1-RATE-TABLE.
004200     02  TB1-RATE-WORK.
004300*RATE 20081001 REGION  LABOR AND NON-LABOR RATES
004400*                  R3=1     /     R3=2
004500*               LARGE URBAN / OTHER URBAN
004600*               LABOR / NON / LABOR / NON
004700*                     /LABOR/       /LABOR
004800*             --------------------------------------------
004900         05  FILLER PIC X(08) VALUE '20081001'.
005000         05  TB1-NAT    PIC X(30) VALUE
005100            ' 0357450 155391 0357450 155391'.
005200         05  TB1-PR     PIC X(30) VALUE
005300            ' 0150782 092415 0150782 092415'.
005400         05  TB1-NATPR  PIC X(30) VALUE
005500            ' 0357450 155391 0357450 155391'.
005600***************************************************************
005700     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
005800         05  TB1-RATE-PERIOD            OCCURS 1.
005900             10  TB1-RATE-EFF-DATE      PIC X(08).
006000             10  TB1-REG-NAT            OCCURS 3.
006100                 15  TB1-LARGE-OTHER    OCCURS 2.
006200                     20  FILLER         PIC X(01).
006300                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
006400                     20  FILLER         PIC X(01).
006500                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
006600
006700***************************************************************
006800************YEARCHANGE 2009.2 *********************************
006900* TABLE 2                                                     *
007000*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
007100*    (REDUCED UPDATE (.697)                                   *
007200*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *
007300***************************************************************
007400 01  TB2-RATE-TABLE.
007500     02  TB2-RATE-WORK.
007600*RATE 20081001 REGION  LABOR AND NON-LABOR RATES
007700*                  R3=1     /     R3=2
007800*               LARGE URBAN / OTHER URBAN
007900*               LABOR / NON / LABOR / NON
008000*                     /LABOR/       /LABOR
008100*             --------------------------------------------
008200         05  FILLER PIC X(08) VALUE '20081001'.
008300         05  TB2-NAT    PIC X(30) VALUE
008400            ' 0350549 152391 0350549 152391'.
008500         05  TB2-PR     PIC X(30) VALUE
008600            ' 0150782 092415 0150782 092415'.
008700         05  TB2-NATPR  PIC X(30) VALUE
008800            ' 0357450 155391 0357450 155391'.
008900***************************************************************
009000     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
009100         05  TB2-RATE-PERIOD             OCCURS 1.
009200             10  TB2-RATE-EFF-DATE       PIC X(08).
009300             10  TB2-REG-NAT             OCCURS 3.
009400                 15  TB2-LARGE-OTHER     OCCURS 2.
009500                     20  FILLER          PIC X(01).
009600                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
009700                     20  FILLER          PIC X(01).
009800                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
009900***************************************************************
010000************YEARCHANGE 2009.1 *********************************
010100* TABLE 3                                                     *
010200*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
010300*    (FULL UPDATE (.62%)                                      *
010400*    (QUALITY = 1 WAGE INDEX <= 1)                            *
010500***************************************************************
010600 01  TB3-RATE-TABLE.
010700     02  TB3-RATE-WORK.
010800*RATE 20081001 REGION  LABOR AND NON-LABOR RATES
010900*                  R3=1     /     R3=2
011000*               LARGE URBAN / OTHER URBAN
011100*               LABOR / NON / LABOR / NON
011200*                     /LABOR/       /LABOR
011300*             --------------------------------------------
011400         05  FILLER PIC X(08) VALUE '20081001'.
011500         05  TB3-NAT    PIC X(30) VALUE
011600            ' 0317961 194880 0317961 194880'.
011700         05  TB3-PR     PIC X(30) VALUE
011800            ' 0142757 100440 0142757 100440'.
011900         05  TB3-NATPR  PIC X(30) VALUE
012000            ' 0317961 194880 0317961 194880'.
012100****************************************************************
012200     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
012300         05  TB3-RATE-PERIOD            OCCURS 1.
012400             10  TB3-RATE-EFF-DATE      PIC X(08).
012500             10  TB3-REG-NAT            OCCURS 3.
012600                 15  TB3-LARGE-OTHER    OCCURS 2.
012700                     20  FILLER         PIC X(01).
012800                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
012900                     20  FILLER         PIC X(01).
013000                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
013100
013200***************************************************************
013300**********YEARCHANGE 2009.1 ***********************************
013400* TABLE 4                                                     *
013500*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
013600*    (REDUCED UPDATE (.62%)                                   *
013700*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *
013800***************************************************************
013900 01  TB4-RATE-TABLE.
014000     02  TB4-RATE-WORK.
014100*RATE 20081001 REGION  LABOR AND NON-LABOR RATES
014200*                  R3=1     /     R3=2
014300*               LARGE URBAN / OTHER URBAN
014400*               LABOR / NON / LABOR / NON
014500*                     /LABOR/       /LABOR
014600*             --------------------------------------------
014700         05  FILLER PIC X(08) VALUE '20081001'.
014800         05  TB4-NAT    PIC X(30) VALUE
014900            ' 0311823 191117 0311823 191117'.
015000         05  TB4-PR     PIC X(30) VALUE
015100            ' 0142757 100440 0142757 100440'.
015200         05  TB4-NATPR  PIC X(30) VALUE
015300            ' 0317961 194880 0317961 194880'.
015400***************************************************************
015500     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
015600         05  TB4-RATE-PERIOD             OCCURS 1.
015700             10  TB4-RATE-EFF-DATE       PIC X(08).
015800             10  TB4-REG-NAT             OCCURS 3.
015900                 15  TB4-LARGE-OTHER     OCCURS 2.
016000                     20  FILLER          PIC X(01).
016100                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
016200                     20  FILLER          PIC X(01).
016300                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
016400
016500 01  DRG-TABLE.
016600     05  D-TAB.
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.
067000         10  DRGX-PERIOD               OCCURS 1
067100                                        INDEXED BY DX5.
067200             15  DRGX-EFF-DATE         PIC X(08).
067300             15  DRG-DATA              OCCURS 1000
067400                                        INDEXED BY DX6.
067500                 20  DRG-WT            PIC 9(02)V9(04).
067600                 20  DRG-ALOS          PIC 9(02)V9(01).
067700                 20  DRG-DAYS-TRIM     PIC 9(02).
067800                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
067900
068000*****YEARCHANGE 2009.1 ************************************
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 ************************************
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
086000 01  HOLD-AREA.
086100     02  HOLD-PPS-COMPONENTS.
086200         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
086300         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
086400
086500         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
086600         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
086700
086800         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
086900         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
087000         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
087100
087200         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
087300         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
087400         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
087500
087600         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
087700         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
087800
087900         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
088000         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
088100
088200         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
088300         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
088400
088500         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
088600         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
088700         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
088800         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
088900         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
089000         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
089100         05  H-CAPI-COLA                  PIC 9(01)V9(03).
089200         05  H-CAPI-SCH                   PIC 9(05)V9(02).
089300         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
089400         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
089500         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
089600         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
089700         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
089800         05  H-CAPI-GAF                   PIC 9(05)V9(04).
089900         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
090000         05  H-BLEND-GAF                  PIC 9(05)V9(04).
090100         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
090200         05  H-COV-DAYS                   PIC 9(3).
090300         05  H-PERDIEM-DAYS               PIC 9(3).
090400         05  H-REG-DAYS                   PIC 9(3).
090500         05  H-LTR-DAYS                   PIC 9(3).
090600         05  H-DSCHG-FRCTN                PIC 9(3)V9999.
090700         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
090800         05  H-ALOS                       PIC 9(02)V9(01).
090900         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
091000         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
091100         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
091200         05  H-CST-THRESH                 PIC 9(05)V9(02).
091300         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
091400         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
091500         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
091600         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
091700         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
091800         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
091900         05  H-BUDG-NUTR06                PIC 9(01)V9(06).
092000         05  H-BUDG-NUTR07                PIC 9(01)V9(06).
092100         05  H-BUDG-NUTR08                PIC 9(01)V9(06).
092200         05  H-BUDG-NUTR09                PIC 9(01)V9(06).
092300         05  H-CASE-MIX-ADJ               PIC 9(01)V9(03).
092400         05  H-UPDATE-01                  PIC 9(01)V9(04).
092500         05  H-UPDATE-02                  PIC 9(01)V9(04).
092600         05  H-UPDATE-03                  PIC 9(01)V9(04).
092700         05  H-UPDATE-04                  PIC 9(01)V9(04).
092800         05  H-UPDATE-05                  PIC 9(01)V9(04).
092900         05  H-UPDATE-06                  PIC 9(01)V9(04).
093000         05  H-UPDATE-07                  PIC 9(01)V9(04).
093100         05  H-UPDATE-08                  PIC 9(01)V9(04).
093200         05  H-UPDATE-09                  PIC 9(01)V9(04).
093300         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
093400         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
093500         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
093600         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
093700         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
093800         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
093900         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
094000         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
094100         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
094200         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
094300         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
094400         05  H-LABOR-PCT                  PIC 9(01)V9(04).
094500         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
094600         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
094700         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
094800         05  H-HSP-RATE                   PIC 9(06)V9(09).
094900         05  H-FSP-RATE                   PIC 9(06)V9(09).
095000         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
095100         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
095200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
095300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
095400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
095500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
095600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
095700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
095800         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
095900         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
096000         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
096100         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.
096200         05  H-NEW-TECH-ADDON-HRTIMP-STOP PIC S9(07)V99.
096300         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.
096400         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).
096500         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).
096600
096700         05  H-LESSER-NEURO-1             PIC S9(07)V99.
096800         05  H-LESSER-NEURO-2             PIC S9(07)V99.
096900
097000         05  H-LESSER-GRAFT-1             PIC S9(07)V99.
097100         05  H-LESSER-GRAFT-2             PIC S9(07)V99.
097200
097300         05  H-LESSER-X-STOP-1            PIC S9(07)V99.
097400         05  H-LESSER-X-STOP-2            PIC S9(07)V99.
097500
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
098100         05  H-CSTMED-NEURO               PIC S9(07)V99.
098200         05  H-CSTMED-GRAFT               PIC S9(07)V99.
098300         05  H-CSTMED-X-STOP              PIC S9(07)V99.
098400         05  H-CSTMED-HRTIMP-STOP         PIC S9(07)V99.
098500
098600
098700     02  HOLD-ADDITIONAL-VARIABLES.
098800         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
098900         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
099000         05  H-NAT-PCT                    PIC 9(01)V9(02).
099100         05  H-REG-PCT                    PIC 9(01)V9(02).
099200         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
099300         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
099400         05  H-DRG-WT                     PIC 9(02)V9(04).
099500         05  H-NAT-LABOR                  PIC 9(05)V9(02).
099600         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
099700         05  H-REG-LABOR                  PIC 9(05)V9(02).
099800         05  H-REG-NONLABOR               PIC 9(05)V9(02).
099900         05  H-OPER-COLA                  PIC 9(01)V9(03).
100000         05  H-INTERN-RATIO               PIC 9(01)V9(04).
100100         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
100200         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
100300         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
100400
100500     02  HOLD-CAPITAL-VARIABLES.
100600         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
100700         05  H-CAPI-HSP                   PIC 9(07)V9(02).
100800         05  H-CAPI-FSP                   PIC 9(07)V9(02).
100900         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
101000         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
101100         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
101200         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
101300         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
101400
101500     02  HOLD-CAPITAL2-VARIABLES.
101600         05  H-CAPI2-PAY-CODE             PIC X(1).
101700         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
101800         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
101900
102000     02  HOLD-OTHER-VARIABLES.
102100         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
102200         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
102300         05  FILLER                       PIC X(21).
102400
102500     02  HOLD-PC-OTH-VARIABLES.
102600         05  H-OPER-DSH                   PIC 9(01)V9(04).
102700         05  H-CAPI-DSH                   PIC 9(01)V9(04).
102800         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
102900         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
103000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
103100         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
103200         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
103300         05  H-PC-HMO-FLAG                PIC X(01).
103400         05  H-PC-COT-FLAG                PIC X(01).
103500         05  H-FILLER                     PIC X(09).
103600
103700 01  HLD-PPS-DATA.
103800         10  HLD-PPS-RTC                PIC 9(02).
103900         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
104000         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
104100         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
104200         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
104300         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
104400         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
104500         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
104600         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
104700         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
104800         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
104900         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
105000         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
105100         10  HLD-PPS-CALC-VERS          PIC X(05).
105200
105300 LINKAGE SECTION.
105400***************************************************************
105500*                 * * * * * * * * *                           *
105600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
105700*    IN HOW TO PAY THE BILL.                                  *
105800*                         *****                               *
105900*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
106000*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
106100*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
106200*                 OUTLIER COMPUTATION.                        *
106300*                         *****                               *
106400*         REVIEW-CODE:                                        *
106500*            00 = PAY-WITH-OUTLIER.                           *
106600*                 WILL CALCULATE THE STANDARD PAYMENT.        *
106700*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
106800*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
106900*            03 = PAY-PERDIEM-DAYS.                           *
107000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
107100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
107200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
107300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
107400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
107500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
107600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
107700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
107800*                 BILL EXCEED THE COST THRESHOLD.             *
107900*            06 = PAY-XFER-NO-COST                            *
108000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
108100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
108200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
108300*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
108400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
108500*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
108600*                 CALCULATE ANY COST OUTLIER PORTION          *
108700*                 OF THE PAYMENT.                             *
108800*            07 = PAY-WITHOUT-COST.                           *
108900*                 WILL CALCULATE THE STANDARD PAYMENT         *
109000*                 WITHOUT COST PORTION.                       *
109100*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
109200*                 50-50> 28  29  30  40  41  42  219
109300*                        220 221 477 478 479 480 481
109400*                        482 492 493 494 500 501 502
109500*                        515 516 517
109600* =======================================================
109700* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
109800* =======================================================
109900*
110000*
110100*     FULL PERDIEM >   3   4   25  26  27  28          31
110200*                      32  33              54  55  56  57
110300*                      64  65  66  70  71  72  85  86  87
110400*                      91  92  93  100 101 163 164 165 166
110500*                      167 168 175 176 177 178 179 186 187
110600*                      188 190 191 192 193 194 195 196 197
110700*                      198 205 206 207 216 217 218
110800*                          228 229 230 233 234 235 236 239
110900*                      240 241 242 243 244 255 256 257 264
111000*                      280 281 282 288 289 290 291 292 293
111100*                      299 300 301 314 315 316 326 327 328
111200*                      329 330 331 332 333 334 335 336 337
111300*                      356 357 358 371 372 373 374 375 376
111400*                      377 378 379 380 381 382 388 389 390
111500*                      405 406 407 414 415 416 441 442 443
111600*                      459 460 463 464 465 466 467 468 469
111700*                      470 474 475 476
111800*                          483 484 488 489             495
111900*                      496 497             510 511 512
112000*                              533 534 535 536 539 540 541
112100*                      542 543 544 545 546 547 551 552 557
112200*                      558 559 560 561 562 563 573 574 575
112300*                      579 580 581 592 593 594 602 603 616
112400*                      617 618 622 623 624 628 629 630 637
112500*                      638 639 640 641 643 644 645 653 654
112600*                      655 659 660 661 682 683 684 689 690
112700*                      698 699 700 840 841 842 853 854 855
112800*                      856 857 858 862 863 867 868 869 870
112900*                      871 872 884 896 897 907 908 909 917
113000*                      918 945 946 947 948 956 981 982 983
113100*                      987 988 989
113200*
113300*                               POST-ACUTE TRANSFERS          *
113400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
113500*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
113600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
113700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
113800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
113900*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
114000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
114100*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
114200*                 BILL EXCEED THE COST THRESHOLD.             *
114300*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
114400*                 POST-ACUTE TRANSFERS                        *
114500*                 50-50> 28  29  30  40  41  42  219
114600*                        220 221 477 478 479 480 481
114700*                        482 492 493 494 500 501 502
114800*                        515 516 517
114900*
115000* =======================================================
115100* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
115200* =======================================================
115300*
115400*     FULL PERDIEM >     3   4   25  26  27              31
115500*                        32  33              54  55  56  57
115600*                        64  65  66  70  71  72  85  86  87
115700*                        91  92  93  100 101 163 164 165 166
115800*                        167 168 175 176 177 178 179 186 187
115900*                        188 190 191 192 193 194 195 196 197
116000*                        198 205 206 207 216 217 218
116100*                            228 229 230 233 234 235 236 239
116200*                        240 241 242 243 244 255 256 257 264
116300*                        280 281 282 288 289 290 291 292 293
116400*                        299 300 301 314 315 316 326 327 328
116500*                        329 330 331 332 333 334 335 336 337
116600*                        356 357 358 371 372 373 374 375 376
116700*                        377 378 379 380 381 382 388 389 390
116800*                        405 406 407 414 415 416 441 442 443
116900*                        459 460 463 464 465 466 467 468 469
117000*                        470 474 475 476
117100*                            483 484 488 489             495
117200*                        496 497             510 511 512
117300*                                533 534 535 536 539 540 541
117400*                        542 543 544 545 546 547 551 552 557
117500*                        558 559 560 561 562 563 573 574 575
117600*                        579 580 581 592 593 594 602 603 616
117700*                        617 618 622 623 624 628 629 630 637
117800*                        638 639 640 641 643 644 645 653 654
117900*                        655 659 660 661 682 683 684 689 690
118000*                        698 699 700 840 841 842 853 854 855
118100*                        856 857 858 862 863 867 868 869 870
118200*                        871 872 884 896 897 907 908 909 917
118300*                        918 945 946 947 948 956 981 982 983
118400*                        987 988 989
118500*
118600*
118700*                               POST-ACUTE TRANSFERS          *
118800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
118900*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
119000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
119100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
119200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
119300*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
119400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
119500*                 PAYMENT.                                    *
119600***************************************************************
119700
119800**************************************************************
119900*      MILLINNIUM COMPATIBLE                                 *
120000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
120100*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
120200*      IN THE NEW FORMAT                                     *
120300**************************************************************
120400 01  BILL-NEW-DATA.
120500         10  B-NPI10.
120600             15  B-NPI8             PIC X(08).
120700             15  B-NPI-FILLER       PIC X(02).
120800         10  B-PROVIDER-NO          PIC X(06).
120900         10  B-REVIEW-CODE          PIC 9(02).
121000             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
121100             88  PAY-WITH-OUTLIER     VALUE 00 07.
121200             88  PAY-PERDIEM-DAYS     VALUE 03.
121300             88  PAY-XFER-NO-COST     VALUE 06.
121400             88  PAY-WITHOUT-COST     VALUE 07.
121500             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
121600             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
121700         10  B-DRG                  PIC 9(03).
121800             88  B-DRG-POSTACUTE-50-50
121900                   VALUE 28  29  30  40  41  42  219
122000                         220 221 477 478 479 480 481
122100                         482 492 493 494 500 501 502
122200                         515 516 517.
122300
122400* =======================================================
122500* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
122600* =======================================================
122700*
122800             88  B-DRG-POSTACUTE-PERDIEM
122900                   VALUE 3   4   25  26  27              31
123000                         32  33              54  55  56  57
123100                         64  65  66  70  71  72  85  86  87
123200                         91  92  93  100 101 163 164 165 166
123300                         167 168 175 176 177 178 179 186 187
123400                         188 190 191 192 193 194 195 196 197
123500                         198 205 206 207 216 217 218
123600                             228 229 230 233 234 235 236 239
123700                         240 241 242 243 244 255 256 257 264
123800                         280 281 282 288 289 290 291 292 293
123900                         299 300 301 314 315 316 326 327 328
124000                         329 330 331 332 333 334 335 336 337
124100                         356 357 358 371 372 373 374 375 376
124200                         377 378 379 380 381 382 388 389 390
124300                         405 406 407 414 415 416 441 442 443
124400                         459 460 463 464 465 466 467 468 469
124500                         470 474 475 476
124600                             483 484 488 489             495
124700                         496 497             510 511 512
124800                                 533 534 535 536 539 540 541
124900                         542 543 544 545 546 547 551 552 557
125000                         558 559 560 561 562 563 573 574 575
125100                         579 580 581 592 593 594 602 603 616
125200                         617 618 622 623 624 628 629 630 637
125300                         638 639 640 641 643 644 645 653 654
125400                         655 659 660 661 682 683 684 689 690
125500                         698 699 700 840 841 842 853 854 855
125600                         856 857 858 862 863 867 868 869 870
125700                         871 872 884 896 897 907 908 909 917
125800                         918 945 946 947 948 956 981 982 983
125900                         987 988 989.
126000
126100         10  B-LOS                  PIC 9(03).
126200         10  B-COVERED-DAYS         PIC 9(03).
126300         10  B-LTR-DAYS             PIC 9(02).
126400         10  B-DISCHARGE-DATE.
126500             15  B-DISCHG-CC        PIC 9(02).
126600             15  B-DISCHG-YY        PIC 9(02).
126700             15  B-DISCHG-MM        PIC 9(02).
126800             15  B-DISCHG-DD        PIC 9(02).
126900         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
127000         10  B-PRIN-PROC-CODE       PIC X(07).
127100         10  B-OTHER-PROC-CODE1     PIC X(07).
127200         10  B-OTHER-PROC-CODE2     PIC X(07).
127300         10  B-OTHER-PROC-CODE3     PIC X(07).
127400         10  B-OTHER-PROC-CODE4     PIC X(07).
127500         10  B-OTHER-PROC-CODE5     PIC X(07).
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).
129600         10  B-OTHER-DIAG-CODE2     PIC X(07).
129700         10  B-OTHER-DIAG-CODE3     PIC X(07).
129800         10  B-OTHER-DIAG-CODE4     PIC X(07).
129900         10  B-OTHER-DIAG-CODE5     PIC X(07).
130000         10  B-OTHER-DIAG-CODE6     PIC X(07).
130100         10  B-OTHER-DIAG-CODE7     PIC X(07).
130200         10  B-OTHER-DIAG-CODE8     PIC X(07).
130300         10  B-OTHER-DIAG-CODE9     PIC X(07).
130400         10  B-OTHER-DIAG-CODE10    PIC X(07).
130500         10  B-OTHER-DIAG-CODE11    PIC X(07).
130600         10  B-OTHER-DIAG-CODE12    PIC X(07).
130700         10  B-OTHER-DIAG-CODE13    PIC X(07).
130800         10  B-OTHER-DIAG-CODE14    PIC X(07).
130900         10  B-OTHER-DIAG-CODE15    PIC X(07).
131000         10  B-OTHER-DIAG-CODE16    PIC X(07).
131100         10  B-OTHER-DIAG-CODE17    PIC X(07).
131200         10  B-OTHER-DIAG-CODE18    PIC X(07).
131300         10  B-OTHER-DIAG-CODE19    PIC X(07).
131400         10  B-OTHER-DIAG-CODE20    PIC X(07).
131500         10  B-OTHER-DIAG-CODE21    PIC X(07).
131600         10  B-OTHER-DIAG-CODE22    PIC X(07).
131700         10  B-OTHER-DIAG-CODE23    PIC X(07).
131800         10  B-OTHER-DIAG-CODE24    PIC X(07).
131900         10  B-OTHER-DIAG-CODE25    PIC X(07).
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
132900
133000
133100***************************************************************
133200*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
133300*    AND PASSED BACK TO THE CALLING PROGRAM                   *
133400*            RETURN CODE VALUES (PPS-RTC)                     *
133500*                                                             *
133600*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
133700*                                                             *
133800*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
133900*                                                             *
134000*           30,00 = PAID NORMAL DRG PAYMENT                   *
134100*                                                             *
134200*              01 = PAID AS A DAY-OUTLIER.                    *
134300*                   NOTE:                                     *
134400*                     DAY-OUTLIER NO LONGER BEING PAID        *
134500*                         AS OF 10/01/97                      *
134600*                                                             *
134700*              02 = PAID AS A COST-OUTLIER.                   *
134800*                                                             *
134900*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
135000*                   AND INCLUDING THE FULL DRG.               *
135100*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
135200*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
135300*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
135400*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
135500*                   AND INCLUDING THE FULL DRG. PROVIDER      *
135600*                   REFUSED COST OUTLIER.                     *
135700*           40,10 = POST-ACUTE TRANSFER                       *
135800*                   DRG = 28  29  30  40  41  42  219
135900*                         220 221 477 478 479 480 481
136000*                         482 492 493 494 500 501 502
136100*                         515 516 517
136200*
136300* =======================================================
136400* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
136500* =======================================================
136600*
136700*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
136800*                       THE FOLLOWING DRG'S                   *
136900*                   DRG = 3   4   25  26  27              31
137000*                         32  33              54  55  56  57
137100*                         64  65  66  70  71  72  85  86  87
137200*                         91  92  93  100 101 163 164 165 166
137300*                         167 168 175 176 177 178 179 186 187
137400*                         188 190 191 192 193 194 195 196 197
137500*                         198 205 206 207 216 217 218
137600*                             228 229 230 233 234 235 236 239
137700*                         240 241 242 243 244 255 256 257 264
137800*                         280 281 282 288 289 290 291 292 293
137900*                         299 300 301 314 315 316 326 327 328
138000*                         329 330 331 332 333 334 335 336 337
138100*                         356 357 358 371 372 373 374 375 376
138200*                         377 378 379 380 381 382 388 389 390
138300*                         405 406 407 414 415 416 441 442 443
138400*                         459 460 463 464 465 466 467 468 469
138500*                         470 474 475 476
138600*                             483 484 488 489             495
138700*                         496 497             510 511 512
138800*                                 533 534 535 536 539 540 541
138900*                         542 543 544 545 546 547 551 552 557
139000*                         558 559 560 561 562 563 573 574 575
139100*                         579 580 581 592 593 594 602 603 616
139200*                         617 618 622 623 624 628 629 630 637
139300*                         638 639 640 641 643 644 645 653 654
139400*                         655 659 660 661 682 683 684 689 690
139500*                         698 699 700 840 841 842 853 854 855
139600*                         856 857 858 862 863 867 868 869 870
139700*                         871 872 884 896 897 907 908 909 917
139800*                         918 945 946 947 948 956 981 982 983
139900*                         987 988 989
140000*
140100*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
140200*                    PERDIEM DAYS = OR > GM  ALOS             *
140300*              16 = PAID AS A COST-OUTLIER WITH               *
140400*                    PERDIEM DAYS = OR > GM  ALOS             *
140500*                                                             *
140600*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
140700*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
140800*              52 = INVALID CBSA# IN PROVIDER FILE            *
140900*                   OR INVALID WAGE INDEX                     *
141000*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
141100*              54 = INVALID DRG                               *
141200*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
141300*                                      OR                     *
141400*                   DISCHARGE DATE < CBSA EFF START DATE      *
141500*                   FOR PPS                                   *
141600*                                      OR                     *
141700*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
141800*                   DISCHARGE DATE                            *
141900*              56 = INVALID LENGTH OF STAY                    *
142000*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
142100*                                        NOT 11)              *
142200*              58 = TOTAL CHARGES NOT NUMERIC                 *
142300*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
142400*                   OR BILL-LTR-DAYS > 60                     *
142500*              62 = INVALID NUMBER OF COVERED DAYS            *
142600*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
142700*                   SPECIFIC FILE FOR CAPITAL                 *
142800*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
142900*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
143000*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
143100***************************************************************
143200 01  PPS-DATA.
143300         10  PPS-RTC                PIC 9(02).
143400         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
143500         10  PPS-OUTLIER-DAYS       PIC 9(03).
143600         10  PPS-AVG-LOS            PIC 9(02)V9(01).
143700         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
143800         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
143900         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
144000         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
144100         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
144200         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
144300         10  PPS-REG-DAYS-USED      PIC 9(03).
144400         10  PPS-LTR-DAYS-USED      PIC 9(02).
144500         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
144600         10  PPS-CALC-VERS          PIC X(05).
144700
144800******************************************************************
144900*            THESE ARE THE VERSIONS OF THE PPCAL
145000*           PROGRAMS THAT WILL BE PASSED BACK----
145100*          ASSOCIATED WITH THE BILL BEING PROCESSED
145200******************************************************************
145300 01  PRICER-OPT-VERS-SW.
145400     02  PRICER-OPTION-SW          PIC X(01).
145500         88  ALL-TABLES-PASSED          VALUE 'A'.
145600         88  PROV-RECORD-PASSED         VALUE 'P'.
145700         88  ADDITIONAL-VARIABLES       VALUE 'M'.
145800         88  PC-PRICER                  VALUE 'C'.
145900     02  PPS-VERSIONS.
146000         10  PPDRV-VERSION         PIC X(05).
146100
146200******************************************************************
146300*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
146400*          ASSOCIATED WITH THE BILL BEING PROCESSED
146500******************************************************************
146600 01  PPS-ADDITIONAL-VARIABLES.
146700     05  PPS-HSP-PCT                PIC 9(01)V9(02).
146800     05  PPS-FSP-PCT                PIC 9(01)V9(02).
146900     05  PPS-NAT-PCT                PIC 9(01)V9(02).
147000     05  PPS-REG-PCT                PIC 9(01)V9(02).
147100     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
147200     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
147300     05  PPS-DRG-WT                 PIC 9(02)V9(04).
147400     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
147500     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
147600     05  PPS-REG-LABOR              PIC 9(05)V9(02).
147700     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
147800     05  PPS-OPER-COLA              PIC 9(01)V9(03).
147900     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
148000     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
148100     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
148200     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
148300     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
148400     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
148500     05  PPS-CAPITAL-VARIABLES.
148600         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
148700         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
148800         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
148900         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
149000         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
149100         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
149200         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
149300         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
149400     05  PPS-CAPITAL2-VARIABLES.
149500         10  PPS-CAPI2-PAY-CODE             PIC X(1).
149600         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
149700         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
149800
149900     05  PPS-OTHER-VARIABLES.
150000         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
150100         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
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
151300     05  PPS-PC-OTH-VARIABLES.
151400         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
151500         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
151600         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
151700         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
151800         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
151900         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
152000         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
152100         10  PPS-PC-HMO-FLAG                PIC X(01).
152200         10  PPS-PC-COT-FLAG                PIC X(01).
152300         10  PPS-FILLER                      PIC X(0998).
152400
152500 01  PROV-NEW-HOLD.
152600     02  PROV-NEWREC-HOLD1.
152700         05  P-NEW-NPI10.
152800             10  P-NEW-NPI8             PIC X(08).
152900             10  P-NEW-NPI-FILLER       PIC X(02).
153000         05  P-NEW-PROVIDER-NO.
153100             88  P-NEW-DSH-ADJ-PROVIDERS
153200                             VALUE '180049' '190044' '190144'
153300                                   '190191' '330047' '340085'
153400                                   '370016' '370149' '420043'.
153500             10  P-NEW-STATE            PIC 9(02).
153600             10  FILLER                 PIC X(04).
153700         05  P-NEW-DATE-DATA.
153800             10  P-NEW-EFF-DATE.
153900                 15  P-NEW-EFF-DT-CC    PIC 9(02).
154000                 15  P-NEW-EFF-DT-YY    PIC 9(02).
154100                 15  P-NEW-EFF-DT-MM    PIC 9(02).
154200                 15  P-NEW-EFF-DT-DD    PIC 9(02).
154300             10  P-NEW-FY-BEGIN-DATE.
154400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
154500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
154600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
154700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
154800             10  P-NEW-REPORT-DATE.
154900                 15  P-NEW-REPORT-DT-CC PIC 9(02).
155000                 15  P-NEW-REPORT-DT-YY PIC 9(02).
155100                 15  P-NEW-REPORT-DT-MM PIC 9(02).
155200                 15  P-NEW-REPORT-DT-DD PIC 9(02).
155300             10  P-NEW-TERMINATION-DATE.
155400                 15  P-NEW-TERM-DT-CC   PIC 9(02).
155500                 15  P-NEW-TERM-DT-YY   PIC 9(02).
155600                 15  P-NEW-TERM-DT-MM   PIC 9(02).
155700                 15  P-NEW-TERM-DT-DD   PIC 9(02).
155800         05  P-NEW-WAIVER-CODE          PIC X(01).
155900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
156000         05  P-NEW-INTER-NO             PIC 9(05).
156100         05  P-NEW-PROVIDER-TYPE        PIC X(02).
156200             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
156300             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
156400                                                  '15' '17'
156500                                                  '22'.
156600             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
156700             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
156800             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
156900             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
157000             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
157100             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
157200             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
157300             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
157400             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
157500             88  P-N-EACH                   VALUE '21' '22'.
157600             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
157700             88  P-N-NHCMQ-II-SNF           VALUE '32'.
157800             88  P-N-NHCMQ-III-SNF          VALUE '33'.
157900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
158000             88  P-N-NEW-ENGLAND            VALUE  1.
158100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
158200             88  P-N-SOUTH-ATLANTIC         VALUE  3.
158300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
158400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
158500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
158600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
158700             88  P-N-MOUNTAIN               VALUE  8.
158800             88  P-N-PACIFIC                VALUE  9.
158900         05  P-NEW-CURRENT-DIV   REDEFINES
159000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
159100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
159200         05  P-NEW-MSA-DATA.
159300             10  P-NEW-CHG-CODE-INDEX       PIC X.
159400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
159500             10  P-NEW-GEO-LOC-MSA9   REDEFINES
159600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
159700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
159800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
159900             10  P-NEW-STAND-AMT-LOC-MSA9
160000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
160100                 15  P-NEW-RURAL-1ST.
160200                     20  P-NEW-STAND-RURAL  PIC XX.
160300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
160400                 15  P-NEW-RURAL-2ND        PIC XX.
160500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
160600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
160700                 88  P-NEW-SCH-YR82       VALUE   '82'.
160800                 88  P-NEW-SCH-YR87       VALUE   '87'.
160900         05  P-NEW-LUGAR                    PIC X.
161000         05  P-NEW-TEMP-RELIEF-IND          PIC X.
161100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
161200         05  FILLER                         PIC X(05).
161300     02  PROV-NEWREC-HOLD2.
161400         05  P-NEW-VARIABLES.
161500             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
161600             10  P-NEW-COLA              PIC  9(01)V9(03).
161700             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
161800             10  P-NEW-BED-SIZE          PIC  9(05).
161900             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
162000             10  P-NEW-CMI               PIC  9(01)V9(04).
162100             10  P-NEW-SSI-RATIO         PIC  V9(04).
162200             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
162300             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
162400             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
162500             10  P-NEW-DSH-PERCENT       PIC  V9(04).
162600             10  P-NEW-FYE-DATE          PIC  X(08).
162700         05  P-NEW-CBSA-DATA.
162800             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
162900             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
163000             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
163100             10  P-NEW-CBSA-GEO-RURAL REDEFINES
163200                 P-NEW-CBSA-GEO-LOC.
163300                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
163400                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
163500                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
163600
163700             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
163800             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
163900             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
164000     02  PROV-NEWREC-HOLD3.
164100         05  P-NEW-PASS-AMT-DATA.
164200             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
164300             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
164400             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
164500             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
164600         05  P-NEW-CAPI-DATA.
164700             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
164800             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
164900             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
165000             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
165100             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
165200             15  P-NEW-CAPI-NEW-HOSP       PIC X.
165300             15  P-NEW-CAPI-IME            PIC 9V9999.
165400             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
165500         05  P-HVBP-HRR-DATA.
165600             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
165700             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
165800             15  P-HOSP-READMISSION-REDUCTN PIC X.
165900             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
166000         05  P-MODEL1-BUNDLE-DATA.
166100             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
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******************************************************************
166800 01  WAGE-NEW-CBSA-INDEX-RECORD.
166900     05  W-CBSA                        PIC X(5).
167000     05  W-CBSA-SIZE                   PIC X.
167100         88  LARGE-URBAN       VALUE 'L'.
167200         88  OTHER-URBAN       VALUE 'O'.
167300         88  ALL-RURAL         VALUE 'R'.
167400     05  W-CBSA-EFF-DATE               PIC X(8).
167500     05  FILLER                        PIC X.
167600     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
167700     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
167800
167900
168000 PROCEDURE DIVISION  USING BILL-NEW-DATA
168100                           PPS-DATA
168200                           PRICER-OPT-VERS-SW
168300                           PPS-ADDITIONAL-VARIABLES
168400                           PROV-NEW-HOLD
168500                           WAGE-NEW-CBSA-INDEX-RECORD.
168600
168700***************************************************************
168800*    PROCESSING:                                              *
168900*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
169000*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
169100*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
169200*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
169300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
169400*           GOBACK.                                           *
169500*        D. ASSEMBLE PRICING COMPONENTS.                      *
169600*        E. CALCULATE THE PRICE.                              *
169700***************************************************************
169800
169900     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
170000     MOVE 'N' TO TEMP-RELIEF-FLAG.
170100     MOVE 'N' TO OUTLIER-RECON-FLAG.
170200
170300     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
170400
170500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
170600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
170700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
170800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
170900     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
171000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
171100     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
171200     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
171300
171400     IF (PPS-RTC = '00' OR '03' OR '10' OR
171500                   '12' OR '14')
171600        MOVE 'Y' TO OUTLIER-RECON-FLAG
171700        MOVE PPS-DATA TO HLD-PPS-DATA
171800        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
171900        MOVE HLD-PPS-DATA TO PPS-DATA.
172000
172100     GOBACK.
172200
172300 0200-MAINLINE-CONTROL.
172400
172500     MOVE 'N' TO HMO-TAG.
172600
172700     IF PPS-PC-HMO-FLAG = 'Y' OR
172800               HMO-FLAG = 'Y'
172900        MOVE 'Y' TO HMO-TAG.
173000
173100     IF P-NEW-STATE NOT = 40
173200        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
173300
173400     MOVE ALL '0' TO PPS-DATA
173500                     H-OPER-DSH-SCH
173600                     H-OPER-DSH-RRC
173700                     HOLD-PPS-COMPONENTS
173800                     HOLD-PPS-COMPONENTS
173900                     HOLD-ADDITIONAL-VARIABLES
174000                     HOLD-CAPITAL-VARIABLES
174100                     HOLD-CAPITAL2-VARIABLES
174200                     HOLD-OTHER-VARIABLES
174300                     HOLD-PC-OTH-VARIABLES.
174400
174500     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
174600        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
174700
174800     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
174900        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
175000
175100     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
175200        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
175300
175400     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
175500        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
175600
175700
175800     PERFORM 1000-EDIT-THE-BILL-INFO.
175900
176000     IF  PPS-RTC = 00
176100         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
176200         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
176300
176400     IF OUTLIER-RECON-FLAG = 'Y'
176500        MOVE 'N' TO OUTLIER-RECON-FLAG
176600        GO TO 0200-EXIT.
176700
176800     IF PPS-RTC = 00
176900        IF H-PERDIEM-DAYS = H-ALOS OR
177000           H-PERDIEM-DAYS > H-ALOS
177100           MOVE 14 TO PPS-RTC.
177200
177300     IF PPS-RTC = 02
177400        IF H-PERDIEM-DAYS = H-ALOS OR
177500           H-PERDIEM-DAYS > H-ALOS
177600           MOVE 16 TO PPS-RTC.
177700
177800 0200-EXIT.   EXIT.
177900
178000 1000-EDIT-THE-BILL-INFO.
178100
178200     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
178300     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
178400
178500     IF  PPS-RTC = 00
178600         IF  P-NEW-WAIVER-STATE
178700             MOVE 53 TO PPS-RTC.
178800
178900     IF  PPS-RTC = 00
179000         IF  B-DRG < 001
179100               OR = 014 OR = 015 OR = 016 OR = 017
179200               OR = 018 OR = 019 OR = 043 OR = 044
179300               OR = 045 OR = 046 OR = 047 OR = 048
179400               OR = 049 OR = 050 OR = 051 OR = 104
179500               OR = 105 OR = 106 OR = 107 OR = 108
179600               OR = 109 OR = 110 OR = 111 OR = 112
179700               OR = 118 OR = 119 OR = 120 OR = 126
179800               OR = 127 OR = 128 OR = 140 OR = 141
179900               OR = 142 OR = 143 OR = 144 OR = 145
180000               OR = 160 OR = 161 OR = 162 OR = 169
180100               OR = 170 OR = 171 OR = 172 OR = 173
180200               OR = 174 OR = 209 OR = 210 OR = 211
180300               OR = 212 OR = 213 OR = 214
180400               OR = 266 OR = 267 OR = 268 OR = 269
180500               OR = 270 OR = 271 OR = 272 OR = 273
180600               OR = 274 OR = 275 OR = 276 OR = 277
180700               OR = 278 OR = 279 OR = 317 OR = 318
180800               OR = 319 OR = 320 OR = 321 OR = 322
180900               OR = 323 OR = 324 OR = 325 OR = 359
181000               OR = 360 OR = 361 OR = 362 OR = 363
181100               OR = 364 OR = 365 OR = 366 OR = 367
181200               OR = 396 OR = 397 OR = 398 OR = 399
181300               OR = 400 OR = 401 OR = 402 OR = 403
181400               OR = 404 OR = 426 OR = 427 OR = 428
181500               OR = 429 OR = 430 OR = 431 OR = 447
181600               OR = 448 OR = 449 OR = 450 OR = 451
181700               OR = 452 OR = 518 OR = 519 OR = 520
181800               OR = 521 OR = 522 OR = 523 OR = 524
181900               OR = 525 OR = 526 OR = 527 OR = 528
182000               OR = 529 OR = 530 OR = 531 OR = 532
182100               OR = 567 OR = 568 OR = 569 OR = 570
182200               OR = 571 OR = 572 OR = 586 OR = 587
182300               OR = 588 OR = 589 OR = 590 OR = 591
182400               OR = 608 OR = 609 OR = 610 OR = 611
182500               OR = 612 OR = 613 OR = 631 OR = 632
182600               OR = 633 OR = 634 OR = 635 OR = 636
182700               OR = 646 OR = 647 OR = 648 OR = 649
182800               OR = 650 OR = 651 OR = 676 OR = 677
182900               OR = 678 OR = 679 OR = 680 OR = 681
183000               OR = 701 OR = 702 OR = 703 OR = 704
183100               OR = 705 OR = 706 OR = 719 OR = 720
183200               OR = 721 OR = 731 OR = 732 OR = 733
183300               OR = 751 OR = 752 OR = 753 OR = 762
183400               OR = 763 OR = 764 OR = 771 OR = 772
183500               OR = 773 OR = 783 OR = 784 OR = 785
183600               OR = 786 OR = 787 OR = 788 OR = 796
183700               OR = 797 OR = 798 OR = 805 OR = 806
183800               OR = 807 OR = 817 OR = 818 OR = 819
183900               OR = 831 OR = 832 OR = 833 OR = 850
184000               OR = 851 OR = 852 OR = 859 OR = 860
184100               OR = 861 OR = 873 OR = 874 OR = 875
184200               OR = 877 OR = 878 OR = 879 OR = 891
184300               OR = 891 OR = 892 OR = 892 OR = 893
184400               OR = 893 OR = 898 OR = 899 OR = 900
184500               OR = 910 OR = 911 OR = 912 OR = 924
184600               OR = 925 OR = 926 OR = 930 OR = 931
184700               OR = 932 OR = 936 OR = 937 OR = 938
184800               OR = 942 OR = 943 OR = 944 OR = 952
184900               OR = 953 OR = 954 OR = 960 OR = 961
185000               OR = 962 OR = 966 OR = 967 OR = 968
185100               OR = 971 OR = 972 OR = 973 OR = 978
185200               OR = 979 OR = 980 OR = 990 OR = 991
185300               OR = 992 OR = 993 OR = 994 OR = 995
185400               OR = 996 OR = 997
185500             MOVE 54 TO PPS-RTC.
185600
185700     IF  PPS-RTC = 00
185800            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
185900                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
186000                MOVE 55 TO PPS-RTC.
186100
186200     IF  PPS-RTC = 00
186300         IF P-NEW-TERMINATION-DATE > 00000000
186400            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
186500                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
186600                  MOVE 55 TO PPS-RTC.
186700
186800     IF  PPS-RTC = 00
186900         IF  B-LOS NOT NUMERIC
187000             MOVE 56 TO PPS-RTC
187100         ELSE
187200         IF  B-LOS = 0
187300             IF B-REVIEW-CODE NOT = 00 AND
187400                              NOT = 03 AND
187500                              NOT = 06 AND
187600                              NOT = 07 AND
187700                              NOT = 09 AND
187800                              NOT = 11
187900             MOVE 56 TO PPS-RTC.
188000
188100     IF  PPS-RTC = 00
188200         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
188300             MOVE 61 TO PPS-RTC
188400         ELSE
188500             MOVE B-LTR-DAYS TO H-LTR-DAYS.
188600
188700     IF  PPS-RTC = 00
188800         IF  B-COVERED-DAYS NOT NUMERIC
188900             MOVE 62 TO PPS-RTC
189000         ELSE
189100         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
189200             MOVE 62 TO PPS-RTC
189300         ELSE
189400             MOVE B-COVERED-DAYS TO H-COV-DAYS.
189500
189600     IF  PPS-RTC = 00
189700         IF  H-LTR-DAYS  > H-COV-DAYS
189800             MOVE 62 TO PPS-RTC
189900         ELSE
190000             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
190100
190200     IF  PPS-RTC = 00
190300         IF  NOT VALID-REVIEW-CODE
190400             MOVE 57 TO PPS-RTC.
190500
190600     IF  PPS-RTC = 00
190700         IF  B-CHARGES-CLAIMED NOT NUMERIC
190800             MOVE 58 TO PPS-RTC.
190900
191000     IF PPS-RTC = 00
191100           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
191200                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
191300                                            NOT = 'B' AND
191400                                            NOT = 'C'
191500                 MOVE 65 TO PPS-RTC.
191600
191700 2000-ASSEMBLE-PPS-VARIABLES.
191800***  GET THE PROVIDER SPECIFIC VARIABLES.
191900***  GET THE PROVIDER SPECIFIC VARIABLES.
192000
192100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
192200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
192300
192400     IF  (P-NEW-STATE = 02 OR 12)
192500         MOVE P-NEW-COLA TO H-OPER-COLA
192600     ELSE
192700         MOVE 1.000  TO H-OPER-COLA.
192800
192900***************************************************************
193000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
193100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
193200
193300     PERFORM 2600-GET-DRG-WEIGHT
193400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
193500
193600***************************************************************
193700***  GET THE WAGE-INDEX
193800***  GET THE WAGE-INDEX
193900
194000     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
194100     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
194200     MOVE P-NEW-STATE            TO MES-PPS-STATE.
194300
194400
194500     PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
194600
194700*****YEARCHANGE 2009.3 ************************************
194800
194900     IF  P-NEW-CBSA-SPEC-PAY-IND = '1' OR '2'
195000       COMPUTE H-WAGE-INDEX ROUNDED =
195100                         H-WAGE-INDEX * 1
195200     ELSE
195300       COMPUTE H-WAGE-INDEX ROUNDED =
195400                         H-WAGE-INDEX * MES-SSRFBN-RATE.
195500
195600*****YEARCHANGE 2009.3 ************************************
195700
195800***************************************************************
195900***  GET THE LABOR, NON-LABOR STANDARD RATES
196000
196100     IF  P-NEW-STATE = 40
196200         MOVE 2 TO R2
196300         MOVE 3 TO R4
196400     ELSE
196500         MOVE 1 TO R2
196600         MOVE 1 TO R4.
196700
196800     IF  LARGE-URBAN
196900         MOVE 1 TO R3
197000     ELSE
197100         MOVE 2 TO R3.
197200
197300     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
197400        (H-WAGE-INDEX > 01.0000))
197500        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
197600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
197700
197800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
197900         (H-WAGE-INDEX > 01.0000))
198000        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
198100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
198200
198300     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
198400         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
198500        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
198600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
198700
198800     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
198900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
199000        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
199100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
199200
199300     IF P-NEW-STATE = 40
199400        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
199500            (H-PR-WAGE-INDEX > 01.0000))
199600             PERFORM 2300-GET-PR-LAB-TB1-RATES
199700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
199800
199900
200000     IF P-NEW-STATE = 40
200100        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
200200             (H-PR-WAGE-INDEX > 01.0000))
200300              PERFORM 2300-GET-PR-LAB-TB2-RATES
200400                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
200500
200600     IF P-NEW-STATE = 40
200700        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
200800         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
200900          PERFORM 2300-GET-PR-LAB-TB3-RATES
201000              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
201100
201200     IF P-NEW-STATE = 40
201300        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
201400         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
201500          PERFORM 2300-GET-PR-LAB-TB4-RATES
201600              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
201700
201800***************************************************************
201900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
202000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
202100
202200     MOVE 0.00  TO H-OPER-HSP-PCT.
202300     MOVE 1.00  TO H-OPER-FSP-PCT.
202400
202500***************************************************************
202600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
202700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
202800
202900      MOVE 1.00 TO H-NAT-PCT.
203000      MOVE 0.00 TO H-REG-PCT.
203100
203200     IF  P-NEW-STATE = 40
203300         MOVE 0.75 TO H-NAT-PCT
203400         MOVE 0.25 TO H-REG-PCT.
203500
203600     IF  P-N-SCH-REBASED-FY90 OR
203700         P-N-EACH OR
203800         P-N-MDH-REBASED-FY90
203900         MOVE 1.00 TO H-OPER-HSP-PCT.
204000
204100 2300-GET-LAB-NONLAB-TB1-RATES.
204200
204300     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
204400         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
204500         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
204600         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
204700         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
204800
204900 2300-GET-LAB-NONLAB-TB2-RATES.
205000
205100     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
205200         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
205300         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
205400         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
205500         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
205600
205700 2300-GET-LAB-NONLAB-TB3-RATES.
205800
205900     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
206000         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
206100         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
206200         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
206300         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
206400
206500 2300-GET-LAB-NONLAB-TB4-RATES.
206600
206700     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
206800         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
206900         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
207000         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
207100         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
207200
207300 2300-GET-PR-LAB-TB1-RATES.
207400
207500     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
207600         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
207700         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
207800
207900 2300-GET-PR-LAB-TB2-RATES.
208000
208100     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
208200         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
208300         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
208400
208500 2300-GET-PR-LAB-TB3-RATES.
208600
208700     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
208800         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
208900         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
209000
209100 2300-GET-PR-LAB-TB4-RATES.
209200
209300     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
209400         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
209500         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
209600
209700
209800 2600-GET-DRG-WEIGHT.
209900
210000     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
210100         SET DX6 TO B-DRG
210200         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
210300         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
210400         MOVE ZEROES                   TO H-DAYS-CUTOFF
210500         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
210600
210700 3000-CALC-PAYMENT.
210800***************************************************************
210900
211000     PERFORM 3100-CALC-STAY-UTILIZATION.
211100     PERFORM 3300-CALC-OPER-FSP-AMT.
211200     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
211300
211400***********************************************************
211500***  OPERATING IME CALCULATION
211600***  OPERATING IME CALCULATION
211700
211800     COMPUTE H-OPER-IME-TEACH ROUNDED =
211900            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
212000
212100***********************************************************
212200
212300     IF P-N-SCH-REBASED-FY90 OR
212400        P-N-EACH OR
212500        P-N-MDH-REBASED-FY90
212600         PERFORM 3450-CALC-ADDITIONAL-HSP.
212700
212800     MOVE 00                 TO  PPS-RTC.
212900     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
213000     MOVE H-ALOS             TO  PPS-AVG-LOS.
213100     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
213200
213300     MOVE B-LOS TO H-PERDIEM-DAYS.
213400     IF H-PERDIEM-DAYS < 1
213500         MOVE 1 TO H-PERDIEM-DAYS.
213600     ADD 1 TO H-PERDIEM-DAYS.
213700
213800     MOVE 1 TO H-DSCHG-FRCTN.
213900
214000     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
214100
214200     IF (PAY-PERDIEM-DAYS  OR
214300         PAY-XFER-NO-COST) OR
214400        (PAY-XFER-SPEC-DRG AND
214500         B-DRG-POSTACUTE-PERDIEM)
214600         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
214700         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
214800         IF H-DSCHG-FRCTN > 1
214900              MOVE 1 TO H-DSCHG-FRCTN
215000              MOVE 1 TO H-TRANSFER-ADJ
215100         ELSE
215200              COMPUTE H-DRG-WT-FRCTN ROUNDED =
215300                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
215400
215500     IF (PAY-XFER-SPEC-DRG AND
215600         B-DRG-POSTACUTE-50-50)
215700         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
215800         COMPUTE H-DSCHG-FRCTN  ROUNDED =
215900                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
216000         IF H-DSCHG-FRCTN > 1
216100              MOVE 1 TO H-DSCHG-FRCTN
216200              MOVE 1 TO H-TRANSFER-ADJ
216300         ELSE
216400              COMPUTE H-DRG-WT-FRCTN ROUNDED =
216500            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
216600
216700
216800***********************************************************
216900***  CAPITAL DSH CALCULATION
217000***  CAPITAL DSH CALCULATION
217100
217200     MOVE 0 TO H-CAPI-DSH.
217300
217400     IF P-NEW-BED-SIZE NOT NUMERIC
217500         MOVE 0 TO P-NEW-BED-SIZE.
217600
217700     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
217800         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
217900                  (.2025 * (P-NEW-SSI-RATIO
218000                          + P-NEW-MEDICAID-RATIO)) - 1.
218100
218200***********************************************************
218300***  CAPITAL IME TEACH CALCULATION
218400***  CAPITAL IME TEACH CALCULATION
218500
218600     MOVE 0 TO H-WK-CAPI-IME-TEACH.
218700
218800     IF P-NEW-CAPI-IME NUMERIC
218900        IF P-NEW-CAPI-IME > 1.5000
219000           MOVE 1.5000 TO P-NEW-CAPI-IME.
219100
219200*****YEARCHANGE 2009.5 ****************************************
219300***
219400***  PER POLICY, WE REMOVED THE .5 MULTIPLER
219500***
219600***********************************************************
219700     IF P-NEW-CAPI-IME NUMERIC
219800        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
219900         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
220000
220100*****YEARCHANGE 2009.5 ****************************************
220200***********************************************************
220300     MOVE 0.00 TO H-DAYOUT-PCT.
220400     MOVE 0.80 TO H-CSTOUT-PCT.
220500
220600******************************************************************
220700**
220800** BURN DRGS FOR FY09 ARE 927, 928, 929, 933, 934 AND 935.
220900**
221000******************************************************************
221100
221200     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
221300             MOVE 0.90 TO H-CSTOUT-PCT.
221400
221500***     NATIONAL PERCENTAGE
221600     MOVE 0.6970   TO H-LABOR-PCT.
221700     MOVE 0.3030   TO H-NONLABOR-PCT.
221800
221900***     PUERTO RICO PERCENTAGE
222000     MOVE 0.6200   TO H-PR-LABOR-PCT.
222100     MOVE 0.3800   TO H-PR-NONLABOR-PCT.
222200
222300     IF (H-WAGE-INDEX < 01.0000 OR
222400         H-WAGE-INDEX = 01.0000)
222500        MOVE 0.6200 TO H-LABOR-PCT
222600        MOVE 0.3800 TO H-NONLABOR-PCT.
222700
222800     IF P-NEW-STATE = 40
222900       IF (H-PR-WAGE-INDEX < 01.0000 OR
223000           H-PR-WAGE-INDEX = 01.0000)
223100          MOVE 0.5870 TO H-PR-LABOR-PCT
223200          MOVE 0.4130 TO H-PR-NONLABOR-PCT.
223300
223400
223500     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
223600             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
223700     ELSE
223800             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
223900
224000     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
224100             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
224200     ELSE
224300             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
224400
224500***********************************************************
224600*****YEARCHANGE 2009.1 ************************************
224700***  CAPITAL PAYMENT METHOD B - YEARCHNG
224800***  CAPITAL PAYMENT METHOD B
224900
225000     IF W-CBSA-SIZE = 'L'
225100        MOVE 1.00 TO H-CAPI-LARG-URBAN
225200     ELSE
225300        MOVE 1.00 TO H-CAPI-LARG-URBAN.
225400
225500     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
225600     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
225700
225800*****YEARCHANGE 2009.1 ************************************
225900     COMPUTE H-FEDERAL-RATE ROUNDED =
226000                                 (0424.17 * H-CAPI-GAF).
226100     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
226200                                 (0198.77 * H-PR-CAPI-GAF).
226300*****YEARCHANGE 2009.1 ************************************
226400
226500     COMPUTE H-CAPI-COLA ROUNDED =
226600                     (.3152 * (H-OPER-COLA - 1) + 1).
226700
226800     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
226900
227000     IF P-NEW-STATE = 40
227100        COMPUTE  H-CAPI-FED-RATE ROUNDED =
227200                 (H-NAT-PCT * H-FEDERAL-RATE) +
227300                 (H-REG-PCT * H-PUERTO-RICO-RATE).
227400***********************************************************
227500***  CAPITAL FSP CALCULATION
227600***  CAPITAL FSP CALCULATION
227700
227800     COMPUTE H-CAPI-FSP-PART ROUNDED =
227900                               H-DRG-WT * H-CAPI-FED-RATE *
228000                               H-CAPI-COLA *
228100                               H-CAPI-LARG-URBAN.
228200
228300***********************************************************
228400***  CAPITAL PAYMENT METHOD A
228500***  CAPITAL PAYMENT METHOD A
228600
228700     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
228800        MOVE 1.00 TO H-CAPI-SCH
228900     ELSE
229000        MOVE 0.85 TO H-CAPI-SCH.
229100
229200***********************************************************
229300***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
229400***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
229500
229600     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
229700                    (P-NEW-CAPI-OLD-HARM-RATE *
229800                    H-CAPI-SCH).
229900
230000***********************************************************
230100        IF PAY-PERDIEM-DAYS
230200            IF  H-PERDIEM-DAYS < H-ALOS
230300                IF  NOT (B-DRG = 789)
230400                    PERFORM 3500-CALC-PERDIEM-AMT
230500                    MOVE 03 TO PPS-RTC.
230600
230700        IF PAY-XFER-SPEC-DRG
230800            IF  H-PERDIEM-DAYS < H-ALOS
230900                IF  NOT (B-DRG = 789)
231000                    PERFORM 3550-CALC-PERDIEM-AMT.
231100
231200        IF  PAY-XFER-NO-COST
231300            MOVE 00 TO PPS-RTC
231400            IF H-PERDIEM-DAYS < H-ALOS
231500               IF  NOT (B-DRG = 789)
231600                   PERFORM 3500-CALC-PERDIEM-AMT
231700                   MOVE 06 TO PPS-RTC.
231800
231900     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
232000
232100     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
232200
232300     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
232400
232500     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
232600
232700        IF PAY-XFER-SPEC-DRG
232800            IF  H-PERDIEM-DAYS < H-ALOS
232900                IF  NOT (B-DRG = 789)
233000                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
233100
233200
233300        IF  PAY-PERDIEM-DAYS
233400            IF  H-OPER-OUTCST-PART > 0
233500                MOVE H-OPER-OUTCST-PART TO
233600                     H-OPER-OUTLIER-PART
233700                MOVE 05 TO PPS-RTC
233800            ELSE
233900            IF  PPS-RTC NOT = 03
234000                MOVE 00 TO PPS-RTC
234100                MOVE 0  TO H-OPER-OUTLIER-PART.
234200
234300        IF  PAY-PERDIEM-DAYS
234400            IF  H-CAPI-OUTCST-PART > 0
234500                MOVE H-CAPI-OUTCST-PART TO
234600                     H-CAPI-OUTLIER-PART
234700                MOVE 05 TO PPS-RTC
234800            ELSE
234900            IF  PPS-RTC NOT = 03
235000                MOVE 0  TO H-CAPI-OUTLIER-PART.
235100
235200
235300 3000-CONTINUE.
235400
235500***********************************************************
235600***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
235700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
235800
235900     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
236000
236100***********************************************************
236200
236300     IF  PPS-RTC = 67
236400         MOVE H-OPER-DOLLAR-THRESHOLD TO
236500              WK-H-OPER-DOLLAR-THRESHOLD.
236600
236700     IF  PPS-RTC < 50
236800         PERFORM 3800-CALC-TOT-AMT
236900     ELSE
237000         MOVE ALL '0' TO PPS-OPER-HSP-PART
237100                         PPS-OPER-FSP-PART
237200                         PPS-OPER-OUTLIER-PART
237300                         PPS-OUTLIER-DAYS
237400                         PPS-REG-DAYS-USED
237500                         PPS-LTR-DAYS-USED
237600                         PPS-TOTAL-PAYMENT
237700                         PPS-OPER-DSH-ADJ
237800                         PPS-OPER-IME-ADJ
237900                         H-DSCHG-FRCTN
238000                         H-DRG-WT-FRCTN
238100                         HOLD-ADDITIONAL-VARIABLES
238200                         HOLD-CAPITAL-VARIABLES
238300                         HOLD-CAPITAL2-VARIABLES
238400                         HOLD-OTHER-VARIABLES
238500                         HOLD-PC-OTH-VARIABLES.
238600
238700     IF  PPS-RTC = 67
238800         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
238900                 H-OPER-DOLLAR-THRESHOLD.
239000
239100 3000-EXIT.  EXIT.
239200
239300 3100-CALC-STAY-UTILIZATION.
239400
239500     MOVE 0 TO PPS-REG-DAYS-USED.
239600     MOVE 0 TO PPS-LTR-DAYS-USED.
239700
239800     IF H-REG-DAYS > 0
239900        IF H-REG-DAYS > B-LOS
240000           MOVE B-LOS TO PPS-REG-DAYS-USED
240100        ELSE
240200           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
240300     ELSE
240400        IF H-LTR-DAYS > B-LOS
240500           MOVE B-LOS TO PPS-LTR-DAYS-USED
240600        ELSE
240700           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
240800
240900
241000
241100 3300-CALC-OPER-FSP-AMT.
241200***********************************************************
241300***  OPERATING FSP CALCULATION
241400***  OPERATING FSP CALCULATION
241500
241600     COMPUTE H-OPER-FSP-PART ROUNDED =
241700           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
241800            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
241900                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
242000
242100     IF P-NEW-STATE = 40
242200       COMPUTE H-OPER-FSP-PART ROUNDED =
242300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
242400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
242500                           +
242600           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
242700            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
242800                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
242900
243000
243100 3450-CALC-ADDITIONAL-HSP.
243200***********************************************************
243300*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
243400*    SOLE COMMUNITY
243500*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
243600*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
243700***********************************************************
243800*****YEARCHANGE 2009.1 ****************************************
243900***         GET THE UPDATING FACTOR
244000***         GET THE UPDATING FACTOR
244100
244200     MOVE 0.995743 TO H-BUDG-NUTR08.
244300*****YEARCHANGE 2009.1 ****************************************
244400     MOVE 0.998795 TO H-BUDG-NUTR09.
244500*****YEARCHANGE 2009.1 ****************************************
244600
244700     MOVE 1.0330 TO H-UPDATE-08.
244800
244900     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
245000*****YEARCHANGE 2009.0 ****************************************
245100        MOVE 1.0360 TO H-UPDATE-09
245200     ELSE
245300        MOVE 1.0160 TO H-UPDATE-09.
245400*****YEARCHANGE 2009.0 ****************************************
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'
246500*       COMPUTE H-HSP-RATE ROUNDED =
246600*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
246700*    ELSE
246800*       COMPUTE H-HSP-RATE ROUNDED =
246900*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
247000*
247100***************************************************************
247200********YEARCHANGE 2009.1 *************************************
247300***         CASE MIX ADJUSTMENT - FOR FUTURE USE
247400***         CASE MIX ADJUSTMENT - FOR FUTURE USE
247500***
247600***  MOVE 0.994 TO H-CASE-MIX-ADJ.
247700***
247800***  COMPUTE H-HSP-RATE ROUNDED =
247900***    H-HSP-RATE * H-CASE-MIX-ADJ.
248000***
248100********YEARCHANGE 2009.1 *************************************
248200***     OUTLIER OFFSETS
248300***     OPERATING NATIONAL
248400***     OPERATING PUERTO RICO BLEND
248500
248600********YEARCHANGE 2009.1 *************************************
248700
248800      MOVE 0.948996 TO H-OUTLIER-OFFSET-NAT
248900      MOVE 0.954304 TO H-OUTLIER-OFFSET-PR.
249000
249100********YEARCHANGE 2009.1 *************************************
249200
249300***************************************************************
249400     COMPUTE H-FSP-RATE ROUNDED =
249500         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
249600         H-NAT-NONLABOR * H-OPER-COLA))
249700                           *
249800     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
249900                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
250000
250100     IF P-NEW-STATE = 40
250200       COMPUTE H-FSP-RATE ROUNDED =
250300        (((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
250400         H-NAT-NONLABOR * H-OPER-COLA))
250500                         *
250600        ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /
250700                            H-OUTLIER-OFFSET-NAT) )
250800                           +
250900          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
251000         H-REG-NONLABOR * H-OPER-COLA)))
251100                           *
251200      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
251300                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
251400
251500
251600     IF  H-HSP-RATE > H-FSP-RATE
251700           COMPUTE H-OPER-HSP-PART ROUNDED =
251800             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
251900                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
252000     ELSE
252100         MOVE 0 TO H-OPER-HSP-PART.
252200
252300***************************************************************
252400***         GET THE MDH REBASE
252500
252600     IF  H-HSP-RATE > H-FSP-RATE
252700         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
252800           COMPUTE H-OPER-HSP-PART ROUNDED =
252900             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .75
253000                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
253100
253200 3500-CALC-PERDIEM-AMT.
253300***********************************************************
253400***  REVIEW CODE = 03 OR 06
253500***  OPERATING PERDIEM-AMT CALCULATION
253600***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
253700
253800        COMPUTE H-OPER-FSP-PART ROUNDED =
253900        H-OPER-FSP-PART * H-TRANSFER-ADJ
254000        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
254100
254200***********************************************************
254300***********************************************************
254400***  REVIEW CODE = 03 OR 06
254500***  CAPITAL   PERDIEM-AMT CALCULATION
254600***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
254700
254800        COMPUTE H-CAPI-FSP-PART ROUNDED =
254900        H-CAPI-FSP-PART * H-TRANSFER-ADJ
255000        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
255100
255200***********************************************************
255300***  REVIEW CODE = 03 OR 06
255400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
255500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
255600
255700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
255800        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
255900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
256000
256100 3550-CALC-PERDIEM-AMT.
256200***********************************************************
256300***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
256400***  OPERATING PERDIEM-AMT CALCULATION
256500***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
256600
256700     IF (B-DRG-POSTACUTE-50-50)
256800        MOVE 10 TO PPS-RTC
256900        COMPUTE H-OPER-FSP-PART ROUNDED =
257000        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
257100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
257200
257300     IF (B-DRG-POSTACUTE-PERDIEM)
257400        MOVE 12 TO PPS-RTC
257500        COMPUTE H-OPER-FSP-PART ROUNDED =
257600        H-OPER-FSP-PART *  H-TRANSFER-ADJ
257700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
257800
257900***********************************************************
258000***  CAPITAL PERDIEM-AMT CALCULATION
258100***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
258200
258300     IF (B-DRG-POSTACUTE-50-50)
258400        MOVE 10 TO PPS-RTC
258500        COMPUTE H-CAPI-FSP-PART ROUNDED =
258600        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
258700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
258800
258900     IF (B-DRG-POSTACUTE-PERDIEM)
259000        MOVE 12 TO PPS-RTC
259100        COMPUTE H-CAPI-FSP-PART ROUNDED =
259200        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
259300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
259400
259500***********************************************************
259600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
259700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
259800
259900     IF (B-DRG-POSTACUTE-50-50)
260000        MOVE 10 TO PPS-RTC
260100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
260200        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
260300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
260400
260500     IF (B-DRG-POSTACUTE-PERDIEM)
260600        MOVE 12 TO PPS-RTC
260700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
260800        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
260900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
261000
261100 3560-CHECK-RTN-CODE.
261200
261300     IF (B-DRG-POSTACUTE-50-50)
261400        MOVE 10 TO PPS-RTC.
261500     IF (B-DRG-POSTACUTE-PERDIEM)
261600        MOVE 12 TO PPS-RTC.
261700
261800 3560-EXIT.    EXIT.
261900
262000 3600-CALC-OUTLIER.
262100***********************************************************
262200***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
262300***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
262400
262500     IF OUTLIER-RECON-FLAG = 'Y'
262600        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
262700               (H-OPER-CSTCHG-RATIO + .2).
262800
262900     IF H-CAPI-CSTCHG-RATIO > 0 OR
263000       H-OPER-CSTCHG-RATIO > 0
263100        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
263200                H-OPER-CSTCHG-RATIO /
263300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
263400        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
263500                H-CAPI-CSTCHG-RATIO /
263600               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
263700     ELSE
263800         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
263900                   H-CAPI-SHARE-DOLL-THRESHOLD.
264000
264100***********************************************************
264200*****YEARCHANGE 2009.1 ************************************
264300***  OUTLIER THRESHOLD AMOUNTS
264400***  OUTLIER THRESHOLD AMOUNTS
264500
264600*****YEARCHANGE 2009.1 ************************************
264700
264800     MOVE 20045.00 TO H-CST-THRESH.
264900
265000*****YEARCHANGE 2009.1 ************************************
265100
265200     IF (B-REVIEW-CODE = '03') AND
265300         H-PERDIEM-DAYS < H-ALOS
265400        COMPUTE H-CST-THRESH ROUNDED =
265500                      (H-CST-THRESH * H-TRANSFER-ADJ)
265600                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
265700
265800     IF ((B-REVIEW-CODE = '09') AND
265900         (H-PERDIEM-DAYS < H-ALOS))
266000         IF (B-DRG-POSTACUTE-PERDIEM)
266100            COMPUTE H-CST-THRESH ROUNDED =
266200                      (H-CST-THRESH * H-TRANSFER-ADJ)
266300                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
266400
266500     IF ((B-REVIEW-CODE = '09') AND
266600         (H-PERDIEM-DAYS < H-ALOS))
266700         IF (B-DRG-POSTACUTE-50-50)
266800           COMPUTE H-CST-THRESH ROUNDED =
266900          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
267000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
267100
267200     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
267300        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
267400         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
267500          H-OPER-SHARE-DOLL-THRESHOLD.
267600
267700     IF P-NEW-STATE = 40
267800        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
267900           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
268000            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
268100             H-OPER-SHARE-DOLL-THRESHOLD
268200        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
268300               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
268400               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
268500
268600***********************************************************
268700
268800     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
268900          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
269000          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
269100
269200
269300     IF P-NEW-STATE = 40
269400        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
269500           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
269600           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
269700        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
269800               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
269900               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
270000
270100
270200     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
270300      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
270400                       +
270500             H-OPER-DOLLAR-THRESHOLD
270600                       +
270700                 H-NEW-TECH-PAY-ADD-ON.
270800
270900     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
271000      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
271100                       +
271200             H-CAPI-DOLLAR-THRESHOLD.
271300
271400     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
271500         MOVE 0 TO H-CAPI-COST-OUTLIER.
271600
271700
271800***********************************************************
271900***  OPERATING COST CALCULATION
272000***  OPERATING COST CALCULATION
272100
272200     COMPUTE H-OPER-BILL-COSTS ROUNDED =
272300         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
272400         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
272500
272600
272700     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
272800         COMPUTE H-OPER-OUTCST-PART ROUNDED =
272900         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
273000                         H-OPER-COST-OUTLIER).
273100
273200     IF PAY-WITHOUT-COST OR
273300        PAY-XFER-NO-COST OR
273400        PAY-XFER-SPEC-DRG-NO-COST
273500         MOVE 0 TO H-OPER-OUTCST-PART.
273600
273700***********************************************************
273800***  CAPITAL COST CALCULATION
273900***  CAPITAL COST CALCULATION
274000
274100     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
274200             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
274300         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
274400
274500     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
274600         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
274700         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
274800                         H-CAPI-COST-OUTLIER).
274900
275000     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
275100       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
275200              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
275300
275400     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
275500        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
275600               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
275700
275800     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
275900        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
276000        MOVE 0 TO H-CAPI-OUTCST-PART
276100                  H-OPER-OUTCST-PART.
276200
276300     IF PAY-WITHOUT-COST OR
276400        PAY-XFER-NO-COST OR
276500        PAY-XFER-SPEC-DRG-NO-COST
276600         MOVE 0 TO H-CAPI-OUTCST-PART.
276700
276800***********************************************************
276900***  DETERMINES THE BILL TO BE COST  OUTLIER
277000
277100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
277200         MOVE 0 TO H-CAPI-OUTDAY-PART
277300                   H-CAPI-OUTCST-PART.
277400
277500     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
277600                 MOVE H-OPER-OUTCST-PART TO
277700                      H-OPER-OUTLIER-PART
277800                 MOVE H-CAPI-OUTCST-PART TO
277900                      H-CAPI-OUTLIER-PART
278000                 MOVE 02 TO PPS-RTC.
278100
278200     IF OUTLIER-RECON-FLAG = 'Y'
278300        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
278400           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
278500           GO TO 3600-EXIT
278600        ELSE
278700           GO TO 3600-EXIT
278800     ELSE
278900        NEXT SENTENCE.
279000
279100
279200***********************************************************
279300***  DETERMINES IF COST OUTLIER
279400***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
279500***         RETURN CODE OF 02
279600
279700     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
279800
279900     IF PPS-RTC = 02
280000             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
280100                     (H-CAPI-COST-OUTLIER  +
280200                      H-OPER-COST-OUTLIER)
280300                             /
280400                    (H-CAPI-CSTCHG-RATIO  +
280500                     H-OPER-CSTCHG-RATIO)
280600             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
280700
280800***********************************************************
280900***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
281000***         RETURN CODE OF 67
281100
281200     IF PPS-RTC = 02
281300         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
281400            PPS-PC-COT-FLAG = 'Y'
281500             MOVE 67 TO PPS-RTC.
281600***********************************************************
281700
281800***********************************************************
281900***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
282000***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
282100
282200     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
282300        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
282400                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
282500         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
282600
282700     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
282800        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
282900                H-CAPI-OUTLIER-PART.
283000
283100     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
283200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
283300                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
283400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
283500
283600 3600-EXIT.   EXIT.
283700
283800***********************************************************
283900 3800-CALC-TOT-AMT.
284000***********************************************************
284100***  CALCULATE TOTALS FOR CAPITAL
284200***  CALCULATE TOTALS FOR CAPITAL
284300
284400     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
284500
284600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
284700        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
284800        MOVE 0.00 TO H-CAPI-HSP-PCT.
284900
285000     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
285100        MOVE 0    TO H-CAPI-OLD-HARMLESS
285200        MOVE 1.00 TO H-CAPI-FSP-PCT
285300        MOVE 0.00 TO H-CAPI-HSP-PCT.
285400
285500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
285600        MOVE 0    TO H-CAPI-OLD-HARMLESS
285700        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
285800        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
285900
286000     COMPUTE H-CAPI-HSP ROUNDED =
286100         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
286200
286300     COMPUTE H-CAPI-FSP ROUNDED =
286400         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
286500
286600     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
286700
286800     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
286900
287000     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
287100             H-CAPI-FSP
287200              * H-CAPI-DSH.
287300
287400     COMPUTE H-CAPI-IME-ADJ ROUNDED =
287500          H-CAPI-FSP *
287600                 H-WK-CAPI-IME-TEACH.
287700
287800     COMPUTE H-CAPI-OUTLIER ROUNDED =
287900             1.00 * H-CAPI-OUTLIER-PART.
288000
288100     COMPUTE H-CAPI2-B-FSP ROUNDED =
288200             1.00 * H-CAPI2-B-FSP-PART.
288300
288400     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
288500             1.00 * H-CAPI2-B-OUTLIER-PART.
288600***********************************************************
288700***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
288800***        THIS ZEROES OUT ALL CAPITAL DATA
288900
289000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
289100        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
289200***********************************************************
289300
289400***********************************************************
289500***  CALCULATE FINAL TOTALS FOR OPERATING
289600***  CALCULATE FINAL TOTALS FOR OPERATING
289700
289800     IF (H-CAPI-OUTLIER > 0 AND
289900         PPS-OPER-OUTLIER-PART = 0)
290000            COMPUTE PPS-OPER-OUTLIER-PART =
290100                    PPS-OPER-OUTLIER-PART + .01.
290200
290300     MOVE 01.000 TO WK-LOW-VOL25PCT.
290400
290500     IF P-NEW-TEMP-RELIEF-IND = 'Y'
290600        MOVE 01.250 TO WK-LOW-VOL25PCT.
290700
290800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
290900
291000     IF  H-OPER-DSH NUMERIC
291100         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
291200       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.
291300
291400     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
291500      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.
291600
291700
291800     COMPUTE PPS-OPER-FSP-PART ROUNDED =
291900        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.
292000
292100     COMPUTE PPS-OPER-HSP-PART ROUNDED =
292200        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.
292300
292400     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
292500      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.
292600
292700     IF HMO-TAG  = 'Y'
292800        PERFORM 3850-HMO-IME-ADJ.
292900
293000***********************************************************
293100***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
293200***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
293300
293400     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
293500            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
293600             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
293700             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT.
293800
293900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
294000             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).
294100
294200***********************************************************
294300* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
294400
294500     IF   H-NEW-TECH-PAY-ADD-ON = 0
294600
294700     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
294800
294900
295000
295100     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
295200
295300     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
295400               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
295500               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
295600                      PPS-OPER-IME-ADJ
295700                           +
295800                 PPS-NEW-TECH-PAY-ADD-ON
295900                           +
296000                 H-WK-PASS-AMT-PLUS-MISC
296100                           +
296200                   H-CAPI-TOTAL-PAY.
296300
296400 3850-HMO-IME-ADJ.
296500***********************************************************
296600***  HMO CALC FOR PASS-THRU ADDON
296700***  HMO CALC FOR PASS-THRU ADDON
296800
296900     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
297000          (P-NEW-PASS-AMT-PLUS-MISC -
297100          (P-NEW-PASS-AMT-ORGAN-ACQ +
297200           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
297300
297400***********************************************************
297500***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
297600
297700     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
297800                   PPS-OPER-IME-ADJ * .0.
297900
298000***********************************************************
298100
298200
298300 3900A-CALC-OPER-DSH.
298400
298500***  OPERATING DSH CALCULATION
298600***  OPERATING DSH CALCULATION
298700
298800      MOVE 0.0000 TO H-OPER-DSH.
298900
299000      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
299100                                     + P-NEW-MEDICAID-RATIO).
299200
299300***********************************************************
299400**1**    0-99 BEDS
299500***  NOT TO EXCEED 12%
299600
299700      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
299800                               AND H-WK-OPER-DSH > .1499
299900                               AND H-WK-OPER-DSH < .2020
300000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
300100                                      * .65 + .025
300200        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
300300
300400      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
300500                               AND H-WK-OPER-DSH > .2019
300600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
300700                                      * .825 + .0588
300800        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
300900
301000***********************************************************
301100**2**   100 + BEDS
301200***  NO CAP >> CAN EXCEED 12%
301300
301400      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
301500                               AND H-WK-OPER-DSH > .1499
301600                               AND H-WK-OPER-DSH < .2020
301700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
301800                                      * .65 + .025.
301900
302000      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
302100                               AND H-WK-OPER-DSH > .2019
302200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
302300                                      * .825 + .0588.
302400
302500***********************************************************
302600**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
302700***  NOT TO EXCEED 12%
302800
302900      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
303000                               AND H-WK-OPER-DSH > .1499
303100                               AND H-WK-OPER-DSH < .2020
303200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
303300                                 * .65 + .025
303400        IF H-OPER-DSH > .1200
303500              MOVE .1200 TO H-OPER-DSH.
303600
303700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
303800                               AND H-WK-OPER-DSH > .2019
303900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
304000                                 * .825 + .0588
304100        IF H-OPER-DSH > .1200
304200                 MOVE .1200 TO H-OPER-DSH.
304300***********************************************************
304400**4**   OTHER RURAL HOSPITALS 500 BEDS +
304500***  NO CAP >> CAN EXCEED 12%
304600
304700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
304800                               AND H-WK-OPER-DSH > .1499
304900                               AND H-WK-OPER-DSH < .2020
305000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
305100                                 * .65 + .025.
305200
305300      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
305400                               AND H-WK-OPER-DSH > .2019
305500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
305600                                 * .825 + .0588.
305700
305800***********************************************************
305900**7**   RURAL HOSPITALS SCH
306000***  NOT TO EXCEED 12%
306100
306200      IF W-CBSA-SIZE = 'R'
306300         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
306400                               AND H-WK-OPER-DSH > .1499
306500                               AND H-WK-OPER-DSH < .2020
306600         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
306700                                 * .65 + .025
306800        IF H-OPER-DSH > .1200
306900                 MOVE .1200 TO H-OPER-DSH.
307000
307100      IF W-CBSA-SIZE = 'R'
307200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
307300                               AND H-WK-OPER-DSH > .2019
307400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
307500                                 * .825 + .0588
307600        IF H-OPER-DSH > .1200
307700                 MOVE .1200 TO H-OPER-DSH.
307800
307900***********************************************************
308000**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
308100***  RRC OVERRIDES SCH CAP
308200***  NO CAP >> CAN EXCEED 12%
308300
308400         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
308500                                   '17' OR '22')
308600                               AND H-WK-OPER-DSH > .1499
308700                               AND H-WK-OPER-DSH < .2020
308800         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
308900                                 * .65 + .025.
309000
309100         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
309200                                   '17' OR '22')
309300                               AND H-WK-OPER-DSH > .2019
309400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
309500                                 * .825 + .0588.
309600
309700      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
309800
309900 3900A-EXIT.   EXIT.
310000
310100 4000-CALC-TECH-ADDON.
310200
310300***********************************************************
310400***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
310500***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
310600
310700     COMPUTE PPS-OPER-HSP-PART ROUNDED =
310800         H-OPER-HSP-PCT * H-OPER-HSP-PART.
310900
311000     COMPUTE PPS-OPER-FSP-PART ROUNDED =
311100         H-OPER-FSP-PCT * H-OPER-FSP-PART.
311200
311300     MOVE ZERO TO PPS-OPER-DSH-ADJ.
311400
311500     IF  H-OPER-DSH NUMERIC
311600             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
311700              PPS-OPER-FSP-PART
311800              * H-OPER-DSH.
311900
312000     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
312100             PPS-OPER-FSP-PART *
312200             H-OPER-IME-TEACH.
312300
312400     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
312500             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
312600             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
312700
312800***********************************************************
312900****      NEUROSTIMULATOR CASES
313000***********************************************************
313100*
313200*    IF '8698   ' =  B-PRIN-PROC-CODE   OR
313300*                    B-OTHER-PROC-CODE1 OR
313400*                    B-OTHER-PROC-CODE2 OR
313500*                    B-OTHER-PROC-CODE3 OR
313600*                    B-OTHER-PROC-CODE4 OR
313700*                    B-OTHER-PROC-CODE5
313800*          NEXT SENTENCE
313900*    ELSE
314000*          MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO
314100*          GO TO 4000-CHECK-GRAFT-CASES.
314200*
314300*    MOVE 18640.00 TO H-CSTMED-NEURO.
314400*
314500*    COMPUTE H-LESSER-NEURO-1 ROUNDED =
314600*            .5   H-CSTMED-NEURO.
314700*
314800*    COMPUTE H-LESSER-NEURO-2 ROUNDED =
314900*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
315000*                    H-BASE-DRG-PAYMENT)   .5.
315100*
315200*    IF H-LESSER-NEURO-2 > 0
315300*       IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2
315400*          MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO
315500*       ELSE
315600*          MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO
315700*    ELSE
315800*       MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.
315900*
316000*4000-CHECK-GRAFT-CASES.
316100*
316200***********************************************************
316300***      GRAFT*(GORE*TAG)*CASES
316400***********************************************************
316500*
316600*    IF '3973   ' =  B-PRIN-PROC-CODE   OR
316700*                    B-OTHER-PROC-CODE1 OR
316800*                    B-OTHER-PROC-CODE2 OR
316900*                    B-OTHER-PROC-CODE3 OR
317000*                    B-OTHER-PROC-CODE4 OR
317100*                    B-OTHER-PROC-CODE5
317200*          NEXT SENTENCE
317300*    ELSE
317400*          MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT
317500*          GO TO 4000-CHECK-X-STOP.
317600*
317700*    MOVE 21198.00 TO H-CSTMED-GRAFT.
317800*
317900*    COMPUTE H-LESSER-GRAFT-1 ROUNDED =
318000*            .5   H-CSTMED-GRAFT.
318100*
318200*    COMPUTE H-LESSER-GRAFT-2 ROUNDED =
318300*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
318400*                    H-BASE-DRG-PAYMENT)   .5.
318500*
318600*    IF H-LESSER-GRAFT-2 > 0
318700*       IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2
318800*          MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT
318900*       ELSE
319000*          MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT
319100*    ELSE
319200*       MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.
319300*
319400*4000-CHECK-X-STOP.
319500*
319600***********************************************************
319700*****    X-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
319800***********************************************************
319900*
320000*    IF '8458   ' =  B-PRIN-PROC-CODE   OR
320100*                    B-OTHER-PROC-CODE1 OR
320200*                    B-OTHER-PROC-CODE2 OR
320300*                    B-OTHER-PROC-CODE3 OR
320400*                    B-OTHER-PROC-CODE4 OR
320500*                    B-OTHER-PROC-CODE5
320600*          NEXT SENTENCE
320700*    ELSE
320800*          MOVE ZEROES TO H-NEW-TECH-ADDON-X-STOP
320900*          GO TO 4000-ADD-TECH-CASES.
321000*
321100*    MOVE 8800.00 TO H-CSTMED-X-STOP.
321200*
321300*    COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =
321400*            .5   H-CSTMED-X-STOP.
321500*
321600*    COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =
321700*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
321800*                    H-BASE-DRG-PAYMENT)   .5.
321900*
322000*    IF H-LESSER-HRTIMP-STOP-2 > 0
322100*       IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2
322200*        MOVE H-LESSER-HRTIMP-STOP-1 TO H-NEW-TECH-ADDON-X-STOP
322300*       ELSE
322400*        MOVE H-LESSER-HRTIMP-STOP-2 TO H-NEW-TECH-ADDON-X-STOP
322500*    ELSE
322600*       MOVE ZEROES          TO H-NEW-TECH-ADDON-X-STOP.
322700*
322800*
322900*4000-ADD-TECH-CASES.
323000*
323100*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
323200*            H-NEW-TECH-ADDON-NEURO  +
323300*            H-NEW-TECH-ADDON-GRAFT +
323400*            H-NEW-TECH-ADDON-X-STOP.
323500*
323600***********************************************************
323700***** HRTIMP-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
323800***********************************************************
323900
324000     IF '3752   ' =  B-PRIN-PROC-CODE   OR
324100                     B-OTHER-PROC-CODE1 OR
324200                     B-OTHER-PROC-CODE2 OR
324300                     B-OTHER-PROC-CODE3 OR
324400                     B-OTHER-PROC-CODE4 OR
324500                     B-OTHER-PROC-CODE5
324600           NEXT SENTENCE
324700     ELSE
324800           MOVE ZEROES TO H-NEW-TECH-ADDON-HRTIMP-STOP
324900           GO TO 4000-ADD-TECH-CASES.
325000
325100     MOVE 53000.00 TO H-CSTMED-HRTIMP-STOP.
325200
325300     COMPUTE H-LESSER-HRTIMP-STOP-1 ROUNDED =
325400                  H-CSTMED-HRTIMP-STOP.
325500
325600     COMPUTE H-LESSER-HRTIMP-STOP-2 ROUNDED =
325700          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
325800                     H-BASE-DRG-PAYMENT)) * .5.
325900
326000     IF H-LESSER-HRTIMP-STOP-2 > 0
326100        IF H-LESSER-HRTIMP-STOP-1 < H-LESSER-HRTIMP-STOP-2
326200         MOVE H-LESSER-HRTIMP-STOP-1 TO
326300                                  H-NEW-TECH-ADDON-HRTIMP-STOP
326400        ELSE
326500         MOVE H-LESSER-HRTIMP-STOP-2 TO
326600                                  H-NEW-TECH-ADDON-HRTIMP-STOP
326700     ELSE
326800        MOVE ZEROES          TO H-NEW-TECH-ADDON-HRTIMP-STOP.
326900
327000
327100 4000-ADD-TECH-CASES.
327200
327300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
327400             H-NEW-TECH-ADDON-HRTIMP-STOP.
327500*
327600 4000-EXIT.    EXIT.
327700***********************************************************
327800
327900 4100-ISLET-ISOLATION-ADD-ON.
328000***********************************************************
328100***  TECHNICAL TRANSPLANTATION OF CELLS
328200***
328300*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
328400*** ISLETS OF LANGERHAUS) AND
328500*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
328600*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
328700*** TIMES IN ANY OTHER PROC-CODE
328800***********************************************************
328900*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
329000*** V70.7
329100***********************************************************
329200
329300     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
329400               H-TECH-ADDON-ISLET-CNTR2.
329500
329600*    IF 'V707   ' =  B-PRIN-PROC-CODE   OR
329700*                    B-OTHER-PROC-CODE1 OR
329800*                    B-OTHER-PROC-CODE2 OR
329900*                    B-OTHER-PROC-CODE3 OR
330000*                    B-OTHER-PROC-CODE4 OR
330100*                    B-OTHER-PROC-CODE5
330200*          NEXT SENTENCE
330300*    ELSE
330400*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
330500*          GO TO 4100-ADD-TECH-CASES.
330600
330700     IF '5285   ' =  B-PRIN-PROC-CODE   OR
330800                     B-OTHER-PROC-CODE1 OR
330900                     B-OTHER-PROC-CODE2 OR
331000                     B-OTHER-PROC-CODE3 OR
331100                     B-OTHER-PROC-CODE4 OR
331200                     B-OTHER-PROC-CODE5
331300           NEXT SENTENCE
331400     ELSE
331500           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
331600           GO TO 4100-ADD-TECH-CASES.
331700
331800     IF '5285   ' =  B-PRIN-PROC-CODE
331900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
332000                       H-TECH-ADDON-ISLET-CNTR + 1.
332100
332200     IF '5285   ' =  B-OTHER-PROC-CODE1
332300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
332400                       H-TECH-ADDON-ISLET-CNTR + 1.
332500
332600     IF '5285   ' =  B-OTHER-PROC-CODE2
332700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
332800                       H-TECH-ADDON-ISLET-CNTR + 1.
332900
333000     IF '5285   ' =  B-OTHER-PROC-CODE3
333100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
333200                       H-TECH-ADDON-ISLET-CNTR + 1.
333300
333400     IF '5285   ' =  B-OTHER-PROC-CODE4
333500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
333600                       H-TECH-ADDON-ISLET-CNTR + 1.
333700
333800
333900     IF '5285   ' =  B-OTHER-PROC-CODE5
334000      COMPUTE H-TECH-ADDON-ISLET-CNTR =
334100                       H-TECH-ADDON-ISLET-CNTR + 1.
334200
334300*    IF 'V707   ' =  B-PRIN-PROC-CODE
334400*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
334500*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
334600*
334700*    IF 'V707   ' =  B-OTHER-PROC-CODE1
334800*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
334900*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
335000*
335100*    IF 'V707   ' =  B-OTHER-PROC-CODE2
335200*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
335300*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
335400*
335500*    IF 'V707   ' =  B-OTHER-PROC-CODE3
335600*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
335700*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
335800*
335900*    IF 'V707   ' =  B-OTHER-PROC-CODE4
336000*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
336100*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
336200*
336300*    IF 'V707   ' =  B-OTHER-PROC-CODE5
336400*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
336500*                    H-TECH-ADDON-ISLET-CNTR2 + 1.
336600*
336700*    IF  H-TECH-ADDON-ISLET-CNTR2 > 0
336800*          NEXT SENTENCE
336900*    ELSE
337000*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
337100*          GO TO 4100-ADD-TECH-CASES.
337200
337300     IF  H-TECH-ADDON-ISLET-CNTR = 1
337400     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
337500           GO TO 4100-ADD-TECH-CASES.
337600
337700     IF  H-TECH-ADDON-ISLET-CNTR > 1
337800     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
337900           GO TO 4100-ADD-TECH-CASES.
338000
338100     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
338200
338300
338400 4100-ADD-TECH-CASES.
338500
338600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
338700             H-NEW-TECH-ADDON-ISLET.
338800
338900 4100-EXIT.    EXIT.
339000
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   *****
