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