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