000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           PPCAL026.                                  00020026
000300*AUTHOR.            DDS TEAM.                                     00030000
000400*REMARKS.                CMS.                                     00040000
000500 DATE-COMPILED.                                                   00050000
000600 ENVIRONMENT DIVISION.                                            00060000
000700 CONFIGURATION SECTION.                                           00070000
000800 SOURCE-COMPUTER.            IBM-370.                             00080000
000900 OBJECT-COMPUTER.            IBM-370.                             00090000
001000 INPUT-OUTPUT  SECTION.                                           00100000
001100 FILE-CONTROL.                                                    00110000
001200                                                                  00120000
001300 DATA DIVISION.                                                   00130000
001400 FILE SECTION.                                                    00140000
001500                                                                  00150000
001600 WORKING-STORAGE SECTION.                                         00160000
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE              00170000
001800     'PPCAL026      - W O R K I N G   S T O R A G E'.             00180026
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C02.6'.     00190026
002000***************************************************************   00200000
002100*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO         *  00210000
002200*     - CHANGE THE HMO-FLAG 01 TO THE VALUE OF 'Y'                00220000
002300*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983             00230000
002400*        BEFORE YOU COMPILE AND LINK THIS PROGRAM                 00240000
002500*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH           00250000
002600*        AN HMO ADJUSTMENT                                        00260000
002700***************************************************************   00270000
002800 01  HMO-FLAG                       PIC X      VALUE 'N'.         00280004
002900 01  HMO-TAG                        PIC X      VALUE SPACE.       00290000
003000 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.         00300000
003100 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES. 00310000
003200 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES. 00320000
003300 01  R1                             PIC S9(04) COMP SYNC.         00330000
003400 01  R2                             PIC S9(04) COMP SYNC.         00340000
003500 01  R3                             PIC S9(04) COMP SYNC.         00350000
003600 01  R4                             PIC S9(04) COMP SYNC.         00360000
003700                                                                  00370000
003800 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).                00380000
003900 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).                00390000
004000***************************************************************   00400000
004100*    LAYUP TABLE AREA FOR FY2002 RATES                        *   00410000
004200***************************************************************   00420000
004300***************************************************************   00430000
004400 01  RATE-TABLE.                                                  00440000
004500     02  RATE-WORK.                                               00450000
004600*RATE 20011001 REGION  LABOR AND NON-LABOR RATES                  00460000
004700*                  R3=1     /     R3=2                            00470000
004800*               LARGE URBAN / OTHER URBAN                         00480000
004900*               LABOR / NON / LABOR / NON                         00490000
005000*                     /LABOR/       /LABOR                        00500000
005100*             --------------------------------------------        00510000
005200         05  FILLER PIC X(08) VALUE '20011001'.                   00520000
005300         05  NAT    PIC X(30) VALUE                               00530000
005400            ' 0295544 120130 0290865 118227'.                     00540000
005500         05  PR     PIC X(30) VALUE                               00550000
005600            ' 0142007 057161 0139759 056256'.                     00560000
005700         05  NATPR  PIC X(30) VALUE                               00570000
005800            ' 0292957 119078 0292957 119078'.                     00580000
005900*************************************************************     00590000
006000     02  RATE-TAB REDEFINES RATE-WORK.                            00600000
006100         05  RATE-PERIOD            OCCURS 1.                     00610000
006200             10  RATE-EFF-DATE      PIC X(08).                    00620000
006300             10  REG-NAT            OCCURS 3.                     00630000
006400                 15  R-LARGE-OTHER  OCCURS 2.                     00640000
006500                     20  FILLER     PIC X(01).                    00650000
006600                     20  REG-LABOR  PIC 9(05)V9(02).              00660000
006700                     20  FILLER     PIC X(01).                    00670000
006800                     20  REG-NLABOR PIC 9(04)V9(02).              00680000
006900                                                                  00690000
007000                                                                  00700000
007100***************************************************************   00710000
007200*    LAYUP TABLE AREA FOR FY2002 DRGS                         *   00720000
007300***************************************************************   00730000
007400 01  DRG-TABLE.                                                   00740000
007500     05  D-TAB.                                                   00750000
007600       10  FILLER                  PIC X(08) VALUE                00760000
007700      '20011001'.                                                 00770000
007800       10  FILLER                  PIC X(56) VALUE                00780000
007900     '03271307632102033874088331110195941273712702414805530081'.  00790000
008000       10  FILLER                  PIC X(56) VALUE                00800000
008100     '01362802322032007230021210300262850833211101395302022029'.  00810000
008200       10  FILLER                  PIC X(56) VALUE                00820000
008300     '01335005229069012690055290720084710332704300902004929063'.  00830000
008400       10  FILLER                  PIC X(56) VALUE                00840000
008500     '00812904526055011655048290610073490301903701186705129065'.  00850000
008600       10  FILLER                  PIC X(56) VALUE                00860000
008700     '00668902719034009744046290580067560302103802776409033114'.  00870000
008800       10  FILLER                  PIC X(56) VALUE                00880000
008900     '01457305530071010037040280510080690342704401017204028053'.  00890000
009000       10  FILLER                  PIC X(56) VALUE                00900000
009100     '00594702718033005981024160300135140372805601360905229068'.  00910000
009200       10  FILLER                  PIC X(56) VALUE                00920000
009300     '00695603022038003314020170200091650352804800523002014026'.  00930000
009400       10  FILLER                  PIC X(56) VALUE                00940000
009500     '00208201609016010074042280540058850271903500661501205015'.  00950000
009600       10  FILLER                  PIC X(56) VALUE                00960000
009700     '01130002927043004751020160260059860151001900826402426036'.  00970000
009800       10  FILLER                  PIC X(56) VALUE                00980000
009900     '00337401607016006302016140230045780281603300655404325052'.  00990000
010000       10  FILLER                  PIC X(56) VALUE                01000000
010100     '00676002717033007962039280500050430272003400297202927029'.  01010000
010200       10  FILLER                  PIC X(56) VALUE                01020000
010300     '01764903828051008158015090190078950181802700759001509019'.  01030000
010400       10  FILLER                  PIC X(56) VALUE                01040000
010500     '01177302326037004817032220320084830181902700878702018027'.  01050000
010600       10  FILLER                  PIC X(56) VALUE                01060000
010700     '01200402827043002735015040150082760191902800208301504015'.  01070000
010800       10  FILLER                  PIC X(56) VALUE                01080000
010900     '01354103327057002950013050130137180332704701231904829068'.  01090000
011000       10  FILLER                  PIC X(56) VALUE                01100000
011100     '00532602415029005536026190330075140302003700666503621043'.  01110000
011200       10  FILLER                  PIC X(56) VALUE                01120000
011300     '00494802816034004575025150300066850312304000669902921037'.  01130000
011400       10  FILLER                  PIC X(56) VALUE                01140000
011500     '00799303628047003352021200210320960883310803012910134127'.  01150000
011600       10  FILLER                  PIC X(56) VALUE                01160000
011700     '01241604128055013295063280720170940763209300921505029060'.  01170000
011800       10  FILLER                  PIC X(56) VALUE                01180000
011900     '01517706130061014316060300760098030482905900545402818035'.  01190000
012000       10  FILLER                  PIC X(56) VALUE                01200000
012100     '01248305529069006769030230380142820553006900912704525054'.  01210000
012200       10  FILLER                  PIC X(56) VALUE                01220000
012300     '01060105328063006344037180430079370382404701229605630068'.  01230000
012400       10  FILLER                  PIC X(56) VALUE                01240000
012500     '00744303522043012024054290690058170322003900760404122049'.  01250000
012600       10  FILLER                  PIC X(56) VALUE                01260000
012700     '00563603218038007496031270460069640262003300518601811022'.  01270000
012800       10  FILLER                  PIC X(56) VALUE                01280000
012900     '00860403627047005207021150272024133926358507841113237153'.  01290000
013000       10  FILLER                  PIC X(56) VALUE                01300000
013100     '05679608833104074396107351230531250973410905532509233112'.  01310000
013200       10  FILLER                  PIC X(56) VALUE                01320000
013300     '03901707027080041576081321030228650432605100000000000000'.  01330000
013400       10  FILLER                  PIC X(56) VALUE                01340000
013500     '02671409834129016809073310940338220723109202264803628049'.  01350000
013600       10  FILLER                  PIC X(56) VALUE                01360000
013700     '01335102827045014339018190270135780332705302355206731099'.  01370000
013800       10  FILLER                  PIC X(56) VALUE                01380000
013900     '01578705630069010241032210390158830322705001407203628046'.  01390000
014000       10  FILLER                  PIC X(56) VALUE                01400000
014100     '01040602217028026836105351300101030452905600732005223059'.  01410000
014200       10  FILLER                  PIC X(56) VALUE                01420000
014300     '01020901720028009379050290610057250382204500647302517031'.  01430000
014400       10  FILLER                  PIC X(56) VALUE                01440000
014500     '00555801912023005814027180340091280372804800564302215028'.  01450000
014600       10  FILLER                  PIC X(56) VALUE                01460000
014700     '00817703327033008222033240420049610211302500533502214027'.  01470000
014800       10  FILLER                  PIC X(56) VALUE                01480000
014900     '00724103021038005395022140270051910171002101201504328058'.  01490000
015000       10  FILLER                  PIC X(56) VALUE                01500000
015100     '00589902216028027764096341090159930622006703533211135131'.  01510000
015200       10  FILLER                  PIC X(56) VALUE                01520000
015300     '01506306219067029483105341220134510532906301947707431087'.  01530000
015400       10  FILLER                  PIC X(56) VALUE                01540000
015500     '01164205118056043519119361470132730342704500842106030060'.  01550000
015600       10  FILLER                  PIC X(56) VALUE                01560000
015700     '01259904428059006209020140250136180422805400765502214027'.  01570000
015800       10  FILLER                  PIC X(56) VALUE                01580000
015900     '01137503227045006121016090190069090211102102396007832090'.  01590000
016000       10  FILLER                  PIC X(56) VALUE                01600000
016100     '01290404519050014934042280540087530221202601298203628052'.  01610000
016200       10  FILLER                  PIC X(56) VALUE                01620000
016300     '00696401813023030540094331250117160382804801398505930076'.  01630000
016400       10  FILLER                  PIC X(56) VALUE                01640000
016500     '00693303025039009896041250510054190261403001088804428056'.  01650000
016600       10  FILLER                  PIC X(56) VALUE                01660000
016700     '00891003923048006408027150320108680512906400956504629057'.  01670000
016800       10  FILLER                  PIC X(56) VALUE                01680000
016900     '00523703017035007940036260460055680241603000414102515030'.  01690000
017000       10  FILLER                  PIC X(56) VALUE                01700000
017100     '00866003628048003210029230290078680322704201125004629060'.  01710000
017200       10  FILLER                  PIC X(56) VALUE                01720000
017300     '00577602519033011897045290740461991223615501825506030071'.  01730000
017400       10  FILLER                  PIC X(56) VALUE                01740000
017500     '03508511636136017294063300730308630943310901611105324060'.  01750000
017600       10  FILLER                  PIC X(56) VALUE                01760000
017700     '02574808132096012062042180470250700843210903181108533120'.  01770000
017800       10  FILLER                  PIC X(56) VALUE                01780000
017900     '03798612336156013291055290700136270573007301204704929062'.  01790000
018000       10  FILLER                  PIC X(56) VALUE                01800000
018100     '01220705229067007302032240410111200432805500638002417030'.  01810000
018200       10  FILLER                  PIC X(56) VALUE                01820000
018300     '01991704616051017503061260690122360461505000845711135111'.  01830000
018400       10  FILLER                  PIC X(56) VALUE                01840000
018500     '01943707732100000000000000000000000000000002317208532109'.  01850000
018600       10  FILLER                  PIC X(56) VALUE                01860000
018700     '03200511035152015499047280580099500281503300583405329053'.  01870000
018800       10  FILLER                  PIC X(56) VALUE                01880000
018900     '00000000000000000000000000000097230211802900769701608019'.  01890000
019000       10  FILLER                  PIC X(56) VALUE                01900000
019100     '01116403828053015902052290730079220211602701090602727040'.  01910000
019200       10  FILLER                  PIC X(56) VALUE                01920000
019300     '00714201915025013598039280580143400362805400953201821029'.  01930000
019400       10  FILLER                  PIC X(56) VALUE                01940000
019500     '02094506330084012097027230360076320412805500688903928049'.  01950000
019600       10  FILLER                  PIC X(56) VALUE                01960000
019700     '00532503019036014154074310940100320542906701369205630073'.  01970000
019800       10  FILLER                  PIC X(56) VALUE                01980000
019900     '00631503321040010953057300720073040402504900715204126051'.  01990000
020000       10  FILLER                  PIC X(56) VALUE                02000000
020100     '00466502919036005717032230410055870282103600816004127051'.  02010000
020200       10  FILLER                  PIC X(56) VALUE                02020000
020300     '00678402727039006809035230430045820241602900253301815018'.  02030000
020400       10  FILLER                  PIC X(56) VALUE                02040000
020500     '00739704026050004294028160330029510292702900815204228054'.  02050000
020600       10  FILLER                  PIC X(56) VALUE                02060000
020700     '00878302214028006954017070190087630181802700643501304014'.  02070000
020800       10  FILLER                  PIC X(56) VALUE                02080000
020900     '00924001713023008487030270430205700913312301107905630073'.  02090000
021000       10  FILLER                  PIC X(56) VALUE                02100000
021100     '01679505229076008414024230340094060332704501236802527037'.  02110000
021200       10  FILLER                  PIC X(56) VALUE                02120000
021300     '01773106931092007806025270360103650623007701024805229067'.  02130000
021400       10  FILLER                  PIC X(56) VALUE                02140000
021500     '00563803423042011927055300730066470312704600703304027050'.  02150000
021600       10  FILLER                  PIC X(56) VALUE                02160000
021700     '00853405127061005487038190450066320422404200694103524044'.  02170000
021800       10  FILLER                  PIC X(56) VALUE                02180000
021900     '00459302517031002565022190220071520382804900420402518032'.  02190000
022000       10  FILLER                  PIC X(56) VALUE                02200000
022100     '02129709133114022343053290690195690893311702159004926060'.  02210000
022200       10  FILLER                  PIC X(56) VALUE                02220000
022300     '00957301922030008862017120230059640150801802689208833116'.  02230000
022400       10  FILLER                  PIC X(56) VALUE                02240000
022500     '01305904328059007608038270490074570312103900861504328055'.  02250000
022600       10  FILLER                  PIC X(56) VALUE                02260000
022700     '00504702918035004155023180300092230442805701124305329066'.  02270000
022800       10  FILLER                  PIC X(56) VALUE                02280000
022900     '00607803020038033278079320930248840753109002461807431097'.  02290000
023000       10  FILLER                  PIC X(56) VALUE                02300000
023100     '01150203119038012988043280620060500191002201689604829069'.  02310000
023200       10  FILLER                  PIC X(56) VALUE                02320000
023300     '00893601812023011366033270470059570150801801078203327048'.  02330000
023400       10  FILLER                  PIC X(56) VALUE                02340000
023500     '00658401814023004944023260230215500482908301374505630073'.  02350000
023600       10  FILLER                  PIC X(56) VALUE                02360000
023700     '00613002020029011723051290660058520211802800859304627056'.  02370000
023800       10  FILLER                  PIC X(56) VALUE                02380000
023900     '00556003318039005267036200430079700252103300442201608019'.  02390000
024000       10  FILLER                  PIC X(56) VALUE                02400000
024100     '00633603123040004120021150270036970281803200726802925039'.  02410000
024200       10  FILLER                  PIC X(56) VALUE                02420000
024300     '00445801610020003185016090160106400462906000605602621034'.  02430000
024400       10  FILLER                  PIC X(56) VALUE                02440000
024500     '00790703928053015177043190500110470311003300863002820036'.  02450000
024600       10  FILLER                  PIC X(56) VALUE                02460000
024700     '00586101908021012191037280560115550332705000283002413024'.  02470000
024800       10  FILLER                  PIC X(56) VALUE                02480000
024900     '01130602021030007852025190330015380170601701174101614024'.  02490000
025000       10  FILLER                  PIC X(56) VALUE                02500000
025100     '00914902727040010304049290640056600231903000699803426044'.  02510000
025200       10  FILLER                  PIC X(56) VALUE                02520000
025300     '00412802015025007164038230460023600130501300686803027042'.  02530000
025400       10  FILLER                  PIC X(56) VALUE                02540000
025500     '01849305429068015317051260610090330310903300744002010023'.  02550000
025600       10  FILLER                  PIC X(56) VALUE                02560000
025700     '02438007532092011902037180440081650260802800852002413029'.  02570000
025800       10  FILLER                  PIC X(56) VALUE                02580000
025900     '01096402119030003017014050140081580262103600817002927041'.  02590000
026000       10  FILLER                  PIC X(56) VALUE                02600000
026100     '02000805830081012699056300740057670242003201135505630070'.  02610000
026200       10  FILLER                  PIC X(56) VALUE                02620000
026300     '00558102522034010572047280610068450331103700555002714033'.  02630000
026400       10  FILLER                  PIC X(56) VALUE                02640000
026500     '00377402007023006835025140310057590210802300496302517032'.  02650000
026600       10  FILLER                  PIC X(56) VALUE                02660000
026700     '01689203828056008017020130240045210242403600420101612021'.  02670000
026800       10  FILLER                  PIC X(56) VALUE                02680000
026900     '00662801815025001599012030130049150282503800362601612021'.  02690000
027000       10  FILLER                  PIC X(56) VALUE                02700000
027100     '01374301826018045319179421790309521333713301867608633086'.  02710000
027200       10  FILLER                  PIC X(56) VALUE                02720000
027300     '03179409333160011253035270430015240311103103389208332108'.  02730000
027400       10  FILLER                  PIC X(56) VALUE                02740000
027500     '01346209133091018231051290810081920352804701040703928050'.  02750000
027600       10  FILLER                  PIC X(56) VALUE                02760000
027700     '01267104228056013082051290640066750302003702934607431105'.  02770000
027800       10  FILLER                  PIC X(56) VALUE                02780000
027900     '02990509934128011594031270440185790683109100871803427046'.  02790000
028000       10  FILLER                  PIC X(56) VALUE                02800000
028100     '01908604929049029939084321110124260382404702214406030092'.  02810000
028200       10  FILLER                  PIC X(56) VALUE                02820000
028300     '01157504929063009991033220410044810181402300595801915024'.  02830000
028400       10  FILLER                  PIC X(56) VALUE                02840000
028500     '01389406130078007418035280460390671263716301622606430081'.  02850000
028600       10  FILLER                  PIC X(56) VALUE                02860000
028700     '00891504428054010493053290660086180402605000611203018036'.  02870000
028800       10  FILLER                  PIC X(56) VALUE                02880000
028900     '00664003221039004757026160310183650673109002451810935159'.  02890000
029000       10  FILLER                  PIC X(56) VALUE                02900000
029100     '00678903226042005261035280470053480352805000724205029078'.  02910000
029200       10  FILLER                  PIC X(56) VALUE                02920000
029300     '00836705229069007676067310890064160512907100710003427051'.  02930000
029400       10  FILLER                  PIC X(56) VALUE                02940000
029500     '00288802321032000000000000000000000000000000000000000000'.  02950000
029600       10  FILLER                  PIC X(56) VALUE                02960000
029700     '00000000000000000000000000000193320673109502080607231103'.  02970000
029800       10  FILLER                  PIC X(56) VALUE                02980000
029900     '00929502324033025304068310960099200272303600727703426044'.  02990000
030000       10  FILLER                  PIC X(56) VALUE                03000000
030100     '00471602416030002959024220240048250181502500097302917029'.  03010000
030200       10  FILLER                  PIC X(56) VALUE                03020000
030300     '00830902827040004139016100200026270211702101012203828052'.  03030000
030400       10  FILLER                  PIC X(56) VALUE                03040000
030500     '00498002217028008692034270490046300191602600000000000000'.  03050000
030600       10  FILLER                  PIC X(56) VALUE                03060000
030700     '00000000000000000000000000000000000000000000000000000000'.  03070000
030800       10  FILLER                  PIC X(56) VALUE                03080000
030900     '01196302526046012125104341230068000342404300462802517031'.  03090000
031000       10  FILLER                  PIC X(56) VALUE                03100000
031100     '00544502123031006416023260380045850212303103875611435147'.  03110000
031200       10  FILLER                  PIC X(56) VALUE                03120000
031300     '00000000000000000000000000000300670501905700000000000000'.  03130000
031400       10  FILLER                  PIC X(56) VALUE                03140000
031500     '03932409834151000000000000000392531003412702291510034123'.  03150000
031600       10  FILLER                  PIC X(56) VALUE                03160000
031700     '01956806731093024161059300820139000282303610981218142239'.  03170000
031800       10  FILLER                  PIC X(56) VALUE                03180000
031900     '08043823648258038583114351431546293425841505296311736149'.  03190000
032000       10  FILLER                  PIC X(56) VALUE                03200000
032100     '03172408533105052888110351430195850633008205196514939197'.  03210000
032200       10  FILLER                  PIC X(56) VALUE                03220000
032300     '01894807031094010584043280580163530301503504888613638190'.  03230000
032400       10  FILLER                  PIC X(56) VALUE                03240000
032500     '01841104929063009754019140240882521383816205728108633105'.  03250000
032600       10  FILLER                  PIC X(56) VALUE                03260000
032700     '03232405827069023026039140430145070382805000938502214026'.  03270000
032800       10  FILLER                  PIC X(56) VALUE                03280000
032900     '02748509834119015544059280690122910332404214172928853347'.  03290000
033000       10  FILLER                  PIC X(56) VALUE                03300000
033100     '01499402026034049233157401990185830733109301296706130083'.  03310000
033200       10  FILLER                  PIC X(56) VALUE                03320000
033300     '00726503728049013681058300800076560362805205781312737149'.  03330000
033400       10  FILLER                  PIC X(56) VALUE                03340000
033500     '05840009734111063663067310880499050422806702747504125050'.  03350000
033600       10  FILLER                  PIC X(56) VALUE                03360000
033700     '02137901918027016989025260370232490382805601419501711022'.  03370000
033800       10  FILLER                  PIC X(56) VALUE                03380000
033900     '00735505029064006249086331040039970352204300000000000000'.  03390000
034000     05  DRGX-TAB REDEFINES D-TAB.                                03400000
034100         10  DRGX-PERIOD               OCCURS 1                   03410000
034200                                        INDEXED BY DX5.           03420000
034300             15  DRGX-EFF-DATE         PIC X(08).                 03430000
034400             15  DRG-DATA              OCCURS 524                 03440000
034500                                        INDEXED BY DX6.           03450000
034600                 20  DRG-WT            PIC 9(02)V9(04).           03460000
034700                 20  DRG-ALOS          PIC 9(02)V9(01).           03470000
034800                 20  DRG-DAYS-TRIM     PIC 9(02).                 03480000
034900                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).           03490000
035000                                                                  03500000
035100 01  HOLD-AREA.                                                   03510000
035200     02  HOLD-PPS-COMPONENTS.                                     03520000
035300         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03530000
035400         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).        03540000
035500                                                                  03550000
035600         05  H-OPER-HSP-PART              PIC 9(06)V9(09).        03560000
035700         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).        03570000
035800                                                                  03580000
035900         05  H-OPER-FSP-PART              PIC 9(06)V9(09).        03590000
036000         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).        03600000
036100         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).        03610000
036200                                                                  03620000
036300         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).        03630000
036400         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).        03640000
036500         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).        03650000
036600                                                                  03660000
036700         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).        03670000
036800         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).        03680000
036900                                                                  03690000
037000         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).        03700000
037100         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).        03710000
037200                                                                  03720000
037300         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).        03730000
037400         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).        03740000
037500                                                                  03750000
037600                                                                  03760000
037700         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).        03770000
037800         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).        03780000
037900         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).        03790000
038000         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).        03800000
038100         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).        03810000
038200         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        03820000
038300         05  H-CAPI-COLA                  PIC 9(01)V9(03).        03830000
038400         05  H-CAPI-SCH                   PIC 9(05)V9(02).        03840000
038500         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).        03850000
038600         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).        03860000
038700         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).        03870000
038800         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).        03880000
038900         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).        03890000
039000         05  H-CAPI-GAF                   PIC 9(05)V9(04).        03900000
039100         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).        03910000
039200         05  H-BLEND-GAF                  PIC 9(05)V9(04).        03920000
039300         05  H-WAGE-INDEX                 PIC 9(02)V9(04).        03930000
039400         05  H-COV-DAYS                   PIC 9(3).               03940000
039500         05  H-PERDIEM-DAYS               PIC 9(3).               03950000
039600         05  H-REG-DAYS                   PIC 9(3).               03960000
039700         05  H-LTR-DAYS                   PIC 9(3).               03970000
039800         05  H-DSCHG-FRCTN                PIC 9(1)V9999.          03980000
039900         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.          03990000
040000         05  H-ALOS                       PIC 9(02)V9(01).        04000000
040100         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).        04010000
040200         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).        04020000
040300         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).        04030000
040400         05  H-CST-THRESH                 PIC 9(05)V9(02).        04040000
040500         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).        04050000
040600         05  H-BUDG-NUTR93                PIC 9(01)V9(06).        04060000
040700         05  H-BUDG-NUTR94                PIC 9(01)V9(06).        04070000
040800         05  H-BUDG-NUTR95                PIC 9(01)V9(06).        04080000
040900         05  H-BUDG-NUTR96                PIC 9(01)V9(06).        04090000
041000         05  H-BUDG-NUTR97                PIC 9(01)V9(06).        04100000
041100         05  H-BUDG-NUTR98                PIC 9(01)V9(06).        04110000
041200         05  H-BUDG-NUTR99                PIC 9(01)V9(06).        04120000
041300         05  H-BUDG-NUTR00                PIC 9(01)V9(06).        04130000
041400         05  H-BUDG-NUTR01                PIC 9(01)V9(06).        04140000
041500         05  H-BUDG-NUTR02                PIC 9(01)V9(06).        04150000
041600         05  H-UPDATE-95                  PIC 9(01)V9(04).        04160000
041700         05  H-UPDATE-96                  PIC 9(01)V9(04).        04170000
041800         05  H-UPDATE-97                  PIC 9(01)V9(04).        04180000
041900         05  H-UPDATE-98                  PIC 9(01)V9(04).        04190000
042000         05  H-UPDATE-99                  PIC 9(01)V9(04).        04200000
042100         05  H-UPDATE-00                  PIC 9(01)V9(04).        04210000
042200         05  H-UPDATE-01                  PIC 9(01)V9(04).        04220000
042300         05  H-UPDATE-02                  PIC 9(01)V9(04).        04230000
042400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).        04240000
042500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).        04250000
042600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).        04260000
042700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).        04270000
042800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).        04280000
042900         05  H-HSP-UPDATE98               PIC 9(01)V9(04).        04290000
043000         05  H-HSP-UPDATE99               PIC 9(01)V9(04).        04300000
043100         05  H-HSP-UPDATE00               PIC 9(01)V9(04).        04310000
043200         05  H-HSP-UPDATE01               PIC 9(01)V9(04).        04320000
043300         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).        04330000
043400         05  H-FEDERAL-RATE               PIC 9(04)V9(02).        04340000
043500         05  H-LABOR-PCT                  PIC 9(01)V9(04).        04350000
043600         05  H-NONLABOR-PCT               PIC 9(01)V9(04).        04360000
043700         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).        04370000
043800         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).        04380000
043900         05  H-HSP-RATE                   PIC 9(06)V9(09).        04390000
044000         05  H-FSP-RATE                   PIC 9(06)V9(09).        04400000
044100         05  H-OUTLIER-FACT               PIC 9(01)V9(06).        04410000
044200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).        04420000
044300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).        04430000
044400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        04440000
044500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).        04450000
044600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).        04460000
044700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.           04470000
044800                                                                  04480000
044900                                                                  04490000
045000     02  HOLD-ADDITIONAL-VARIABLES.                               04500000
045100         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).        04510000
045200         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).        04520000
045300         05  H-NAT-PCT                    PIC 9(01)V9(02).        04530000
045400         05  H-REG-PCT                    PIC 9(01)V9(02).        04540000
045500         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).        04550000
045600         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).        04560000
045700         05  H-DRG-WT                     PIC 9(02)V9(04).        04570000
045800         05  H-NAT-LABOR                  PIC 9(05)V9(02).        04580000
045900         05  H-NAT-NONLABOR               PIC 9(05)V9(02).        04590000
046000         05  H-REG-LABOR                  PIC 9(05)V9(02).        04600000
046100         05  H-REG-NONLABOR               PIC 9(05)V9(02).        04610000
046200         05  H-OPER-COLA                  PIC 9(01)V9(03).        04620000
046300         05  H-INTERN-RATIO               PIC 9(01)V9(04).        04630000
046400         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).        04640000
046500         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).        04650000
046600         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).        04660000
046700                                                                  04670000
046800     02  HOLD-CAPITAL-VARIABLES.                                  04680000
046900         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).        04690000
047000         05  H-CAPI-HSP                   PIC 9(07)V9(02).        04700000
047100         05  H-CAPI-FSP                   PIC 9(07)V9(02).        04710000
047200         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).        04720000
047300         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).        04730000
047400         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).        04740000
047500         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).        04750000
047600         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).        04760000
047700                                                                  04770000
047800     02  HOLD-CAPITAL2-VARIABLES.                                 04780000
047900         05  H-CAPI2-PAY-CODE             PIC X(1).               04790000
048000         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).        04800000
048100         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).        04810000
048200                                                                  04820000
048300     02  HOLD-OTHER-VARIABLES.                                    04830000
048400         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).        04840000
048500         05  FILLER                       PIC X(30).              04850000
048600                                                                  04860000
048700     02  HOLD-PC-OTH-VARIABLES.                                   04870000
048800         05  H-OPER-DSH                   PIC 9(01)V9(04).        04880000
048900         05  H-CAPI-DSH                   PIC 9(01)V9(04).        04890000
049000         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).        04900000
049100         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).        04910000
049200         05  H-ARITH-ALOS                 PIC 9(02)V9(01).        04920000
049300         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).        04930000
049400         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).        04940000
049500         05  H-PC-HMO-FLAG                PIC X(01).              04950000
049600         05  H-PC-COT-FLAG                PIC X(01).              04960000
049700         05  H-FILLER                     PIC X(09).              04970000
049800                                                                  04980000
049900 LINKAGE SECTION.                                                 04990000
050000***************************************************************   05000000
050100*                 * * * * * * * * *                           *   05010000
050200*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *   05020000
050300*    IN HOW TO PAY THE BILL.                                  *   05030000
050400*                         *****                               *   05040000
050500*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *   05050000
050600*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *   05060000
050700*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *   05070000
050800*                 OUTLIER COMPUTATION.                        *   05080000
050900*                         *****                               *   05090000
051000*         REVIEW-CODE:                                        *   05100000
051100*            00 = PAY-WITH-OUTLIER.                           *   05110000
051200*                 WILL CALCULATE THE STANDARD PAYMENT.        *   05120000
051300*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *   05130000
051400*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *   05140000
051500*            03 = PAY-PERDIEM-DAYS.                           *   05150000
051600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05160000
051700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   05170000
051800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05180000
051900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   05190000
052000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05200000
052100*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   05210000
052200*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   05220000
052300*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   05230000
052400*                 BILL EXCEED THE COST THRESHOLD.             *   05240000
052500*            06 = PAY-XFER-NO-COST                            *   05250000
052600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05260000
052700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *   05270000
052800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05280000
052900*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *   05290000
053000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05300000
053100*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   05310000
053200*                 CALCULATE ANY COST OUTLIER PORTION          *   05320000
053300*                 OF THE PAYMENT.                             *   05330000
053400*            07 = PAY-WITHOUT-COST.                           *   05340000
053500*                 WILL CALCULATE THE STANDARD PAYMENT         *   05350000
053600*                 WITHOUT COST PORTION.                       *   05360000
053700*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *   05370000
053800*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *   05380000
053900*                 429,483.      POST-ACUTE TRANSFERS          *   05390000
054000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05400000
054100*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   05410000
054200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05420000
054300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   05430000
054400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05440000
054500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *   05450000
054600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   05460000
054700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *   05470000
054800*                 BILL EXCEED THE COST THRESHOLD.             *   05480000
054900*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *   05490000
055000*                 POST-ACUTE TRANSFERS                        *   05500000
055100*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *   05510000
055200*                 429,483.      POST-ACUTE TRANSFERS          *   05520000
055300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *   05530000
055400*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*   05540000
055500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *   05550000
055600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *   05560000
055700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *   05570000
055800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *   05580000
055900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *   05590000
056000*                 PAYMENT.                                    *   05600000
056100***************************************************************   05610000
056200                                                                  05620000
056300**************************************************************    05630000
056400*      MILLINNIUM COMPATIBLE                                 *    05640000
056500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *    05650000
056600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *    05660000
056700*      IN THE NEW FORMAT                                     *    05670000
056800**************************************************************    05680000
056900 01  BILL-NEW-DATA.                                               05690000
057000         10  B-NPI10.                                             05700000
057100             15  B-NPI8             PIC X(08).                    05710000
057200             15  B-NPI-FILLER       PIC X(02).                    05720000
057300         10  B-PROVIDER-NO          PIC X(06).                    05730000
057400         10  B-REVIEW-CODE          PIC 9(02).                    05740000
057500             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.    05750000
057600             88  PAY-WITH-OUTLIER     VALUE 00 07.                05760000
057700             88  PAY-PERDIEM-DAYS     VALUE 03.                   05770000
057800             88  PAY-XFER-NO-COST     VALUE 06.                   05780000
057900             88  PAY-WITHOUT-COST     VALUE 07.                   05790000
058000             88  PAY-XFER-SPEC-DRG    VALUE 09 11.                05800000
058100             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.              05810000
058200         10  B-DRG                  PIC 9(03).                    05820000
058300         10  B-LOS                  PIC 9(03).                    05830000
058400         10  B-COVERED-DAYS         PIC 9(03).                    05840000
058500         10  B-LTR-DAYS             PIC 9(02).                    05850000
058600         10  B-DISCHARGE-DATE.                                    05860000
058700             15  B-DISCHG-CC        PIC 9(02).                    05870000
058800             15  B-DISCHG-YY        PIC 9(02).                    05880000
058900             15  B-DISCHG-MM        PIC 9(02).                    05890000
059000             15  B-DISCHG-DD        PIC 9(02).                    05900000
059100         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).              05910000
059200         10  B-PRIN-PROC-CODE       PIC X(07).                    05911007
059300         10  B-OTHER-PROC-CODE1     PIC X(07).                    05912007
059400         10  B-OTHER-PROC-CODE2     PIC X(07).                    05913007
059500         10  B-OTHER-PROC-CODE3     PIC X(07).                    05914007
059600         10  B-OTHER-PROC-CODE4     PIC X(07).                    05915007
059700         10  B-OTHER-PROC-CODE5     PIC X(07).                    05916007
059800         10  B-OTHER-PROC-CODE6     PIC X(07).                    05917007
059900         10  B-OTHER-PROC-CODE7     PIC X(07).                    05918007
060000         10  B-OTHER-PROC-CODE8     PIC X(07).                    05919007
060100         10  B-OTHER-PROC-CODE9     PIC X(07).                    05919107
060200         10  B-OTHER-PROC-CODE10    PIC X(07).                    05919207
060300         10  B-OTHER-PROC-CODE11    PIC X(07).                    05919307
060400         10  B-OTHER-PROC-CODE12    PIC X(07).                    05919407
060500         10  B-OTHER-PROC-CODE13    PIC X(07).                    05919507
060600         10  B-OTHER-PROC-CODE14    PIC X(07).                    05919607
060700         10  B-OTHER-PROC-CODE15    PIC X(07).                    05919707
060800         10  B-OTHER-PROC-CODE16    PIC X(07).                    05919807
060900         10  B-OTHER-PROC-CODE17    PIC X(07).                    05919907
061000         10  B-OTHER-PROC-CODE18    PIC X(07).                    05920007
061100         10  B-OTHER-PROC-CODE19    PIC X(07).                    05920107
061200         10  B-OTHER-PROC-CODE20    PIC X(07).                    05920207
061300         10  B-OTHER-PROC-CODE21    PIC X(07).                    05920307
061400         10  B-OTHER-PROC-CODE22    PIC X(07).                    05920407
061500         10  B-OTHER-PROC-CODE23    PIC X(07).                    05920507
061600         10  B-OTHER-PROC-CODE24    PIC X(07).                    05920607
061700         10  B-OTHER-DIAG-CODE1     PIC X(07).                    05920708
061800         10  B-OTHER-DIAG-CODE2     PIC X(07).                    05920808
061900         10  B-OTHER-DIAG-CODE3     PIC X(07).                    05920908
062000         10  B-OTHER-DIAG-CODE4     PIC X(07).                    05921008
062100         10  B-OTHER-DIAG-CODE5     PIC X(07).                    05921108
062200         10  B-OTHER-DIAG-CODE6     PIC X(07).                    05921208
062300         10  B-OTHER-DIAG-CODE7     PIC X(07).                    05921308
062400         10  B-OTHER-DIAG-CODE8     PIC X(07).                    05921408
062500         10  B-OTHER-DIAG-CODE9     PIC X(07).                    05921508
062600         10  B-OTHER-DIAG-CODE10    PIC X(07).                    05921608
062700         10  B-OTHER-DIAG-CODE11    PIC X(07).                    05921708
062800         10  B-OTHER-DIAG-CODE12    PIC X(07).                    05921808
062900         10  B-OTHER-DIAG-CODE13    PIC X(07).                    05921908
063000         10  B-OTHER-DIAG-CODE14    PIC X(07).                    05922008
063100         10  B-OTHER-DIAG-CODE15    PIC X(07).                    05922108
063200         10  B-OTHER-DIAG-CODE16    PIC X(07).                    05922208
063300         10  B-OTHER-DIAG-CODE17    PIC X(07).                    05922308
063400         10  B-OTHER-DIAG-CODE18    PIC X(07).                    05922408
063500         10  B-OTHER-DIAG-CODE19    PIC X(07).                    05922508
063600         10  B-OTHER-DIAG-CODE20    PIC X(07).                    05922608
063700         10  B-OTHER-DIAG-CODE21    PIC X(07).                    05922708
063800         10  B-OTHER-DIAG-CODE22    PIC X(07).                    05922808
063900         10  B-OTHER-DIAG-CODE23    PIC X(07).                    05922908
064000         10  B-OTHER-DIAG-CODE24    PIC X(07).                    05923008
064100         10  B-OTHER-DIAG-CODE25    PIC X(07).                    05923108
064200         10  BILL-DEMO-DATA.                                      05923214
064300             15  BILL-DEMO-CODE1        PIC X(02).                05923314
064400             15  BILL-DEMO-CODE2        PIC X(02).                05923414
064500             15  BILL-DEMO-CODE3        PIC X(02).                05923514
064600             15  BILL-DEMO-CODE4        PIC X(02).                05923614
064700         10  BILL-NDC-DATA.                                       05923714
064800             15  BILL-NDC-NUMBER        PIC X(11).                05923814
064900         10  FILLER                     PIC X(73).                05923914
065000                                                                  05924014
065100                                                                  05925000
065200***************************************************************   05930000
065300*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   05940000
065400*    AND PASSED BACK TO THE CALLING PROGRAM                   *   05950000
065500*            RETURN CODE VALUES (PPS-RTC)                     *   05960000
065600*                                                             *   05970000
065700*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   05980000
065800*              00 = PAID NORMAL DRG PAYMENT                   *   05990000
065900*                                                             *   06000000
066000*              01 = PAID AS A DAY-OUTLIER.                    *   06010000
066100*                   NOTE:                                     *   06020000
066200*                     DAY-OUTLIER NO LONGER BEING PAID        *   06030000
066300*                         AS OF 10/01/97                      *   06040000
066400*                                                             *   06050000
066500*              02 = PAID AS A COST-OUTLIER.                   *   06060000
066600*                                                             *   06070000
066700*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   06080000
066800*                   AND INCLUDING THE FULL DRG.               *   06090000
066900*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   06100000
067000*                   AND INCLUDING THE FULL DRG WHICH ALSO     *   06110000
067100*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *   06120000
067200*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *   06130000
067300*                   AND INCLUDING THE FULL DRG. PROVIDER      *   06140000
067400*                   REFUSED COST OUTLIER.                     *   06150000
067500*              10 = DRG IS 209, 210 OR 211 AND                *   06160000
067600*                   POST-ACUTE TRANSFER                       *   06170000
067700*              12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *   06180000
067800*                       THE FOLLOWING DRG'S                   *   06190000
067900*                   14,113,236,263,264,429,483                *   06200000
068000*              14 = PAID NORMAL DRG PAYMENT WITH              *   06210000
068100*                    PERDIEM DAYS = OR > GM  ALOS             *   06220000
068200*              16 = PAID AS A COST-OUTLIER WITH               *   06230000
068300*                    PERDIEM DAYS = OR > GM  ALOS             *   06240000
068400*                                                             *   06250000
068500*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   06260000
068600*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   06270000
068700*              52 = INVALID MSA # IN PROVIDER FILE            *   06280000
068800*                   OR INVALID WAGE INDEX                     *   06290000
068900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   06300000
069000*              54 = DRG < 001 OR > 523, OR = 214 OR = 215     *   06310000
069100*                                       OR = 221 OR = 222     *   06320000
069200*                                       OR = 112              *   06330000
069300*                                       OR = 434 OR = 435     *   06340000
069400*                                       OR = 436 OR = 437     *   06350000
069500*                                       OR = 438 OR = 456     *   06360000
069600*                                       OR = 457 OR = 458     *   06370000
069700*                                       OR = 459 OR = 460     *   06380000
069800*                                       OR = 469 OR = 470     *   06390000
069900*                                       OR = 472 OR = 474     *   06400000
070000*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   06410000
070100*                                      OR                     *   06420000
070200*                   DISCHARGE DATE < MSA EFF START DATE       *   06430000
070300*                   FOR PPS                                   *   06440000
070400*                                      OR                     *   06450000
070500*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *   06460000
070600*                   DISCHARGE DATE                            *   06470000
070700*              56 = INVALID LENGTH OF STAY                    *   06480000
070800*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *   06490000
070900*                                        NOT 11)              *   06500000
071000*              58 = TOTAL CHARGES NOT NUMERIC                 *   06510000
071100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   06520000
071200*                   OR BILL-LTR-DAYS > 60                     *   06530000
071300*              62 = INVALID NUMBER OF COVERED DAYS            *   06540000
071400*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *   06550000
071500*                   SPECIFIC FILE FOR CAPITAL                 *   06560000
071600*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   06570000
071700*                   OR COST OUTLIER THRESHOLD CALUCULATION    *   06580000
071800*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *   06590000
071900***************************************************************   06600000
072000 01  PPS-DATA.                                                    06610000
072100         10  PPS-RTC                PIC 9(02).                    06620000
072200         10  PPS-WAGE-INDX          PIC 9(02)V9(04).              06630000
072300         10  PPS-OUTLIER-DAYS       PIC 9(03).                    06640000
072400         10  PPS-AVG-LOS            PIC 9(02)V9(01).              06650000
072500         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).              06660000
072600         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).              06670000
072700         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).              06680000
072800         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).              06690000
072900         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).              06700000
073000         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).              06710000
073100         10  PPS-REG-DAYS-USED      PIC 9(03).                    06720000
073200         10  PPS-LTR-DAYS-USED      PIC 9(02).                    06730000
073300         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).              06740000
073400         10  PPS-CALC-VERS          PIC X(05).                    06750000
073500                                                                  06760000
073600******************************************************************06770000
073700*            THESE ARE THE VERSIONS OF THE PPCAL                  06780000
073800*           PROGRAMS THAT WILL BE PASSED BACK----                 06790000
073900*          ASSOCIATED WITH THE BILL BEING PROCESSED               06800000
074000******************************************************************06810000
074100 01  PRICER-OPT-VERS-SW.                                          06820000
074200     02  PRICER-OPTION-SW          PIC X(01).                     06830000
074300         88  ALL-TABLES-PASSED          VALUE 'A'.                06840000
074400         88  PROV-RECORD-PASSED         VALUE 'P'.                06850000
074500         88  ADDITIONAL-VARIABLES       VALUE 'M'.                06860000
074600         88  PC-PRICER                  VALUE 'C'.                06870000
074700     02  PPS-VERSIONS.                                            06880000
074800         10  PPDRV-VERSION         PIC X(05).                     06890000
074900                                                                  06900000
075000******************************************************************06910000
075100*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK           06920000
075200*          ASSOCIATED WITH THE BILL BEING PROCESSED               06930000
075300******************************************************************06940000
075400 01  PPS-ADDITIONAL-VARIABLES.                                    06950000
075500     05  PPS-HSP-PCT                PIC 9(01)V9(02).              06960000
075600     05  PPS-FSP-PCT                PIC 9(01)V9(02).              06970000
075700     05  PPS-NAT-PCT                PIC 9(01)V9(02).              06980000
075800     05  PPS-REG-PCT                PIC 9(01)V9(02).              06990000
075900     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).              07000000
076000     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).              07010000
076100     05  PPS-DRG-WT                 PIC 9(02)V9(04).              07020000
076200     05  PPS-NAT-LABOR              PIC 9(05)V9(02).              07030000
076300     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).              07040000
076400     05  PPS-REG-LABOR              PIC 9(05)V9(02).              07050000
076500     05  PPS-REG-NLABOR             PIC 9(05)V9(02).              07060000
076600     05  PPS-OPER-COLA              PIC 9(01)V9(03).              07070000
076700     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).              07080000
076800     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).              07090000
076900     05  PPS-BILL-COSTS             PIC 9(07)V9(09).              07100000
077000     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).              07110000
077100     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.                07120000
077200     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.                07130000
077300     05  PPS-CAPITAL-VARIABLES.                                   07140000
077400         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).        07150000
077500         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).        07160000
077600         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).        07170000
077700         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).        07180000
077800         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).        07190000
077900         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).        07200000
078000         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).        07210000
078100         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).        07220000
078200     05  PPS-CAPITAL2-VARIABLES.                                  07230000
078300         10  PPS-CAPI2-PAY-CODE             PIC X(1).             07240000
078400         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).      07250000
078500         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).      07260000
078600                                                                  07270000
078700     05  PPS-OTHER-VARIABLES.                                     07280000
078800         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).      07290000
078900         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).      07291007
079000         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).      07292007
079100         10  PPS-HVBP-HRR-DATA.                                   07292214
079200             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.              07292314
079300             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).        07292414
079400             15  PPS-HOSP-READMISS-REDUCTN    PIC X.              07292514
079500             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).         07292622
079600         10  PPS-OPERATNG-DATA.                                   07292714
079700             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.            07292825
079800             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.        07292914
079900             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.        07293014
080000                                                                  07310000
080100     05  PPS-PC-OTH-VARIABLES.                                    07320000
080200         10  PPS-OPER-DSH                   PIC 9(01)V9(04).      07330000
080300         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).      07340000
080400         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).      07350000
080500         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).      07360000
080600         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).      07370000
080700         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).      07380000
080800         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).      07390000
080900         10  PPS-PC-HMO-FLAG                PIC X(01).            07400000
081000         10  PPS-PC-COT-FLAG                PIC X(01).            07410000
081100         10  PPS-FILLER                     PIC X(0998).          07411025
081200                                                                  07430000
081300**************************************************************    07440000
081400*      MILLINNIUM COMPATIBLE                                 *    07450000
081500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    07460000
081600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *    07470000
081700*      IN THE NEW FORMAT                                     *    07480000
081800**************************************************************    07490000
081900 01  PROV-NEW-HOLD.                                               07500000
082000     02  PROV-NEWREC-HOLD1.                                       07510000
082100         05  P-NEW-NPI10.                                         07520000
082200             10  P-NEW-NPI8             PIC X(08).                07530000
082300             10  P-NEW-NPI-FILLER       PIC X(02).                07540000
082400         05  P-NEW-PROVIDER-NO.                                   07550000
082500             10  P-NEW-STATE            PIC 9(02).                07560000
082600             10  FILLER                 PIC X(04).                07570000
082700         05  P-NEW-DATE-DATA.                                     07580000
082800             10  P-NEW-EFF-DATE.                                  07590000
082900                 15  P-NEW-EFF-DT-CC    PIC 9(02).                07600000
083000                 15  P-NEW-EFF-DT-YY    PIC 9(02).                07610000
083100                 15  P-NEW-EFF-DT-MM    PIC 9(02).                07620000
083200                 15  P-NEW-EFF-DT-DD    PIC 9(02).                07630000
083300             10  P-NEW-FY-BEGIN-DATE.                             07640000
083400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                07650000
083500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                07660000
083600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                07670000
083700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                07680000
083800             10  P-NEW-REPORT-DATE.                               07690000
083900                 15  P-NEW-REPORT-DT-CC PIC 9(02).                07700000
084000                 15  P-NEW-REPORT-DT-YY PIC 9(02).                07710000
084100                 15  P-NEW-REPORT-DT-MM PIC 9(02).                07720000
084200                 15  P-NEW-REPORT-DT-DD PIC 9(02).                07730000
084300             10  P-NEW-TERMINATION-DATE.                          07740000
084400                 15  P-NEW-TERM-DT-CC   PIC 9(02).                07750000
084500                 15  P-NEW-TERM-DT-YY   PIC 9(02).                07760000
084600                 15  P-NEW-TERM-DT-MM   PIC 9(02).                07770000
084700                 15  P-NEW-TERM-DT-DD   PIC 9(02).                07780000
084800         05  P-NEW-WAIVER-CODE          PIC X(01).                07790000
084900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              07800000
085000         05  P-NEW-INTER-NO             PIC 9(05).                07810000
085100         05  P-NEW-PROVIDER-TYPE        PIC X(02).                07820000
085200             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      07830000
085300             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       07840000
085400                                                  '15' '17'       07850000
085500                                                  '22'.           07860000
085600             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           07870000
085700             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           07880000
085800             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           07890000
085900             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           07900000
086000             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      07910000
086100             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           07920000
086200             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      07930000
086300             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           07940000
086400             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           07950000
086500             88  P-N-EACH                   VALUE '21' '22'.      07960000
086600             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           07970000
086700             88  P-N-NHCMQ-II-SNF           VALUE '32'.           07980000
086800             88  P-N-NHCMQ-III-SNF          VALUE '33'.           07990000
086900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                08000000
087000             88  P-N-NEW-ENGLAND            VALUE  1.             08010000
087100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             08020000
087200             88  P-N-SOUTH-ATLANTIC         VALUE  3.             08030000
087300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             08040000
087400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             08050000
087500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             08060000
087600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             08070000
087700             88  P-N-MOUNTAIN               VALUE  8.             08080000
087800             88  P-N-PACIFIC                VALUE  9.             08090000
087900         05  P-NEW-CURRENT-DIV   REDEFINES                        08100000
088000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         08110000
088100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          08120000
088200         05  P-NEW-MSA-DATA.                                      08130000
088300             10  P-NEW-CHG-CODE-INDEX       PIC X.                08140000
088400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 08150000
088500             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   08160000
088600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       08170000
088700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 08180000
088800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 08190000
088900             10  P-NEW-STAND-AMT-LOC-MSA9                         08200000
089000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         08210000
089100                 15  P-NEW-RURAL-1ST.                             08220000
089200                     20  P-NEW-STAND-RURAL  PIC XX.               08230000
089300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    08240000
089400                 15  P-NEW-RURAL-2ND        PIC XX.               08250000
089500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    08260000
089600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           08270000
089700                 88  P-NEW-SCH-YR82       VALUE   '82'.           08280000
089800                 88  P-NEW-SCH-YR87       VALUE   '87'.           08290000
089900         05  P-NEW-LUGAR                    PIC X.                08300000
090000         05  P-NEW-TEMP-RELIEF-IND          PIC X.                08310000
090100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                08320000
090200         05  FILLER                         PIC X(05).            08330000
090300     02  PROV-NEWREC-HOLD2.                                       08340000
090400         05  P-NEW-VARIABLES.                                     08350000
090500             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        08360000
090600             10  P-NEW-COLA              PIC  9(01)V9(03).        08370000
090700             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        08380000
090800             10  P-NEW-BED-SIZE          PIC  9(05).              08390000
090900             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        08400000
091000             10  P-NEW-CMI               PIC  9(01)V9(04).        08410000
091100             10  P-NEW-SSI-RATIO         PIC  V9(04).             08420000
091200             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             08430000
091300             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              08440000
091400             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        08450000
091500             10  P-NEW-DSH-PERCENT       PIC  V9(04).             08460000
091600             10  P-NEW-FYE-DATE          PIC  X(08).              08470000
091700         05  FILLER                      PIC  X(23).              08480000
091800     02  PROV-NEWREC-HOLD3.                                       08490000
091900         05  P-NEW-PASS-AMT-DATA.                                 08500000
092000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          08510000
092100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          08520000
092200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          08530000
092300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          08540000
092400         05  P-NEW-CAPI-DATA.                                     08550000
092500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 08560000
092600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          08570000
092700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          08580000
092800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        08590000
092900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             08600000
093000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 08610000
093100             15  P-NEW-CAPI-IME            PIC 9V9999.            08620000
093200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          08630000
093300         05  P-HVBP-HRR-DATA.                                     08631014
093400             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.                08632014
093500             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).          08633014
093600             15  P-HOSP-READMISSION-REDUCTN PIC X.                08634014
093700             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).           08635022
093800         05  P-MODEL1-BUNDLE-DATA.                                08636019
093900             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.             08637025
094000             15  P-HAC-REDUC-IND            PIC X.                08637127
094100             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.         08637227
094200             15  P-EHR-REDUC-IND            PIC X.                08637327
094300         05  FILLER                         PIC X(09).            08637427
094400                                                                  08637719
094500************************************************************      08639014
094600******************************************************************08650000
094700*      MILLINNIUM COMPATIBLE                                      08660000
094800*                   THIS IS THE WAGE-INDEX                        08670000
094900*          ASSOCIATED WITH THE BILL BEING PROCESSED               08680000
095000******************************************************************08690000
095100 01  WAGE-NEW-INDEX-RECORD.                                       08700000
095200     05  W-MSA                         PIC X(4).                  08710000
095300     05  W-SIZE                        PIC X.                     08720000
095400         88  LARGE-URBAN       VALUE 'L'.                         08730000
095500         88  OTHER-URBAN       VALUE 'O'.                         08740000
095600         88  ALL-RURAL         VALUE 'R'.                         08750000
095700     05  W-EFF-DATE                    PIC X(8).                  08760000
095800     05  FILLER                        PIC X.                     08770000
095900     05  W-INDEX-RECORD                PIC S9(02)V9(04).          08780000
096000     05  W-PR-INDEX-RECORD             PIC S9(02)V9(04).          08790000
096100                                                                  08800000
096200                                                                  08810000
096300 PROCEDURE DIVISION  USING BILL-NEW-DATA                          08820000
096400                           PPS-DATA                               08830000
096500                           PRICER-OPT-VERS-SW                     08840000
096600                           PPS-ADDITIONAL-VARIABLES               08850000
096700                           PROV-NEW-HOLD                          08860000
096800                           WAGE-NEW-INDEX-RECORD.                 08870000
096900                                                                  08880000
097000***************************************************************   08890000
097100*    PROCESSING:                                              *   08900000
097200*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE            08910000
097300*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *   08920000
097400*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   08930000
097500*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *   08940000
097600*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   08950000
097700*           GOBACK.                                           *   08960000
097800*        D. ASSEMBLE PRICING COMPONENTS.                      *   08970000
097900*        E. CALCULATE THE PRICE.                              *   08980000
098000***************************************************************   08990000
098100                                                                  09000000
098200     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.                      09010000
098300     MOVE 'N' TO TEMP-RELIEF-FLAG.                                09020000
098400                                                                  09030000
098500     PERFORM 0200-MAINLINE-CONTROL.                               09040000
098600                                                                  09050000
098700**************************************************************    09060000
098800***  NO LONGER PROCESSING TEMP RELIEF AS OF 100199                09070000
098900                                                                  09080000
099000***  IF P-NEW-TEMP-RELIEF-IND  = 'Y'                              09090000
099100***     MOVE PPS-TOTAL-PAYMENT TO NON-TEMP-RELIEF-PAYMENT         09100000
099200***     MOVE 'Y' TO TEMP-RELIEF-FLAG                              09110000
099300***     PERFORM 0200-MAINLINE-CONTROL                             09120000
099400***     MOVE NON-TEMP-RELIEF-PAYMENT TO                           09130000
099500***                   H-NON-TEMP-RELIEF-PAYMENT.                  09140000
099600                                                                  09150000
099700**************************************************************    09160000
099800     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES. 09170000
099900     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.          09180000
100000     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.         09190000
100100     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.    09200000
100200     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.   09210000
100300     MOVE CAL-VERSION               TO  PPS-CALC-VERS.            09220000
100400     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.      09230000
100500     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.     09240000
100600                                                                  09250000
100700     GOBACK.                                                      09260000
100800                                                                  09270000
100900 0200-MAINLINE-CONTROL.                                           09280000
101000                                                                  09290000
101100     MOVE 'N' TO HMO-TAG.                                         09300000
101200                                                                  09310000
101300     IF PPS-PC-HMO-FLAG = 'Y' OR                                  09320000
101400               HMO-FLAG = 'Y'                                     09330000
101500        MOVE 'Y' TO HMO-TAG.                                      09340000
101600                                                                  09350000
101700     IF P-NEW-STATE NOT = 40                                      09360000
101800        MOVE ZEROES TO W-PR-INDEX-RECORD.                         09370000
101900                                                                  09380000
102000     MOVE ALL '0' TO PPS-DATA                                     09390000
102100                     H-OPER-DSH-SCH                               09400000
102200                     H-OPER-DSH-RRC                               09410000
102300                     HOLD-PPS-COMPONENTS                          09420000
102400                     HOLD-PPS-COMPONENTS                          09430000
102500                     HOLD-ADDITIONAL-VARIABLES                    09440000
102600                     HOLD-CAPITAL-VARIABLES                       09450000
102700                     HOLD-CAPITAL2-VARIABLES                      09460000
102800                     HOLD-OTHER-VARIABLES                         09470000
102900                     HOLD-PC-OTH-VARIABLES.                       09480000
103000                                                                  09490000
103100     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC                     09500000
103200        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.                      09510000
103300                                                                  09520000
103400     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC                     09530000
103500        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.                       09540000
103600                                                                  09550000
103700     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC                     09560000
103800        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.                      09570000
103900                                                                  09580000
104000     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC                       09590000
104100        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.                        09600000
104200                                                                  09610000
104300     PERFORM 1000-EDIT-THE-BILL-INFO.                             09620000
104400                                                                  09630000
104500     IF  PPS-RTC = 00                                             09640000
104600         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                      09650000
104700         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.                09660000
104800                                                                  09670000
104900     IF PPS-RTC = 00                                              09680000
105000        IF H-PERDIEM-DAYS = H-ALOS OR                             09690000
105100           H-PERDIEM-DAYS > H-ALOS                                09700000
105200           MOVE 14 TO PPS-RTC.                                    09710000
105300                                                                  09720000
105400     IF PPS-RTC = 02                                              09730000
105500        IF H-PERDIEM-DAYS = H-ALOS OR                             09740000
105600           H-PERDIEM-DAYS > H-ALOS                                09750000
105700           MOVE 16 TO PPS-RTC.                                    09760000
105800                                                                  09770000
105900 1000-EDIT-THE-BILL-INFO.                                         09780000
106000***************************************************************   09790000
106100*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   09800000
106200*    AND DO NOT ATTEMPT TO PRICE.                             *   09810000
106300***************************************************************   09820000
106400***************************************************************   09830000
106500***************************************************************   09840000
106600***     NO LONGER BEING PAY FEDERAL PERCENT FOR TRANSITION    *   09850000
106700***     PAID 100% FEDERAL AS OF OCT 1, 2001                   *   09860000
106800***************************************************************   09870000
106900*    IF P-NEW-FY-BEGIN-DATE < 20001001                            09880000
107000*       MOVE .90 TO H-CAPI-PAYCDE-PCT1                            09890000
107100*       MOVE .10 TO H-CAPI-PAYCDE-PCT2                            09900000
107200*    ELSE                                                         09910000
107300*       IF (P-NEW-FY-BEGIN-DATE < B-DISCHARGE-DATE) OR            09920000
107400*          (P-NEW-FY-BEGIN-DATE = B-DISCHARGE-DATE)               09930000
107500*             MOVE 1.00 TO H-CAPI-PAYCDE-PCT1                     09940000
107600*             MOVE 0.00 TO H-CAPI-PAYCDE-PCT2                     09950000
107700*       ELSE                                                      09960000
107800*             MOVE .90 TO H-CAPI-PAYCDE-PCT1                      09970000
107900*             MOVE .10 TO H-CAPI-PAYCDE-PCT2.                     09980000
108000***************************************************************   09990000
108100***************************************************************   10000000
108200***************************************************************   10010000
108300                                                                  10020000
108400     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.                             10030000
108500     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.                             10040000
108600                                                                  10050000
108700     IF  PPS-RTC = 00                                             10060000
108800         IF  P-NEW-WAIVER-STATE                                   10070000
108900             MOVE 53 TO PPS-RTC.                                  10080000
109000                                                                  10090000
109100     IF  PPS-RTC = 00                                             10100000
109200         IF  B-DRG < 001 OR > 523 OR = 214 OR = 215 OR 112        10110000
109300                                  OR = 221 OR = 222               10120000
109400                                  OR = 434 OR = 435               10130000
109500                                  OR = 436 OR = 437               10140000
109600                                  OR = 438 OR = 456               10150000
109700                                  OR = 457 OR = 458               10160000
109800                                  OR = 459 OR = 460               10170000
109900                                  OR = 469 OR = 470               10180000
110000                                  OR = 472 OR = 474               10190000
110100             MOVE 54 TO PPS-RTC.                                  10200000
110200                                                                  10210000
110300     IF  PPS-RTC = 00                                             10220000
110400            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR           10230000
110500                 (B-DISCHARGE-DATE < W-EFF-DATE))                 10240000
110600                MOVE 55 TO PPS-RTC.                               10250000
110700                                                                  10260000
110800     IF  PPS-RTC = 00                                             10270000
110900         IF P-NEW-TERMINATION-DATE > 00000000                     10280000
111000            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR   10290000
111100                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))     10300000
111200                  MOVE 55 TO PPS-RTC.                             10310000
111300                                                                  10320000
111400     IF  PPS-RTC = 00                                             10330000
111500         IF  B-LOS NOT NUMERIC                                    10340000
111600             MOVE 56 TO PPS-RTC                                   10350000
111700         ELSE                                                     10360000
111800         IF  B-LOS = 0                                            10370000
111900             IF B-REVIEW-CODE NOT = 00 AND                        10380000
112000                              NOT = 03 AND                        10390000
112100                              NOT = 06 AND                        10400000
112200                              NOT = 07 AND                        10410000
112300                              NOT = 09 AND                        10420000
112400                              NOT = 11                            10430000
112500             MOVE 56 TO PPS-RTC.                                  10440000
112600                                                                  10450000
112700     IF  PPS-RTC = 00                                             10460000
112800         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60            10470000
112900             MOVE 61 TO PPS-RTC                                   10480000
113000         ELSE                                                     10490000
113100             MOVE B-LTR-DAYS TO H-LTR-DAYS.                       10500000
113200                                                                  10510000
113300     IF  PPS-RTC = 00                                             10520000
113400         IF  B-COVERED-DAYS NOT NUMERIC                           10530000
113500             MOVE 62 TO PPS-RTC                                   10540000
113600         ELSE                                                     10550000
113700         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                     10560000
113800             MOVE 62 TO PPS-RTC                                   10570000
113900         ELSE                                                     10580000
114000             MOVE B-COVERED-DAYS TO H-COV-DAYS.                   10590000
114100                                                                  10600000
114200     IF  PPS-RTC = 00                                             10610000
114300         IF  H-LTR-DAYS  > H-COV-DAYS                             10620000
114400             MOVE 62 TO PPS-RTC                                   10630000
114500         ELSE                                                     10640000
114600             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.        10650000
114700                                                                  10660000
114800     IF  PPS-RTC = 00                                             10670000
114900         IF  NOT VALID-REVIEW-CODE                                10680000
115000             MOVE 57 TO PPS-RTC.                                  10690000
115100                                                                  10700000
115200     IF  PPS-RTC = 00                                             10710000
115300         IF  B-CHARGES-CLAIMED NOT NUMERIC                        10720000
115400             MOVE 58 TO PPS-RTC.                                  10730000
115500                                                                  10740000
115600     IF PPS-RTC = 00                                              10750000
115700           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'                       10760000
115800                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND         10770000
115900                                            NOT = 'B' AND         10780000
116000                                            NOT = 'C'             10790000
116100                 MOVE 65 TO PPS-RTC.                              10800000
116200                                                                  10810000
116300 2000-ASSEMBLE-PPS-VARIABLES.                                     10820000
116400***************************************************************   10830000
116500*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   10840000
116600*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   10850000
116700*    OF THAT VARIABLE.                                        *   10860000
116800***************************************************************   10870000
116900***  GET THE PROVIDER SPECIFIC VARIABLES.                         10880000
117000***  GET THE PROVIDER SPECIFIC VARIABLES.                         10890000
117100                                                                  10900000
117200     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.                 10910000
117300     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.                   10920000
117400                                                                  10930000
117500     IF  (P-NEW-STATE = 02 OR 12)                                 10940000
117600         MOVE P-NEW-COLA TO H-OPER-COLA                           10950000
117700     ELSE                                                         10960000
117800         MOVE 1.000  TO H-OPER-COLA.                              10970000
117900                                                                  10980000
118000***************************************************************   10990000
118100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              11000000
118200***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF              11010000
118300                                                                  11020000
118400     PERFORM 2600-GET-DRG-WEIGHT                                  11030000
118500             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.               11040000
118600                                                                  11050000
118700***************************************************************   11060000
118800***  GET THE WAGE-INDEX                                           11070000
118900***  GET THE WAGE-INDEX                                           11080000
119000                                                                  11090000
119100     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.                         11100000
119200     MOVE W-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.                   11110000
119300                                                                  11120000
119400***************************************************************   11130000
119500***  GET THE LABOR, NON-LABOR STANDARD RATES                      11140000
119600                                                                  11150000
119700     IF  P-NEW-STATE = 40                                         11160000
119800         MOVE 2 TO R2                                             11170000
119900         MOVE 3 TO R4                                             11180000
120000     ELSE                                                         11190000
120100         MOVE 1 TO R2                                             11200000
120200         MOVE 1 TO R4.                                            11210000
120300                                                                  11220000
120400     IF  LARGE-URBAN                                              11230000
120500         MOVE 1 TO R3                                             11240000
120600     ELSE                                                         11250000
120700         MOVE 2 TO R3.                                            11260000
120800                                                                  11270000
120900     PERFORM 2300-GET-LABOR-NLABOR-RATES                          11280000
121000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.                 11290000
121100                                                                  11300000
121200**************************************************************    11310000
121300***  NO LONGER PROCESSING TEMP RELIEF AS OF 100199                11320000
121400                                                                  11330000
121500***  IF TEMP-RELIEF-FLAG = 'Y'                                    11340000
121600***     COMPUTE H-REG-LABOR ROUNDED =                             11350000
121700***             H-REG-LABOR * 1.008 / 1.005                       11360000
121800***     COMPUTE H-REG-NONLABOR ROUNDED =                          11370000
121900***             H-REG-NONLABOR * 1.008 / 1.005                    11380000
122000***     COMPUTE H-NAT-LABOR ROUNDED =                             11390000
122100***             H-NAT-LABOR * 1.008 / 1.005                       11400000
122200***     COMPUTE H-NAT-NONLABOR ROUNDED =                          11410000
122300***             H-NAT-NONLABOR * 1.008 / 1.005.                   11420000
122400                                                                  11430000
122500***************************************************************   11440000
122600**************************************************************    11450000
122700***************************************************************   11460000
122800** NO LONGER PAID FOR 2002                             *******    11470000
122900***   16 = REBASED SOLE COMMUNITY HOSP                            11480000
123000***   17 = REBASED SOLE COMMUNITY HOSP/REFERRAL CENTER            11490000
123100***   21 = ESSENTIAL ACCESS COMMUNITY HOSP                        11500000
123200***   22 = ESSENTIAL ACCESS COMMUNITY HOSP/REFERRAL CENTER        11510000
123300*                                                                 11520000
123400*    IF (P-N-SCH-REBASED-FY90  OR                                 11530000
123500*           P-N-EACH)                                             11540000
123600*       IF B-DISCHARGE-DATE > 20010331                            11550000
123700*          COMPUTE H-REG-LABOR ROUNDED =                          11560000
123800*                  H-REG-LABOR * 1.034 / 1.045                    11570000
123900*          COMPUTE H-REG-NONLABOR ROUNDED =                       11580000
124000*                  H-REG-NONLABOR * 1.034 / 1.045                 11590000
124100*          COMPUTE H-NAT-LABOR ROUNDED =                          11600000
124200*                  H-NAT-LABOR * 1.034 / 1.045                    11610000
124300*          COMPUTE H-NAT-NONLABOR ROUNDED =                       11620000
124400*                  H-NAT-NONLABOR * 1.034 / 1.045                 11630000
124500*       ELSE                                                      11640000
124600*          COMPUTE H-REG-LABOR ROUNDED =                          11650000
124700*                  H-REG-LABOR * 1.034 / 1.023                    11660000
124800*          COMPUTE H-REG-NONLABOR ROUNDED =                       11670000
124900*                  H-REG-NONLABOR * 1.034 / 1.023                 11680000
125000*          COMPUTE H-NAT-LABOR ROUNDED =                          11690000
125100*                  H-NAT-LABOR * 1.034 / 1.023                    11700000
125200*          COMPUTE H-NAT-NONLABOR ROUNDED =                       11710000
125300*                  H-NAT-NONLABOR * 1.034 / 1.023.                11720000
125400*                                                                 11730000
125500*                                                                 11740000
125600***************************************************************   11750000
125700***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               11760000
125800***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL               11770000
125900                                                                  11780000
126000     MOVE 0.00  TO H-OPER-HSP-PCT.                                11790000
126100     MOVE 1.00  TO H-OPER-FSP-PCT.                                11800000
126200                                                                  11810000
126300***************************************************************   11820000
126400***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     11830000
126500***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL     11840000
126600                                                                  11850000
126700      MOVE 1.00 TO H-NAT-PCT.                                     11860000
126800      MOVE 0.00 TO H-REG-PCT.                                     11870000
126900                                                                  11880000
127000     IF  P-NEW-STATE = 40                                         11890000
127100         MOVE 0.50 TO H-NAT-PCT                                   11900000
127200         MOVE 0.50 TO H-REG-PCT.                                  11910000
127300                                                                  11920000
127400     IF  P-N-SCH-REBASED-FY90 OR                                  11930000
127500         P-N-EACH OR                                              11940000
127600         P-N-MDH-REBASED-FY90                                     11950000
127700         MOVE 1.00 TO H-OPER-HSP-PCT.                             11960000
127800                                                                  11970000
127900 2300-GET-LABOR-NLABOR-RATES.                                     11980000
128000                                                                  11990000
128100     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE (R1)                12000000
128200         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR                12010000
128300         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR             12020000
128400         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR                12030000
128500         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.            12040000
128600                                                                  12050000
128700 2600-GET-DRG-WEIGHT.                                             12060000
128800     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)               12070000
128900         SET DX6 TO B-DRG                                         12080000
129000         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT                12090000
129100         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS                  12100000
129200*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF           12110000
129300         MOVE ZEROES                   TO H-DAYS-CUTOFF           12120000
129400         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.           12130000
129500                                                                  12140000
129600 3000-CALC-PAYMENT.                                               12150000
129700***************************************************************   12160000
129800*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   12170000
129900*        CALCULATE THE STAY UTILIZATION.                      *   12180000
130000*        CALCULATE THE FEDERAL PORTION.                       *   12190000
130100*        CALCULATE THE HOSPITAL PORTION.                      *   12200000
130200*        CALCULATE THE COST-OUTLIER PORTION.                  *   12210000
130300*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *   12220000
130400*        CALCULATE THE DSH ADJUSTMENT.                        *   12230000
130500*        CALCULATE THE IME TEACHING.                          *   12240000
130600***************************************************************   12250000
130700     PERFORM 3100-CALC-STAY-UTILIZATION.                          12260000
130800     PERFORM 3300-CALC-OPER-FSP-AMT.                              12270000
130900***************************************************************   12280000
131000     PERFORM 3900A-CALC-OPER-DSH.                                 12290000
131100***********************************************************       12300000
131200***  OPERATING IME CALCULATION                                    12310000
131300***  OPERATING IME CALCULATION                                    12320000
131400                                                                  12330000
131500     COMPUTE H-OPER-IME-TEACH ROUNDED =                           12340000
131600            1.60 * ((1 + H-INTERN-RATIO) ** .405  - 1).           12350000
131700                                                                  12360000
131800***********************************************************       12370000
131900                                                                  12380000
132000     IF P-N-SCH-REBASED-FY90 OR                                   12390000
132100        P-N-EACH OR                                               12400000
132200        P-N-MDH-REBASED-FY90                                      12410000
132300         PERFORM 3450-CALC-ADDITIONAL-HSP.                        12420000
132400                                                                  12430000
132500     MOVE 00                 TO  PPS-RTC.                         12440000
132600     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.                   12450000
132700     MOVE H-ALOS             TO  PPS-AVG-LOS.                     12460000
132800     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.                 12470000
132900                                                                  12480000
133000     MOVE B-LOS TO H-PERDIEM-DAYS.                                12490000
133100     IF H-PERDIEM-DAYS < 1                                        12500000
133200         MOVE 1 TO H-PERDIEM-DAYS.                                12510000
133300     ADD 1 TO H-PERDIEM-DAYS.                                     12520000
133400                                                                  12530000
133500     MOVE 1 TO H-DSCHG-FRCTN.                                     12540000
133600                                                                  12550000
133700     IF  (PAY-PERDIEM-DAYS OR                                     12560000
133800          PAY-XFER-NO-COST) OR                                    12570000
133900       (PAY-XFER-SPEC-DRG AND (B-DRG = 014 OR 113 OR 236 OR       12580000
134000                                       263 OR 264 OR 429 OR 483)) 12590000
134100         COMPUTE H-DSCHG-FRCTN ROUNDED = H-PERDIEM-DAYS / H-ALOS  12600000
134200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS.12610000
134300                                                                  12620000
134400     IF (PAY-XFER-SPEC-DRG AND (B-DRG = 209 OR 210 OR 211))       12630000
134500         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS 12640000
134600         COMPUTE H-DSCHG-FRCTN ROUNDED =                          12650000
134700                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS).    12660000
134800                                                                  12670000
134900     IF H-DSCHG-FRCTN > 1                                         12680000
135000              MOVE 1 TO H-DSCHG-FRCTN                             12690000
135100              MOVE 1 TO H-TRANSFER-ADJ.                           12700000
135200                                                                  12710000
135300     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.   12720000
135400                                                                  12730000
135500     PERFORM 3600-CALC-OUTLIER.                                   12740000
135600                                                                  12750000
135700     IF PPS-RTC = 67  GO TO 3000-CONTINUE.                        12760000
135800                                                                  12770000
135900        IF PAY-PERDIEM-DAYS                                       12780000
136000            IF  H-PERDIEM-DAYS < H-ALOS                           12790000
136100                IF  NOT (B-DRG = 385)                             12800000
136200                    PERFORM 3500-CALC-PERDIEM-AMT                 12810000
136300                    MOVE 03 TO PPS-RTC.                           12820000
136400                                                                  12830000
136500        IF PAY-XFER-SPEC-DRG                                      12840000
136600            IF  H-PERDIEM-DAYS < H-ALOS                           12850000
136700                IF  NOT (B-DRG = 385)                             12860000
136800                    PERFORM 3550-CALC-PERDIEM-AMT.                12870000
136900                                                                  12880000
137000        IF  PAY-PERDIEM-DAYS                                      12890000
137100            IF  H-OPER-OUTCST-PART > 0                            12900000
137200                MOVE H-OPER-OUTCST-PART TO                        12910000
137300                     H-OPER-OUTLIER-PART                          12920000
137400                MOVE 05 TO PPS-RTC                                12930000
137500            ELSE                                                  12940000
137600            IF  PPS-RTC NOT = 03                                  12950000
137700                MOVE 00 TO PPS-RTC                                12960000
137800                MOVE 0  TO H-OPER-OUTLIER-PART.                   12970000
137900                                                                  12980000
138000        IF  PAY-PERDIEM-DAYS                                      12990000
138100            IF  H-CAPI-OUTCST-PART > 0                            13000000
138200                MOVE H-CAPI-OUTCST-PART TO                        13010000
138300                     H-CAPI-OUTLIER-PART                          13020000
138400                MOVE 05 TO PPS-RTC                                13030000
138500            ELSE                                                  13040000
138600            IF  PPS-RTC NOT = 03                                  13050000
138700                MOVE 0  TO H-CAPI-OUTLIER-PART.                   13060000
138800                                                                  13070000
138900        IF  PAY-XFER-NO-COST                                      13080000
139000            MOVE 0  TO H-OPER-OUTLIER-PART                        13090000
139100                       H-CAPI-OUTLIER-PART                        13100000
139200            MOVE 00 TO PPS-RTC                                    13110000
139300            IF H-PERDIEM-DAYS < H-ALOS                            13120000
139400               IF  NOT (B-DRG = 385)                              13130000
139500                   PERFORM 3500-CALC-PERDIEM-AMT                  13140000
139600                   MOVE 06 TO PPS-RTC.                            13150000
139700                                                                  13160000
139800 3000-CONTINUE.                                                   13170000
139900                                                                  13180000
140000***********************************************************       13190000
140100***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF          13200000
140200***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          13210000
140300                                                                  13220000
140400     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.        13230000
140500                                                                  13240000
140600***********************************************************       13250000
140700                                                                  13260000
140800     IF  PPS-RTC = 67                                             13270000
140900         MOVE H-OPER-DOLLAR-THRESHOLD TO                          13280000
141000              WK-H-OPER-DOLLAR-THRESHOLD.                         13290000
141100                                                                  13300000
141200     IF  PPS-RTC < 50                                             13310000
141300         PERFORM 3800-CALC-TOT-AMT                                13320000
141400     ELSE                                                         13330000
141500         MOVE ALL '0' TO PPS-OPER-HSP-PART                        13340000
141600                         PPS-OPER-FSP-PART                        13350000
141700                         PPS-OPER-OUTLIER-PART                    13360000
141800                         PPS-OUTLIER-DAYS                         13370000
141900                         PPS-REG-DAYS-USED                        13380000
142000                         PPS-LTR-DAYS-USED                        13390000
142100                         PPS-TOTAL-PAYMENT                        13400000
142200                         PPS-OPER-DSH-ADJ                         13410000
142300                         PPS-OPER-IME-ADJ                         13420000
142400                         H-DSCHG-FRCTN                            13430000
142500                         H-DRG-WT-FRCTN                           13440000
142600                         HOLD-ADDITIONAL-VARIABLES                13450000
142700                         HOLD-CAPITAL-VARIABLES                   13460000
142800                         HOLD-CAPITAL2-VARIABLES                  13470000
142900                         HOLD-OTHER-VARIABLES                     13480000
143000                         HOLD-PC-OTH-VARIABLES.                   13490000
143100                                                                  13500000
143200     IF  PPS-RTC = 67                                             13510000
143300         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO                       13520000
143400                 H-OPER-DOLLAR-THRESHOLD.                         13530000
143500                                                                  13540000
143600 3000-EXIT.  EXIT.                                                13550000
143700                                                                  13560000
143800 3100-CALC-STAY-UTILIZATION.                                      13570000
143900                                                                  13580000
144000     MOVE 0 TO PPS-REG-DAYS-USED.                                 13590000
144100     MOVE 0 TO PPS-LTR-DAYS-USED.                                 13600000
144200                                                                  13610000
144300     IF H-REG-DAYS > 0                                            13620000
144400        IF H-REG-DAYS > B-LOS                                     13630000
144500           MOVE B-LOS TO PPS-REG-DAYS-USED                        13640000
144600        ELSE                                                      13650000
144700           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                   13660000
144800     ELSE                                                         13670000
144900        IF H-LTR-DAYS > B-LOS                                     13680000
145000           MOVE B-LOS TO PPS-LTR-DAYS-USED                        13690000
145100        ELSE                                                      13700000
145200           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.                  13710000
145300                                                                  13720000
145400                                                                  13730000
145500                                                                  13740000
145600 3300-CALC-OPER-FSP-AMT.                                          13750000
145700***********************************************************       13760000
145800***  OPERATING FSP CALCULATION                                    13770000
145900***  OPERATING FSP CALCULATION                                    13780000
146000                                                                  13790000
146100     IF P-NEW-STATE = 40                                          13800000
146200       COMPUTE H-OPER-FSP-PART ROUNDED =                          13810000
146300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             13820000
146400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             13830000
146500                           +                                      13840000
146600           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +          13850000
146700            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)             13860000
146800                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART        13870000
146900     ELSE                                                         13880000
147000        COMPUTE H-OPER-FSP-PART ROUNDED =                         13890000
147100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +             13900000
147200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)             13910000
147300                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.       13920000
147400                                                                  13930000
147500                                                                  13940000
147600 3450-CALC-ADDITIONAL-HSP.                                        13950000
147700***********************************************************       13960000
147800*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                 13970000
147900*    SOLE COMMUNITY                                               13980000
148000*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)              13990000
148100*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES              14000000
148200***********************************************************       14010000
148300**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE       14020000
148400****    USE ACTUAL FEDERAL REGISTER NUMBER                        14030000
148500                                                                  14040000
148600     MOVE 0.948928 TO H-OUTLIER-FACT.                             14050000
148700***************************************************************   14060000
148800***         GET THE UPDATING FACTOR                               14070000
148900***         GET THE UPDATING FACTOR                               14080000
149000                                                                  14090000
149100     MOVE 0.997174 TO H-BUDG-NUTR01.                              14100000
149200     MOVE 0.995821 TO H-BUDG-NUTR02.                              14110000
149300                                                                  14120000
149400     MOVE 1.0340 TO H-UPDATE-01.                                  14130000
149500     MOVE 1.0275 TO H-UPDATE-02.                                  14140000
149600                                                                  14150000
149700     COMPUTE H-UPDATE-FACTOR ROUNDED =                            14160000
149800                       (H-UPDATE-01 * H-UPDATE-02 *               14170000
149900                        H-BUDG-NUTR01 * H-BUDG-NUTR02).           14180000
150000                                                                  14190000
150100     COMPUTE H-HSP-RATE ROUNDED =                                 14200000
150200         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.                       14210000
150300***************************************************************   14220000
150400                                                                  14230000
150500     IF P-NEW-STATE = 40                                          14240000
150600       COMPUTE H-FSP-RATE ROUNDED =                               14250000
150700         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +              14260000
150800         H-NAT-NONLABOR * H-OPER-COLA))                           14270000
150900                           +                                      14280000
151000          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +           14290000
151100         H-REG-NONLABOR * H-OPER-COLA)))                          14300000
151200                           *                                      14310000
151300       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT)     14320000
151400                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE             14330000
151500     ELSE                                                         14340000
151600       COMPUTE H-FSP-RATE ROUNDED =                               14350000
151700         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +               14360000
151800         H-NAT-NONLABOR * H-OPER-COLA))                           14370000
151900                           *                                      14380000
152000       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT)     14390000
152100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.            14400000
152200                                                                  14410000
152300     IF  H-HSP-RATE > H-FSP-RATE                                  14420000
152400           COMPUTE H-OPER-HSP-PART ROUNDED =                      14430000
152500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                 14440000
152600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART        14450000
152700     ELSE                                                         14460000
152800         MOVE 0 TO H-OPER-HSP-PART.                               14470000
152900                                                                  14480000
153000***************************************************************   14490000
153100***         GET THE MDH REBASE                                    14500000
153200***     HAS BEEN REVIVED FOR 10/01/97                             14510000
153300                                                                  14520000
153400     IF  H-HSP-RATE > H-FSP-RATE                                  14530000
153500         IF P-NEW-PROVIDER-TYPE = '14' OR '15'                    14540000
153600           COMPUTE H-OPER-HSP-PART ROUNDED =                      14550000
153700             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5            14560000
153800                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.       14570000
153900                                                                  14580000
154000 3500-CALC-PERDIEM-AMT.                                           14590000
154100***********************************************************       14600000
154200***  REVIEW CODE = 03 OR 06                                       14610000
154300***  OPERATING PERDIEM-AMT CALCULATION                            14620000
154400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              14630000
154500                                                                  14640000
154600        COMPUTE H-OPER-HSP-PART ROUNDED =                         14650000
154700        H-OPER-HSP-PART * H-TRANSFER-ADJ                          14660000
154800        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  14670000
154900                                                                  14680000
155000        COMPUTE H-OPER-FSP-PART ROUNDED =                         14690000
155100        H-OPER-FSP-PART * H-TRANSFER-ADJ                          14700000
155200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  14710000
155300                                                                  14720000
155400***********************************************************       14730000
155500***********************************************************       14740000
155600***  REVIEW CODE = 03 OR 06                                       14750000
155700***  CAPITAL   PERDIEM-AMT CALCULATION                            14760000
155800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS              14770000
155900                                                                  14780000
156000***********************************************************       14790000
156100**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    ************** 14800000
156200*       COMPUTE H-CAPI-HSP-PART ROUNDED =                         14810000
156300*       H-CAPI-HSP-PART * H-TRANSFER-ADJ                          14820000
156400*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  14830000
156500***********************************************************       14840000
156600                                                                  14850000
156700        COMPUTE H-CAPI-FSP-PART ROUNDED =                         14860000
156800        H-CAPI-FSP-PART * H-TRANSFER-ADJ                          14870000
156900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  14880000
157000                                                                  14890000
157100***********************************************************       14900000
157200***  REVIEW CODE = 03 OR 06                                       14910000
157300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                14920000
157400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                14930000
157500                                                                  14940000
157600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     14950000
157700        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ                      14960000
157800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              14970000
157900                                                                  14980000
158000 3550-CALC-PERDIEM-AMT.                                           14990000
158100***********************************************************       15000000
158200***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG            15010000
158300***  OPERATING PERDIEM-AMT CALCULATION                            15020000
158400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS              15030000
158500                                                                  15040000
158600     IF (B-DRG = 209 OR 210 OR 211)                               15050000
158700        MOVE 10 TO PPS-RTC                                        15060000
158800        COMPUTE H-OPER-HSP-PART ROUNDED =                         15070000
158900        H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15080000
159000        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  15090000
159100                                                                  15100000
159200     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15110000
159300                 264 OR 429 OR 483)                               15120000
159400        MOVE 12 TO PPS-RTC                                        15130000
159500        COMPUTE H-OPER-HSP-PART ROUNDED =                         15140000
159600        H-OPER-HSP-PART *  H-TRANSFER-ADJ                         15150000
159700        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.                  15160000
159800                                                                  15170000
159900     IF (B-DRG = 209 OR 210 OR 211)                               15180000
160000        MOVE 10 TO PPS-RTC                                        15190000
160100        COMPUTE H-OPER-FSP-PART ROUNDED =                         15200000
160200        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15210000
160300        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  15220000
160400                                                                  15230000
160500     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15240000
160600                 264 OR 429 OR 483)                               15250000
160700        MOVE 12 TO PPS-RTC                                        15260000
160800        COMPUTE H-OPER-FSP-PART ROUNDED =                         15270000
160900        H-OPER-FSP-PART *  H-TRANSFER-ADJ                         15280000
161000        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.                  15290000
161100                                                                  15300000
161200***********************************************************       15310000
161300***  CAPITAL PERDIEM-AMT CALCULATION                              15320000
161400***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS                15330000
161500                                                                  15340000
161600***********************************************************       15350000
161700**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    ************** 15360000
161800*    IF (B-DRG = 209 OR 210 OR 211)                               15370000
161900*       MOVE 10 TO PPS-RTC                                        15380000
162000*       COMPUTE H-CAPI-HSP-PART ROUNDED =                         15390000
162100*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15400000
162200*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  15410000
162300*                                                                 15420000
162400*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15430000
162500*                264 OR 429 OR 483)                               15440000
162600*       MOVE 12 TO PPS-RTC                                        15450000
162700*       COMPUTE H-CAPI-HSP-PART ROUNDED =                         15460000
162800*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ                         15470000
162900*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.                  15480000
163000***********************************************************       15490000
163100                                                                  15500000
163200     IF (B-DRG = 209 OR 210 OR 211)                               15510000
163300        MOVE 10 TO PPS-RTC                                        15520000
163400        COMPUTE H-CAPI-FSP-PART ROUNDED =                         15530000
163500        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))             15540000
163600        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  15550000
163700                                                                  15560000
163800     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15570000
163900                 264 OR 429 OR 483)                               15580000
164000        MOVE 12 TO PPS-RTC                                        15590000
164100        COMPUTE H-CAPI-FSP-PART ROUNDED =                         15600000
164200        H-CAPI-FSP-PART *  H-TRANSFER-ADJ                         15610000
164300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.                  15620000
164400                                                                  15630000
164500***********************************************************       15640000
164600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                15650000
164700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION                15660000
164800                                                                  15670000
164900     IF (B-DRG = 209 OR 210 OR 211)                               15680000
165000        MOVE 10 TO PPS-RTC                                        15690000
165100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     15700000
165200        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))         15710000
165300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              15720000
165400                                                                  15730000
165500     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                      15740000
165600                 264 OR 429 OR 483)                               15750000
165700        MOVE 12 TO PPS-RTC                                        15760000
165800        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                     15770000
165900        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ                     15780000
166000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.              15790000
166100                                                                  15800000
166200 3600-CALC-OUTLIER.                                               15810000
166300******************************************************************15820000
166400***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97             15830000
166500***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97             15840000
166600***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97             15850000
166700                                                                  15860000
166800     MOVE 0.00 TO H-DAYOUT-PCT.                                   15870000
166900******************************************************************15880000
167000                                                                  15890000
167100     MOVE 0.80 TO H-CSTOUT-PCT.                                   15900000
167200                                                                  15910000
167300******************************************************************15920000
167400*****THESE ARE BURNS DRG'S                                        15930000
167500     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR               15940000
167600                 509 OR 510 OR 511                                15950000
167700             MOVE 0.90 TO H-CSTOUT-PCT.                           15960000
167800                                                                  15970000
167900***     NATIONAL PERCENTAGE                                       15980000
168000     MOVE 0.7110   TO H-LABOR-PCT.                                15990000
168100     MOVE 0.2890   TO H-NONLABOR-PCT.                             16000000
168200                                                                  16010000
168300***     PUERTO RICO PERCENTAGE                                    16020000
168400     MOVE 0.7130   TO H-PR-LABOR-PCT.                             16030000
168500     MOVE 0.2870   TO H-PR-NONLABOR-PCT.                          16040000
168600                                                                  16050000
168700     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC                          16060000
168800             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO  16070000
168900     ELSE                                                         16080000
169000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.                   16090000
169100                                                                  16100000
169200     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC                           16110000
169300             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO  16120000
169400     ELSE                                                         16130000
169500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.                   16140000
169600                                                                  16150000
169700***********************************************************       16160000
169800***  CAPITAL PAYMENT METHOD B                                     16170000
169900***  CAPITAL PAYMENT METHOD B                                     16180000
170000                                                                  16190000
170100     IF W-SIZE = 'L'                                              16200000
170200        MOVE 1.03 TO H-CAPI-LARG-URBAN                            16210000
170300     ELSE                                                         16220000
170400        MOVE 1.00 TO H-CAPI-LARG-URBAN.                           16230000
170500                                                                  16240000
170600     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).     16250000
170700     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).  16260000
170800                                                                  16270000
170900     COMPUTE H-FEDERAL-RATE ROUNDED =                             16280000
171000                                 (0390.74 * H-CAPI-GAF)           16290000
171100     COMPUTE H-PUERTO-RICO-RATE ROUNDED =                         16300000
171200                                 (0187.73 * H-PR-CAPI-GAF).       16310000
171300                                                                  16320000
171400     COMPUTE H-CAPI-COLA ROUNDED =                                16330000
171500                     (.3152 * (H-OPER-COLA - 1) + 1).             16340000
171600                                                                  16350000
171700     IF P-NEW-STATE = 40                                          16360000
171800        COMPUTE  H-CAPI-FED-RATE ROUNDED =                        16370000
171900                 (H-NAT-PCT * H-FEDERAL-RATE) +                   16380000
172000                 (H-REG-PCT * H-PUERTO-RICO-RATE)                 16390000
172100     ELSE                                                         16400000
172200        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.                   16410000
172300                                                                  16420000
172400***********************************************************       16430000
172500***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001                16440000
172600***  CAPITAL HSP CALCULATION                                      16450000
172700***  CAPITAL HSP CALCULATION                                      16460000
172800*                                                                 16470000
172900*    IF B-DISCHARGE-DATE > 20010331                               16480000
173000*        MOVE 1.0149 TO H-HSP-UPDATE01                            16490000
173100*    ELSE                                                         16500000
173200*        MOVE 1.0147 TO H-HSP-UPDATE01.                           16510000
173300*                                                                 16520000
173400*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.             16530000
173500*                                                                 16540000
173600*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *                16550000
173700*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).   16560000
173800***********************************************************       16570000
173900                                                                  16580000
174000***********************************************************       16590000
174100***  CAPITAL FSP CALCULATION                                      16600000
174200***  CAPITAL FSP CALCULATION                                      16610000
174300                                                                  16620000
174400     COMPUTE H-CAPI-FSP-PART ROUNDED =                            16630000
174500                               H-DRG-WT * H-CAPI-FED-RATE *       16640000
174600                               H-CAPI-COLA *                      16650000
174700                               H-CAPI-LARG-URBAN.                 16660000
174800                                                                  16670000
174900***********************************************************       16680000
175000***  CAPITAL PAYMENT METHOD A                                     16690000
175100***  CAPITAL PAYMENT METHOD A                                     16700000
175200                                                                  16710000
175300     IF P-N-SCH-REBASED-FY90 OR P-N-EACH                          16720000
175400        MOVE 1.00 TO H-CAPI-SCH                                   16730000
175500     ELSE                                                         16740000
175600        MOVE 0.85 TO H-CAPI-SCH.                                  16750000
175700                                                                  16760000
175800***********************************************************       16770000
175900***********  CAPITAL OLD-HARMLESS CALCULATION ***********         16780000
176000***********  CAPITAL OLD-HARMLESS CALCULATION ***********         16790000
176100                                                                  16800000
176200     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =                        16810000
176300                    (P-NEW-CAPI-OLD-HARM-RATE *                   16820000
176400                    H-CAPI-SCH).                                  16830000
176500                                                                  16840000
176600***********************************************************       16850000
176700***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               16860000
176800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION               16870000
176900                                                                  16880000
177000     IF H-CAPI-CSTCHG-RATIO > 0 OR                                16890000
177100       H-OPER-CSTCHG-RATIO > 0                                    16900000
177200        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =             16910000
177300                H-OPER-CSTCHG-RATIO /                             16920000
177400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        16930000
177500        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =             16940000
177600                H-CAPI-CSTCHG-RATIO /                             16950000
177700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)        16960000
177800     ELSE                                                         16970000
177900         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD                    16980000
178000                   H-CAPI-SHARE-DOLL-THRESHOLD.                   16990000
178100                                                                  17000000
178200***********************************************************       17010000
178300***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************       17020000
178400***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS          17030000
178500***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS          17040000
178600                                                                  17050000
178700***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************       17060000
178800***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.                       17070000
178900***********************************************************       17080000
179000***********************************************************       17090000
179100***********************************************************       17100000
179200***********************************************************       17110000
179300                                                                  17120000
179400***  OUTLIER THRESHOLD THRESHOLD AMOUNTS                          17130000
179500***********************************************************       17140000
179600     MOVE 21025.00 TO H-CST-THRESH                                17150000
179700                                                                  17160000
179800     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                    17170000
179900        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +            17180000
180000         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *         17190000
180100          H-OPER-SHARE-DOLL-THRESHOLD.                            17200000
180200                                                                  17210000
180300     IF P-NEW-STATE = 40                                          17220000
180400        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              17230000
180500           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +   17240000
180600            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *   17250000
180700             H-OPER-SHARE-DOLL-THRESHOLD                          17260000
180800        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 17270000
180900               (H-OPER-DOLLAR-THRESHOLD +                         17280000
181000                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.          17290000
181100                                                                  17300000
181200***********************************************************       17310000
181300***  CAPITAL DSH CALCULATION                                      17320000
181400***  CAPITAL DSH CALCULATION                                      17330000
181500                                                                  17340000
181600     MOVE 0 TO H-CAPI-DSH.                                        17350000
181700                                                                  17360000
181800     IF P-NEW-BED-SIZE NOT NUMERIC                                17370000
181900         MOVE 0 TO P-NEW-BED-SIZE.                                17380000
182000                                                                  17390000
182100     IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99             17400000
182200         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **                   17410000
182300                  (.2025 * (P-NEW-SSI-RATIO                       17420000
182400                          + P-NEW-MEDICAID-RATIO)) - 1.           17430000
182500                                                                  17440000
182600***********************************************************       17450000
182700***  CAPITAL IME TEACH CALCULATION                                17460000
182800***  CAPITAL IME TEACH CALCULATION                                17470000
182900                                                                  17480000
183000     MOVE 0 TO H-WK-CAPI-IME-TEACH.                               17490000
183100                                                                  17500000
183200     IF P-NEW-CAPI-IME NUMERIC                                    17510000
183300        IF P-NEW-CAPI-IME > 1.5000                                17520000
183400           MOVE 1.5000 TO P-NEW-CAPI-IME.                         17530000
183500                                                                  17540000
183600     IF P-NEW-CAPI-IME NUMERIC                                    17550000
183700        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =                     17560000
183800          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.               17570000
183900                                                                  17580000
184000***********************************************************       17590000
184100***********************************************************       17600000
184200***********************************************************       17610000
184300***NO LONGER PAID AS OF OCT. 1, 2001    *******************       17620000
184400***  DIFFERENT THRESHOLD   PRE-CAPITAL                            17630000
184500***  DIFFERENT THRESHOLD   PRE-CAPITAL                            17640000
184600*                                                                 17650000
184700*    IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               17660000
184800*       COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 17670000
184900*       (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +        17680000
185000*       (H-PRE-CAPI-THRESH * H-NONLABOR-PCT * H-OPER-COLA)        17690000
185100*      IF P-NEW-STATE = 40                                        17700000
185200*       COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =              17710000
185300*        (H-PRE-CAPI-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) + 17720000
185400*        (H-PRE-CAPI-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)    17730000
185500*       COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =                 17740000
185600*              (H-OPER-DOLLAR-THRESHOLD +                         17750000
185700*               H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.          17760000
185800***********************************************************       17770000
185900***********************************************************       17780000
186000***********************************************************       17790000
186100                                                                  17800000
186200     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                    17810000
186300          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *         17820000
186400          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.              17830000
186500                                                                  17840000
186600                                                                  17850000
186700     IF P-NEW-STATE = 40                                          17860000
186800        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =              17870000
186900           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *     17880000
187000           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA              17890000
187100        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =                 17900000
187200               (H-CAPI-DOLLAR-THRESHOLD +                         17910000
187300                H-CAPI-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.          17920000
187400                                                                  17930000
187500     COMPUTE H-OPER-COST-OUTLIER ROUNDED =                        17940000
187600      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))     17950000
187700                       +                                          17960000
187800             H-OPER-DOLLAR-THRESHOLD.                             17970000
187900                                                                  17980000
188000     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                        17990000
188100      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))  18000000
188200                       +                                          18010000
188300             H-CAPI-DOLLAR-THRESHOLD.                             18020000
188400                                                                  18030000
188500     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               18040000
188600         MOVE 0 TO H-CAPI-COST-OUTLIER.                           18050000
188700                                                                  18060000
188800     IF (B-REVIEW-CODE = '03') AND                                18070000
188900         H-PERDIEM-DAYS < H-ALOS                                  18080000
189000        COMPUTE H-OPER-COST-OUTLIER ROUNDED =                     18090000
189100                (H-OPER-COST-OUTLIER * H-TRANSFER-ADJ)            18100000
189200                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      18110000
189300                                                                  18120000
189400     IF (B-REVIEW-CODE = '03') AND                                18130000
189500         H-PERDIEM-DAYS < H-ALOS                                  18140000
189600        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                     18150000
189700                (H-CAPI-COST-OUTLIER * H-TRANSFER-ADJ)            18160000
189800                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      18170000
189900                                                                  18180000
190000     IF ((B-REVIEW-CODE = '09') AND                               18190000
190100         (H-PERDIEM-DAYS < H-ALOS))                               18200000
190200         IF (B-DRG = 209 OR 210 OR 211)                           18210000
190300           COMPUTE H-OPER-COST-OUTLIER ROUNDED =                  18220000
190400               (H-OPER-COST-OUTLIER * (.5 * (1 + H-TRANSFER-ADJ)))18230000
190500                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      18240000
190600                                                                  18250000
190700     IF ((B-REVIEW-CODE = '09') AND                               18260000
190800         (H-PERDIEM-DAYS < H-ALOS))                               18270000
190900         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                  18280000
191000                     264 OR 429 OR 483)                           18290000
191100            COMPUTE H-OPER-COST-OUTLIER ROUNDED =                 18300000
191200                (H-OPER-COST-OUTLIER *  H-TRANSFER-ADJ)           18310000
191300                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.      18320000
191400                                                                  18330000
191500     IF ((B-REVIEW-CODE = '09') AND                               18340000
191600         (H-PERDIEM-DAYS < H-ALOS))                               18350000
191700         IF (B-DRG = 209 OR 210 OR 211)                           18360000
191800           COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                  18370000
191900               (H-CAPI-COST-OUTLIER * (.5 * (1 + H-TRANSFER-ADJ)))18380000
192000                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      18390000
192100                                                                  18400000
192200     IF ((B-REVIEW-CODE = '09') AND                               18410000
192300         (H-PERDIEM-DAYS < H-ALOS))                               18420000
192400         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR                  18430000
192500                     264 OR 429 OR 483)                           18440000
192600            COMPUTE H-CAPI-COST-OUTLIER ROUNDED =                 18450000
192700                (H-CAPI-COST-OUTLIER *  H-TRANSFER-ADJ)           18460000
192800                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.      18470000
192900                                                                  18480000
193000                                                                  18490000
193100***********************************************************       18500000
193200***  OPERATING COST CALCULATION                                   18510000
193300***  OPERATING COST CALCULATION                                   18520000
193400                                                                  18530000
193500     COMPUTE H-OPER-BILL-COSTS ROUNDED =                          18540000
193600         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO                  18550000
193700         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.               18560000
193800                                                                  18570000
193900                                                                  18580000
194000     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER                  18590000
194100         COMPUTE H-OPER-OUTCST-PART ROUNDED =                     18600000
194200         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -                      18610000
194300                         H-OPER-COST-OUTLIER).                    18620000
194400                                                                  18630000
194500     IF PAY-WITHOUT-COST OR                                       18640000
194600        PAY-XFER-NO-COST OR                                       18650000
194700        PAY-XFER-SPEC-DRG-NO-COST                                 18660000
194800         MOVE 0 TO H-OPER-OUTCST-PART.                            18670000
194900                                                                  18680000
195000***********************************************************       18690000
195100***  CAPITAL COST CALCULATION                                     18700000
195200***  CAPITAL COST CALCULATION                                     18710000
195300                                                                  18720000
195400     COMPUTE H-CAPI-BILL-COSTS ROUNDED =                          18730000
195500             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO              18740000
195600         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.               18750000
195700                                                                  18760000
195800     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER                  18770000
195900         COMPUTE H-CAPI-OUTCST-PART ROUNDED =                     18780000
196000         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -                      18790000
196100                         H-CAPI-COST-OUTLIER).                    18800000
196200                                                                  18810000
196300     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             18820000
196400       COMPUTE H-CAPI-OUTCST-PART ROUNDED =                       18830000
196500              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).   18840000
196600                                                                  18850000
196700     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             18860000
196800        COMPUTE H-CAPI-OUTCST-PART ROUNDED =                      18870000
196900               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).         18880000
197000                                                                  18890000
197100     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <               18900000
197200        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)               18910000
197300        MOVE 0 TO H-CAPI-OUTCST-PART                              18920000
197400                  H-OPER-OUTCST-PART.                             18930000
197500                                                                  18940000
197600     IF PAY-WITHOUT-COST OR                                       18950000
197700        PAY-XFER-NO-COST OR                                       18960000
197800        PAY-XFER-SPEC-DRG-NO-COST                                 18970000
197900         MOVE 0 TO H-CAPI-OUTCST-PART.                            18980000
198000                                                                  18990000
198100***********************************************************       19000000
198200***  DETERMINES THE BILL TO BE COST  OUTLIER                      19010000
198300                                                                  19020000
198400     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               19030000
198500         MOVE 0 TO H-CAPI-OUTDAY-PART                             19040000
198600                   H-CAPI-OUTCST-PART.                            19050000
198700                                                                  19060000
198800     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0             19070000
198900                 MOVE H-OPER-OUTCST-PART TO                       19080000
199000                      H-OPER-OUTLIER-PART                         19090000
199100                 MOVE H-CAPI-OUTCST-PART TO                       19100000
199200                      H-CAPI-OUTLIER-PART                         19110000
199300                 MOVE 02 TO PPS-RTC.                              19120000
199400                                                                  19130000
199500                                                                  19140000
199600***********************************************************       19150000
199700***  DETERMINES IF COST OUTLIER                                   19160000
199800***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH             19170000
199900***         RETURN CODE OF 02                                     19180000
200000                                                                  19190000
200100     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.                           19200000
200200                                                                  19210000
200300     IF PPS-RTC = 02                                              19220000
200400             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =            19230000
200500                     (H-CAPI-COST-OUTLIER  +                      19240000
200600                      H-OPER-COST-OUTLIER)                        19250000
200700                             /                                    19260000
200800                    (H-CAPI-CSTCHG-RATIO  +                       19270000
200900                     H-OPER-CSTCHG-RATIO)                         19280000
201000             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.     19290000
201100                                                                  19300000
201200***********************************************************       19310000
201300***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS       19320000
201400***         RETURN CODE OF 67                                     19330000
201500                                                                  19340000
201600     IF PPS-RTC = 02                                              19350000
201700         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR                19360000
201800            PPS-PC-COT-FLAG = 'Y'                                 19370000
201900             MOVE 67 TO PPS-RTC.                                  19380000
202000***********************************************************       19390000
202100                                                                  19400000
202200***********************************************************       19410000
202300***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF          19420000
202400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE          19430000
202500                                                                  19440000
202600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             19450000
202700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  19460000
202800                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO   19470000
202900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          19480000
203000                                                                  19490000
203100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             19500000
203200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  19510000
203300                H-CAPI-OUTLIER-PART.                              19520000
203400                                                                  19530000
203500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             19540000
203600        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =                  19550000
203700                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1          19560000
203800         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.          19570000
203900***********************************************************       19580000
204000                                                                  19590000
204100 3800-CALC-TOT-AMT.                                               19600000
204200                                                                  19610000
204300***********************************************************       19620000
204400***  CALCULATE FINAL TOTALS FOR OPERATING                         19630000
204500***  CALCULATE FINAL TOTALS FOR OPERATING                         19640000
204600                                                                  19650000
204700     COMPUTE PPS-OPER-HSP-PART ROUNDED =                          19660000
204800         H-OPER-HSP-PCT * H-OPER-HSP-PART.                        19670000
204900                                                                  19680000
205000     COMPUTE PPS-OPER-FSP-PART ROUNDED =                          19690000
205100         H-OPER-FSP-PCT * H-OPER-FSP-PART.                        19700000
205200                                                                  19710000
205300     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =                      19720000
205400             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.                19730000
205500                                                                  19740000
205600     MOVE ZERO TO PPS-OPER-DSH-ADJ.                               19750000
205700                                                                  19760000
205800     IF  H-OPER-DSH NUMERIC                                       19770000
205900             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =                   19780000
206000              PPS-OPER-FSP-PART                                   19790000
206100              * H-OPER-DSH.                                       19800000
206200                                                                  19810000
206300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =                           19820000
206400          PPS-OPER-FSP-PART *                                     19830000
206500                 H-OPER-IME-TEACH.                                19840000
206600                                                                  19850000
206700***********************************************************       19860000
206800***  CALCULATE FINAL TOTALS FOR CAPITAL                           19870000
206900***  CALCULATE FINAL TOTALS FOR CAPITAL                           19880000
207000                                                                  19890000
207100     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.           19900000
207200                                                                  19910000
207300     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'                             19920000
207400        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT          19930000
207500        MOVE 0.00 TO H-CAPI-HSP-PCT.                              19940000
207600                                                                  19950000
207700     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'                             19960000
207800        MOVE 0    TO H-CAPI-OLD-HARMLESS                          19970000
207900        MOVE 1.00 TO H-CAPI-FSP-PCT                               19980000
208000        MOVE 0.00 TO H-CAPI-HSP-PCT.                              19990000
208100                                                                  20000000
208200     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'                             20010000
208300        MOVE 0    TO H-CAPI-OLD-HARMLESS                          20020000
208400        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT                 20030000
208500        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.                20040000
208600                                                                  20050000
208700     COMPUTE H-CAPI-HSP ROUNDED =                                 20060000
208800         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.                        20070000
208900                                                                  20080000
209000     COMPUTE H-CAPI-FSP ROUNDED =                                 20090000
209100         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.                        20100000
209200                                                                  20110000
209300     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.             20120000
209400                                                                  20130000
209500     COMPUTE H-CAPI-OUTLIER ROUNDED =                             20140000
209600             1.00 * H-CAPI-OUTLIER-PART.                          20150000
209700                                                                  20160000
209800     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =                          20170000
209900             1.00 * H-CAPI2-B-OUTLIER-PART.                       20180000
210000                                                                  20190000
210100     COMPUTE H-CAPI2-B-FSP ROUNDED =                              20200000
210200             1.00 * H-CAPI2-B-FSP-PART.                           20210000
210300                                                                  20220000
210400     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.                 20230000
210500                                                                  20240000
210600     COMPUTE H-CAPI-DSH-ADJ ROUNDED =                             20250000
210700             H-CAPI-FSP                                           20260000
210800              * H-CAPI-DSH.                                       20270000
210900                                                                  20280000
211000     COMPUTE H-CAPI-IME-ADJ ROUNDED =                             20290000
211100          H-CAPI-FSP *                                            20300000
211200                 H-WK-CAPI-IME-TEACH.                             20310000
211300                                                                  20320000
211400***********************************************************       20330000
211500***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER               20340000
211600***        THIS ZEROES OUT ALL CAPITAL DATA                       20350000
211700                                                                  20360000
211800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')                               20370000
211900        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.                   20380000
212000                                                                  20390000
212100***********************************************************       20400000
212200     IF HMO-TAG  = 'Y'                                            20410000
212300        PERFORM 3850-HMO-IME-ADJ.                                 20420000
212400                                                                  20430000
212500     IF (H-CAPI-OUTLIER > 0 AND                                   20440000
212600         PPS-OPER-OUTLIER-PART = 0)                               20450000
212700            COMPUTE PPS-OPER-OUTLIER-PART =                       20460000
212800                    PPS-OPER-OUTLIER-PART + .01.                  20470000
212900                                                                  20480000
213000     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =                           20490000
213100             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +        20500000
213200             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +                    20510000
213300             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.                    20520000
213400                                                                  20530000
213500***********************************************************       20540000
213600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             20550000
213700***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING             20560000
213800                                                                  20570000
213900     COMPUTE PPS-TOTAL-PAYMENT ROUNDED =                          20580000
214000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +              20590000
214100             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +           20600000
214200             PPS-OPER-IME-ADJ                                     20610000
214300                           +                                      20620000
214400                H-WK-PASS-AMT-PLUS-MISC                           20630000
214500                           +                                      20640000
214600                  H-CAPI-TOTAL-PAY.                               20650000
214700                                                                  20660000
214800 3850-HMO-IME-ADJ.                                                20670000
214900***********************************************************       20680000
215000***  HMO ADJUSTMENT FOR OPERATING IME                             20690000
215100***  HMO ADJUSTMENT FOR OPERATING IME                             20700000
215200***  HMO CALC FOR PASS THRU ADDON                                 20710000
215300***  HMO CALC FOR PASS THRU ADDON                                 20720000
215400                                                                  20730000
215500     IF B-DISCHARGE-DATE < 20020101                               20740000
215600        COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                 20750000
215700          (P-NEW-PASS-AMT-PLUS-MISC -                             20760000
215800          (P-NEW-PASS-AMT-DIR-MED-ED * .80)) * B-LOS              20770000
215900     ELSE                                                         20780000
216000        COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                 20790000
216100          (P-NEW-PASS-AMT-PLUS-MISC -                             20800000
216200          (P-NEW-PASS-AMT-DIR-MED-ED * 1.00)) * B-LOS.            20810004
216300                                                                  20820000
216400***  COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =                    20830000
216500***          P-NEW-PASS-AMT-PLUS-MISC  * B-LOS.                   20840000
216600                                                                  20850000
216700        IF B-DISCHARGE-DATE < 20020101                            20860000
216800           COMPUTE PPS-OPER-IME-ADJ ROUNDED =                     20870000
216900                   PPS-OPER-IME-ADJ * .2                          20880000
217000        ELSE                                                      20890000
217100           COMPUTE PPS-OPER-IME-ADJ ROUNDED =                     20900000
217200                   PPS-OPER-IME-ADJ * .0.                         20910000
217300                                                                  20920000
217400                                                                  20930000
217500 3900A-CALC-OPER-DSH.                                             20940000
217600***********************************************************       20950000
217700***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001            20960000
217800***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001            20970000
217900                                                                  20980000
218000      MOVE 0.0000 TO H-OPER-DSH.                                  20990000
218100                                                                  21000000
218200      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO           21010000
218300                                     + P-NEW-MEDICAID-RATIO).     21020000
218400                                                                  21030000
218500***********************************************************       21040000
218600*****    0-99 BEDS                                                21050000
218700      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100           21060000
218800                               AND H-WK-OPER-DSH > .1499          21070000
218900                               AND H-WK-OPER-DSH < .1923          21080000
219000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        21090000
219100                                      * .65 + .025.               21100000
219200                                                                  21110000
219300      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100           21120000
219400                               AND H-WK-OPER-DSH > .1922          21130000
219500             MOVE .0525 TO H-OPER-DSH.                            21140000
219600                                                                  21150000
219700***********************************************************       21160000
219800*****   100 + BEDS                                                21170000
219900                                                                  21180000
220000      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99            21190000
220100                               AND H-WK-OPER-DSH > .1499          21200000
220200                               AND H-WK-OPER-DSH < .2021          21210000
220300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        21220000
220400                                      * .65 + .025.               21230000
220500                                                                  21240000
220600      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99            21250000
220700                               AND H-WK-OPER-DSH > .202           21260000
220800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       21270000
220900                                      * .825 + .0588.             21280000
221000                                                                  21290000
221100***********************************************************       21300000
221200*****   OTHER RURAL HOSPITALS LESS THEN 500 BEDS                  21310000
221300                                                                  21320000
221400      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500           21330000
221500                               AND H-WK-OPER-DSH > .1499          21340000
221600                               AND H-WK-OPER-DSH < .1923          21350000
221700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        21360000
221800                                 * .65 + .025.                    21370000
221900                                                                  21380000
222000      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500           21390000
222100                               AND H-WK-OPER-DSH > .1922          21400000
222200        MOVE .0525 TO H-OPER-DSH.                                 21410000
222300                                                                  21420000
222400***********************************************************       21430000
222500*****   OTHER RURAL HOSPITALS 500 BEDS +                          21440000
222600                                                                  21450000
222700      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499           21460000
222800                               AND H-WK-OPER-DSH > .1499          21470000
222900                               AND H-WK-OPER-DSH < .2021          21480000
223000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)        21490000
223100                                 * .65 + .025.                    21500000
223200                                                                  21510000
223300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499           21520000
223400                               AND H-WK-OPER-DSH > .202           21530000
223500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)       21540000
223600                                 * .825 + .0588.                  21550000
223700                                                                  21560000
223800***********************************************************       21570000
223900*****   RURAL HOSPITALS SCH                                       21580000
224000                                                                  21590000
224100      IF W-SIZE = 'R'                                             21600000
224200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  21610000
224300                               AND H-WK-OPER-DSH > .1499          21620000
224400                               AND H-WK-OPER-DSH < .1923          21630000
224500         COMPUTE H-OPER-DSH-SCH ROUNDED = (H-WK-OPER-DSH - .15)   21640000
224600                                 * .65 + .025                     21650000
224700         MOVE H-OPER-DSH-SCH TO H-OPER-DSH.                       21660000
224800      IF W-SIZE = 'R'                                             21670000
224900         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  21680000
225000                               AND H-WK-OPER-DSH > .1922          21690000
225100                               AND H-WK-OPER-DSH < .3000          21700000
225200         MOVE .0525 TO H-OPER-DSH-SCH                             21710000
225300                       H-OPER-DSH.                                21720000
225400      IF W-SIZE = 'R'                                             21730000
225500         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')  21740000
225600                               AND H-WK-OPER-DSH > .2999          21750000
225700         MOVE .10 TO H-OPER-DSH-SCH                               21760000
225800                     H-OPER-DSH.                                  21770000
225900***********************************************************       21780000
226000*****   RURAL HOSPITALS RRC                                       21790000
226100                                                                  21800000
226200      IF W-SIZE = 'R'                                             21810000
226300         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')          21820000
226400                               AND H-WK-OPER-DSH > .1499          21830000
226500                               AND H-WK-OPER-DSH < .1923          21840000
226600         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .15)   21850000
226700                                 * .65 + .025.                    21860000
226800      IF W-SIZE = 'R'                                             21870000
226900         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')          21880000
227000                               AND H-WK-OPER-DSH > .1922          21890000
227100                               AND H-WK-OPER-DSH < .3000          21900000
227200         MOVE .0525 TO H-OPER-DSH-RRC.                            21910000
227300                                                                  21920000
227400      IF W-SIZE = 'R'                                             21930000
227500         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')          21940000
227600                               AND H-WK-OPER-DSH > .2999          21950000
227700         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .30)   21960000
227800                                 * .60 + .0525.                   21970000
227900                                                                  21980000
228000***********************************************************       21990000
228100*****   RURAL HOSPITALS BOTH SCH AND RRC                          22000000
228200                                                                  22010000
228300      IF W-SIZE = 'R'                                             22020000
228400         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')                  22030000
228500                MOVE H-OPER-DSH-RRC TO H-OPER-DSH                 22040000
228600             IF H-OPER-DSH-SCH > H-OPER-DSH-RRC                   22050000
228700                MOVE H-OPER-DSH-SCH TO H-OPER-DSH.                22060000
228800                                                                  22070000
228900***********************************************************       22080000
229000*** RRC ONLY                                                      22090000
229100      IF W-SIZE = 'R'                                             22100000
229200         IF (P-NEW-PROVIDER-TYPE = '07')                          22110000
229300                MOVE H-OPER-DSH-RRC TO H-OPER-DSH.                22120000
229400                                                                  22130000
229500***********************************************************       22140000
229600                                                                  22150000
229700      MOVE 0.9700 TO H-DSH-REDUCT-FACTOR.                         22160000
229800                                                                  22170000
229900      COMPUTE H-OPER-DSH ROUNDED =                                22180000
230000                        H-OPER-DSH * H-DSH-REDUCT-FACTOR.         22190000
230100                                                                  22200000
230200                                                                  22210000
230300******        L A S T   S O U R C E   S T A T E M E N T   *****   22220000
