000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL964.
000300*AUTHOR.            DDS TEAM.
000400*REMARKS.                HCFA.
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     'PPCAL964 - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C96.4'.
002000 01  R1                             PIC S9(04) COMP SYNC.
002100 01  R2                             PIC S9(04) COMP SYNC.
002200 01  R3                             PIC S9(04) COMP SYNC.
002300 01  R4                             PIC S9(04) COMP SYNC.
002400
002500***************************************************************
002600*    LAYUP TABLE AREA FOR FY96 RATES                          *
002700***************************************************************
002800 01  RATE-TABLE.
002900     02  RATE-WORK.
003000*RATE   951001 REGION  LABOR AND NON-LABOR RATES
003100*               LARGE URBAN /OTHER URBAN & / ALL RURAL
003200*                           /REFERRAL CTR  /
003300         05  FILLER PIC X(06) VALUE '951001'.
003400         05  NE01   PIC X(45) VALUE
003500            ' 0287414 115127 0282862 113304 0282862 113304'.
003600         05  MA02   PIC X(45) VALUE
003700            ' 0262306 105069 0258153 103406 0258153 103406'.
003800         05  SA03   PIC X(45) VALUE
003900            ' 0268562 107575 0264311 105872 0264311 105872'.
004000         05  ENC04  PIC X(45) VALUE
004100            ' 0292645 117222 0288012 115366 0288012 115366'.
004200         05  ESC05  PIC X(45) VALUE
004300            ' 0253785 101656 0249767 100047 0249767 100047'.
004400         05  WNC06  PIC X(45) VALUE
004500            ' 0274319 109881 0269976 108141 0269976 108141'.
004600         05  WSC07  PIC X(45) VALUE
004700            ' 0266998 106949 0262771 105255 0262771 105255'.
004800         05  MNT08  PIC X(45) VALUE
004900            ' 0265282 106262 0261082 104579 0261082 104579'.
005000         05  PAC09  PIC X(45) VALUE
005100            ' 0271220 108640 0266927 106920 0266927 106920'.
005200         05  NTL10  PIC X(45) VALUE
005300            ' 0274139 109809 0269799 108071 0269799 108071'.
005400         05  PR11   PIC X(45) VALUE
005500            ' 0244477 050950 0240607 050143 0240607 050143'.
005600         05  NPR12  PIC X(45) VALUE
005700            ' 0271463 108737 0271463 108737 0271463 108737'.
005800     02  RATE-TAB REDEFINES RATE-WORK.
005900         05  RATE-PERIOD            OCCURS 1.
006000             10  RATE-EFF-DATE      PIC X(06).
006100             10  REG-NAT            OCCURS 12.
006200                 15  R-URBAN-RURAL  OCCURS 3.
006300                     20  FILLER     PIC X(01).
006400                     20  REG-LABOR  PIC 9(05)V9(02).
006500                     20  FILLER     PIC X(01).
006600                     20  REG-NLABOR PIC 9(04)V9(02).
006700
006800
006900***************************************************************
007000*    LAYUP TABLE AREA FOR FY96 DRGS                           *
007100***************************************************************
007200 01  DRG-TABLE.
007300     05  D-TAB.
007400      10  FILLER                  PIC X(06) VALUE
007500     '951001'.
007600      10  FILLER                  PIC X(56) VALUE
007700     '03093208732124030095090321260188481273612702329606529100'.
007800      10  FILLER                  PIC X(56) VALUE
007900     '01579804027052008124024250400260170933214701179403126046'.
008000      10  FILLER                  PIC X(56) VALUE
008100     '01304705729085012299062290890080000382705300989106029087'.
008200      10  FILLER                  PIC X(56) VALUE
008300     '00785805428069012065060290820072270382704901063905428074'.
008400      10  FILLER                  PIC X(56) VALUE
008500     '00602603226043009242051280690059900362704702115708331115'.
008600      10  FILLER                  PIC X(56) VALUE
008700     '01535006530087008127040270510080900392705500990804628065'.
008800      10  FILLER                  PIC X(56) VALUE
008900     '00568103126041008993031260450134760392707201200105228079'.
009000      10  FILLER                  PIC X(56) VALUE
009100     '00621703126044003187020170200079340382705700481902422033'.
009200      10  FILLER                  PIC X(56) VALUE
009300     '00200301609016010569049280690059140342604800593001407017'.
009400      10  FILLER                  PIC X(56) VALUE
009500     '00882102626041004243020170270050360150901900700002325036'.
009600      10  FILLER                  PIC X(56) VALUE
009700     '00324401607016005615016120220036650302503800615004828059'.
009800      10  FILLER                  PIC X(56) VALUE
009900     '00646003425043007593042270590045390302604000285902926029'.
010000      10  FILLER                  PIC X(56) VALUE
010100     '01770104728070007522018120240073250202303000849202425034'.
010200      10  FILLER                  PIC X(56) VALUE
010300     '00939202325037004634032220320072380192203000819502121030'.
010400      10  FILLER                  PIC X(56) VALUE
010500     '01045003226049002631015040150059630211902900200401504015'.
010600      10  FILLER                  PIC X(56) VALUE
010700     '01222103126059002837013050130114620332604901188705128082'.
010800      10  FILLER                  PIC X(56) VALUE
010900     '00516202922037005306030240390080600342504300709404227052'.
011000      10  FILLER                  PIC X(56) VALUE
011100     '00527003421041003129024170300072060362504400641903026047'.
011200      10  FILLER                  PIC X(56) VALUE
011300     '00773004027054003223021200210310340933211902560109633134'.
011400      10  FILLER                  PIC X(56) VALUE
011500     '01121903927059014136074300880166250783110100950805729072'.
011600      10  FILLER                  PIC X(56) VALUE
011700     '00955804728067013166060290840095570522806900500203025042'.
011800      10  FILLER                  PIC X(56) VALUE
011900     '01191705929079006848036270460135890532807301001805328066'.
012000      10  FILLER                  PIC X(56) VALUE
012100     '01121106229076006996047260550083660442706001200006029077'.
012200      10  FILLER                  PIC X(56) VALUE
012300     '00755004227053012378062290810062420382604700839004928059'.
012400      10  FILLER                  PIC X(56) VALUE
012500     '00608903823046006696042270510069590292603900503402114026'.
012600      10  FILLER                  PIC X(56) VALUE
012700     '00912004527060005595029260401382732745039107314313336160'.
012800      10  FILLER                  PIC X(56) VALUE
012900     '05631010033120056187112341270418030863209805945510533135'.
013000      10  FILLER                  PIC X(56) VALUE
013100     '00000000000000041308087321160225840632907201992203627050'.
013200      10  FILLER                  PIC X(56) VALUE
013300     '02753611635160015383074301050355130953311802394904227059'.
013400      10  FILLER                  PIC X(56) VALUE
013500     '01145403026045015260022250340112470342605901953105829101'.
013600      10  FILLER                  PIC X(56) VALUE
013700     '01645907030084011614049280580143700282604901293304027053'.
013800      10  FILLER                  PIC X(56) VALUE
013900     '00876702422032026049123351630103020522806700792906329072'.
014000      10  FILLER                  PIC X(56) VALUE
014100     '01137602125037009384056290720060020452705500686103123040'.
014200      10  FILLER                  PIC X(56) VALUE
014300     '00534702518031005800033250420089880412705700578902822036'.
014400      10  FILLER                  PIC X(56) VALUE
014500     '00786603326033008049037270500049450251803200631203122038'.
014600      10  FILLER                  PIC X(56) VALUE
014700     '00714903727050005216027200350051590231502801068904327061'.
014800      10  FILLER                  PIC X(56) VALUE
014900     '00620402722035025898102331180153680722907903326411735142'.
015000      10  FILLER                  PIC X(56) VALUE
015100     '01565407426081026561101331240126060552906801886008031097'.
015200      10  FILLER                  PIC X(56) VALUE
015300     '01125705726064042102126361610138850542806700810106029060'.
015400      10  FILLER                  PIC X(56) VALUE
015500     '01104804327061005789023180300117070412705600674602517031'.
015600      10  FILLER                  PIC X(56) VALUE
015700     '00955403126045005365018110220075780352705002237408531099'.
015800      10  FILLER                  PIC X(56) VALUE
015900     '01236505325061013695049280610078920301603601176103627056'.
016000      10  FILLER                  PIC X(56) VALUE
016100     '00643402017027027116091321330116280442706201289806129088'.
016200      10  FILLER                  PIC X(56) VALUE
016300     '00656903226046009880047280600054570311903801056305028065'.
016400      10  FILLER                  PIC X(56) VALUE
016500     '00827004427054005990032210390109930602907800924005028065'.
016600      10  FILLER                  PIC X(56) VALUE
016700     '00523103423042007794041270540054800302203700391002518031'.
016800      10  FILLER                  PIC X(56) VALUE
016900     '00889204127058003088029230290064730282603801045804728066'.
017000      10  FILLER                  PIC X(56) VALUE
017100     '00543802826038012379046280650444951293617501710306429083'.
017200      10  FILLER                  PIC X(56) VALUE
017300     '03213112335149016937069300860261470943211201569506229072'.
017400      10  FILLER                  PIC X(56) VALUE
017500     '02203407931097011355046240540233090923212403015807931127'.
017600      10  FILLER                  PIC X(56) VALUE
017700     '03295111735161013177061290830121870592908301202005528072'.
017800      10  FILLER                  PIC X(56) VALUE
017900     '01227605829080006801036270500102870472806200594302823036'.
018000      10  FILLER                  PIC X(56) VALUE
018100     '02270706827076018616082310980128930632807201129604327052'.
018200      10  FILLER                  PIC X(56) VALUE
018300     '01719607631106019184057290740109240352204202107508632122'.
018400      10  FILLER                  PIC X(56) VALUE
018500     '02897511134171014231053280690091790342204100561105328053'.
018600      10  FILLER                  PIC X(56) VALUE
018700     '01846306329088009747033260420083640231703000698302011024'.
018800      10  FILLER                  PIC X(56) VALUE
018900     '00950403326051013656047280730072730242003200931502425038'.
019000      10  FILLER                  PIC X(56) VALUE
019100     '00596501814024010399035270560121310352605501057802626045'.
019200      10  FILLER                  PIC X(56) VALUE
019300     '01927506830098010039033260450085010522807800781805228071'.
019400      10  FILLER                  PIC X(56) VALUE
019500     '00571103727049014356084311150102190632908401190005929081'.
019600      10  FILLER                  PIC X(56) VALUE
019700     '00598603827049011295067300900072480472806100744604628064'.
019800      10  FILLER                  PIC X(56) VALUE
019900     '00505003426046005646037270470055340312604300727504127057'.
020000      10  FILLER                  PIC X(56) VALUE
020100     '00655803126047007193039270570044230242103200243801815018'.
020200      10  FILLER                  PIC X(56) VALUE
020300     '00763704728066004365030260410028380292602900641903226044'.
020400      10  FILLER                  PIC X(56) VALUE
020500     '00899703120039006965024110280087650262604100574901708020'.
020600      10  FILLER                  PIC X(56) VALUE
020700     '00808001913026007115026260400223441123415801163306730092'.
020800      10  FILLER                  PIC X(56) VALUE
020900     '01413104928079007451028260390080220282604400906802726044'.
021000      10  FILLER                  PIC X(56) VALUE
021100     '01649506730100006796024250360111570723009501020806129081'.
021200      10  FILLER                  PIC X(56) VALUE
021300     '00640304527061010741055280810048450242503500641804227054'.
021400      10  FILLER                  PIC X(56) VALUE
021500     '00870305929073005822046270550070700422705900684704027056'.
021600      10  FILLER                  PIC X(56) VALUE
021700     '00452302826039002467022190220071710442706000430703126041'.
021800      10  FILLER                  PIC X(56) VALUE
021900     '02388011034154023163069300900211261073415502039705929080'.
022000      10  FILLER                  PIC X(56) VALUE
022100     '01038503026045008537023160300046570140601602630109232135'.
022200      10  FILLER                  PIC X(56) VALUE
022300     '01186604628064007579047280620076340372705100916605128070'.
022400      10  FILLER                  PIC X(56) VALUE
022500     '00535303527046004756028260380097900422706201091905829079'.
022600      10  FILLER                  PIC X(56) VALUE
022700     '00618103627048041370119351400261710913211002371508131111'.
022800      10  FILLER                  PIC X(56) VALUE
022900     '01160004227054012441049280710066390271703301484805028075'.
023000      10  FILLER                  PIC X(56) VALUE
023100     '00806102521032009694033260490054860191202400889103326051'.
023200      10  FILLER                  PIC X(56) VALUE
023300     '00500801915026004756023250230206120572910301299605729081'.
023400      10  FILLER                  PIC X(56) VALUE
023500     '00655602726041011007052280760054320222503400932005629071'.
023600      10  FILLER                  PIC X(56) VALUE
023700     '00610404225051006651039270540072810282603800399201811023'.
023800      10  FILLER                  PIC X(56) VALUE
023900     '00643603727049004233026210340023020312603100667203226044'.
024000      10  FILLER                  PIC X(56) VALUE
024100     '00423301913023003063016090160101220492806800617603126042'.
024200      10  FILLER                  PIC X(56) VALUE
024300     '00870104227060016948061250690130440482005300880203625046'.
024400      10  FILLER                  PIC X(56) VALUE
024500     '00612802612030010260037270570093300312604700272302413024'.
024600      10  FILLER                  PIC X(56) VALUE
024700     '01069902625037007360028260420014790170601701020902425035'.
024800      10  FILLER                  PIC X(56) VALUE
024900     '00843503026046009626051280750048530252503600710603827053'.
025000      10  FILLER                  PIC X(56) VALUE
025100     '00424102322031006810043270530022710130501300593203126042'.
025200      10  FILLER                  PIC X(56) VALUE
025300     '01948307530094014609056290680088810381204100732302913033'.
025400      10  FILLER                  PIC X(56) VALUE
025500     '02367908531106011458043200510080720321003500873903323042'.
025600      10  FILLER                  PIC X(56) VALUE
025700     '01198403226050002902014050140068810272203700666702626038'.
025800      10  FILLER                  PIC X(56) VALUE
025900     '01773906029087011405055290820051790252503700984105529071'.
026000      10  FILLER                  PIC X(56) VALUE
026100     '00513002726039009573045260570065310341103800555802620035'.
026200      10  FILLER                  PIC X(56) VALUE
026300     '00344601808021006721023130280065870442704400441802526037'.
026400      10  FILLER                  PIC X(56) VALUE
026500     '00818102826043007409024140280039620222503400374201609020'.
026600      10  FILLER                  PIC X(56) VALUE
026700     '00467301511021001922012070190045870312604400281801610021'.
026800      10  FILLER                  PIC X(56) VALUE
026900     '01321901825018043591179411790297721333613301796408632086'.
027000      10  FILLER                  PIC X(56) VALUE
027100     '02378507831103006218027260440014650311103103190809332120'.
027200      10  FILLER                  PIC X(56) VALUE
027300     '01294909132091016252049280850083590412705800598002826042'.
027400      10  FILLER                  PIC X(56) VALUE
027500     '01282504828066012360056290720069340382704702603407230112'.
027600      10  FILLER                  PIC X(56) VALUE
027700     '02453309032131009428031260460168230693010000814003827054'.
027800      10  FILLER                  PIC X(56) VALUE
027900     '01835804928049026558086321200116260402705101684005228088'.
028000      10  FILLER                  PIC X(56) VALUE
028100     '00947504928070007172026200330050150252503400453002124029'.
028200      10  FILLER                  PIC X(56) VALUE
028300     '01342206429092007285039270590347691243517301477006530089'.
028400      10  FILLER                  PIC X(56) VALUE
028500     '00876404828061009777057290730092230482806200625803825046'.
028600      10  FILLER                  PIC X(56) VALUE
028700     '00698203827049005446033260430158280683009402454312135200'.
028800      10  FILLER                  PIC X(56) VALUE
028900     '00712903927055005949045270630057940412705900684705228081'.
029000      10  FILLER                  PIC X(56) VALUE
029100     '00953706630104008670075301070063620532807600701804227066'.
029200      10  FILLER                  PIC X(56) VALUE
029300     '00308002626037007373047280640042490392705100838412636157'.
029400      10  FILLER                  PIC X(56) VALUE
029500     '00797209933118000000000000000165990562909301779207030110'.
029600      10  FILLER                  PIC X(56) VALUE
029700     '00878502325043020836057290910081300242503400729004427058'.
029800      10  FILLER                  PIC X(56) VALUE
029900     '00466402926039002846024220240049760232003100089601001010'.
030000      10  FILLER                  PIC X(56) VALUE
030100     '00788603326048004329019150260025270211702100912703927056'.
030200      10  FILLER                  PIC X(56) VALUE
030300     '00475202624035008906038270610046890232503501941004227082'.
030400      10  FILLER                  PIC X(56) VALUE
030500     '01584902526051034645128361840193980823113200936905128073'.
030600      10  FILLER                  PIC X(56) VALUE
030700     '01010402626054014731118351470074160422705900497203026040'.
030800      10  FILLER                  PIC X(56) VALUE
030900     '00436201920029005601025260460042910262605003539111434165'.
031000      10  FILLER                  PIC X(56) VALUE
031100     '00000000000000000000000000000364580803109610699314337314'.
031200      10  FILLER                  PIC X(56) VALUE
031300     '03479708932153000000000000000370150913213102270311535151'.
031400      10  FILLER                  PIC X(56) VALUE
031500     '01568205829094022709060290900138640372705016306624447338'.
031600      10  FILLER                  PIC X(56) VALUE
031700     '11679627250312036620124351631610903826149705448810934171'.
031800      10  FILLER                  PIC X(56) VALUE
031900     '03261010533134048763096331510199320683010104217713937190'.
032000      10  FILLER                  PIC X(56) VALUE
032100     '01785607831117010476047280730160880402204804152911835184'.
032200      10  FILLER                  PIC X(56) VALUE
032300     '01650104327062008769018150240956781824123200000000000000'.
032400     05  DRGX-TAB REDEFINES D-TAB.
032500         10  DRGX-PERIOD               OCCURS 1
032600                                        INDEXED BY DX5.
032700             15  DRGX-EFF-DATE         PIC X(06).
032800             15  DRG-DATA              OCCURS 496
032900                                        INDEXED BY DX6.
033000                 20  DRG-WT            PIC 9(02)V9(04).
033100                 20  DRG-ALOS          PIC 9(02)V9(01).
033200                 20  DRG-DAYS-TRIM     PIC 9(02).
033300                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
033400
033500 01  HOLD-AREA.
033600     02  HOLD-DATES.
033700         05  HOLD-BILL-DATE.
033800             10  H-BILL-YY                PIC 9(02).
033900             10  H-BILL-MM                PIC 9(02).
034000             10  H-BILL-DD                PIC 9(02).
034100
034200         05  HOLD-FY-BEGIN-DATE.
034300             10  H-FY-BEGIN-YY            PIC 9(02).
034400             10  H-FY-BEGIN-MM            PIC 9(02).
034500             10  H-FY-BEGIN-DD            PIC 9(02).
034600
034700         05  HOLD-ADD-FY-BEGN-DATE.
034800             10  H-ADD-FY-BEGN-YY            PIC 9(02).
034900             10  H-ADD-FY-BEGN-MM            PIC 9(02).
035000             10  H-ADD-FY-BEGN-DD            PIC 9(02).
035100
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         05  H-OPER-DSH                   PIC 9(01)V9(04).
037700         05  H-CAPI-DSH                   PIC 9(01)V9(04).
037800
037900         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
038000         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
038100         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
038200         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
038300         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
038400         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
038500         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
038600         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
038700         05  H-CAPI-COLA                  PIC 9(01)V9(03).
038800         05  H-CAPI-SCH                   PIC 9(05)V9(02).
038900         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
039000         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
039100         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
039200         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
039300         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
039400         05  H-CAPI-GAF                   PIC 9(05)V9(04).
039500         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
039600         05  H-COV-DAYS                   PIC 9(3).
039700         05  H-PERDIEM-DAYS               PIC 9(3).
039800         05  H-REG-DAYS                   PIC 9(3).
039900         05  H-LTR-DAYS                   PIC 9(3).
040000         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
040100         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
040200         05  H-ALOS                       PIC 9(02)V9(01).
040300         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
040400         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
040500         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
040600         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
040700         05  H-CST-THRESH                 PIC 9(05)V9(02).
040800         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
040900         05  H-BUDG-NUTR93                PIC 9(01)V9(06).
041000         05  H-BUDG-NUTR94                PIC 9(01)V9(06).
041100         05  H-BUDG-NUTR95                PIC 9(01)V9(06).
041200         05  H-BUDG-NUTR96                PIC 9(01)V9(06).
041300         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
041400         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
041500         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
041600         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
041700         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
041800         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
041900         05  H-LABOR-PCT                  PIC 9(01)V9(04).
042000         05  H-NLABOR-PCT                 PIC 9(01)V9(04).
042100         05  H-HSP-RATE                   PIC 9(06)V9(09).
042200         05  H-FSP-RATE                   PIC 9(06)V9(09).
042300         05  H-OUTLIER-FACT               PIC 9(01)V9(06).
042400         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
042500         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
042600
042700
042800     02  HOLD-ADDITIONAL-VARIABLES.
042900         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
043000         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
043100         05  H-NAT-PCT                    PIC 9(01)V9(02).
043200         05  H-REG-PCT                    PIC 9(01)V9(02).
043300         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).
043400         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
043500         05  H-DRG-WT                     PIC 9(02)V9(04).
043600         05  H-NAT-LABOR                  PIC 9(05)V9(02).
043700         05  H-NAT-NLABOR                 PIC 9(05)V9(02).
043800         05  H-REG-LABOR                  PIC 9(05)V9(02).
043900         05  H-REG-NLABOR                 PIC 9(05)V9(02).
044000         05  H-OPER-COLA                  PIC 9(01)V9(03).
044100         05  H-INTERN-RATIO               PIC 9(01)V9(04).
044200         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
044300         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
044400         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
044500
044600     02  HOLD-CAPITAL-VARIABLES.
044700         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
044800         05  H-CAPI-HSP                   PIC 9(07)V9(02).
044900         05  H-CAPI-FSP                   PIC 9(07)V9(02).
045000         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
045100         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
045200         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
045300         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
045400         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
045500
045600     02  HOLD-CAPITAL2-VARIABLES.
045700         05  H-CAPI2-PAY-CODE             PIC X(1).
045800         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
045900         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
046000
046100 LINKAGE SECTION.
046200***************************************************************
046300*                 * * * * * * * * *                           *
046400*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
046500*    IN HOW TO PAY THE BILL.                                  *
046600*         REVIEW-CODE:                                        *
046700*            00 = PAY-WITH-OUTLIER.                           *
046800*                 WILL CALCULATE THE STANDARD PAYMENT.        *
046900*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
047000*                 OUTLIERS.                                   *
047100*            03 = PAY-PERDIEM-DAYS.                           *
047200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
047300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
047400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
047500*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
047600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
047700*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
047800*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
047900*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
048000*                 BILL EXCEED THE COST THRESHOLD.             *
048100*            06 = PAY-XFER-NO-COST                            *
048200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
048300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
048400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
048500*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
048600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
048700*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
048800*                 CALCULATE ANY COST OUTLIER PORTION          *
048900*                 OF THE PAYMENT.                             *
049000*            07 = PAY-WITHOUT-COST.                           *
049100*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
049200*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
049300*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
049400*                 OUTLIER CUTOFF FOR THE DRG.                 *
049500***************************************************************
049600 01  BILL-DATA.
049700         10  B-PROVIDER-NO          PIC X(06).
049800         10  B-REVIEW-CODE          PIC 9(02).
049900             88  VALID-REVIEW-CODE  VALUE 00 03 06 07.
050000             88  PAY-WITH-OUTLIER   VALUE 00 07.
050100             88  PAY-PERDIEM-DAYS   VALUE 03.
050200             88  PAY-XFER-NO-COST   VALUE 06.
050300             88  PAY-WITHOUT-COST   VALUE 07.
050400         10  B-DRG                  PIC 9(03).
050500         10  B-LOS                  PIC 9(03).
050600         10  B-COVERED-DAYS         PIC 9(03).
050700         10  B-LTR-DAYS             PIC 9(02).
050800         10  B-DISCHARGE-DATE.
050900             15  B-DISCHG-MM        PIC 9(02).
051000             15  B-DISCHG-DD        PIC 9(02).
051100             15  B-DISCHG-YY        PIC 9(02).
051200         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
051300
051400***************************************************************
051500*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
051600*    AND PASSED BACK TO THE CALLING PROGRAM                   *
051700*            RETURN CODE VALUES (PPS-RTC)                     *
051800*                                                             *
051900*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
052000*              00 = PAID NORMAL DRG PAYMENT                   *
052100*                                                             *
052200*              01 = PAID AS A DAY-OUTLIER.                    *
052300*                                                             *
052400*              02 = PAID AS A COST-OUTLIER.                   *
052500*                                                             *
052600*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
052700*                   AND INCLUDING THE FULL DRG.               *
052800*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
052900*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
053000*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
053100*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
053200*                   AND INCLUDING THE FULL DRG. PROVIDER      *
053300*                   REFUSED COST OUTLIER.                     *
053400*                                                             *
053500*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
053600*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
053700*              52 = INVALID MSA # IN PROVIDER FILE            *
053800*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
053900*              54 = DRG < 001 OR > 495, OR = 109 OR = 438     *
054000*                                       OR = 469 OR = 470     *
054100*                                       OR = 474              *
054200*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
054300*              56 = INVALID LENGTH OF STAY                    *
054400*              57 = REVIEW CODE INVALID (NOT 00 03 06 07)     *
054500*              58 = TOTAL CHARGES NOT NUMERIC                 *
054600*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
054700*              62 = INVALID NUMBER OF COVERED DAYS            *
054800*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
054900*                   SPECIFIC FILE FOR CAPITAL                 *
055000*              66 = THERE ARE NOT AS MANY BENEFIT DAYS        *
055100*                   AVAILABLE ON THE BILL AS THERE ARE OUTLIER*
055200*                   DAYS COMPUTED BY PRICER --BENEFITS ARE    *
055300*                   EXHAUSTED ---                             *
055400*                   APPORTION THE CORRECT COVERED CHARGES     *
055500*                   FOR THE MAXIMUM NUMBER OF COVERED DAYS    *
055600*                   AVAILABLE BEFORE RESUBMITTING THE BILL    *
055700*                   FOR THE COST OUTLIER PAYMENT.             *
055800*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
055900***************************************************************
056000 01  PPS-DATA.
056100         10  PPS-RTC                PIC 9(02).
056200         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
056300         10  PPS-OUTLIER-DAYS       PIC 9(03).
056400         10  PPS-AVG-LOS            PIC 9(02)V9(01).
056500         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
056600         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
056700         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
056800         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
056900         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
057000         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
057100         10  PPS-REG-DAYS-USED      PIC 9(03).
057200         10  PPS-LTR-DAYS-USED      PIC 9(02).
057300         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
057400         10  PPS-CALC-VERS          PIC X(05).
057500
057600******************************************************************
057700*            THESE ARE THE VERSIONS OF THE PPCAL
057800*           PROGRAMS THAT WILL BE PASSED BACK----
057900*          ASSOCIATED WITH THE BILL BEING PROCESSED
058000******************************************************************
058100 01  PRICER-OPT-VERS-SW.
058200     02  PRICER-OPTION-SW          PIC X(01).
058300         88  ALL-TABLES-PASSED          VALUE 'A'.
058400         88  PROV-RECORD-PASSED         VALUE 'P'.
058500         88  ADDITIONAL-VARIABLES       VALUE 'M'.
058600     02  PPS-VERSIONS.
058700         10  PPDRV-VERSION         PIC X(05).
058800
058900******************************************************************
059000*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
059100*          ASSOCIATED WITH THE BILL BEING PROCESSED
059200******************************************************************
059300 01  PPS-ADDITIONAL-VARIABLES.
059400     05  PPS-HSP-PCT                PIC 9(01)V9(02).
059500     05  PPS-FSP-PCT                PIC 9(01)V9(02).
059600     05  PPS-NAT-PCT                PIC 9(01)V9(02).
059700     05  PPS-REG-PCT                PIC 9(01)V9(02).
059800     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
059900     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
060000     05  PPS-DRG-WT                 PIC 9(02)V9(04).
060100     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
060200     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
060300     05  PPS-REG-LABOR              PIC 9(05)V9(02).
060400     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
060500     05  PPS-OPER-COLA              PIC 9(01)V9(03).
060600     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
060700     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
060800     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
060900     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
061000     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
061100     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
061200     05  PPS-CAPITAL-VARIABLES.
061300         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
061400         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
061500         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
061600         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
061700         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
061800         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
061900         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
062000         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
062100     05  PPS-CAPITAL2-VARIABLES.
062200         10  PPS-CAPI2-PAY-CODE             PIC X(1).
062300         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
062400         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
062500
062600
062700******************************************************************
062800*               THIS IS THE PROVIDER RECORD
062900*          ASSOCIATED WITH THE BILL BEING PROCESSED
063000******************************************************************
063100 01  PROV-HOLD.
063200     02  PROV-REC-HOLD.
063300         05  P-PROVIDER-NO.
063400             10  P-STATE                PIC 9(02).
063500             10  FILLER                 PIC X(04).
063600         05  P-EFF-DATE.
063700             10  P-EFF-YY               PIC 9(02).
063800             10  P-EFF-MM               PIC 9(02).
063900             10  P-EFF-DD               PIC 9(02).
064000         05  P-WAIVER-CODE              PIC X(01).
064100             88  WAIVER-STATE           VALUE 'Y'.
064200         05  P-PROVIDER-TYPE            PIC X(02).
064300             88  REFERRAL-CENTER        VALUE '07' '15' '17' '22'.
064400             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
064500             88  MDH-REBASED-FY90       VALUE '14' '15'.
064600             88  MDH-RRC-REBASED-FY90   VALUE '15'.
064700             88  SCH-REBASED-FY90       VALUE '16' '17'.
064800             88  SCH-RRC-REBASED-FY90   VALUE '17'.
064900             88  MEDICAL-ASSIST-FACIL   VALUE '18'.
065000             88  EACH                   VALUE '21' '22'.
065100             88  EACH-REFERRAL-CENTER   VALUE '22'.
065200         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
065300             88  NEW-ENGLAND            VALUE  1.
065400             88  MIDDLE-ATLANTIC        VALUE  2.
065500             88  SOUTH-ATLANTIC         VALUE  3.
065600             88  EAST-NORTH-CENTRAL     VALUE  4.
065700             88  EAST-SOUTH-CENTRAL     VALUE  5.
065800             88  WEST-NORTH-CENTRAL     VALUE  6.
065900             88  WEST-SOUTH-CENTRAL     VALUE  7.
066000             88  MOUNTAIN               VALUE  8.
066100             88  PACIFIC                VALUE  9.
066200         05  P-CENSUS-DIV  REDEFINES
066300                    P-CURRENT-CENSUS-DIV       PIC 9(01).
066400             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.
066500         05  P-PPS-BLEND-YEAR           PIC 9(01).
066600             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
066700         05  P-MSA-X.
066800             10  P-MSA-9                PIC X(04).
066900         05  P-FISCAL-YEAR-END.
067000             10  P-MM                   PIC 9(02).
067100             10  P-DD                   PIC 9(02).
067200             10  P-YY                   PIC 9(02).
067300         05  P-VARIABLES.
067400             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
067500             10  P-COLA                 PIC S9(01)V9(03).
067600             10  P-INTERN-RATIO         PIC S9(01)V9(04).
067700             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
067800             10  P-BED-SIZE             PIC  9(05).
067900             10  P-DSH-PERCENT          PIC V9(04).
068000             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).
068100             10  P-CMI                  PIC  9(01)V9(04).
068200             10  FILLER                 PIC  9(01).
068300             10  P-REPORT-DATE          PIC  9(06).
068400             10  FILLER                 PIC  9(01).
068500             10  P-INTER-NO             PIC  9(05).
068600     02  PROV-REC-HOLD2.
068700         05  P-FY-BEGIN-DATE.
068800             10  P-FY-BEGIN-MM          PIC 9(2).
068900             10  P-FY-BEGIN-DD          PIC 9(2).
069000             10  P-FY-BEGIN-YY          PIC 9(2).
069100         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.
069200         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.
069300         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.
069400         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.
069500         05  P-SSI-RATIO                PIC V9(4).
069600         05  P-MEDICAID-RATIO           PIC V9(4).
069700         05  P-TERMINATION-DATE         PIC X(6).
069800         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).
069900         05  P-CHG-CODE-INDEX           PIC X.
070000         05  P-STAND-AMT-LOC-MSA.
070100             10  P-RURAL-1ST            PIC XX.
070200                 88  P-RURAL-CHECK        VALUE '  '.
070300             10  P-RURAL-2ND            PIC XX.
070400         05  P-CAPI-SOL-HOSP-RATE       PIC XX.
070500         05  FILLER                     PIC X.
070600         05  FILLER                     PIC X(06).
070700         05  FILLER                     PIC X(18).
070800     02  PROV-REC-HOLD3.
070900         05  P-CAPI-PPS-PAY-CODE        PIC X.
071000         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.
071100         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.
071200         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.
071300         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.
071400         05  P-CAPI-NEW-HOSP            PIC X.
071500         05  P-CAPI-IME                 PIC 9V9999.
071600         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.
071700         05  FILLER                     PIC X(46).
071800
071900******************************************************************
072000*                   THIS IS THE WAGE-INDEX
072100*          ASSOCIATED WITH THE BILL BEING PROCESSED
072200******************************************************************
072300 01  WAGE-INDEX-RECORD.
072400     05  W-MSA                         PIC X(4).
072500     05  W-SIZE                        PIC X.
072600         88  LARGE-URBAN       VALUE 'L'.
072700         88  OTHER-URBAN       VALUE 'O'.
072800         88  ALL-RURAL         VALUE 'R'.
072900     05  W-EFF-DATE                    PIC X(6).
073000     05  FILLER                        PIC X.
073100     05  W-INDEX-RECORD                PIC S9(02)V9(04).
073200
073300
073400 PROCEDURE DIVISION  USING BILL-DATA
073500                           PPS-DATA
073600                           PRICER-OPT-VERS-SW
073700                           PPS-ADDITIONAL-VARIABLES
073800                           PROV-HOLD
073900                           WAGE-INDEX-RECORD.
074000
074100***************************************************************
074200*    PROCESSING:                                              *
074300*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
074400*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
074500*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
074600*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
074700*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
074800*           GOBACK.                                           *
074900*        D. ASSEMBLE PRICING COMPONENTS.                      *
075000*        E. CALCULATE THE BLENDED PRICE.                      *
075100***************************************************************
075200
075300     PERFORM 0200-MAINLINE-CONTROL.
075400
075500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
075600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
075700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
075800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
075900     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
076000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
076100
076200     GOBACK.
076300
076400 0200-MAINLINE-CONTROL.
076500     MOVE ALL '0' TO PPS-DATA
076600                     HOLD-PPS-COMPONENTS
076700                     HOLD-ADDITIONAL-VARIABLES
076800                     HOLD-CAPITAL-VARIABLES
076900                     HOLD-CAPITAL2-VARIABLES.
077000
077100     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC
077200        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.
077300
077400     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC
077500        MOVE 0 TO P-CAPI-OLD-HARM-RATE.
077600
077700     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC
077800        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.
077900
078000     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC
078100        MOVE 0 TO P-CAPI-CSTCHG-RATIO.
078200
078300******************************************************************
078400     PERFORM 1000-EDIT-THE-BILL-INFO.
078500
078600     IF  PPS-RTC = 00
078700         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
078800         PERFORM 3000-CALC-BLENDED-PAYMENT.
078900
079000 1000-EDIT-THE-BILL-INFO.
079100***************************************************************
079200*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
079300*    AND DO NOT ATTEMPT TO PRICE.                             *
079400***************************************************************
079500
079600     MOVE B-DISCHG-YY TO H-BILL-YY.
079700     MOVE B-DISCHG-MM TO H-BILL-MM.
079800     MOVE B-DISCHG-DD TO H-BILL-DD.
079900
080000     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.
080100     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.
080200     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.
080300
080400     IF HOLD-FY-BEGIN-DATE < 951001
080500        MOVE .40 TO H-CAPI-PAYCDE-PCT1
080600        MOVE .60 TO H-CAPI-PAYCDE-PCT2
080700     ELSE
080800        IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR
080900           (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)
081000              MOVE .50 TO H-CAPI-PAYCDE-PCT1
081100              MOVE .50 TO H-CAPI-PAYCDE-PCT2
081200        ELSE
081300              MOVE .40 TO H-CAPI-PAYCDE-PCT1
081400              MOVE .60 TO H-CAPI-PAYCDE-PCT2.
081500
081600     IF  PPS-RTC = 00
081700         IF  WAIVER-STATE
081800             MOVE 53 TO PPS-RTC.
081900
082000     IF  PPS-RTC = 00
082100         IF  B-DRG < 001 OR > 495 OR = 109 OR = 438
082200                                  OR = 469 OR = 470
082300                                  OR = 474
082400             MOVE 54 TO PPS-RTC.
082500
082600     IF  PPS-RTC = 00
082700         IF  HOLD-BILL-DATE < P-EFF-DATE
082800             MOVE 55 TO PPS-RTC.
082900
083000     IF  PPS-RTC = 00
083100         IF  B-REVIEW-CODE NOT NUMERIC
083200             MOVE 57 TO PPS-RTC.
083300     IF  PPS-RTC = 00
083400         IF  B-LOS NOT NUMERIC
083500             MOVE 56 TO PPS-RTC
083600         ELSE
083700         IF  B-LOS = 0
083800             IF B-REVIEW-CODE NOT = 03 AND
083900                              NOT = 06
084000             MOVE 56 TO PPS-RTC.
084100
084200     IF  PPS-RTC = 00
084300         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
084400             MOVE 61 TO PPS-RTC
084500         ELSE
084600             MOVE B-LTR-DAYS TO H-LTR-DAYS.
084700
084800     IF  PPS-RTC = 00
084900         IF  B-COVERED-DAYS NOT NUMERIC
085000             MOVE 62 TO PPS-RTC
085100         ELSE
085200         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
085300             MOVE 62 TO PPS-RTC
085400         ELSE
085500             MOVE B-COVERED-DAYS TO H-COV-DAYS.
085600
085700     IF  PPS-RTC = 00
085800         IF  H-LTR-DAYS  > H-COV-DAYS
085900             MOVE 62 TO PPS-RTC
086000         ELSE
086100             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
086200
086300     IF  PPS-RTC = 00
086400         IF  NOT VALID-REVIEW-CODE
086500             MOVE 57 TO PPS-RTC.
086600
086700     IF  PPS-RTC = 00
086800         IF  B-CHARGES-CLAIMED NOT NUMERIC
086900             MOVE 58 TO PPS-RTC.
087000
087100     IF PPS-RTC = 00
087200        IF NOT INDIAN-HEALTH-SERVICE
087300           IF P-CAPI-NEW-HOSP NOT = 'Y'
087400                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND
087500                                        NOT = 'B' AND
087600                                        NOT = 'C'
087700                 MOVE 65 TO PPS-RTC.
087800
087900 2000-ASSEMBLE-PPS-VARIABLES.
088000***************************************************************
088100*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
088200*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
088300*    OF THAT VARIABLE.                                        *
088400***************************************************************
088500***  GET THE PROVIDER SPECIFIC VARIABLES.
088600
088700     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
088800     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
088900
089000     IF  NOT (P-STATE = 02 OR 12)
089100         MOVE 1 TO H-OPER-COLA
089200     ELSE
089300         MOVE P-COLA TO H-OPER-COLA.
089400
089500***************************************************************
089600***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
089700
089800     PERFORM 2600-GET-DRG-WEIGHT
089900             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
090000
090100***************************************************************
090200***  GET THE WAGE-INDEX
090300
090400     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
090500
090600***************************************************************
090700***  GET THE LABOR, NON-LABOR STANDARD RATES
090800
090900     IF  VALID-CENSUS-DIV
091000         MOVE P-CURRENT-CENSUS-DIV TO R2
091100     ELSE
091200         MOVE 10 TO R2.
091300
091400     MOVE 10 TO R4.
091500
091600     IF  P-STATE = 40
091700         MOVE 11 TO R2
091800         MOVE 12 TO R4.
091900
092000     IF  LARGE-URBAN
092100         MOVE 1 TO R3
092200     ELSE
092300     IF  OTHER-URBAN OR REFERRAL-CENTER
092400         MOVE 2 TO R3
092500     ELSE
092600         MOVE 3 TO R3.
092700
092800     PERFORM 2300-GET-LABOR-NLABOR-RATES
092900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
093000
093100***************************************************************
093200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
093300
093400     MOVE 0.00  TO H-OPER-HSP-PCT.
093500     MOVE 1.00  TO H-OPER-FSP-PCT.
093600
093700***************************************************************
093800***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
093900
094000      MOVE 1.00 TO H-NAT-PCT.
094100      MOVE 0.00 TO H-REG-PCT.
094200
094300***************************************************************
094400*    REGIONAL FLOOR
094500
094600     IF  (H-REG-LABOR + H-REG-NLABOR) >
094700         (H-NAT-LABOR + H-NAT-NLABOR)
094800           MOVE 0.85 TO H-NAT-PCT
094900           MOVE 0.15 TO H-REG-PCT.
095000
095100     IF  P-STATE = 40
095200         MOVE 0.25 TO H-NAT-PCT
095300         MOVE 0.75 TO H-REG-PCT.
095400
095500     IF  SCH-REBASED-FY90 OR EACH
095600         MOVE 1.00 TO H-OPER-HSP-PCT.
095700
095800 2300-GET-LABOR-NLABOR-RATES.
095900
096000     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)
096100         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
096200         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR
096300         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
096400         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR.
096500
096600 2600-GET-DRG-WEIGHT.
096700     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)
096800         SET DX6 TO B-DRG
096900         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
097000         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
097100         MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
097200         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
097300
097400 3000-CALC-BLENDED-PAYMENT.
097500***************************************************************
097600*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
097700*        CALCULATE COVERED DAYS UTILIZATION.                  *
097800*        CALCULATE THE FEDERAL PORTION.                       *
097900*        CALCULATE THE HOSPITAL PORTION.                      *
098000*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
098100*        CALCULATE THE COST-OUTLIER PORTION.                  *
098200*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *
098300*        CALCULATE THE DSH ADJUSTMENT.                        *
098400***************************************************************
098500     PERFORM 3100-CALC-STAY-UTILIZATION.
098600     PERFORM 3300-CALC-OPER-FSP-AMT.
098700     PERFORM 3900-CALC-OPER-DSH.
098800***********************************************************
098900***  OPERATING IME CALCULATION
099000
099100         COMPUTE H-OPER-IME-TEACH =
099200            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).
099300
099400***********************************************************
099500
099600     IF  SCH-REBASED-FY90 OR EACH
099700         PERFORM 3450-CALC-ADDITIONAL-HSP.
099800
099900     MOVE 00                 TO  PPS-RTC.
100000     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
100100     MOVE H-ALOS             TO  PPS-AVG-LOS.
100200     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
100300
100400     MOVE B-LOS TO H-PERDIEM-DAYS.
100500     IF H-PERDIEM-DAYS < 1
100600         MOVE 1 TO H-PERDIEM-DAYS.
100700     ADD 1 TO H-PERDIEM-DAYS.
100800
100900     PERFORM 3600-CALC-OUTLIER.
101000
101100     IF PAY-PERDIEM-DAYS
101200         IF  H-PERDIEM-DAYS < H-ALOS
101300             IF  NOT (B-DRG = 385 OR 456)
101400                 PERFORM 3500-CALC-PERDIEM-AMT
101500                 MOVE 03 TO PPS-RTC.
101600
101700     IF  PAY-PERDIEM-DAYS
101800         IF  H-OPER-OUTCST-PART > 0
101900             MOVE H-OPER-OUTCST-PART TO
102000                  H-OPER-OUTLIER-PART
102100             MOVE 05 TO PPS-RTC
102200         ELSE
102300         IF  PPS-RTC NOT = 03
102400             MOVE 00 TO PPS-RTC
102500             MOVE 0  TO H-OPER-OUTLIER-PART.
102600
102700     IF  PAY-PERDIEM-DAYS
102800         IF  H-CAPI-OUTCST-PART > 0
102900             MOVE H-CAPI-OUTCST-PART TO
103000                  H-CAPI-OUTLIER-PART
103100             MOVE 05 TO PPS-RTC
103200         ELSE
103300         IF  PPS-RTC NOT = 03
103400             MOVE 0  TO H-CAPI-OUTLIER-PART.
103500
103600     IF  PAY-XFER-NO-COST
103700         MOVE 0  TO H-OPER-OUTLIER-PART
103800                    H-CAPI-OUTLIER-PART
103900         MOVE 00 TO PPS-RTC
104000         IF H-PERDIEM-DAYS < H-ALOS
104100            IF  NOT (B-DRG = 385 OR 456)
104200                PERFORM 3500-CALC-PERDIEM-AMT
104300                MOVE 06 TO PPS-RTC.
104400
104500     MOVE 1 TO H-DSCHG-FRCTN.
104600
104700     IF  (PAY-PERDIEM-DAYS OR
104800          PAY-XFER-NO-COST)
104900          COMPUTE H-DSCHG-FRCTN = H-PERDIEM-DAYS / H-ALOS
105000          IF H-DSCHG-FRCTN > 1
105100             MOVE 1 TO H-DSCHG-FRCTN.
105200
105300     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.
105400
105500***********************************************************
105600***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
105700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
105800
105900     COMPUTE H-CAPI2-B-FSP-PART = H-CAPI-FSP-PART.
106000
106100***********************************************************
106200     IF  PPS-RTC < 50
106300         PERFORM 3800-CALC-TOT-AMT
106400     ELSE
106500         MOVE 0 TO PPS-OPER-HSP-PART
106600                   PPS-OPER-FSP-PART
106700                   PPS-OPER-OUTLIER-PART
106800                   PPS-OUTLIER-DAYS
106900                   PPS-REG-DAYS-USED
107000                   PPS-LTR-DAYS-USED
107100                   PPS-TOTAL-PAYMENT
107200                   PPS-OPER-DSH-ADJ
107300                   PPS-OPER-IME-ADJ
107400                   H-DSCHG-FRCTN
107500                   H-DRG-WT-FRCTN
107600                   HOLD-CAPITAL-VARIABLES
107700                   HOLD-CAPITAL2-VARIABLES.
107800
107900 3100-CALC-STAY-UTILIZATION.
108000     IF  H-REG-DAYS > 0
108100         IF  H-REG-DAYS < H-DAYS-CUTOFF
108200             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
108300             MOVE 0          TO H-REG-DAYS
108400         ELSE
108500             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
108600             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
108700     ELSE
108800     IF  H-LTR-DAYS < H-DAYS-CUTOFF
108900         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
109000         MOVE 0          TO H-LTR-DAYS
109100     ELSE
109200         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
109300         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.
109400
109500     IF  B-LOS > H-DAYS-CUTOFF
109600         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
109700
109800 3200-CALC-OUTLIER-UTILIZATION.
109900     COMPUTE PPS-OUTLIER-DAYS =
110000         B-LOS - H-DAYS-CUTOFF.
110100
110200     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
110300         COMPUTE PPS-OUTLIER-DAYS =
110400             H-REG-DAYS + H-LTR-DAYS
110500         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
110600         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
110700     ELSE
110800     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
110900         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
111000         COMPUTE PPS-LTR-DAYS-USED =
111100             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -
111200                                  H-REG-DAYS)
111300     ELSE
111400         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
111500
111600     IF  B-REVIEW-CODE = 03
111700         IF  PPS-REG-DAYS-USED > 0
111800             MOVE 0 TO PPS-LTR-DAYS-USED.
111900
112000 3300-CALC-OPER-FSP-AMT.
112100***********************************************************
112200***  OPERATING FSP CALCULATION
112300
112400     COMPUTE H-OPER-FSP-PART ROUNDED =
112500         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
112600         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)
112700                           +
112800         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
112900         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).
113000
113100
113200 3450-CALC-ADDITIONAL-HSP.
113300***********************************************************
113400*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
113500*    SOLE COMMUNITY
113600*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
113700*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
113800***********************************************************
113900**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
114000****    USE ACTUAL FEDERAL REGISTER NUMBER
114100
114200     MOVE 0.948950 TO H-OUTLIER-FACT.
114300***************************************************************
114400***         GET THE UPDATING FACTOR
114500
114600     MOVE 0.999851 TO H-BUDG-NUTR93.
114700     MOVE 0.999003 TO H-BUDG-NUTR94.
114800     MOVE 0.998050 TO H-BUDG-NUTR95.
114900     MOVE 0.999306 TO H-BUDG-NUTR96.
115000
115100     COMPUTE H-UPDATE-FACTOR ROUNDED =
115200        (1.014 * H-BUDG-NUTR93 * H-BUDG-NUTR94 *
115300                 H-BUDG-NUTR95 * H-BUDG-NUTR96 * 1.015).
115400
115500     COMPUTE H-HSP-RATE ROUNDED =
115600         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.
115700
115800     COMPUTE H-FSP-RATE ROUNDED =
115900         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
116000         H-NAT-NLABOR * H-OPER-COLA))
116100                           +
116200          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
116300         H-REG-NLABOR * H-OPER-COLA)))
116400                           *
116500       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT).
116600
116700     IF  H-HSP-RATE > H-FSP-RATE
116800           COMPUTE H-OPER-HSP-PART =
116900             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
117000     ELSE
117100         MOVE 0 TO H-OPER-HSP-PART.
117200
117300***************************************************************
117400***        IF MDH IS REVIVED --- REPLACE THIS CODE
117500***  IF  H-HSP-RATE > H-FSP-RATE
117600***      IF P-PROVIDER-TYPE = '14' OR '15'
117700***         COMPUTE H-OPER-HSP-PART =
117800***            (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5.
117900***************************************************************
118000
118100 3500-CALC-PERDIEM-AMT.
118200***********************************************************
118300***  OPERATING PERDIEM-AMT CALCULATION
118400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
118500
118600     COMPUTE H-OPER-HSP-PART ROUNDED =
118700        H-OPER-HSP-PART / H-ALOS * H-PERDIEM-DAYS
118800        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
118900
119000     COMPUTE H-OPER-FSP-PART ROUNDED =
119100        H-OPER-FSP-PART / H-ALOS * H-PERDIEM-DAYS
119200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
119300
119400***********************************************************
119500***  CAPITAL PERDIEM-AMT CALCULATION
119600***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
119700
119800     COMPUTE H-CAPI-HSP-PART ROUNDED =
119900        H-CAPI-HSP-PART / H-ALOS * H-PERDIEM-DAYS
120000        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
120100
120200     COMPUTE H-CAPI-FSP-PART ROUNDED =
120300        H-CAPI-FSP-PART / H-ALOS * H-PERDIEM-DAYS
120400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
120500
120600***********************************************************
120700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
120800
120900     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
121000        H-CAPI-OLD-HARMLESS / H-ALOS * H-PERDIEM-DAYS
121100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
121200
121300 3600-CALC-OUTLIER.
121400     MOVE 0.44 TO H-DAYOUT-PCT.
121500
121600     MOVE 0.80 TO H-CSTOUT-PCT.
121700
121800     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
121900             MOVE 0.90 TO H-CSTOUT-PCT.
122000
122100     MOVE 0.7140   TO H-LABOR-PCT.
122200     MOVE 0.2860   TO H-NLABOR-PCT.
122300
122400     IF  P-OPER-CSTCHG-RATIO NUMERIC
122500             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
122600     ELSE
122700             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
122800
122900     IF P-CAPI-CSTCHG-RATIO NUMERIC
123000             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
123100     ELSE
123200             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
123300
123400***********************************************************
123500***  OPERATING DAY OUTLIER CALCULATION
123600
123700     IF  PPS-OUTLIER-DAYS > 0
123800        COMPUTE H-OPER-OUTDAY-PART =
123900            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ARITH-ALOS
124000                                       * PPS-OUTLIER-DAYS
124100            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.
124200
124300***********************************************************
124400***********************************************************
124500***  CAPITAL PAYMENT METHOD B
124600
124700     IF W-SIZE = 'L'
124800        MOVE 1.03 TO H-CAPI-LARG-URBAN
124900     ELSE
125000        MOVE 1.00 TO H-CAPI-LARG-URBAN.
125100
125200     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).
125300
125400     COMPUTE H-CAPI-COLA =
125500                     (.3152 * (H-OPER-COLA - 1) + 1).
125600
125700     MOVE 0355.35 TO H-PUERTO-RICO-RATE.
125800     MOVE 0461.96 TO H-FEDERAL-RATE.
125900
126000     IF P-STATE = 40
126100        COMPUTE  H-CAPI-FED-RATE =
126200                      (.75 * H-PUERTO-RICO-RATE) +
126300                      (.25 * H-FEDERAL-RATE)
126400     ELSE
126500        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
126600
126700***********************************************************
126800***  CAPITAL HSP CALCULATION
126900
127000     MOVE 0.9784 TO H-HSP-UPDATE94.
127100     MOVE 1.0005 TO H-HSP-UPDATE95.
127200     MOVE 1.2110 TO H-HSP-UPDATE96.
127300
127400     COMPUTE H-ACCUM-TO-HSP = (H-HSP-UPDATE94 *
127500                               H-HSP-UPDATE95 *
127600                               H-HSP-UPDATE96).
127700
127800     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *
127900                   P-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
128000***********************************************************
128100***  CAPITAL FSP CALCULATION
128200
128300     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *
128400                               H-CAPI-COLA * H-CAPI-GAF *
128500                               H-CAPI-LARG-URBAN.
128600
128700***********************************************************
128800***  CAPITAL PAYMENT METHOD A
128900
129000     IF SCH-REBASED-FY90 OR EACH
129100        MOVE 1.00 TO H-CAPI-SCH
129200     ELSE
129300        MOVE 0.85 TO H-CAPI-SCH.
129400
129500***********************************************************
129600***********  CAPITAL OLD-HARMLESS CALCULATION ***********
129700
129800     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
129900                    (P-CAPI-OLD-HARM-RATE *
130000                    H-CAPI-SCH).
130100
130200***********************************************************
130300***********************************************************
130400***  CAPITAL DAY OUTLIER CALCULATION
130500
130600     IF  PPS-OUTLIER-DAYS > 0
130700         COMPUTE H-CAPI-OUTDAY-PART =
130800            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ARITH-ALOS
130900                                       * PPS-OUTLIER-DAYS
131000            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
131100
131200     IF  H-CAPI-OUTDAY-PART  > 0
131300         IF P-CAPI-PPS-PAY-CODE = 'A'
131400             COMPUTE H-CAPI-OUTDAY-PART =
131500                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO
131600             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
131700
131800     IF  H-CAPI-OUTDAY-PART  > 0
131900         IF P-CAPI-PPS-PAY-CODE = 'C'
132000             COMPUTE H-CAPI-OUTDAY-PART =
132100                    (H-CAPI-OUTDAY-PART * H-CAPI-PAYCDE-PCT1)
132200             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
132300
132400***********************************************************
132500***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
132600
132700     IF H-CAPI-CSTCHG-RATIO > 0 OR
132800       H-OPER-CSTCHG-RATIO > 0
132900        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =
133000                H-OPER-CSTCHG-RATIO /
133100               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
133200        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =
133300                H-CAPI-CSTCHG-RATIO /
133400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
133500     ELSE
133600         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
133700                   H-CAPI-SHARE-DOLL-THRESHOLD.
133800
133900     MOVE 15150.00 TO H-CST-THRESH.
134000     MOVE 13800.00 TO H-PRE-CAPI-THRESH.
134100
134200     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
134300        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +
134400         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *
134500          H-OPER-SHARE-DOLL-THRESHOLD.
134600
134700***********************************************************
134800***  DIFFERENT THRESHOLD   PRE-CAPITAL
134900
135000     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
135100        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
135200        (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
135300        (H-PRE-CAPI-THRESH * H-NLABOR-PCT * H-OPER-COLA).
135400***********************************************************
135500
135600     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
135700          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
135800          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
135900
136000     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
136100          H-OPER-FSP-PART + H-OPER-DOLLAR-THRESHOLD.
136200
136300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
136400          H-CAPI-FSP-PART + H-CAPI-DOLLAR-THRESHOLD.
136500
136600     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
136700         MOVE 0 TO H-CAPI-COST-OUTLIER.
136800
136900     IF B-REVIEW-CODE = '03'  AND H-PERDIEM-DAYS < H-ALOS
137000        COMPUTE H-OPER-COST-OUTLIER ROUNDED =
137100                (H-OPER-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)
137200                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.
137300
137400     IF B-REVIEW-CODE = '03'  AND H-PERDIEM-DAYS < H-ALOS
137500        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
137600                (H-CAPI-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)
137700                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.
137800
137900***********************************************************
138000***  CAPITAL DSH CALCULATION
138100     MOVE 0 TO H-CAPI-DSH.
138200
138300     IF P-BED-SIZE NOT NUMERIC
138400         MOVE 0 TO P-BED-SIZE.
138500
138600     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
138700         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
138800                  (.2025 * (P-SSI-RATIO
138900                          + P-MEDICAID-RATIO)) - 1.
139000
139100***********************************************************
139200***  OPERATING COST CALCULATION
139300
139400     COMPUTE H-OPER-BILL-COSTS ROUNDED =
139500         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /
139600         (1 + H-OPER-IME-TEACH + H-OPER-DSH)
139700         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
139800
139900     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
140000         COMPUTE H-OPER-OUTCST-PART =
140100         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
140200                         H-OPER-COST-OUTLIER).
140300
140400     IF PAY-WITHOUT-COST
140500         MOVE 0 TO H-OPER-OUTCST-PART.
140600
140700***********************************************************
140800***  CAPITAL IME TEACH CALCULATION
140900
141000     MOVE 0 TO H-WK-CAPI-IME-TEACH.
141100
141200     IF P-CAPI-IME NUMERIC
141300        COMPUTE H-WK-CAPI-IME-TEACH =
141400          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.
141500
141600***********************************************************
141700***  CAPITAL COST CALCULATION
141800
141900     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
142000             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /
142100            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)
142200         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
142300
142400     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
142500         COMPUTE H-CAPI-OUTCST-PART =
142600         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
142700                         H-CAPI-COST-OUTLIER).
142800
142900     IF P-CAPI-PPS-PAY-CODE = 'A'
143000       COMPUTE H-CAPI-OUTCST-PART =
143100              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).
143200
143300     IF P-CAPI-PPS-PAY-CODE = 'C'
143400        COMPUTE H-CAPI-OUTCST-PART =
143500               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
143600
143700     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
143800        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
143900        MOVE 0 TO H-CAPI-OUTCST-PART
144000                  H-OPER-OUTCST-PART.
144100
144200     IF PAY-WITHOUT-COST
144300         MOVE 0 TO H-CAPI-OUTCST-PART.
144400
144500***********************************************************
144600***  DETERMINES THE BILL TO BE EITHER COST OR DAY OUTLIER
144700***     GREATER OF DAY OR COST OPERATING AND CAPITAL
144800
144900     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
145000         MOVE 0 TO H-CAPI-OUTDAY-PART
145100                   H-CAPI-OUTCST-PART.
145200
145300      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR
145400         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
145500         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >
145600            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)
145700                 MOVE H-OPER-OUTDAY-PART TO
145800                      H-OPER-OUTLIER-PART
145900                 MOVE H-CAPI-OUTDAY-PART TO
146000                      H-CAPI-OUTLIER-PART
146100                 MOVE 01 TO PPS-RTC
146200             ELSE
146300                 MOVE H-OPER-OUTCST-PART TO
146400                      H-OPER-OUTLIER-PART
146500                 MOVE H-CAPI-OUTCST-PART TO
146600                      H-CAPI-OUTLIER-PART
146700                 MOVE 02 TO PPS-RTC
146800                 IF B-COVERED-DAYS > H-DAYS-CUTOFF
146900                    IF (H-REG-DAYS
147000                            +
147100                        H-LTR-DAYS)   <
147200                       (B-COVERED-DAYS - H-DAYS-CUTOFF)
147300                       MOVE 66 TO PPS-RTC.
147400
147500***********************************************************
147600***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
147700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
147800
147900     IF P-CAPI-PPS-PAY-CODE = 'A'
148000        COMPUTE H-CAPI2-B-OUTLIER-PART =
148100                H-CAPI-OUTLIER-PART / P-CAPI-NEW-HARM-RATIO
148200         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
148300
148400     IF P-CAPI-PPS-PAY-CODE = 'B'
148500        COMPUTE H-CAPI2-B-OUTLIER-PART =
148600                H-CAPI-OUTLIER-PART.
148700
148800     IF P-CAPI-PPS-PAY-CODE = 'C'
148900        COMPUTE H-CAPI2-B-OUTLIER-PART =
149000                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
149100         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
149200***********************************************************
149300
149400 3800-CALC-TOT-AMT.
149500
149600***********************************************************
149700***  CALCULATE FINAL TOTALS FOR OPERATING
149800
149900     COMPUTE PPS-OPER-HSP-PART ROUNDED =
150000         H-OPER-HSP-PCT * H-OPER-HSP-PART.
150100
150200     COMPUTE PPS-OPER-FSP-PART ROUNDED =
150300         H-OPER-FSP-PCT * H-OPER-FSP-PART.
150400
150500     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
150600             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
150700
150800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
150900
151000     IF  H-OPER-DSH NUMERIC
151100             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
151200             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)
151300              * H-OPER-DSH.
151400
151500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
151600         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *
151700                 H-OPER-IME-TEACH.
151800
151900***********************************************************
152000***  CALCULATE FINAL TOTALS FOR CAPITAL
152100
152200     MOVE P-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
152300
152400     IF P-CAPI-PPS-PAY-CODE = 'A'
152500        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
152600        MOVE 0.00 TO H-CAPI-HSP-PCT.
152700
152800     IF P-CAPI-PPS-PAY-CODE = 'B'
152900        MOVE 0    TO H-CAPI-OLD-HARMLESS
153000        MOVE 1.00 TO H-CAPI-FSP-PCT
153100        MOVE 0.00 TO H-CAPI-HSP-PCT.
153200
153300     IF P-CAPI-PPS-PAY-CODE = 'C'
153400        MOVE 0    TO H-CAPI-OLD-HARMLESS
153500        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
153600        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
153700
153800     COMPUTE H-CAPI-HSP ROUNDED =
153900         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
154000
154100     COMPUTE H-CAPI-FSP ROUNDED =
154200         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
154300
154400     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
154500
154600     COMPUTE H-CAPI-OUTLIER ROUNDED =
154700             1.00 * H-CAPI-OUTLIER-PART.
154800
154900     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
155000             1.00 * H-CAPI2-B-OUTLIER-PART.
155100
155200     COMPUTE H-CAPI2-B-FSP ROUNDED =
155300             1.00 * H-CAPI2-B-FSP-PART.
155400
155500     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
155600
155700     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
155800             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)
155900              * H-CAPI-DSH.
156000
156100     COMPUTE H-CAPI-IME-ADJ ROUNDED =
156200         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *
156300                 H-WK-CAPI-IME-TEACH.
156400
156500***********************************************************
156600***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
156700***        THIS ZEROES OUT ALL CAPITAL DATA
156800
156900     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
157000        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
157100
157200     COMPUTE H-CAPI-TOTAL-PAY =
157300             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
157400             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
157500             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
157600
157700***********************************************************
157800***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
157900
158000     COMPUTE PPS-TOTAL-PAYMENT =
158100             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
158200             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
158300             PPS-OPER-IME-ADJ
158400                           +
158500                  H-CAPI-TOTAL-PAY.
158600
158700 3900-CALC-OPER-DSH.
158800***********************************************************
158900***  OPERATING DSH CALCULATION
159000
159100      MOVE .00 TO H-OPER-DSH.
159200
159300      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO
159400                                     + P-MEDICAID-RATIO).
159500
159600      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100
159700                               AND H-WK-OPER-DSH > .3999
159800        MOVE .05 TO H-OPER-DSH.
159900
160000      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
160100                               AND H-WK-OPER-DSH > .1499
160200                               AND H-WK-OPER-DSH < .2021
160300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
160400                                      * .65 + .025.
160500
160600      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
160700                               AND H-WK-OPER-DSH > .1499
160800                               AND H-WK-OPER-DSH < .2021
160900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
161000                                 * .65 + .025.
161100
161200      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
161300                               AND H-WK-OPER-DSH > .202
161400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
161500                                 * .825 + .0588.
161600
161700      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
161800                               AND H-WK-OPER-DSH > .202
161900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
162000                                 * .825 + .0588.
162100
162200      IF W-SIZE = 'R'          AND P-BED-SIZE < 101
162300                               AND H-WK-OPER-DSH > .4499
162400        MOVE .04 TO H-OPER-DSH.
162500
162600      IF W-SIZE = 'R'          AND P-BED-SIZE > 100
162700                               AND P-BED-SIZE < 500
162800                               AND H-WK-OPER-DSH > .2999
162900        MOVE .04 TO H-OPER-DSH.
163000
163100      IF W-SIZE = 'R'
163200         IF (P-PROVIDER-TYPE = '16' OR '21')
163300                               AND H-WK-OPER-DSH > .2999
163400                               AND P-BED-SIZE < 500
163500            MOVE .10 TO H-OPER-DSH.
163600
163700      IF W-SIZE = 'R'
163800         IF (P-PROVIDER-TYPE = '07')
163900                               AND H-WK-OPER-DSH > .2999
164000                               AND P-BED-SIZE > 100
164100                               AND P-BED-SIZE < 500
164200            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
164300                                 * .6 + .04.
164400
164500      IF W-SIZE = 'R'
164600         IF (P-PROVIDER-TYPE = '17' OR '22')
164700                               AND H-WK-OPER-DSH > .2999
164800                               AND P-BED-SIZE < 500
164900            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
165000                                 * .6 + .04.
165100
165200      IF W-SIZE = 'R'
165300         IF (P-PROVIDER-TYPE = '17' OR '22')
165400                               AND H-WK-OPER-DSH > .2999
165500                               AND P-BED-SIZE < 500
165600                               AND H-OPER-DSH < .10
165700            MOVE .10 TO H-OPER-DSH.
165800
165900******        L A S T   S O U R C E   S T A T E M E N T   *****
