000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL026.
000300*AUTHOR.            DDS TEAM.
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL026      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C02.6'.
002000***************************************************************
002100*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO         *
002200*     - CHANGE THE HMO-FLAG 01 TO THE VALUE OF 'Y'
002300*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983
002400*        BEFORE YOU COMPILE AND LINK THIS PROGRAM
002500*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH
002600*        AN HMO ADJUSTMENT
002700***************************************************************
002800 01  HMO-FLAG                       PIC X      VALUE 'N'.
002900 01  HMO-TAG                        PIC X      VALUE SPACE.
003000 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
003100 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
003200 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
003300 01  R1                             PIC S9(04) COMP SYNC.
003400 01  R2                             PIC S9(04) COMP SYNC.
003500 01  R3                             PIC S9(04) COMP SYNC.
003600 01  R4                             PIC S9(04) COMP SYNC.
003700
003800 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).
003900 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).
004000***************************************************************
004100*    LAYUP TABLE AREA FOR FY2002 RATES                        *
004200***************************************************************
004300***************************************************************
004400 01  RATE-TABLE.
004500     02  RATE-WORK.
004600*RATE 20011001 REGION  LABOR AND NON-LABOR RATES
004700*                  R3=1     /     R3=2
004800*               LARGE URBAN / OTHER URBAN
004900*               LABOR / NON / LABOR / NON
005000*                     /LABOR/       /LABOR
005100*             --------------------------------------------
005200         05  FILLER PIC X(08) VALUE '20011001'.
005300         05  NAT    PIC X(30) VALUE
005400            ' 0295544 120130 0290865 118227'.
005500         05  PR     PIC X(30) VALUE
005600            ' 0142007 057161 0139759 056256'.
005700         05  NATPR  PIC X(30) VALUE
005800            ' 0292957 119078 0292957 119078'.
005900*************************************************************
006000     02  RATE-TAB REDEFINES RATE-WORK.
006100         05  RATE-PERIOD            OCCURS 1.
006200             10  RATE-EFF-DATE      PIC X(08).
006300             10  REG-NAT            OCCURS 3.
006400                 15  R-LARGE-OTHER  OCCURS 2.
006500                     20  FILLER     PIC X(01).
006600                     20  REG-LABOR  PIC 9(05)V9(02).
006700                     20  FILLER     PIC X(01).
006800                     20  REG-NLABOR PIC 9(04)V9(02).
006900
007000
007100***************************************************************
007200*    LAYUP TABLE AREA FOR FY2002 DRGS                         *
007300***************************************************************
007400 01  DRG-TABLE.
007500     05  D-TAB.
007600       10  FILLER                  PIC X(08) VALUE
007700      '20011001'.
007800       10  FILLER                  PIC X(56) VALUE
007900     '03271307632102033874088331110195941273712702414805530081'.
008000       10  FILLER                  PIC X(56) VALUE
008100     '01362802322032007230021210300262850833211101395302022029'.
008200       10  FILLER                  PIC X(56) VALUE
008300     '01335005229069012690055290720084710332704300902004929063'.
008400       10  FILLER                  PIC X(56) VALUE
008500     '00812904526055011655048290610073490301903701186705129065'.
008600       10  FILLER                  PIC X(56) VALUE
008700     '00668902719034009744046290580067560302103802776409033114'.
008800       10  FILLER                  PIC X(56) VALUE
008900     '01457305530071010037040280510080690342704401017204028053'.
009000       10  FILLER                  PIC X(56) VALUE
009100     '00594702718033005981024160300135140372805601360905229068'.
009200       10  FILLER                  PIC X(56) VALUE
009300     '00695603022038003314020170200091650352804800523002014026'.
009400       10  FILLER                  PIC X(56) VALUE
009500     '00208201609016010074042280540058850271903500661501205015'.
009600       10  FILLER                  PIC X(56) VALUE
009700     '01130002927043004751020160260059860151001900826402426036'.
009800       10  FILLER                  PIC X(56) VALUE
009900     '00337401607016006302016140230045780281603300655404325052'.
010000       10  FILLER                  PIC X(56) VALUE
010100     '00676002717033007962039280500050430272003400297202927029'.
010200       10  FILLER                  PIC X(56) VALUE
010300     '01764903828051008158015090190078950181802700759001509019'.
010400       10  FILLER                  PIC X(56) VALUE
010500     '01177302326037004817032220320084830181902700878702018027'.
010600       10  FILLER                  PIC X(56) VALUE
010700     '01200402827043002735015040150082760191902800208301504015'.
010800       10  FILLER                  PIC X(56) VALUE
010900     '01354103327057002950013050130137180332704701231904829068'.
011000       10  FILLER                  PIC X(56) VALUE
011100     '00532602415029005536026190330075140302003700666503621043'.
011200       10  FILLER                  PIC X(56) VALUE
011300     '00494802816034004575025150300066850312304000669902921037'.
011400       10  FILLER                  PIC X(56) VALUE
011500     '00799303628047003352021200210320960883310803012910134127'.
011600       10  FILLER                  PIC X(56) VALUE
011700     '01241604128055013295063280720170940763209300921505029060'.
011800       10  FILLER                  PIC X(56) VALUE
011900     '01517706130061014316060300760098030482905900545402818035'.
012000       10  FILLER                  PIC X(56) VALUE
012100     '01248305529069006769030230380142820553006900912704525054'.
012200       10  FILLER                  PIC X(56) VALUE
012300     '01060105328063006344037180430079370382404701229605630068'.
012400       10  FILLER                  PIC X(56) VALUE
012500     '00744303522043012024054290690058170322003900760404122049'.
012600       10  FILLER                  PIC X(56) VALUE
012700     '00563603218038007496031270460069640262003300518601811022'.
012800       10  FILLER                  PIC X(56) VALUE
012900     '00860403627047005207021150272024133926358507841113237153'.
013000       10  FILLER                  PIC X(56) VALUE
013100     '05679608833104074396107351230531250973410905532509233112'.
013200       10  FILLER                  PIC X(56) VALUE
013300     '03901707027080041576081321030228650432605100000000000000'.
013400       10  FILLER                  PIC X(56) VALUE
013500     '02671409834129016809073310940338220723109202264803628049'.
013600       10  FILLER                  PIC X(56) VALUE
013700     '01335102827045014339018190270135780332705302355206731099'.
013800       10  FILLER                  PIC X(56) VALUE
013900     '01578705630069010241032210390158830322705001407203628046'.
014000       10  FILLER                  PIC X(56) VALUE
014100     '01040602217028026836105351300101030452905600732005223059'.
014200       10  FILLER                  PIC X(56) VALUE
014300     '01020901720028009379050290610057250382204500647302517031'.
014400       10  FILLER                  PIC X(56) VALUE
014500     '00555801912023005814027180340091280372804800564302215028'.
014600       10  FILLER                  PIC X(56) VALUE
014700     '00817703327033008222033240420049610211302500533502214027'.
014800       10  FILLER                  PIC X(56) VALUE
014900     '00724103021038005395022140270051910171002101201504328058'.
015000       10  FILLER                  PIC X(56) VALUE
015100     '00589902216028027764096341090159930622006703533211135131'.
015200       10  FILLER                  PIC X(56) VALUE
015300     '01506306219067029483105341220134510532906301947707431087'.
015400       10  FILLER                  PIC X(56) VALUE
015500     '01164205118056043519119361470132730342704500842106030060'.
015600       10  FILLER                  PIC X(56) VALUE
015700     '01259904428059006209020140250136180422805400765502214027'.
015800       10  FILLER                  PIC X(56) VALUE
015900     '01137503227045006121016090190069090211102102396007832090'.
016000       10  FILLER                  PIC X(56) VALUE
016100     '01290404519050014934042280540087530221202601298203628052'.
016200       10  FILLER                  PIC X(56) VALUE
016300     '00696401813023030540094331250117160382804801398505930076'.
016400       10  FILLER                  PIC X(56) VALUE
016500     '00693303025039009896041250510054190261403001088804428056'.
016600       10  FILLER                  PIC X(56) VALUE
016700     '00891003923048006408027150320108680512906400956504629057'.
016800       10  FILLER                  PIC X(56) VALUE
016900     '00523703017035007940036260460055680241603000414102515030'.
017000       10  FILLER                  PIC X(56) VALUE
017100     '00866003628048003210029230290078680322704201125004629060'.
017200       10  FILLER                  PIC X(56) VALUE
017300     '00577602519033011897045290740461991223615501825506030071'.
017400       10  FILLER                  PIC X(56) VALUE
017500     '03508511636136017294063300730308630943310901611105324060'.
017600       10  FILLER                  PIC X(56) VALUE
017700     '02574808132096012062042180470250700843210903181108533120'.
017800       10  FILLER                  PIC X(56) VALUE
017900     '03798612336156013291055290700136270573007301204704929062'.
018000       10  FILLER                  PIC X(56) VALUE
018100     '01220705229067007302032240410111200432805500638002417030'.
018200       10  FILLER                  PIC X(56) VALUE
018300     '01991704616051017503061260690122360461505000845711135111'.
018400       10  FILLER                  PIC X(56) VALUE
018500     '01943707732100000000000000000000000000000002317208532109'.
018600       10  FILLER                  PIC X(56) VALUE
018700     '03200511035152015499047280580099500281503300583405329053'.
018800       10  FILLER                  PIC X(56) VALUE
018900     '00000000000000000000000000000097230211802900769701608019'.
019000       10  FILLER                  PIC X(56) VALUE
019100     '01116403828053015902052290730079220211602701090602727040'.
019200       10  FILLER                  PIC X(56) VALUE
019300     '00714201915025013598039280580143400362805400953201821029'.
019400       10  FILLER                  PIC X(56) VALUE
019500     '02094506330084012097027230360076320412805500688903928049'.
019600       10  FILLER                  PIC X(56) VALUE
019700     '00532503019036014154074310940100320542906701369205630073'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '00631503321040010953057300720073040402504900715204126051'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '00466502919036005717032230410055870282103600816004127051'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '00678402727039006809035230430045820241602900253301815018'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '00739704026050004294028160330029510292702900815204228054'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '00878302214028006954017070190087630181802700643501304014'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '00924001713023008487030270430205700913312301107905630073'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '01679505229076008414024230340094060332704501236802527037'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '01773106931092007806025270360103650623007701024805229067'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '00563803423042011927055300730066470312704600703304027050'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00853405127061005487038190450066320422404200694103524044'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00459302517031002565022190220071520382804900420402518032'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '02129709133114022343053290690195690893311702159004926060'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '00957301922030008862017120230059640150801802689208833116'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '01305904328059007608038270490074570312103900861504328055'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '00504702918035004155023180300092230442805701124305329066'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '00607803020038033278079320930248840753109002461807431097'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '01150203119038012988043280620060500191002201689604829069'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '00893601812023011366033270470059570150801801078203327048'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '00658401814023004944023260230215500482908301374505630073'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '00613002020029011723051290660058520211802800859304627056'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '00556003318039005267036200430079700252103300442201608019'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '00633603123040004120021150270036970281803200726802925039'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00445801610020003185016090160106400462906000605602621034'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '00790703928053015177043190500110470311003300863002820036'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '00586101908021012191037280560115550332705000283002413024'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '01130602021030007852025190330015380170601701174101614024'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '00914902727040010304049290640056600231903000699803426044'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '00412802015025007164038230460023600130501300686803027042'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '01849305429068015317051260610090330310903300744002010023'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '02438007532092011902037180440081650260802800852002413029'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '01096402119030003017014050140081580262103600817002927041'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '02000805830081012699056300740057670242003201135505630070'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '00558102522034010572047280610068450331103700555002714033'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '00377402007023006835025140310057590210802300496302517032'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '01689203828056008017020130240045210242403600420101612021'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '00662801815025001599012030130049150282503800362601612021'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '01374301826018045319179421790309521333713301867608633086'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '03179409333160011253035270430015240311103103389208332108'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '01346209133091018231051290810081920352804701040703928050'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '01267104228056013082051290640066750302003702934607431105'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '02990509934128011594031270440185790683109100871803427046'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '01908604929049029939084321110124260382404702214406030092'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '01157504929063009991033220410044810181402300595801915024'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '01389406130078007418035280460390671263716301622606430081'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '00891504428054010493053290660086180402605000611203018036'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '00664003221039004757026160310183650673109002451810935159'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '00678903226042005261035280470053480352805000724205029078'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '00836705229069007676067310890064160512907100710003427051'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '00288802321032000000000000000000000000000000000000000000'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '00000000000000000000000000000193320673109502080607231103'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '00929502324033025304068310960099200272303600727703426044'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '00471602416030002959024220240048250181502500097302917029'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '00830902827040004139016100200026270211702101012203828052'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '00498002217028008692034270490046300191602600000000000000'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00000000000000000000000000000000000000000000000000000000'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '01196302526046012125104341230068000342404300462802517031'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00544502123031006416023260380045850212303103875611435147'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '00000000000000000000000000000300670501905700000000000000'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '03932409834151000000000000000392531003412702291510034123'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '01956806731093024161059300820139000282303610981218142239'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '08043823648258038583114351431546293425841505296311736149'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '03172408533105052888110351430195850633008205196514939197'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '01894807031094010584043280580163530301503504888613638190'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '01841104929063009754019140240882521383816205728108633105'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '03232405827069023026039140430145070382805000938502214026'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '02748509834119015544059280690122910332404214172928853347'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '01499402026034049233157401990185830733109301296706130083'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '00726503728049013681058300800076560362805205781312737149'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '05840009734111063663067310880499050422806702747504125050'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '02137901918027016989025260370232490382805601419501711022'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '00735505029064006249086331040039970352204300000000000000'.
034000     05  DRGX-TAB REDEFINES D-TAB.
034100         10  DRGX-PERIOD               OCCURS 1
034200                                        INDEXED BY DX5.
034300             15  DRGX-EFF-DATE         PIC X(08).
034400             15  DRG-DATA              OCCURS 524
034500                                        INDEXED BY DX6.
034600                 20  DRG-WT            PIC 9(02)V9(04).
034700                 20  DRG-ALOS          PIC 9(02)V9(01).
034800                 20  DRG-DAYS-TRIM     PIC 9(02).
034900                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
035000
035100 01  HOLD-AREA.
035200     02  HOLD-PPS-COMPONENTS.
035300         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
035400         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
035500
035600         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
035700         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
035800
035900         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
036000         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
036100         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
036200
036300         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
036400         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
036500         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
036600
036700         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
036800         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
036900
037000         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
037100         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
037200
037300         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
037400         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
037500
037600
037700         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
037800         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
037900         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
038000         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
038100         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
038200         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
038300         05  H-CAPI-COLA                  PIC 9(01)V9(03).
038400         05  H-CAPI-SCH                   PIC 9(05)V9(02).
038500         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
038600         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
038700         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
038800         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
038900         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
039000         05  H-CAPI-GAF                   PIC 9(05)V9(04).
039100         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
039200         05  H-BLEND-GAF                  PIC 9(05)V9(04).
039300         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
039400         05  H-COV-DAYS                   PIC 9(3).
039500         05  H-PERDIEM-DAYS               PIC 9(3).
039600         05  H-REG-DAYS                   PIC 9(3).
039700         05  H-LTR-DAYS                   PIC 9(3).
039800         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
039900         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
040000         05  H-ALOS                       PIC 9(02)V9(01).
040100         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
040200         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
040300         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
040400         05  H-CST-THRESH                 PIC 9(05)V9(02).
040500         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
040600         05  H-BUDG-NUTR93                PIC 9(01)V9(06).
040700         05  H-BUDG-NUTR94                PIC 9(01)V9(06).
040800         05  H-BUDG-NUTR95                PIC 9(01)V9(06).
040900         05  H-BUDG-NUTR96                PIC 9(01)V9(06).
041000         05  H-BUDG-NUTR97                PIC 9(01)V9(06).
041100         05  H-BUDG-NUTR98                PIC 9(01)V9(06).
041200         05  H-BUDG-NUTR99                PIC 9(01)V9(06).
041300         05  H-BUDG-NUTR00                PIC 9(01)V9(06).
041400         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
041500         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
041600         05  H-UPDATE-95                  PIC 9(01)V9(04).
041700         05  H-UPDATE-96                  PIC 9(01)V9(04).
041800         05  H-UPDATE-97                  PIC 9(01)V9(04).
041900         05  H-UPDATE-98                  PIC 9(01)V9(04).
042000         05  H-UPDATE-99                  PIC 9(01)V9(04).
042100         05  H-UPDATE-00                  PIC 9(01)V9(04).
042200         05  H-UPDATE-01                  PIC 9(01)V9(04).
042300         05  H-UPDATE-02                  PIC 9(01)V9(04).
042400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
042500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
042600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
042700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
042800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
042900         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
043000         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
043100         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
043200         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
043300         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
043400         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
043500         05  H-LABOR-PCT                  PIC 9(01)V9(04).
043600         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
043700         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
043800         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
043900         05  H-HSP-RATE                   PIC 9(06)V9(09).
044000         05  H-FSP-RATE                   PIC 9(06)V9(09).
044100         05  H-OUTLIER-FACT               PIC 9(01)V9(06).
044200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
044300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
044400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
044500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
044600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
044700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
044800
044900
045000     02  HOLD-ADDITIONAL-VARIABLES.
045100         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
045200         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
045300         05  H-NAT-PCT                    PIC 9(01)V9(02).
045400         05  H-REG-PCT                    PIC 9(01)V9(02).
045500         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
045600         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
045700         05  H-DRG-WT                     PIC 9(02)V9(04).
045800         05  H-NAT-LABOR                  PIC 9(05)V9(02).
045900         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
046000         05  H-REG-LABOR                  PIC 9(05)V9(02).
046100         05  H-REG-NONLABOR               PIC 9(05)V9(02).
046200         05  H-OPER-COLA                  PIC 9(01)V9(03).
046300         05  H-INTERN-RATIO               PIC 9(01)V9(04).
046400         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
046500         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
046600         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
046700
046800     02  HOLD-CAPITAL-VARIABLES.
046900         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
047000         05  H-CAPI-HSP                   PIC 9(07)V9(02).
047100         05  H-CAPI-FSP                   PIC 9(07)V9(02).
047200         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
047300         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
047400         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
047500         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
047600         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
047700
047800     02  HOLD-CAPITAL2-VARIABLES.
047900         05  H-CAPI2-PAY-CODE             PIC X(1).
048000         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
048100         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
048200
048300     02  HOLD-OTHER-VARIABLES.
048400         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
048500         05  FILLER                       PIC X(30).
048600
048700     02  HOLD-PC-OTH-VARIABLES.
048800         05  H-OPER-DSH                   PIC 9(01)V9(04).
048900         05  H-CAPI-DSH                   PIC 9(01)V9(04).
049000         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
049100         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
049200         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
049300         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
049400         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
049500         05  H-PC-HMO-FLAG                PIC X(01).
049600         05  H-PC-COT-FLAG                PIC X(01).
049700         05  H-FILLER                     PIC X(09).
049800
049900 LINKAGE SECTION.
050000***************************************************************
050100*                 * * * * * * * * *                           *
050200*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
050300*    IN HOW TO PAY THE BILL.                                  *
050400*                         *****                               *
050500*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
050600*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
050700*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
050800*                 OUTLIER COMPUTATION.                        *
050900*                         *****                               *
051000*         REVIEW-CODE:                                        *
051100*            00 = PAY-WITH-OUTLIER.                           *
051200*                 WILL CALCULATE THE STANDARD PAYMENT.        *
051300*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
051400*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
051500*            03 = PAY-PERDIEM-DAYS.                           *
051600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
051700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
051800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
051900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
052000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
052100*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
052200*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
052300*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
052400*                 BILL EXCEED THE COST THRESHOLD.             *
052500*            06 = PAY-XFER-NO-COST                            *
052600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
052700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
052800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
052900*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
053000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
053100*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
053200*                 CALCULATE ANY COST OUTLIER PORTION          *
053300*                 OF THE PAYMENT.                             *
053400*            07 = PAY-WITHOUT-COST.                           *
053500*                 WILL CALCULATE THE STANDARD PAYMENT         *
053600*                 WITHOUT COST PORTION.                       *
053700*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
053800*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *
053900*                 429,483.      POST-ACUTE TRANSFERS          *
054000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
054100*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
054200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
054300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
054400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
054500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
054600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
054700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
054800*                 BILL EXCEED THE COST THRESHOLD.             *
054900*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
055000*                 POST-ACUTE TRANSFERS                        *
055100*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *
055200*                 429,483.      POST-ACUTE TRANSFERS          *
055300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
055400*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
055500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
055600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
055700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
055800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
055900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
056000*                 PAYMENT.                                    *
056100***************************************************************
056200
056300**************************************************************
056400*      MILLINNIUM COMPATIBLE                                 *
056500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
056600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
056700*      IN THE NEW FORMAT                                     *
056800**************************************************************
056900 01  BILL-NEW-DATA.
057000         10  B-NPI10.
057100             15  B-NPI8             PIC X(08).
057200             15  B-NPI-FILLER       PIC X(02).
057300         10  B-PROVIDER-NO          PIC X(06).
057400         10  B-REVIEW-CODE          PIC 9(02).
057500             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
057600             88  PAY-WITH-OUTLIER     VALUE 00 07.
057700             88  PAY-PERDIEM-DAYS     VALUE 03.
057800             88  PAY-XFER-NO-COST     VALUE 06.
057900             88  PAY-WITHOUT-COST     VALUE 07.
058000             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
058100             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
058200         10  B-DRG                  PIC 9(03).
058300         10  B-LOS                  PIC 9(03).
058400         10  B-COVERED-DAYS         PIC 9(03).
058500         10  B-LTR-DAYS             PIC 9(02).
058600         10  B-DISCHARGE-DATE.
058700             15  B-DISCHG-CC        PIC 9(02).
058800             15  B-DISCHG-YY        PIC 9(02).
058900             15  B-DISCHG-MM        PIC 9(02).
059000             15  B-DISCHG-DD        PIC 9(02).
059100         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
059200         10  B-PRIN-PROC-CODE       PIC X(07).
059300         10  B-OTHER-PROC-CODE1     PIC X(07).
059400         10  B-OTHER-PROC-CODE2     PIC X(07).
059500         10  B-OTHER-PROC-CODE3     PIC X(07).
059600         10  B-OTHER-PROC-CODE4     PIC X(07).
059700         10  B-OTHER-PROC-CODE5     PIC X(07).
059800         10  B-OTHER-PROC-CODE6     PIC X(07).
059900         10  B-OTHER-PROC-CODE7     PIC X(07).
060000         10  B-OTHER-PROC-CODE8     PIC X(07).
060100         10  B-OTHER-PROC-CODE9     PIC X(07).
060200         10  B-OTHER-PROC-CODE10    PIC X(07).
060300         10  B-OTHER-PROC-CODE11    PIC X(07).
060400         10  B-OTHER-PROC-CODE12    PIC X(07).
060500         10  B-OTHER-PROC-CODE13    PIC X(07).
060600         10  B-OTHER-PROC-CODE14    PIC X(07).
060700         10  B-OTHER-PROC-CODE15    PIC X(07).
060800         10  B-OTHER-PROC-CODE16    PIC X(07).
060900         10  B-OTHER-PROC-CODE17    PIC X(07).
061000         10  B-OTHER-PROC-CODE18    PIC X(07).
061100         10  B-OTHER-PROC-CODE19    PIC X(07).
061200         10  B-OTHER-PROC-CODE20    PIC X(07).
061300         10  B-OTHER-PROC-CODE21    PIC X(07).
061400         10  B-OTHER-PROC-CODE22    PIC X(07).
061500         10  B-OTHER-PROC-CODE23    PIC X(07).
061600         10  B-OTHER-PROC-CODE24    PIC X(07).
061700         10  B-OTHER-DIAG-CODE1     PIC X(07).
061800         10  B-OTHER-DIAG-CODE2     PIC X(07).
061900         10  B-OTHER-DIAG-CODE3     PIC X(07).
062000         10  B-OTHER-DIAG-CODE4     PIC X(07).
062100         10  B-OTHER-DIAG-CODE5     PIC X(07).
062200         10  B-OTHER-DIAG-CODE6     PIC X(07).
062300         10  B-OTHER-DIAG-CODE7     PIC X(07).
062400         10  B-OTHER-DIAG-CODE8     PIC X(07).
062500         10  B-OTHER-DIAG-CODE9     PIC X(07).
062600         10  B-OTHER-DIAG-CODE10    PIC X(07).
062700         10  B-OTHER-DIAG-CODE11    PIC X(07).
062800         10  B-OTHER-DIAG-CODE12    PIC X(07).
062900         10  B-OTHER-DIAG-CODE13    PIC X(07).
063000         10  B-OTHER-DIAG-CODE14    PIC X(07).
063100         10  B-OTHER-DIAG-CODE15    PIC X(07).
063200         10  B-OTHER-DIAG-CODE16    PIC X(07).
063300         10  B-OTHER-DIAG-CODE17    PIC X(07).
063400         10  B-OTHER-DIAG-CODE18    PIC X(07).
063500         10  B-OTHER-DIAG-CODE19    PIC X(07).
063600         10  B-OTHER-DIAG-CODE20    PIC X(07).
063700         10  B-OTHER-DIAG-CODE21    PIC X(07).
063800         10  B-OTHER-DIAG-CODE22    PIC X(07).
063900         10  B-OTHER-DIAG-CODE23    PIC X(07).
064000         10  B-OTHER-DIAG-CODE24    PIC X(07).
064100         10  B-OTHER-DIAG-CODE25    PIC X(07).
064200         10  BILL-DEMO-DATA.
064300             15  BILL-DEMO-CODE1        PIC X(02).
064400             15  BILL-DEMO-CODE2        PIC X(02).
064500             15  BILL-DEMO-CODE3        PIC X(02).
064600             15  BILL-DEMO-CODE4        PIC X(02).
064700         10  BILL-NDC-DATA.
064800             15  BILL-NDC-NUMBER        PIC X(11).
064900         10  FILLER                     PIC X(73).
065000
065100
065200***************************************************************
065300*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
065400*    AND PASSED BACK TO THE CALLING PROGRAM                   *
065500*            RETURN CODE VALUES (PPS-RTC)                     *
065600*                                                             *
065700*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
065800*              00 = PAID NORMAL DRG PAYMENT                   *
065900*                                                             *
066000*              01 = PAID AS A DAY-OUTLIER.                    *
066100*                   NOTE:                                     *
066200*                     DAY-OUTLIER NO LONGER BEING PAID        *
066300*                         AS OF 10/01/97                      *
066400*                                                             *
066500*              02 = PAID AS A COST-OUTLIER.                   *
066600*                                                             *
066700*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
066800*                   AND INCLUDING THE FULL DRG.               *
066900*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
067000*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
067100*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
067200*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
067300*                   AND INCLUDING THE FULL DRG. PROVIDER      *
067400*                   REFUSED COST OUTLIER.                     *
067500*              10 = DRG IS 209, 210 OR 211 AND                *
067600*                   POST-ACUTE TRANSFER                       *
067700*              12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *
067800*                       THE FOLLOWING DRG'S                   *
067900*                   14,113,236,263,264,429,483                *
068000*              14 = PAID NORMAL DRG PAYMENT WITH              *
068100*                    PERDIEM DAYS = OR > GM  ALOS             *
068200*              16 = PAID AS A COST-OUTLIER WITH               *
068300*                    PERDIEM DAYS = OR > GM  ALOS             *
068400*                                                             *
068500*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
068600*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
068700*              52 = INVALID MSA # IN PROVIDER FILE            *
068800*                   OR INVALID WAGE INDEX                     *
068900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
069000*              54 = DRG < 001 OR > 523, OR = 214 OR = 215     *
069100*                                       OR = 221 OR = 222     *
069200*                                       OR = 112              *
069300*                                       OR = 434 OR = 435     *
069400*                                       OR = 436 OR = 437     *
069500*                                       OR = 438 OR = 456     *
069600*                                       OR = 457 OR = 458     *
069700*                                       OR = 459 OR = 460     *
069800*                                       OR = 469 OR = 470     *
069900*                                       OR = 472 OR = 474     *
070000*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
070100*                                      OR                     *
070200*                   DISCHARGE DATE < MSA EFF START DATE       *
070300*                   FOR PPS                                   *
070400*                                      OR                     *
070500*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
070600*                   DISCHARGE DATE                            *
070700*              56 = INVALID LENGTH OF STAY                    *
070800*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
070900*                                        NOT 11)              *
071000*              58 = TOTAL CHARGES NOT NUMERIC                 *
071100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
071200*                   OR BILL-LTR-DAYS > 60                     *
071300*              62 = INVALID NUMBER OF COVERED DAYS            *
071400*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
071500*                   SPECIFIC FILE FOR CAPITAL                 *
071600*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
071700*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
071800*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
071900***************************************************************
072000 01  PPS-DATA.
072100         10  PPS-RTC                PIC 9(02).
072200         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
072300         10  PPS-OUTLIER-DAYS       PIC 9(03).
072400         10  PPS-AVG-LOS            PIC 9(02)V9(01).
072500         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
072600         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
072700         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
072800         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
072900         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
073000         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
073100         10  PPS-REG-DAYS-USED      PIC 9(03).
073200         10  PPS-LTR-DAYS-USED      PIC 9(02).
073300         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
073400         10  PPS-CALC-VERS          PIC X(05).
073500
073600******************************************************************
073700*            THESE ARE THE VERSIONS OF THE PPCAL
073800*           PROGRAMS THAT WILL BE PASSED BACK----
073900*          ASSOCIATED WITH THE BILL BEING PROCESSED
074000******************************************************************
074100 01  PRICER-OPT-VERS-SW.
074200     02  PRICER-OPTION-SW          PIC X(01).
074300         88  ALL-TABLES-PASSED          VALUE 'A'.
074400         88  PROV-RECORD-PASSED         VALUE 'P'.
074500         88  ADDITIONAL-VARIABLES       VALUE 'M'.
074600         88  PC-PRICER                  VALUE 'C'.
074700     02  PPS-VERSIONS.
074800         10  PPDRV-VERSION         PIC X(05).
074900
075000******************************************************************
075100*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
075200*          ASSOCIATED WITH THE BILL BEING PROCESSED
075300******************************************************************
075400 01  PPS-ADDITIONAL-VARIABLES.
075500     05  PPS-HSP-PCT                PIC 9(01)V9(02).
075600     05  PPS-FSP-PCT                PIC 9(01)V9(02).
075700     05  PPS-NAT-PCT                PIC 9(01)V9(02).
075800     05  PPS-REG-PCT                PIC 9(01)V9(02).
075900     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
076000     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
076100     05  PPS-DRG-WT                 PIC 9(02)V9(04).
076200     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
076300     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
076400     05  PPS-REG-LABOR              PIC 9(05)V9(02).
076500     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
076600     05  PPS-OPER-COLA              PIC 9(01)V9(03).
076700     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
076800     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
076900     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
077000     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
077100     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
077200     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
077300     05  PPS-CAPITAL-VARIABLES.
077400         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
077500         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
077600         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
077700         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
077800         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
077900         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
078000         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
078100         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
078200     05  PPS-CAPITAL2-VARIABLES.
078300         10  PPS-CAPI2-PAY-CODE             PIC X(1).
078400         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
078500         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
078600
078700     05  PPS-OTHER-VARIABLES.
078800         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
078900         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
079000         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
079100         10  PPS-HVBP-HRR-DATA.
079200             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
079300             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
079400             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
079500             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
079600         10  PPS-OPERATNG-DATA.
079700             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
079800             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
079900             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
080000
080100     05  PPS-PC-OTH-VARIABLES.
080200         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
080300         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
080400         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
080500         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
080600         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
080700         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
080800         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
080900         10  PPS-PC-HMO-FLAG                PIC X(01).
081000         10  PPS-PC-COT-FLAG                PIC X(01).
081100         10  PPS-FILLER                     PIC X(0998).
081200
081300**************************************************************
081400*      MILLINNIUM COMPATIBLE                                 *
081500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *
081600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
081700*      IN THE NEW FORMAT                                     *
081800**************************************************************
081900 01  PROV-NEW-HOLD.
082000     02  PROV-NEWREC-HOLD1.
082100         05  P-NEW-NPI10.
082200             10  P-NEW-NPI8             PIC X(08).
082300             10  P-NEW-NPI-FILLER       PIC X(02).
082400         05  P-NEW-PROVIDER-NO.
082500             10  P-NEW-STATE            PIC 9(02).
082600             10  FILLER                 PIC X(04).
082700         05  P-NEW-DATE-DATA.
082800             10  P-NEW-EFF-DATE.
082900                 15  P-NEW-EFF-DT-CC    PIC 9(02).
083000                 15  P-NEW-EFF-DT-YY    PIC 9(02).
083100                 15  P-NEW-EFF-DT-MM    PIC 9(02).
083200                 15  P-NEW-EFF-DT-DD    PIC 9(02).
083300             10  P-NEW-FY-BEGIN-DATE.
083400                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
083500                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
083600                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
083700                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
083800             10  P-NEW-REPORT-DATE.
083900                 15  P-NEW-REPORT-DT-CC PIC 9(02).
084000                 15  P-NEW-REPORT-DT-YY PIC 9(02).
084100                 15  P-NEW-REPORT-DT-MM PIC 9(02).
084200                 15  P-NEW-REPORT-DT-DD PIC 9(02).
084300             10  P-NEW-TERMINATION-DATE.
084400                 15  P-NEW-TERM-DT-CC   PIC 9(02).
084500                 15  P-NEW-TERM-DT-YY   PIC 9(02).
084600                 15  P-NEW-TERM-DT-MM   PIC 9(02).
084700                 15  P-NEW-TERM-DT-DD   PIC 9(02).
084800         05  P-NEW-WAIVER-CODE          PIC X(01).
084900             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
085000         05  P-NEW-INTER-NO             PIC 9(05).
085100         05  P-NEW-PROVIDER-TYPE        PIC X(02).
085200             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
085300             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
085400                                                  '15' '17'
085500                                                  '22'.
085600             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
085700             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
085800             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
085900             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
086000             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
086100             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
086200             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
086300             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
086400             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
086500             88  P-N-EACH                   VALUE '21' '22'.
086600             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
086700             88  P-N-NHCMQ-II-SNF           VALUE '32'.
086800             88  P-N-NHCMQ-III-SNF          VALUE '33'.
086900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
087000             88  P-N-NEW-ENGLAND            VALUE  1.
087100             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
087200             88  P-N-SOUTH-ATLANTIC         VALUE  3.
087300             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
087400             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
087500             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
087600             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
087700             88  P-N-MOUNTAIN               VALUE  8.
087800             88  P-N-PACIFIC                VALUE  9.
087900         05  P-NEW-CURRENT-DIV   REDEFINES
088000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
088100             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
088200         05  P-NEW-MSA-DATA.
088300             10  P-NEW-CHG-CODE-INDEX       PIC X.
088400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
088500             10  P-NEW-GEO-LOC-MSA9   REDEFINES
088600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
088700             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
088800             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
088900             10  P-NEW-STAND-AMT-LOC-MSA9
089000       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
089100                 15  P-NEW-RURAL-1ST.
089200                     20  P-NEW-STAND-RURAL  PIC XX.
089300                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
089400                 15  P-NEW-RURAL-2ND        PIC XX.
089500         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
089600                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
089700                 88  P-NEW-SCH-YR82       VALUE   '82'.
089800                 88  P-NEW-SCH-YR87       VALUE   '87'.
089900         05  P-NEW-LUGAR                    PIC X.
090000         05  P-NEW-TEMP-RELIEF-IND          PIC X.
090100         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
090200         05  FILLER                         PIC X(05).
090300     02  PROV-NEWREC-HOLD2.
090400         05  P-NEW-VARIABLES.
090500             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
090600             10  P-NEW-COLA              PIC  9(01)V9(03).
090700             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
090800             10  P-NEW-BED-SIZE          PIC  9(05).
090900             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
091000             10  P-NEW-CMI               PIC  9(01)V9(04).
091100             10  P-NEW-SSI-RATIO         PIC  V9(04).
091200             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
091300             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
091400             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
091500             10  P-NEW-DSH-PERCENT       PIC  V9(04).
091600             10  P-NEW-FYE-DATE          PIC  X(08).
091700         05  FILLER                      PIC  X(23).
091800     02  PROV-NEWREC-HOLD3.
091900         05  P-NEW-PASS-AMT-DATA.
092000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
092100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
092200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
092300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
092400         05  P-NEW-CAPI-DATA.
092500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
092600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
092700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
092800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
092900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
093000             15  P-NEW-CAPI-NEW-HOSP       PIC X.
093100             15  P-NEW-CAPI-IME            PIC 9V9999.
093200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
093300         05  P-HVBP-HRR-DATA.
093400             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
093500             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
093600             15  P-HOSP-READMISSION-REDUCTN PIC X.
093700             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
093800         05  P-MODEL1-BUNDLE-DATA.
093900             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
094000             15  P-HAC-REDUC-IND            PIC X.
094100             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
094200             15  P-EHR-REDUC-IND            PIC X.
094300         05  FILLER                         PIC X(09).
094400
094500************************************************************
094600******************************************************************
094700*      MILLINNIUM COMPATIBLE
094800*                   THIS IS THE WAGE-INDEX
094900*          ASSOCIATED WITH THE BILL BEING PROCESSED
095000******************************************************************
095100 01  WAGE-NEW-INDEX-RECORD.
095200     05  W-MSA                         PIC X(4).
095300     05  W-SIZE                        PIC X.
095400         88  LARGE-URBAN       VALUE 'L'.
095500         88  OTHER-URBAN       VALUE 'O'.
095600         88  ALL-RURAL         VALUE 'R'.
095700     05  W-EFF-DATE                    PIC X(8).
095800     05  FILLER                        PIC X.
095900     05  W-INDEX-RECORD                PIC S9(02)V9(04).
096000     05  W-PR-INDEX-RECORD             PIC S9(02)V9(04).
096100
096200
096300 PROCEDURE DIVISION  USING BILL-NEW-DATA
096400                           PPS-DATA
096500                           PRICER-OPT-VERS-SW
096600                           PPS-ADDITIONAL-VARIABLES
096700                           PROV-NEW-HOLD
096800                           WAGE-NEW-INDEX-RECORD.
096900
097000***************************************************************
097100*    PROCESSING:                                              *
097200*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
097300*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
097400*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
097500*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
097600*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
097700*           GOBACK.                                           *
097800*        D. ASSEMBLE PRICING COMPONENTS.                      *
097900*        E. CALCULATE THE PRICE.                              *
098000***************************************************************
098100
098200     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
098300     MOVE 'N' TO TEMP-RELIEF-FLAG.
098400
098500     PERFORM 0200-MAINLINE-CONTROL.
098600
098700**************************************************************
098800***  NO LONGER PROCESSING TEMP RELIEF AS OF 100199
098900
099000***  IF P-NEW-TEMP-RELIEF-IND  = 'Y'
099100***     MOVE PPS-TOTAL-PAYMENT TO NON-TEMP-RELIEF-PAYMENT
099200***     MOVE 'Y' TO TEMP-RELIEF-FLAG
099300***     PERFORM 0200-MAINLINE-CONTROL
099400***     MOVE NON-TEMP-RELIEF-PAYMENT TO
099500***                   H-NON-TEMP-RELIEF-PAYMENT.
099600
099700**************************************************************
099800     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
099900     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
100000     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
100100     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
100200     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
100300     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
100400     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
100500     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
100600
100700     GOBACK.
100800
100900 0200-MAINLINE-CONTROL.
101000
101100     MOVE 'N' TO HMO-TAG.
101200
101300     IF PPS-PC-HMO-FLAG = 'Y' OR
101400               HMO-FLAG = 'Y'
101500        MOVE 'Y' TO HMO-TAG.
101600
101700     IF P-NEW-STATE NOT = 40
101800        MOVE ZEROES TO W-PR-INDEX-RECORD.
101900
102000     MOVE ALL '0' TO PPS-DATA
102100                     H-OPER-DSH-SCH
102200                     H-OPER-DSH-RRC
102300                     HOLD-PPS-COMPONENTS
102400                     HOLD-PPS-COMPONENTS
102500                     HOLD-ADDITIONAL-VARIABLES
102600                     HOLD-CAPITAL-VARIABLES
102700                     HOLD-CAPITAL2-VARIABLES
102800                     HOLD-OTHER-VARIABLES
102900                     HOLD-PC-OTH-VARIABLES.
103000
103100     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
103200        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
103300
103400     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
103500        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
103600
103700     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
103800        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
103900
104000     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
104100        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
104200
104300     PERFORM 1000-EDIT-THE-BILL-INFO.
104400
104500     IF  PPS-RTC = 00
104600         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
104700         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
104800
104900     IF PPS-RTC = 00
105000        IF H-PERDIEM-DAYS = H-ALOS OR
105100           H-PERDIEM-DAYS > H-ALOS
105200           MOVE 14 TO PPS-RTC.
105300
105400     IF PPS-RTC = 02
105500        IF H-PERDIEM-DAYS = H-ALOS OR
105600           H-PERDIEM-DAYS > H-ALOS
105700           MOVE 16 TO PPS-RTC.
105800
105900 1000-EDIT-THE-BILL-INFO.
106000***************************************************************
106100*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
106200*    AND DO NOT ATTEMPT TO PRICE.                             *
106300***************************************************************
106400***************************************************************
106500***************************************************************
106600***     NO LONGER BEING PAY FEDERAL PERCENT FOR TRANSITION    *
106700***     PAID 100% FEDERAL AS OF OCT 1, 2001                   *
106800***************************************************************
106900*    IF P-NEW-FY-BEGIN-DATE < 20001001
107000*       MOVE .90 TO H-CAPI-PAYCDE-PCT1
107100*       MOVE .10 TO H-CAPI-PAYCDE-PCT2
107200*    ELSE
107300*       IF (P-NEW-FY-BEGIN-DATE < B-DISCHARGE-DATE) OR
107400*          (P-NEW-FY-BEGIN-DATE = B-DISCHARGE-DATE)
107500*             MOVE 1.00 TO H-CAPI-PAYCDE-PCT1
107600*             MOVE 0.00 TO H-CAPI-PAYCDE-PCT2
107700*       ELSE
107800*             MOVE .90 TO H-CAPI-PAYCDE-PCT1
107900*             MOVE .10 TO H-CAPI-PAYCDE-PCT2.
108000***************************************************************
108100***************************************************************
108200***************************************************************
108300
108400     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
108500     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
108600
108700     IF  PPS-RTC = 00
108800         IF  P-NEW-WAIVER-STATE
108900             MOVE 53 TO PPS-RTC.
109000
109100     IF  PPS-RTC = 00
109200         IF  B-DRG < 001 OR > 523 OR = 214 OR = 215 OR 112
109300                                  OR = 221 OR = 222
109400                                  OR = 434 OR = 435
109500                                  OR = 436 OR = 437
109600                                  OR = 438 OR = 456
109700                                  OR = 457 OR = 458
109800                                  OR = 459 OR = 460
109900                                  OR = 469 OR = 470
110000                                  OR = 472 OR = 474
110100             MOVE 54 TO PPS-RTC.
110200
110300     IF  PPS-RTC = 00
110400            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
110500                 (B-DISCHARGE-DATE < W-EFF-DATE))
110600                MOVE 55 TO PPS-RTC.
110700
110800     IF  PPS-RTC = 00
110900         IF P-NEW-TERMINATION-DATE > 00000000
111000            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
111100                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
111200                  MOVE 55 TO PPS-RTC.
111300
111400     IF  PPS-RTC = 00
111500         IF  B-LOS NOT NUMERIC
111600             MOVE 56 TO PPS-RTC
111700         ELSE
111800         IF  B-LOS = 0
111900             IF B-REVIEW-CODE NOT = 00 AND
112000                              NOT = 03 AND
112100                              NOT = 06 AND
112200                              NOT = 07 AND
112300                              NOT = 09 AND
112400                              NOT = 11
112500             MOVE 56 TO PPS-RTC.
112600
112700     IF  PPS-RTC = 00
112800         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
112900             MOVE 61 TO PPS-RTC
113000         ELSE
113100             MOVE B-LTR-DAYS TO H-LTR-DAYS.
113200
113300     IF  PPS-RTC = 00
113400         IF  B-COVERED-DAYS NOT NUMERIC
113500             MOVE 62 TO PPS-RTC
113600         ELSE
113700         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
113800             MOVE 62 TO PPS-RTC
113900         ELSE
114000             MOVE B-COVERED-DAYS TO H-COV-DAYS.
114100
114200     IF  PPS-RTC = 00
114300         IF  H-LTR-DAYS  > H-COV-DAYS
114400             MOVE 62 TO PPS-RTC
114500         ELSE
114600             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
114700
114800     IF  PPS-RTC = 00
114900         IF  NOT VALID-REVIEW-CODE
115000             MOVE 57 TO PPS-RTC.
115100
115200     IF  PPS-RTC = 00
115300         IF  B-CHARGES-CLAIMED NOT NUMERIC
115400             MOVE 58 TO PPS-RTC.
115500
115600     IF PPS-RTC = 00
115700           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
115800                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
115900                                            NOT = 'B' AND
116000                                            NOT = 'C'
116100                 MOVE 65 TO PPS-RTC.
116200
116300 2000-ASSEMBLE-PPS-VARIABLES.
116400***************************************************************
116500*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
116600*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
116700*    OF THAT VARIABLE.                                        *
116800***************************************************************
116900***  GET THE PROVIDER SPECIFIC VARIABLES.
117000***  GET THE PROVIDER SPECIFIC VARIABLES.
117100
117200     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
117300     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
117400
117500     IF  (P-NEW-STATE = 02 OR 12)
117600         MOVE P-NEW-COLA TO H-OPER-COLA
117700     ELSE
117800         MOVE 1.000  TO H-OPER-COLA.
117900
118000***************************************************************
118100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
118200***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
118300
118400     PERFORM 2600-GET-DRG-WEIGHT
118500             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
118600
118700***************************************************************
118800***  GET THE WAGE-INDEX
118900***  GET THE WAGE-INDEX
119000
119100     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
119200     MOVE W-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
119300
119400***************************************************************
119500***  GET THE LABOR, NON-LABOR STANDARD RATES
119600
119700     IF  P-NEW-STATE = 40
119800         MOVE 2 TO R2
119900         MOVE 3 TO R4
120000     ELSE
120100         MOVE 1 TO R2
120200         MOVE 1 TO R4.
120300
120400     IF  LARGE-URBAN
120500         MOVE 1 TO R3
120600     ELSE
120700         MOVE 2 TO R3.
120800
120900     PERFORM 2300-GET-LABOR-NLABOR-RATES
121000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
121100
121200**************************************************************
121300***  NO LONGER PROCESSING TEMP RELIEF AS OF 100199
121400
121500***  IF TEMP-RELIEF-FLAG = 'Y'
121600***     COMPUTE H-REG-LABOR ROUNDED =
121700***             H-REG-LABOR * 1.008 / 1.005
121800***     COMPUTE H-REG-NONLABOR ROUNDED =
121900***             H-REG-NONLABOR * 1.008 / 1.005
122000***     COMPUTE H-NAT-LABOR ROUNDED =
122100***             H-NAT-LABOR * 1.008 / 1.005
122200***     COMPUTE H-NAT-NONLABOR ROUNDED =
122300***             H-NAT-NONLABOR * 1.008 / 1.005.
122400
122500***************************************************************
122600**************************************************************
122700***************************************************************
122800** NO LONGER PAID FOR 2002                             *******
122900***   16 = REBASED SOLE COMMUNITY HOSP
123000***   17 = REBASED SOLE COMMUNITY HOSP/REFERRAL CENTER
123100***   21 = ESSENTIAL ACCESS COMMUNITY HOSP
123200***   22 = ESSENTIAL ACCESS COMMUNITY HOSP/REFERRAL CENTER
123300*
123400*    IF (P-N-SCH-REBASED-FY90  OR
123500*           P-N-EACH)
123600*       IF B-DISCHARGE-DATE > 20010331
123700*          COMPUTE H-REG-LABOR ROUNDED =
123800*                  H-REG-LABOR * 1.034 / 1.045
123900*          COMPUTE H-REG-NONLABOR ROUNDED =
124000*                  H-REG-NONLABOR * 1.034 / 1.045
124100*          COMPUTE H-NAT-LABOR ROUNDED =
124200*                  H-NAT-LABOR * 1.034 / 1.045
124300*          COMPUTE H-NAT-NONLABOR ROUNDED =
124400*                  H-NAT-NONLABOR * 1.034 / 1.045
124500*       ELSE
124600*          COMPUTE H-REG-LABOR ROUNDED =
124700*                  H-REG-LABOR * 1.034 / 1.023
124800*          COMPUTE H-REG-NONLABOR ROUNDED =
124900*                  H-REG-NONLABOR * 1.034 / 1.023
125000*          COMPUTE H-NAT-LABOR ROUNDED =
125100*                  H-NAT-LABOR * 1.034 / 1.023
125200*          COMPUTE H-NAT-NONLABOR ROUNDED =
125300*                  H-NAT-NONLABOR * 1.034 / 1.023.
125400*
125500*
125600***************************************************************
125700***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
125800***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
125900
126000     MOVE 0.00  TO H-OPER-HSP-PCT.
126100     MOVE 1.00  TO H-OPER-FSP-PCT.
126200
126300***************************************************************
126400***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
126500***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
126600
126700      MOVE 1.00 TO H-NAT-PCT.
126800      MOVE 0.00 TO H-REG-PCT.
126900
127000     IF  P-NEW-STATE = 40
127100         MOVE 0.50 TO H-NAT-PCT
127200         MOVE 0.50 TO H-REG-PCT.
127300
127400     IF  P-N-SCH-REBASED-FY90 OR
127500         P-N-EACH OR
127600         P-N-MDH-REBASED-FY90
127700         MOVE 1.00 TO H-OPER-HSP-PCT.
127800
127900 2300-GET-LABOR-NLABOR-RATES.
128000
128100     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE (R1)
128200         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
128300         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
128400         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
128500         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
128600
128700 2600-GET-DRG-WEIGHT.
128800     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
128900         SET DX6 TO B-DRG
129000         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
129100         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
129200*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
129300         MOVE ZEROES                   TO H-DAYS-CUTOFF
129400         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
129500
129600 3000-CALC-PAYMENT.
129700***************************************************************
129800*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
129900*        CALCULATE THE STAY UTILIZATION.                      *
130000*        CALCULATE THE FEDERAL PORTION.                       *
130100*        CALCULATE THE HOSPITAL PORTION.                      *
130200*        CALCULATE THE COST-OUTLIER PORTION.                  *
130300*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
130400*        CALCULATE THE DSH ADJUSTMENT.                        *
130500*        CALCULATE THE IME TEACHING.                          *
130600***************************************************************
130700     PERFORM 3100-CALC-STAY-UTILIZATION.
130800     PERFORM 3300-CALC-OPER-FSP-AMT.
130900***************************************************************
131000     PERFORM 3900A-CALC-OPER-DSH.
131100***********************************************************
131200***  OPERATING IME CALCULATION
131300***  OPERATING IME CALCULATION
131400
131500     COMPUTE H-OPER-IME-TEACH ROUNDED =
131600            1.60 * ((1 + H-INTERN-RATIO) ** .405  - 1).
131700
131800***********************************************************
131900
132000     IF P-N-SCH-REBASED-FY90 OR
132100        P-N-EACH OR
132200        P-N-MDH-REBASED-FY90
132300         PERFORM 3450-CALC-ADDITIONAL-HSP.
132400
132500     MOVE 00                 TO  PPS-RTC.
132600     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
132700     MOVE H-ALOS             TO  PPS-AVG-LOS.
132800     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
132900
133000     MOVE B-LOS TO H-PERDIEM-DAYS.
133100     IF H-PERDIEM-DAYS < 1
133200         MOVE 1 TO H-PERDIEM-DAYS.
133300     ADD 1 TO H-PERDIEM-DAYS.
133400
133500     MOVE 1 TO H-DSCHG-FRCTN.
133600
133700     IF  (PAY-PERDIEM-DAYS OR
133800          PAY-XFER-NO-COST) OR
133900       (PAY-XFER-SPEC-DRG AND (B-DRG = 014 OR 113 OR 236 OR
134000                                       263 OR 264 OR 429 OR 483))
134100         COMPUTE H-DSCHG-FRCTN ROUNDED = H-PERDIEM-DAYS / H-ALOS
134200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS.
134300
134400     IF (PAY-XFER-SPEC-DRG AND (B-DRG = 209 OR 210 OR 211))
134500         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
134600         COMPUTE H-DSCHG-FRCTN ROUNDED =
134700                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS).
134800
134900     IF H-DSCHG-FRCTN > 1
135000              MOVE 1 TO H-DSCHG-FRCTN
135100              MOVE 1 TO H-TRANSFER-ADJ.
135200
135300     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
135400
135500     PERFORM 3600-CALC-OUTLIER.
135600
135700     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
135800
135900        IF PAY-PERDIEM-DAYS
136000            IF  H-PERDIEM-DAYS < H-ALOS
136100                IF  NOT (B-DRG = 385)
136200                    PERFORM 3500-CALC-PERDIEM-AMT
136300                    MOVE 03 TO PPS-RTC.
136400
136500        IF PAY-XFER-SPEC-DRG
136600            IF  H-PERDIEM-DAYS < H-ALOS
136700                IF  NOT (B-DRG = 385)
136800                    PERFORM 3550-CALC-PERDIEM-AMT.
136900
137000        IF  PAY-PERDIEM-DAYS
137100            IF  H-OPER-OUTCST-PART > 0
137200                MOVE H-OPER-OUTCST-PART TO
137300                     H-OPER-OUTLIER-PART
137400                MOVE 05 TO PPS-RTC
137500            ELSE
137600            IF  PPS-RTC NOT = 03
137700                MOVE 00 TO PPS-RTC
137800                MOVE 0  TO H-OPER-OUTLIER-PART.
137900
138000        IF  PAY-PERDIEM-DAYS
138100            IF  H-CAPI-OUTCST-PART > 0
138200                MOVE H-CAPI-OUTCST-PART TO
138300                     H-CAPI-OUTLIER-PART
138400                MOVE 05 TO PPS-RTC
138500            ELSE
138600            IF  PPS-RTC NOT = 03
138700                MOVE 0  TO H-CAPI-OUTLIER-PART.
138800
138900        IF  PAY-XFER-NO-COST
139000            MOVE 0  TO H-OPER-OUTLIER-PART
139100                       H-CAPI-OUTLIER-PART
139200            MOVE 00 TO PPS-RTC
139300            IF H-PERDIEM-DAYS < H-ALOS
139400               IF  NOT (B-DRG = 385)
139500                   PERFORM 3500-CALC-PERDIEM-AMT
139600                   MOVE 06 TO PPS-RTC.
139700
139800 3000-CONTINUE.
139900
140000***********************************************************
140100***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
140200***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
140300
140400     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
140500
140600***********************************************************
140700
140800     IF  PPS-RTC = 67
140900         MOVE H-OPER-DOLLAR-THRESHOLD TO
141000              WK-H-OPER-DOLLAR-THRESHOLD.
141100
141200     IF  PPS-RTC < 50
141300         PERFORM 3800-CALC-TOT-AMT
141400     ELSE
141500         MOVE ALL '0' TO PPS-OPER-HSP-PART
141600                         PPS-OPER-FSP-PART
141700                         PPS-OPER-OUTLIER-PART
141800                         PPS-OUTLIER-DAYS
141900                         PPS-REG-DAYS-USED
142000                         PPS-LTR-DAYS-USED
142100                         PPS-TOTAL-PAYMENT
142200                         PPS-OPER-DSH-ADJ
142300                         PPS-OPER-IME-ADJ
142400                         H-DSCHG-FRCTN
142500                         H-DRG-WT-FRCTN
142600                         HOLD-ADDITIONAL-VARIABLES
142700                         HOLD-CAPITAL-VARIABLES
142800                         HOLD-CAPITAL2-VARIABLES
142900                         HOLD-OTHER-VARIABLES
143000                         HOLD-PC-OTH-VARIABLES.
143100
143200     IF  PPS-RTC = 67
143300         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
143400                 H-OPER-DOLLAR-THRESHOLD.
143500
143600 3000-EXIT.  EXIT.
143700
143800 3100-CALC-STAY-UTILIZATION.
143900
144000     MOVE 0 TO PPS-REG-DAYS-USED.
144100     MOVE 0 TO PPS-LTR-DAYS-USED.
144200
144300     IF H-REG-DAYS > 0
144400        IF H-REG-DAYS > B-LOS
144500           MOVE B-LOS TO PPS-REG-DAYS-USED
144600        ELSE
144700           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
144800     ELSE
144900        IF H-LTR-DAYS > B-LOS
145000           MOVE B-LOS TO PPS-LTR-DAYS-USED
145100        ELSE
145200           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
145300
145400
145500
145600 3300-CALC-OPER-FSP-AMT.
145700***********************************************************
145800***  OPERATING FSP CALCULATION
145900***  OPERATING FSP CALCULATION
146000
146100     IF P-NEW-STATE = 40
146200       COMPUTE H-OPER-FSP-PART ROUNDED =
146300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
146400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
146500                           +
146600           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
146700            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
146800                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART
146900     ELSE
147000        COMPUTE H-OPER-FSP-PART ROUNDED =
147100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
147200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
147300                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
147400
147500
147600 3450-CALC-ADDITIONAL-HSP.
147700***********************************************************
147800*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
147900*    SOLE COMMUNITY
148000*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
148100*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
148200***********************************************************
148300**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
148400****    USE ACTUAL FEDERAL REGISTER NUMBER
148500
148600     MOVE 0.948928 TO H-OUTLIER-FACT.
148700***************************************************************
148800***         GET THE UPDATING FACTOR
148900***         GET THE UPDATING FACTOR
149000
149100     MOVE 0.997174 TO H-BUDG-NUTR01.
149200     MOVE 0.995821 TO H-BUDG-NUTR02.
149300
149400     MOVE 1.0340 TO H-UPDATE-01.
149500     MOVE 1.0275 TO H-UPDATE-02.
149600
149700     COMPUTE H-UPDATE-FACTOR ROUNDED =
149800                       (H-UPDATE-01 * H-UPDATE-02 *
149900                        H-BUDG-NUTR01 * H-BUDG-NUTR02).
150000
150100     COMPUTE H-HSP-RATE ROUNDED =
150200         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
150300***************************************************************
150400
150500     IF P-NEW-STATE = 40
150600       COMPUTE H-FSP-RATE ROUNDED =
150700         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
150800         H-NAT-NONLABOR * H-OPER-COLA))
150900                           +
151000          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
151100         H-REG-NONLABOR * H-OPER-COLA)))
151200                           *
151300       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT)
151400                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE
151500     ELSE
151600       COMPUTE H-FSP-RATE ROUNDED =
151700         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
151800         H-NAT-NONLABOR * H-OPER-COLA))
151900                           *
152000       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT)
152100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
152200
152300     IF  H-HSP-RATE > H-FSP-RATE
152400           COMPUTE H-OPER-HSP-PART ROUNDED =
152500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
152600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
152700     ELSE
152800         MOVE 0 TO H-OPER-HSP-PART.
152900
153000***************************************************************
153100***         GET THE MDH REBASE
153200***     HAS BEEN REVIVED FOR 10/01/97
153300
153400     IF  H-HSP-RATE > H-FSP-RATE
153500         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
153600           COMPUTE H-OPER-HSP-PART ROUNDED =
153700             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5
153800                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
153900
154000 3500-CALC-PERDIEM-AMT.
154100***********************************************************
154200***  REVIEW CODE = 03 OR 06
154300***  OPERATING PERDIEM-AMT CALCULATION
154400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
154500
154600        COMPUTE H-OPER-HSP-PART ROUNDED =
154700        H-OPER-HSP-PART * H-TRANSFER-ADJ
154800        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
154900
155000        COMPUTE H-OPER-FSP-PART ROUNDED =
155100        H-OPER-FSP-PART * H-TRANSFER-ADJ
155200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
155300
155400***********************************************************
155500***********************************************************
155600***  REVIEW CODE = 03 OR 06
155700***  CAPITAL   PERDIEM-AMT CALCULATION
155800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
155900
156000***********************************************************
156100**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
156200*       COMPUTE H-CAPI-HSP-PART ROUNDED =
156300*       H-CAPI-HSP-PART * H-TRANSFER-ADJ
156400*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
156500***********************************************************
156600
156700        COMPUTE H-CAPI-FSP-PART ROUNDED =
156800        H-CAPI-FSP-PART * H-TRANSFER-ADJ
156900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
157000
157100***********************************************************
157200***  REVIEW CODE = 03 OR 06
157300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
157400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
157500
157600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
157700        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
157800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
157900
158000 3550-CALC-PERDIEM-AMT.
158100***********************************************************
158200***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
158300***  OPERATING PERDIEM-AMT CALCULATION
158400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
158500
158600     IF (B-DRG = 209 OR 210 OR 211)
158700        MOVE 10 TO PPS-RTC
158800        COMPUTE H-OPER-HSP-PART ROUNDED =
158900        H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
159000        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
159100
159200     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
159300                 264 OR 429 OR 483)
159400        MOVE 12 TO PPS-RTC
159500        COMPUTE H-OPER-HSP-PART ROUNDED =
159600        H-OPER-HSP-PART *  H-TRANSFER-ADJ
159700        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
159800
159900     IF (B-DRG = 209 OR 210 OR 211)
160000        MOVE 10 TO PPS-RTC
160100        COMPUTE H-OPER-FSP-PART ROUNDED =
160200        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
160300        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
160400
160500     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
160600                 264 OR 429 OR 483)
160700        MOVE 12 TO PPS-RTC
160800        COMPUTE H-OPER-FSP-PART ROUNDED =
160900        H-OPER-FSP-PART *  H-TRANSFER-ADJ
161000        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
161100
161200***********************************************************
161300***  CAPITAL PERDIEM-AMT CALCULATION
161400***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
161500
161600***********************************************************
161700**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
161800*    IF (B-DRG = 209 OR 210 OR 211)
161900*       MOVE 10 TO PPS-RTC
162000*       COMPUTE H-CAPI-HSP-PART ROUNDED =
162100*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
162200*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
162300*
162400*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
162500*                264 OR 429 OR 483)
162600*       MOVE 12 TO PPS-RTC
162700*       COMPUTE H-CAPI-HSP-PART ROUNDED =
162800*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ
162900*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
163000***********************************************************
163100
163200     IF (B-DRG = 209 OR 210 OR 211)
163300        MOVE 10 TO PPS-RTC
163400        COMPUTE H-CAPI-FSP-PART ROUNDED =
163500        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
163600        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
163700
163800     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
163900                 264 OR 429 OR 483)
164000        MOVE 12 TO PPS-RTC
164100        COMPUTE H-CAPI-FSP-PART ROUNDED =
164200        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
164300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
164400
164500***********************************************************
164600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
164700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
164800
164900     IF (B-DRG = 209 OR 210 OR 211)
165000        MOVE 10 TO PPS-RTC
165100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
165200        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
165300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
165400
165500     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
165600                 264 OR 429 OR 483)
165700        MOVE 12 TO PPS-RTC
165800        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
165900        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
166000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
166100
166200 3600-CALC-OUTLIER.
166300******************************************************************
166400***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
166500***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
166600***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97
166700
166800     MOVE 0.00 TO H-DAYOUT-PCT.
166900******************************************************************
167000
167100     MOVE 0.80 TO H-CSTOUT-PCT.
167200
167300******************************************************************
167400*****THESE ARE BURNS DRG'S
167500     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR
167600                 509 OR 510 OR 511
167700             MOVE 0.90 TO H-CSTOUT-PCT.
167800
167900***     NATIONAL PERCENTAGE
168000     MOVE 0.7110   TO H-LABOR-PCT.
168100     MOVE 0.2890   TO H-NONLABOR-PCT.
168200
168300***     PUERTO RICO PERCENTAGE
168400     MOVE 0.7130   TO H-PR-LABOR-PCT.
168500     MOVE 0.2870   TO H-PR-NONLABOR-PCT.
168600
168700     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
168800             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
168900     ELSE
169000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
169100
169200     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
169300             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
169400     ELSE
169500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
169600
169700***********************************************************
169800***  CAPITAL PAYMENT METHOD B
169900***  CAPITAL PAYMENT METHOD B
170000
170100     IF W-SIZE = 'L'
170200        MOVE 1.03 TO H-CAPI-LARG-URBAN
170300     ELSE
170400        MOVE 1.00 TO H-CAPI-LARG-URBAN.
170500
170600     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
170700     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
170800
170900     COMPUTE H-FEDERAL-RATE ROUNDED =
171000                                 (0390.74 * H-CAPI-GAF)
171100     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
171200                                 (0187.73 * H-PR-CAPI-GAF).
171300
171400     COMPUTE H-CAPI-COLA ROUNDED =
171500                     (.3152 * (H-OPER-COLA - 1) + 1).
171600
171700     IF P-NEW-STATE = 40
171800        COMPUTE  H-CAPI-FED-RATE ROUNDED =
171900                 (H-NAT-PCT * H-FEDERAL-RATE) +
172000                 (H-REG-PCT * H-PUERTO-RICO-RATE)
172100     ELSE
172200        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
172300
172400***********************************************************
172500***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001
172600***  CAPITAL HSP CALCULATION
172700***  CAPITAL HSP CALCULATION
172800*
172900*    IF B-DISCHARGE-DATE > 20010331
173000*        MOVE 1.0149 TO H-HSP-UPDATE01
173100*    ELSE
173200*        MOVE 1.0147 TO H-HSP-UPDATE01.
173300*
173400*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.
173500*
173600*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *
173700*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
173800***********************************************************
173900
174000***********************************************************
174100***  CAPITAL FSP CALCULATION
174200***  CAPITAL FSP CALCULATION
174300
174400     COMPUTE H-CAPI-FSP-PART ROUNDED =
174500                               H-DRG-WT * H-CAPI-FED-RATE *
174600                               H-CAPI-COLA *
174700                               H-CAPI-LARG-URBAN.
174800
174900***********************************************************
175000***  CAPITAL PAYMENT METHOD A
175100***  CAPITAL PAYMENT METHOD A
175200
175300     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
175400        MOVE 1.00 TO H-CAPI-SCH
175500     ELSE
175600        MOVE 0.85 TO H-CAPI-SCH.
175700
175800***********************************************************
175900***********  CAPITAL OLD-HARMLESS CALCULATION ***********
176000***********  CAPITAL OLD-HARMLESS CALCULATION ***********
176100
176200     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
176300                    (P-NEW-CAPI-OLD-HARM-RATE *
176400                    H-CAPI-SCH).
176500
176600***********************************************************
176700***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
176800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
176900
177000     IF H-CAPI-CSTCHG-RATIO > 0 OR
177100       H-OPER-CSTCHG-RATIO > 0
177200        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
177300                H-OPER-CSTCHG-RATIO /
177400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
177500        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
177600                H-CAPI-CSTCHG-RATIO /
177700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
177800     ELSE
177900         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
178000                   H-CAPI-SHARE-DOLL-THRESHOLD.
178100
178200***********************************************************
178300***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
178400***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
178500***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
178600
178700***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
178800***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.
178900***********************************************************
179000***********************************************************
179100***********************************************************
179200***********************************************************
179300
179400***  OUTLIER THRESHOLD THRESHOLD AMOUNTS
179500***********************************************************
179600     MOVE 21025.00 TO H-CST-THRESH
179700
179800     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
179900        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
180000         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
180100          H-OPER-SHARE-DOLL-THRESHOLD.
180200
180300     IF P-NEW-STATE = 40
180400        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
180500           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
180600            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
180700             H-OPER-SHARE-DOLL-THRESHOLD
180800        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
180900               (H-OPER-DOLLAR-THRESHOLD +
181000                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
181100
181200***********************************************************
181300***  CAPITAL DSH CALCULATION
181400***  CAPITAL DSH CALCULATION
181500
181600     MOVE 0 TO H-CAPI-DSH.
181700
181800     IF P-NEW-BED-SIZE NOT NUMERIC
181900         MOVE 0 TO P-NEW-BED-SIZE.
182000
182100     IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
182200         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
182300                  (.2025 * (P-NEW-SSI-RATIO
182400                          + P-NEW-MEDICAID-RATIO)) - 1.
182500
182600***********************************************************
182700***  CAPITAL IME TEACH CALCULATION
182800***  CAPITAL IME TEACH CALCULATION
182900
183000     MOVE 0 TO H-WK-CAPI-IME-TEACH.
183100
183200     IF P-NEW-CAPI-IME NUMERIC
183300        IF P-NEW-CAPI-IME > 1.5000
183400           MOVE 1.5000 TO P-NEW-CAPI-IME.
183500
183600     IF P-NEW-CAPI-IME NUMERIC
183700        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
183800          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
183900
184000***********************************************************
184100***********************************************************
184200***********************************************************
184300***NO LONGER PAID AS OF OCT. 1, 2001    *******************
184400***  DIFFERENT THRESHOLD   PRE-CAPITAL
184500***  DIFFERENT THRESHOLD   PRE-CAPITAL
184600*
184700*    IF (P-NEW-CAPI-NEW-HOSP = 'Y')
184800*       COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
184900*       (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
185000*       (H-PRE-CAPI-THRESH * H-NONLABOR-PCT * H-OPER-COLA)
185100*      IF P-NEW-STATE = 40
185200*       COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
185300*        (H-PRE-CAPI-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
185400*        (H-PRE-CAPI-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)
185500*       COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
185600*              (H-OPER-DOLLAR-THRESHOLD +
185700*               H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
185800***********************************************************
185900***********************************************************
186000***********************************************************
186100
186200     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
186300          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
186400          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
186500
186600
186700     IF P-NEW-STATE = 40
186800        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
186900           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
187000           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
187100        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
187200               (H-CAPI-DOLLAR-THRESHOLD +
187300                H-CAPI-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
187400
187500     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
187600      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
187700                       +
187800             H-OPER-DOLLAR-THRESHOLD.
187900
188000     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
188100      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
188200                       +
188300             H-CAPI-DOLLAR-THRESHOLD.
188400
188500     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
188600         MOVE 0 TO H-CAPI-COST-OUTLIER.
188700
188800     IF (B-REVIEW-CODE = '03') AND
188900         H-PERDIEM-DAYS < H-ALOS
189000        COMPUTE H-OPER-COST-OUTLIER ROUNDED =
189100                (H-OPER-COST-OUTLIER * H-TRANSFER-ADJ)
189200                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.
189300
189400     IF (B-REVIEW-CODE = '03') AND
189500         H-PERDIEM-DAYS < H-ALOS
189600        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
189700                (H-CAPI-COST-OUTLIER * H-TRANSFER-ADJ)
189800                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.
189900
190000     IF ((B-REVIEW-CODE = '09') AND
190100         (H-PERDIEM-DAYS < H-ALOS))
190200         IF (B-DRG = 209 OR 210 OR 211)
190300           COMPUTE H-OPER-COST-OUTLIER ROUNDED =
190400               (H-OPER-COST-OUTLIER * (.5 * (1 + H-TRANSFER-ADJ)))
190500                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.
190600
190700     IF ((B-REVIEW-CODE = '09') AND
190800         (H-PERDIEM-DAYS < H-ALOS))
190900         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
191000                     264 OR 429 OR 483)
191100            COMPUTE H-OPER-COST-OUTLIER ROUNDED =
191200                (H-OPER-COST-OUTLIER *  H-TRANSFER-ADJ)
191300                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.
191400
191500     IF ((B-REVIEW-CODE = '09') AND
191600         (H-PERDIEM-DAYS < H-ALOS))
191700         IF (B-DRG = 209 OR 210 OR 211)
191800           COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
191900               (H-CAPI-COST-OUTLIER * (.5 * (1 + H-TRANSFER-ADJ)))
192000                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.
192100
192200     IF ((B-REVIEW-CODE = '09') AND
192300         (H-PERDIEM-DAYS < H-ALOS))
192400         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
192500                     264 OR 429 OR 483)
192600            COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
192700                (H-CAPI-COST-OUTLIER *  H-TRANSFER-ADJ)
192800                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.
192900
193000
193100***********************************************************
193200***  OPERATING COST CALCULATION
193300***  OPERATING COST CALCULATION
193400
193500     COMPUTE H-OPER-BILL-COSTS ROUNDED =
193600         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
193700         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
193800
193900
194000     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
194100         COMPUTE H-OPER-OUTCST-PART ROUNDED =
194200         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
194300                         H-OPER-COST-OUTLIER).
194400
194500     IF PAY-WITHOUT-COST OR
194600        PAY-XFER-NO-COST OR
194700        PAY-XFER-SPEC-DRG-NO-COST
194800         MOVE 0 TO H-OPER-OUTCST-PART.
194900
195000***********************************************************
195100***  CAPITAL COST CALCULATION
195200***  CAPITAL COST CALCULATION
195300
195400     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
195500             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
195600         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
195700
195800     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
195900         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
196000         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
196100                         H-CAPI-COST-OUTLIER).
196200
196300     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
196400       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
196500              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
196600
196700     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
196800        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
196900               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
197000
197100     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
197200        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
197300        MOVE 0 TO H-CAPI-OUTCST-PART
197400                  H-OPER-OUTCST-PART.
197500
197600     IF PAY-WITHOUT-COST OR
197700        PAY-XFER-NO-COST OR
197800        PAY-XFER-SPEC-DRG-NO-COST
197900         MOVE 0 TO H-CAPI-OUTCST-PART.
198000
198100***********************************************************
198200***  DETERMINES THE BILL TO BE COST  OUTLIER
198300
198400     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
198500         MOVE 0 TO H-CAPI-OUTDAY-PART
198600                   H-CAPI-OUTCST-PART.
198700
198800     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
198900                 MOVE H-OPER-OUTCST-PART TO
199000                      H-OPER-OUTLIER-PART
199100                 MOVE H-CAPI-OUTCST-PART TO
199200                      H-CAPI-OUTLIER-PART
199300                 MOVE 02 TO PPS-RTC.
199400
199500
199600***********************************************************
199700***  DETERMINES IF COST OUTLIER
199800***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
199900***         RETURN CODE OF 02
200000
200100     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
200200
200300     IF PPS-RTC = 02
200400             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
200500                     (H-CAPI-COST-OUTLIER  +
200600                      H-OPER-COST-OUTLIER)
200700                             /
200800                    (H-CAPI-CSTCHG-RATIO  +
200900                     H-OPER-CSTCHG-RATIO)
201000             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
201100
201200***********************************************************
201300***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
201400***         RETURN CODE OF 67
201500
201600     IF PPS-RTC = 02
201700         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
201800            PPS-PC-COT-FLAG = 'Y'
201900             MOVE 67 TO PPS-RTC.
202000***********************************************************
202100
202200***********************************************************
202300***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
202400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
202500
202600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
202700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
202800                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
202900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
203000
203100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
203200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
203300                H-CAPI-OUTLIER-PART.
203400
203500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
203600        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
203700                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
203800         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
203900***********************************************************
204000
204100 3800-CALC-TOT-AMT.
204200
204300***********************************************************
204400***  CALCULATE FINAL TOTALS FOR OPERATING
204500***  CALCULATE FINAL TOTALS FOR OPERATING
204600
204700     COMPUTE PPS-OPER-HSP-PART ROUNDED =
204800         H-OPER-HSP-PCT * H-OPER-HSP-PART.
204900
205000     COMPUTE PPS-OPER-FSP-PART ROUNDED =
205100         H-OPER-FSP-PCT * H-OPER-FSP-PART.
205200
205300     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
205400             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
205500
205600     MOVE ZERO TO PPS-OPER-DSH-ADJ.
205700
205800     IF  H-OPER-DSH NUMERIC
205900             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
206000              PPS-OPER-FSP-PART
206100              * H-OPER-DSH.
206200
206300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
206400          PPS-OPER-FSP-PART *
206500                 H-OPER-IME-TEACH.
206600
206700***********************************************************
206800***  CALCULATE FINAL TOTALS FOR CAPITAL
206900***  CALCULATE FINAL TOTALS FOR CAPITAL
207000
207100     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
207200
207300     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
207400        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
207500        MOVE 0.00 TO H-CAPI-HSP-PCT.
207600
207700     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
207800        MOVE 0    TO H-CAPI-OLD-HARMLESS
207900        MOVE 1.00 TO H-CAPI-FSP-PCT
208000        MOVE 0.00 TO H-CAPI-HSP-PCT.
208100
208200     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
208300        MOVE 0    TO H-CAPI-OLD-HARMLESS
208400        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
208500        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
208600
208700     COMPUTE H-CAPI-HSP ROUNDED =
208800         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
208900
209000     COMPUTE H-CAPI-FSP ROUNDED =
209100         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
209200
209300     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
209400
209500     COMPUTE H-CAPI-OUTLIER ROUNDED =
209600             1.00 * H-CAPI-OUTLIER-PART.
209700
209800     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
209900             1.00 * H-CAPI2-B-OUTLIER-PART.
210000
210100     COMPUTE H-CAPI2-B-FSP ROUNDED =
210200             1.00 * H-CAPI2-B-FSP-PART.
210300
210400     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
210500
210600     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
210700             H-CAPI-FSP
210800              * H-CAPI-DSH.
210900
211000     COMPUTE H-CAPI-IME-ADJ ROUNDED =
211100          H-CAPI-FSP *
211200                 H-WK-CAPI-IME-TEACH.
211300
211400***********************************************************
211500***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
211600***        THIS ZEROES OUT ALL CAPITAL DATA
211700
211800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
211900        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
212000
212100***********************************************************
212200     IF HMO-TAG  = 'Y'
212300        PERFORM 3850-HMO-IME-ADJ.
212400
212500     IF (H-CAPI-OUTLIER > 0 AND
212600         PPS-OPER-OUTLIER-PART = 0)
212700            COMPUTE PPS-OPER-OUTLIER-PART =
212800                    PPS-OPER-OUTLIER-PART + .01.
212900
213000     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
213100             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
213200             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
213300             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
213400
213500***********************************************************
213600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
213700***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
213800
213900     COMPUTE PPS-TOTAL-PAYMENT ROUNDED =
214000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
214100             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
214200             PPS-OPER-IME-ADJ
214300                           +
214400                H-WK-PASS-AMT-PLUS-MISC
214500                           +
214600                  H-CAPI-TOTAL-PAY.
214700
214800 3850-HMO-IME-ADJ.
214900***********************************************************
215000***  HMO ADJUSTMENT FOR OPERATING IME
215100***  HMO ADJUSTMENT FOR OPERATING IME
215200***  HMO CALC FOR PASS THRU ADDON
215300***  HMO CALC FOR PASS THRU ADDON
215400
215500     IF B-DISCHARGE-DATE < 20020101
215600        COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
215700          (P-NEW-PASS-AMT-PLUS-MISC -
215800          (P-NEW-PASS-AMT-DIR-MED-ED * .80)) * B-LOS
215900     ELSE
216000        COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
216100          (P-NEW-PASS-AMT-PLUS-MISC -
216200          (P-NEW-PASS-AMT-DIR-MED-ED * 1.00)) * B-LOS.
216300
216400***  COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
216500***          P-NEW-PASS-AMT-PLUS-MISC  * B-LOS.
216600
216700        IF B-DISCHARGE-DATE < 20020101
216800           COMPUTE PPS-OPER-IME-ADJ ROUNDED =
216900                   PPS-OPER-IME-ADJ * .2
217000        ELSE
217100           COMPUTE PPS-OPER-IME-ADJ ROUNDED =
217200                   PPS-OPER-IME-ADJ * .0.
217300
217400
217500 3900A-CALC-OPER-DSH.
217600***********************************************************
217700***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
217800***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
217900
218000      MOVE 0.0000 TO H-OPER-DSH.
218100
218200      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
218300                                     + P-NEW-MEDICAID-RATIO).
218400
218500***********************************************************
218600*****    0-99 BEDS
218700      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
218800                               AND H-WK-OPER-DSH > .1499
218900                               AND H-WK-OPER-DSH < .1923
219000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
219100                                      * .65 + .025.
219200
219300      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
219400                               AND H-WK-OPER-DSH > .1922
219500             MOVE .0525 TO H-OPER-DSH.
219600
219700***********************************************************
219800*****   100 + BEDS
219900
220000      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
220100                               AND H-WK-OPER-DSH > .1499
220200                               AND H-WK-OPER-DSH < .2021
220300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
220400                                      * .65 + .025.
220500
220600      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
220700                               AND H-WK-OPER-DSH > .202
220800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
220900                                      * .825 + .0588.
221000
221100***********************************************************
221200*****   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
221300
221400      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
221500                               AND H-WK-OPER-DSH > .1499
221600                               AND H-WK-OPER-DSH < .1923
221700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
221800                                 * .65 + .025.
221900
222000      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
222100                               AND H-WK-OPER-DSH > .1922
222200        MOVE .0525 TO H-OPER-DSH.
222300
222400***********************************************************
222500*****   OTHER RURAL HOSPITALS 500 BEDS +
222600
222700      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
222800                               AND H-WK-OPER-DSH > .1499
222900                               AND H-WK-OPER-DSH < .2021
223000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
223100                                 * .65 + .025.
223200
223300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
223400                               AND H-WK-OPER-DSH > .202
223500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
223600                                 * .825 + .0588.
223700
223800***********************************************************
223900*****   RURAL HOSPITALS SCH
224000
224100      IF W-SIZE = 'R'
224200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
224300                               AND H-WK-OPER-DSH > .1499
224400                               AND H-WK-OPER-DSH < .1923
224500         COMPUTE H-OPER-DSH-SCH ROUNDED = (H-WK-OPER-DSH - .15)
224600                                 * .65 + .025
224700         MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
224800      IF W-SIZE = 'R'
224900         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
225000                               AND H-WK-OPER-DSH > .1922
225100                               AND H-WK-OPER-DSH < .3000
225200         MOVE .0525 TO H-OPER-DSH-SCH
225300                       H-OPER-DSH.
225400      IF W-SIZE = 'R'
225500         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
225600                               AND H-WK-OPER-DSH > .2999
225700         MOVE .10 TO H-OPER-DSH-SCH
225800                     H-OPER-DSH.
225900***********************************************************
226000*****   RURAL HOSPITALS RRC
226100
226200      IF W-SIZE = 'R'
226300         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
226400                               AND H-WK-OPER-DSH > .1499
226500                               AND H-WK-OPER-DSH < .1923
226600         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .15)
226700                                 * .65 + .025.
226800      IF W-SIZE = 'R'
226900         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
227000                               AND H-WK-OPER-DSH > .1922
227100                               AND H-WK-OPER-DSH < .3000
227200         MOVE .0525 TO H-OPER-DSH-RRC.
227300
227400      IF W-SIZE = 'R'
227500         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
227600                               AND H-WK-OPER-DSH > .2999
227700         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .30)
227800                                 * .60 + .0525.
227900
228000***********************************************************
228100*****   RURAL HOSPITALS BOTH SCH AND RRC
228200
228300      IF W-SIZE = 'R'
228400         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')
228500                MOVE H-OPER-DSH-RRC TO H-OPER-DSH
228600             IF H-OPER-DSH-SCH > H-OPER-DSH-RRC
228700                MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
228800
228900***********************************************************
229000*** RRC ONLY
229100      IF W-SIZE = 'R'
229200         IF (P-NEW-PROVIDER-TYPE = '07')
229300                MOVE H-OPER-DSH-RRC TO H-OPER-DSH.
229400
229500***********************************************************
229600
229700      MOVE 0.9700 TO H-DSH-REDUCT-FACTOR.
229800
229900      COMPUTE H-OPER-DSH ROUNDED =
230000                        H-OPER-DSH * H-DSH-REDUCT-FACTOR.
230100
230200
230300******        L A S T   S O U R C E   S T A T E M E N T   *****
