000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL04D.
000300*AUTHOR.            DDS TEAM.
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL04D      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C04.D'.
002000***************************************************************
002100***************************************************************
002200****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**
002300****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**
002400***************************************************************
002500*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO        *
002600*     - CHANGE THE > 01 HMO-FLAG < TO THE VALUE OF 'Y' *
002700*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983 *
002800*        BEFORE YOU COMPILE AND LINK THEM *
002900*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH *
003000*        AN HMO ADJUSTMENT *
003100***************************************************************
003200***************************************************************
003300 01  HMO-FLAG                       PIC X      VALUE 'N'.
003400***************************************************************
003500***************************************************************
003600 01  HMO-TAG                        PIC X      VALUE SPACE.
003700 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
003800 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
003900 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
004000 01  R1                             PIC S9(04) COMP SYNC.
004100 01  R2                             PIC S9(04) COMP SYNC.
004200 01  R3                             PIC S9(04) COMP SYNC.
004300 01  R4                             PIC S9(04) COMP SYNC.
004400
004500 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).
004600 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).
004700
004800***************************************************************
004900***************************************************************
005000*    LAYUP TABLE AREA FOR FY2004 RATES UP TO NOV 1, 2003      *
005100***************************************************************
005200 01  RATE-TABLE.
005300     02  RATE-WORK.
005400*RATE 20031001 REGION  LABOR AND NON-LABOR RATES
005500*                  R3=1     /     R3=2
005600*               LARGE URBAN / OTHER URBAN
005700*               LABOR / NON / LABOR / NON
005800*                     /LABOR/       /LABOR
005900*             --------------------------------------------
006000         05  FILLER PIC X(08) VALUE '20031001'.
006100         05  NAT    PIC X(30) VALUE
006200            ' 0313639 127485 0308673 125467'.
006300         05  PR     PIC X(30) VALUE
006400            ' 0150957 060764 0148568 059802'.
006500         05  NATPR  PIC X(30) VALUE
006600            ' 0311002 126414 0311002 126414'.
006700***************************************************************
006800     02  RATE-TAB REDEFINES RATE-WORK.
006900         05  RATE-PERIOD            OCCURS 1.
007000             10  RATE-EFF-DATE      PIC X(08).
007100             10  REG-NAT            OCCURS 3.
007200                 15  R-LARGE-OTHER  OCCURS 2.
007300                     20  FILLER     PIC X(01).
007400                     20  REG-LABOR  PIC 9(05)V9(02).
007500                     20  FILLER     PIC X(01).
007600                     20  REG-NLABOR PIC 9(04)V9(02).
007700
007800
007900***************************************************************
008000***************************************************************
008100*    LAYUP TABLE2 AREA FOR FY2004 RATES                       *
008200*         NOV 1,2003 THROUGH MARCH 31,2004                    *
008300***************************************************************
008400***************************************************************
008500 01  RATE-TABLE2.
008600     02  RATE-WORK2.
008700*RATE 20031101 REGION  LABOR AND NON-LABOR RATES
008800*                  R3=1     /     R3=2
008900*               LARGE URBAN / OTHER URBAN
009000*               LABOR / NON / LABOR / NON
009100*                     /LABOR/       /LABOR
009200*             --------------------------------------------
009300         05  FILLER PIC X(08) VALUE '20031101'.
009400         05  NAT2    PIC X(30) VALUE
009500            ' 0313639 127485 0314632 127889'.
009600         05  PR2     PIC X(30) VALUE
009700            ' 0150957 060764 0148568 059802'.
009800         05  NATPR2  PIC X(30) VALUE
009900            ' 0314166 127699 0314166 127699'.
010000***************************************************************
010100     02  RATE-TAB2 REDEFINES RATE-WORK2.
010200         05  RATE-PERIOD2            OCCURS 1.
010300             10  RATE-EFF-DATE2      PIC X(08).
010400             10  REG-NAT2            OCCURS 3.
010500                 15  R-LARGE-OTHER2  OCCURS 2.
010600                     20  FILLER      PIC X(01).
010700                     20  REG-LABOR2  PIC 9(05)V9(02).
010800                     20  FILLER      PIC X(01).
010900                     20  REG-NLABOR2 PIC 9(04)V9(02).
011000
011100***************************************************************
011200*    LAYUP TABLE3 AREA FOR FY2004 RATES                       *
011300*         APR 1,2004 THROUGH SEPTEMBER 30,2004                *
011400***************************************************************
011500***************************************************************
011600 01  RATE-TABLE3.
011700     02  RATE-WORK3.
011800*RATE 20040401 REGION  LABOR AND NON-LABOR RATES
011900*                  R3=1     /     R3=2
012000*               LARGE URBAN / OTHER URBAN
012100*               LABOR / NON / LABOR / NON
012200*                     /LABOR/       /LABOR
012300*             --------------------------------------------
012400         05  FILLER PIC X(08) VALUE '20040401'.
012500         05  NAT3    PIC X(30) VALUE
012600            ' 0313549 127449 0313549 127449'.
012700         05  PR3     PIC X(30) VALUE
012800            ' 0150758 060683 0153938 061964'.
012900         05  NATPR3  PIC X(30) VALUE
013000            ' 0313549 127449 0313549 127449'.
013100***************************************************************
013200     02  RATE-TAB3 REDEFINES RATE-WORK3.
013300         05  RATE-PERIOD3            OCCURS 1.
013400             10  RATE-EFF-DATE3      PIC X(08).
013500             10  REG-NAT3            OCCURS 3.
013600                 15  R-LARGE-OTHER3  OCCURS 2.
013700                     20  FILLER      PIC X(01).
013800                     20  REG-LABOR3  PIC 9(05)V9(02).
013900                     20  FILLER      PIC X(01).
014000                     20  REG-NLABOR3 PIC 9(04)V9(02).
014100
014200
014300***************************************************************
014400*    LAYUP TABLE AREA FOR FY2004 DRGS                         *
014500***************************************************************
014600 01  DRG-TABLE.
014700     05  D-TAB.
014800       10  FILLER                  PIC X(08) VALUE
014900      '20031001'.
015000       10  FILLER                  PIC X(56) VALUE
015100     '03618608000109020850041000530197531270012700000000000000'.
015200       10  FILLER                  PIC X(56) VALUE
015300     '00000000000000008092022000310265190660009801545301900028'.
015400       10  FILLER                  PIC X(56) VALUE
015500     '01421404700069012448048000650085710300004100925904500059'.
015600       10  FILLER                  PIC X(56) VALUE
015700     '00817604000050012682047000610096770390004901261804800064'.
015800       10  FILLER                  PIC X(56) VALUE
015900     '00699102500032010026042000550070410280003502739408000105'.
016000       10  FILLER                  PIC X(56) VALUE
016100     '01513805000066010737039000510082390320004301012103700050'.
016200       10  FILLER                  PIC X(56) VALUE
016300     '00610902500032013730022000410133700320005201338604400061'.
016400       10  FILLER                  PIC X(56) VALUE
016500     '00708702700035003341020000200091170310004100568402000025'.
016600       10  FILLER                  PIC X(56) VALUE
016700     '00209801600016009931037000500063550250003100629801200015'.
016800       10  FILLER                  PIC X(56) VALUE
016900     '01057502500038004669019000280062850150002100893702700038'.
017000       10  FILLER                  PIC X(56) VALUE
017100     '00340101600016007064019000270053820240003400659704000050'.
017200       10  FILLER                  PIC X(56) VALUE
017300     '00725002500031007936034000450053170240003100299602900029'.
017400       10  FILLER                  PIC X(56) VALUE
017500     '01727703200045008317015000190084100190002800801801400018'.
017600       10  FILLER                  PIC X(56) VALUE
017700     '01252002200036004856032000320092470200003000923301900029'.
017800       10  FILLER                  PIC X(56) VALUE
017900     '01102902400037002757015000150095570190002700209901500015'.
018000       10  FILLER                  PIC X(56) VALUE
018100     '01233403100052002973013000130137590300004401308904300065'.
018200       10  FILLER                  PIC X(56) VALUE
018300     '00574802300028005811024000310077800290003700653103100039'.
018400       10  FILLER                  PIC X(56) VALUE
018500     '00498702500030003188020000240070650250003400695402600034'.
018600       10  FILLER                  PIC X(56) VALUE
018700     '00818403300045003380021000210304370770010002818408400111'.
018800       10  FILLER                  PIC X(56) VALUE
018900     '01237803500048012731056000660159740670008500840004300054'.
019000       10  FILLER                  PIC X(56) VALUE
019100     '01530006100061013724051000690096200430005400537102600033'.
019200       10  FILLER                  PIC X(56) VALUE
019300     '01192704800063006864028000360134300480006400903104100051'.
019400       10  FILLER                  PIC X(56) VALUE
019500     '01046304900059006147034000400074080310005101202405000063'.
019600       10  FILLER                  PIC X(56) VALUE
019700     '00717603300040011340047000630061660300003800746403700046'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '00550502900035009662037000370070320240003200522201800021'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '00865403300044005437021000261860812610042407938912200144'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '05715608200099072936096001140537510920010405365607300098'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '03940106700077040492062000890247970320004100000000000000'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '03010610400133016436063000870354650500007402359003100044'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '01395102600043016089020000290137390320005302316405600090'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '01616905300066010297029000370156450290004801436703300044'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '01094702200028025418092001180102650420005300728504600055'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '01022901700026009505045000570056760330004100642202300029'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00555901800023005954025000320092820340004500574002200027'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00824303300033008355031000400051600200002500530502000025'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '00747302800036005761021000260054800170002101226003900056'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '00578702000026027376088001020153750560006203402510100123'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '01459005800063028711092001130130610440005601913406900084'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '01131004700053040212099001330130430300004100848906000060'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '01315204000058006517020000260137440380005100821902200027'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '01167603000043006446016000190069650210002102330607000084'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '01230203900045014317036000470088890200002401315803300049'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '00752501800024028245075001090119120330004301367005200070'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '00752802800038010025039000480055870250002901099804100052'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '00925903700046006940026000310108850460006000964204200055'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '00537602800034008223034000440057590230002900481302400033'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00868503300047003236029000290077780300004001108804100056'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '00598702400031008104037000520427870980013801802504700062'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '03421110400128016030057000670306130870010601611704800056'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '02554707500092011831038000440239530700009803041506700105'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '03684110200142013120048000640134820500006701167504400058'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '01209504600062007071029000380115390400005300660102300029'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '02032704400049018477061000700125440450004901415203200064'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '01890406700092000000000000000000000000000002110705000080'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '03002009000134015750043000550102580270003200588105300053'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '00000000000000000000000000000105730220003000789801600019'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '01170403600053015529045000660081900210002601163902700042'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '00706401800023013147036000560000000000000000967401800027'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '02002405000074011977022000310075800380004900735803900048'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '00598302900037013564065000870106140510006401315304900067'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '00635803000038011695053000690075250370004700715503700047'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '00478602600033006063030000380057240260003300858503800049'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '00674402500036007091032000410045780230002800255301800018'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '00758103700047004464026000320029740290002900819003800051'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '00891302100026007018016000180094200180002700685401200014'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '00894401600021009533029000430205560830011501060505000066'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '01598404200066008791023000320095740290004501151302400038'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '01774706000085008129025000360102800560007201018504600060'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '00619203000039011574047000650057290240003400647103500045'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '00880504700058005432035000420077790400005300710903200041'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '00486602300029002586022000220073220350004700421502300029'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '02082507900106020342044000590188990770010302149803900050'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '00944101800027008938017000220064680140001602733607300106'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '01389603200047007800035000460079750300004000863904000051'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '00508502700033004537024000310094660380005501100104700062'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '00615802800036032343072000850236590640008002385606200089'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '01185402800036012257035000540061450170002101599304000062'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '00899101700021011502029000440062580150001801084103000045'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00681401700022004984023000230207960370007001298704900066'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '00850302400036011871044000610067710220002900885304300054'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00568503100037004625028000330080880240003200479701600019'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '00655302900038004206021000260037270310003100761302700038'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '00529601700021003210016000160106180420005600598202400032'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '00948303700057014810039000460108350280003000859502600034'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '00586901800020012316035000550113450290004800285302400024'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '01273901900032007800024000320015510170001701330601600025'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '01167103000049010213045000590054170220003000747203300044'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '00460802000025007370036000450023790130001300709702900040'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '01839004900065014808047000570089120300003200755601800021'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '02273706700084011807034000420080990230002600866102200028'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '01079302200032003041014000140093740260003600909802900041'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '02128405300082012826048000680055880230003101165705100067'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '00606502400033010119042000570063170320003500552002700035'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '00385602000023007402025000300058060440004400569302500034'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '01032103100041007950020000260036260200003000432301600020'.
034000       10  FILLER                  PIC X(56) VALUE
034100     '00525701500019002190013000170051230270003800348501900026'.
034200       10  FILLER                  PIC X(56) VALUE
034300     '01385501800018045687179001790312031330013301882708600086'.
034400       10  FILLER                  PIC X(56) VALUE
034500     '03205204700047011344034000340015360310003103316407100097'.
034600       10  FILLER                  PIC X(56) VALUE
034700     '01357109100091019338047000760083070320004400698602900042'.
034800       10  FILLER                  PIC X(56) VALUE
034900     '01264803700052012360045000590066510270003500000000000000'.
035000       10  FILLER                  PIC X(56) VALUE
035100     '02894608100116011430027000400181970580008200865803000041'.
035200       10  FILLER                  PIC X(56) VALUE
035300     '01924104900049027055069000970124100320004102198404800082'.
035400       10  FILLER                  PIC X(56) VALUE
035500     '01243904600061010833032000410039480470004700567902500036'.
035600       10  FILLER                  PIC X(56) VALUE
035700     '01322405200071007370032000420362761040014401591805600075'.
035800       10  FILLER                  PIC X(56) VALUE
035900     '00961204400057010672048000630084760360004600610702800034'.
036000       10  FILLER                  PIC X(56) VALUE
036100     '00746403100041007248025000370181550590008402407408000131'.
036200       10  FILLER                  PIC X(56) VALUE
036300     '00678102800038005087032000450050120310004400729104500071'.
036400       10  FILLER                  PIC X(56) VALUE
036500     '00829104500061006801056000790066200440006900651302900040'.
036600       10  FILLER                  PIC X(56) VALUE
036700     '00290402200031000000000000000000000000000000000000000000'.
036800       10  FILLER                  PIC X(56) VALUE
036900     '00000000000000000000000000000175470520008201887805800091'.
037000       10  FILLER                  PIC X(56) VALUE
037100     '00966202100031024200056000860097870250003400747503200042'.
037200       10  FILLER                  PIC X(56) VALUE
037300     '00501502300029002983024000240052380190002500098102900029'.
037400       10  FILLER                  PIC X(56) VALUE
037500     '00835202600037004246016000200026480210002101045503500049'.
037600       10  FILLER                  PIC X(56) VALUE
037700     '00511302100028008153030000420047730180002400000000000000'.
037800       10  FILLER                  PIC X(56) VALUE
037900     '00000000000000000000000000000000000000000000000000000000'.
038000       10  FILLER                  PIC X(56) VALUE
038100     '01169202200036009747090001100068560310004100498202400030'.
038200       10  FILLER                  PIC X(56) VALUE
038300     '00888102000039008088022000390052740190003703845409400131'.
038400       10  FILLER                  PIC X(56) VALUE
038500     '00000000000000000000000000000305760470005400000000000000'.
038600       10  FILLER                  PIC X(56) VALUE
038700     '03488507400127000000000000000360000800011302247708000111'.
038800       10  FILLER                  PIC X(56) VALUE
038900     '01887305400083023743049000730143000240003209782314000211'.
039000       10  FILLER                  PIC X(56) VALUE
039100     '06107419200218034803096001251677623420041605417909700145'.
039200       10  FILLER                  PIC X(56) VALUE
039300     '03212107900100048793087001290200570530007304811811700170'.
039400       10  FILLER                  PIC X(56) VALUE
039500     '01860306000086010512039000550171390280003403837109300149'.
039600       10  FILLER                  PIC X(56) VALUE
039700     '01830204400060010034020000250855511340016205683906800089'.
039800       10  FILLER                  PIC X(56) VALUE
039900     '03405605200063025319036000400142440330004500936902000024'.
040000       10  FILLER                  PIC X(56) VALUE
040100     '02639308300107014192051000620122330300003911621520300280'.
040200       10  FILLER                  PIC X(56) VALUE
040300     '02000602300056041070121001690181540650009201377505600080'.
040400       10  FILLER                  PIC X(56) VALUE
040500     '00642603100044011812046000680067530320004705340511100132'.
040600       10  FILLER                  PIC X(56) VALUE
040700     '06159408700100000000000000000533660300005202691103800048'.
040800       10  FILLER                  PIC X(56) VALUE
040900     '02159801800025017494023000340242660320005101578001700021'.
041000       10  FILLER                  PIC X(56) VALUE
041100     '00711504300058005226077000970039560330004100732002700034'.
041200       10  FILLER                  PIC X(56) VALUE
041300     '14189610200196029891036000450244830180002507220514200175'.
041400       10  FILLER                  PIC X(56) VALUE
041500     '02252905300082012017028000360305520680009901448202900040'.
041600       10  FILLER                  PIC X(56) VALUE
041700     '01667802700041010748016000200815600810011006277503900058'.
041800       10  FILLER                  PIC X(56) VALUE
041900     '01818504700070009919021000290338460740011201289102900040'.
042000     05  DRGX-TAB REDEFINES D-TAB.
042100         10  DRGX-PERIOD               OCCURS 1
042200                                        INDEXED BY DX5.
042300             15  DRGX-EFF-DATE         PIC X(08).
042400             15  DRG-DATA              OCCURS 540
042500                                        INDEXED BY DX6.
042600                 20  DRG-WT            PIC 9(02)V9(04).
042700                 20  DRG-ALOS          PIC 9(02)V9(01).
042800                 20  DRG-DAYS-TRIM     PIC 9(02).
042900                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
043000
043100 01  HOLD-AREA.
043200     02  HOLD-PPS-COMPONENTS.
043300         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
043400         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
043500
043600         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
043700         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
043800
043900         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
044000         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
044100         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
044200
044300         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
044400         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
044500         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
044600
044700         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
044800         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
044900
045000         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
045100         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
045200
045300         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
045400         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
045500
045600
045700         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
045800         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
045900         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
046000         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
046100         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
046200         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
046300         05  H-CAPI-COLA                  PIC 9(01)V9(03).
046400         05  H-CAPI-SCH                   PIC 9(05)V9(02).
046500         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
046600         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
046700         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
046800         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
046900         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
047000         05  H-CAPI-GAF                   PIC 9(05)V9(04).
047100         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
047200         05  H-BLEND-GAF                  PIC 9(05)V9(04).
047300         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
047400         05  H-COV-DAYS                   PIC 9(3).
047500         05  H-PERDIEM-DAYS               PIC 9(3).
047600         05  H-REG-DAYS                   PIC 9(3).
047700         05  H-LTR-DAYS                   PIC 9(3).
047800         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
047900         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
048000         05  H-ALOS                       PIC 9(02)V9(01).
048100         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
048200         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
048300         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
048400         05  H-CST-THRESH                 PIC 9(05)V9(02).
048500         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
048600         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
048700         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
048800         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
048900         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
049000         05  H-UPDATE-01                  PIC 9(01)V9(04).
049100         05  H-UPDATE-02                  PIC 9(01)V9(04).
049200         05  H-UPDATE-03                  PIC 9(01)V9(04).
049300         05  H-UPDATE-04                  PIC 9(01)V9(04).
049400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
049500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
049600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
049700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
049800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
049900         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
050000         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
050100         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
050200         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
050300         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
050400         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
050500         05  H-LABOR-PCT                  PIC 9(01)V9(04).
050600         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
050700         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
050800         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
050900         05  H-HSP-RATE                   PIC 9(06)V9(09).
051000         05  H-FSP-RATE                   PIC 9(06)V9(09).
051100         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
051200         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
051300         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
051400         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
051500         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
051600         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
051700         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
051800         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
051900         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
052000         05  H-NEW-TECH-ADDON-XIGRIS      PIC S9(07)V99.
052100         05  H-NEW-TECH-ADDON-INFUSE      PIC S9(07)V99.
052200         05  H-LESSER-XIGRIS-1            PIC S9(07)V99.
052300         05  H-LESSER-XIGRIS-2            PIC S9(07)V99.
052400         05  H-LESSER-INFUSE-1            PIC S9(07)V99.
052500         05  H-LESSER-INFUSE-2            PIC S9(07)V99.
052600         05  H-CSTMED-XIGRIS              PIC S9(07)V99.
052700         05  H-CSTMED-INFUSE              PIC S9(07)V99.
052800
052900
053000     02  HOLD-ADDITIONAL-VARIABLES.
053100         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
053200         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
053300         05  H-NAT-PCT                    PIC 9(01)V9(02).
053400         05  H-REG-PCT                    PIC 9(01)V9(02).
053500         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
053600         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
053700         05  H-DRG-WT                     PIC 9(02)V9(04).
053800         05  H-TOT-REG-AL                 PIC 9(05)V9(02).
053900         05  H-TOT-NAT-AL                 PIC 9(05)V9(02).
054000         05  H-NAT-LABOR                  PIC 9(05)V9(02).
054100         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
054200         05  H-REG-LABOR                  PIC 9(05)V9(02).
054300         05  H-REG-NONLABOR               PIC 9(05)V9(02).
054400         05  H-OPER-COLA                  PIC 9(01)V9(03).
054500         05  H-INTERN-RATIO               PIC 9(01)V9(04).
054600         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
054700         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
054800         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
054900
055000     02  HOLD-CAPITAL-VARIABLES.
055100         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
055200         05  H-CAPI-HSP                   PIC 9(07)V9(02).
055300         05  H-CAPI-FSP                   PIC 9(07)V9(02).
055400         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
055500         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
055600         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
055700         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
055800         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
055900
056000     02  HOLD-CAPITAL2-VARIABLES.
056100         05  H-CAPI2-PAY-CODE             PIC X(1).
056200         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
056300         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
056400
056500     02  HOLD-OTHER-VARIABLES.
056600         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
056700         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
056800         05  H-LOW-VOL-PAYMENT              PIC 9(07)V9(02).
056900         05  H-HVBP-HRR-DATA.
057000             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
057100             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
057200             10  H-HOSP-READMISS-REDUCTN      PIC X.
057300             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
057400         05  H-OPERATNG-DATA.
057500             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
057600             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
057700             10  H-OPER-HSP-AMT              PIC 9(08)V99.
057800
057900     02  HOLD-PC-OTH-VARIABLES.
058000         05  H-OPER-DSH                   PIC 9(01)V9(04).
058100         05  H-CAPI-DSH                   PIC 9(01)V9(04).
058200         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
058300         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
058400         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
058500         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
058600         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
058700         05  H-PC-HMO-FLAG                PIC X(01).
058800         05  H-PC-COT-FLAG                PIC X(01).
058900         05  H-FILLER                     PIC X(0998).
059000
059100 LINKAGE SECTION.
059200***************************************************************
059300*                 * * * * * * * * *                           *
059400*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
059500*    IN HOW TO PAY THE BILL.                                  *
059600*                         *****                               *
059700*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
059800*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
059900*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
060000*                 OUTLIER COMPUTATION.                        *
060100*                         *****                               *
060200*         REVIEW-CODE:                                        *
060300*            00 = PAY-WITH-OUTLIER.                           *
060400*                 WILL CALCULATE THE STANDARD PAYMENT.        *
060500*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
060600*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
060700*            03 = PAY-PERDIEM-DAYS.                           *
060800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
060900*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
061000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
061100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
061200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
061300*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
061400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
061500*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
061600*                 BILL EXCEED THE COST THRESHOLD.             *
061700*            06 = PAY-XFER-NO-COST                            *
061800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
061900*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
062000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
062100*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
062200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
062300*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
062400*                 CALCULATE ANY COST OUTLIER PORTION          *
062500*                 OF THE PAYMENT.                             *
062600*            07 = PAY-WITHOUT-COST.                           *
062700*                 WILL CALCULATE THE STANDARD PAYMENT         *
062800*                 WITHOUT COST PORTION.                       *
062900*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
063000*                 FOR DRG'S 209,210,211,014,113,236,          *
063100*                           012,024,025,088,089,090,          *
063200*                           121,122,127,130,131,239,          *
063300*                           277,278,294,296,297,320,          *
063400*                           321,395,468,429,483               *
063500*                               POST-ACUTE TRANSFERS          *
063600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
063700*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
063800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
063900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
064000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
064100*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
064200*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
064300*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
064400*                 BILL EXCEED THE COST THRESHOLD.             *
064500*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
064600*                 POST-ACUTE TRANSFERS                        *
064700*                 FOR DRG'S 209,210,211,014,113,236,          *
064800*                           012,024,025,088,089,090,          *
064900*                           121,122,127,130,131,239,          *
065000*                           277,278,294,296,297,320,          *
065100*                           321,395,468,429,483               *
065200*                               POST-ACUTE TRANSFERS          *
065300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
065400*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
065500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
065600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
065700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
065800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
065900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
066000*                 PAYMENT.                                    *
066100***************************************************************
066200
066300**************************************************************
066400*      MILLINNIUM COMPATIBLE                                 *
066500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
066600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
066700*      IN THE NEW FORMAT                                     *
066800**************************************************************
066900 01  BILL-NEW-DATA.
067000         10  B-NPI10.
067100             15  B-NPI8             PIC X(08).
067200             15  B-NPI-FILLER       PIC X(02).
067300         10  B-PROVIDER-NO          PIC X(06).
067400             88  SE-AL-PROV           VALUE
067500            '010001' '010005' '010006' '010007' '010008'
067600            '010009' '010010' '010011' '010012' '010015'
067700            '010016' '010018' '010019' '010021' '010022'
067800            '010023' '010024' '010025' '010027' '010029'
067900            '010032' '010033' '010034' '010035' '010038'
068000            '010039' '010040' '010043' '010044' '010045'
068100            '010046' '010049' '010050' '010051' '010053'
068200            '010054' '010055' '010056' '010058' '010059'
068300            '010061' '010062' '010064' '010065' '010066'
068400            '010068' '010072' '010073' '010078' '010079'
068500            '010083' '010084' '010085' '010087' '010089'
068600            '010090' '010091' '010092' '010095' '010098'
068700            '010099' '010100' '010101' '010103' '010104'
068800            '010108' '010109' '010110' '010112' '010113'
068900            '010114' '010115' '010118' '010119' '010120'
069000            '010125' '010126' '010128' '010129' '010130'
069100            '010131' '010137' '010138' '010139' '010143'
069200            '010144' '010145' '010146' '010148' '010149'
069300            '010150' '010152' '010157' '010158' '190013'
069400            '190040' '190045' '190050' '190053' '190060'
069500            '190064' '190086' '190102' '190111' '190113'
069600            '190125' '190242' '250040' '250048' '250050'
069700            '250078' '250082' '250104'.
069800         10  B-REVIEW-CODE          PIC 9(02).
069900             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
070000             88  PAY-WITH-OUTLIER     VALUE 00 07.
070100             88  PAY-PERDIEM-DAYS     VALUE 03.
070200             88  PAY-XFER-NO-COST     VALUE 06.
070300             88  PAY-WITHOUT-COST     VALUE 07.
070400             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
070500             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
070600         10  B-DRG                  PIC 9(03).
070700         10  B-LOS                  PIC 9(03).
070800         10  B-COVERED-DAYS         PIC 9(03).
070900         10  B-LTR-DAYS             PIC 9(02).
071000         10  B-DISCHARGE-DATE.
071100             15  B-DISCHG-CC        PIC 9(02).
071200             15  B-DISCHG-YY        PIC 9(02).
071300             15  B-DISCHG-MM        PIC 9(02).
071400             15  B-DISCHG-DD        PIC 9(02).
071500         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
071600         10  B-PRIN-PROC-CODE       PIC X(07).
071700         10  B-OTHER-PROC-CODE1     PIC X(07).
071800         10  B-OTHER-PROC-CODE2     PIC X(07).
071900         10  B-OTHER-PROC-CODE3     PIC X(07).
072000         10  B-OTHER-PROC-CODE4     PIC X(07).
072100         10  B-OTHER-PROC-CODE5     PIC X(07).
072200         10  B-OTHER-PROC-CODE6     PIC X(07).
072300         10  B-OTHER-PROC-CODE7     PIC X(07).
072400         10  B-OTHER-PROC-CODE8     PIC X(07).
072500         10  B-OTHER-PROC-CODE9     PIC X(07).
072600         10  B-OTHER-PROC-CODE10    PIC X(07).
072700         10  B-OTHER-PROC-CODE11    PIC X(07).
072800         10  B-OTHER-PROC-CODE12    PIC X(07).
072900         10  B-OTHER-PROC-CODE13    PIC X(07).
073000         10  B-OTHER-PROC-CODE14    PIC X(07).
073100         10  B-OTHER-PROC-CODE15    PIC X(07).
073200         10  B-OTHER-PROC-CODE16    PIC X(07).
073300         10  B-OTHER-PROC-CODE17    PIC X(07).
073400         10  B-OTHER-PROC-CODE18    PIC X(07).
073500         10  B-OTHER-PROC-CODE19    PIC X(07).
073600         10  B-OTHER-PROC-CODE20    PIC X(07).
073700         10  B-OTHER-PROC-CODE21    PIC X(07).
073800         10  B-OTHER-PROC-CODE22    PIC X(07).
073900         10  B-OTHER-PROC-CODE23    PIC X(07).
074000         10  B-OTHER-PROC-CODE24    PIC X(07).
074100         10  B-OTHER-DIAG-CODE1     PIC X(07).
074200         10  B-OTHER-DIAG-CODE2     PIC X(07).
074300         10  B-OTHER-DIAG-CODE3     PIC X(07).
074400         10  B-OTHER-DIAG-CODE4     PIC X(07).
074500         10  B-OTHER-DIAG-CODE5     PIC X(07).
074600         10  B-OTHER-DIAG-CODE6     PIC X(07).
074700         10  B-OTHER-DIAG-CODE7     PIC X(07).
074800         10  B-OTHER-DIAG-CODE8     PIC X(07).
074900         10  B-OTHER-DIAG-CODE9     PIC X(07).
075000         10  B-OTHER-DIAG-CODE10    PIC X(07).
075100         10  B-OTHER-DIAG-CODE11    PIC X(07).
075200         10  B-OTHER-DIAG-CODE12    PIC X(07).
075300         10  B-OTHER-DIAG-CODE13    PIC X(07).
075400         10  B-OTHER-DIAG-CODE14    PIC X(07).
075500         10  B-OTHER-DIAG-CODE15    PIC X(07).
075600         10  B-OTHER-DIAG-CODE16    PIC X(07).
075700         10  B-OTHER-DIAG-CODE17    PIC X(07).
075800         10  B-OTHER-DIAG-CODE18    PIC X(07).
075900         10  B-OTHER-DIAG-CODE19    PIC X(07).
076000         10  B-OTHER-DIAG-CODE20    PIC X(07).
076100         10  B-OTHER-DIAG-CODE21    PIC X(07).
076200         10  B-OTHER-DIAG-CODE22    PIC X(07).
076300         10  B-OTHER-DIAG-CODE23    PIC X(07).
076400         10  B-OTHER-DIAG-CODE24    PIC X(07).
076500         10  B-OTHER-DIAG-CODE25    PIC X(07).
076600         10  BILL-DEMO-DATA.
076700             15  BILL-DEMO-CODE1        PIC X(02).
076800             15  BILL-DEMO-CODE2        PIC X(02).
076900             15  BILL-DEMO-CODE3        PIC X(02).
077000             15  BILL-DEMO-CODE4        PIC X(02).
077100         10  BILL-NDC-DATA.
077200             15  BILL-NDC-NUMBER        PIC X(11).
077300         10  FILLER                     PIC X(73).
077400
077500
077600
077700***************************************************************
077800*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
077900*    AND PASSED BACK TO THE CALLING PROGRAM                   *
078000*            RETURN CODE VALUES (PPS-RTC)                     *
078100*                                                             *
078200*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
078300*              00 = PAID NORMAL DRG PAYMENT                   *
078400*                                                             *
078500*              01 = PAID AS A DAY-OUTLIER.                    *
078600*                   NOTE:                                     *
078700*                     DAY-OUTLIER NO LONGER BEING PAID        *
078800*                         AS OF 10/01/97                      *
078900*                                                             *
079000*              02 = PAID AS A COST-OUTLIER.                   *
079100*                                                             *
079200*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
079300*                   AND INCLUDING THE FULL DRG.               *
079400*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
079500*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
079600*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
079700*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
079800*                   AND INCLUDING THE FULL DRG. PROVIDER      *
079900*                   REFUSED COST OUTLIER.                     *
080000*              10 = DRG IS 209, 210 OR 211 AND                *
080100*                   POST-ACUTE TRANSFER                       *
080200*              12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *
080300*                       THE FOLLOWING DRG'S                   *
080400*                 FOR DRG'S             014,113,236,          *
080500*                           012,024,025,088,089,090,          *
080600*                           121,122,127,130,131,239,          *
080700*                           277,278,294,296,297,320,          *
080800*                           321,395,468,429,483               *
080900*              14 = PAID NORMAL DRG PAYMENT WITH              *
081000*                    PERDIEM DAYS = OR > GM  ALOS             *
081100*              16 = PAID AS A COST-OUTLIER WITH               *
081200*                    PERDIEM DAYS = OR > GM  ALOS             *
081300*                                                             *
081400*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
081500*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
081600*              52 = INVALID MSA # IN PROVIDER FILE            *
081700*                   OR INVALID WAGE INDEX                     *
081800*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
081900*              54 = DRG < 001 OR > 540,                       *
082000*                                       OR = 004 OR = 005     *
082100*                                       OR = 112              *
082200*                                       OR = 214 OR = 215     *
082300*                                       OR = 221 OR = 222     *
082400*                                       OR = 231 OR = 400     *
082500*                                       OR = 434 OR = 435     *
082600*                                       OR = 436 OR = 437     *
082700*                                       OR = 438 OR = 456     *
082800*                                       OR = 457 OR = 458     *
082900*                                       OR = 459 OR = 460     *
083000*                                       OR = 469 OR = 470     *
083100*                                       OR = 472 OR = 474     *
083200*                                       OR = 514              *
083300*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
083400*                                      OR                     *
083500*                   DISCHARGE DATE < MSA EFF START DATE       *
083600*                   FOR PPS                                   *
083700*                                      OR                     *
083800*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
083900*                   DISCHARGE DATE                            *
084000*              56 = INVALID LENGTH OF STAY                    *
084100*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
084200*                                        NOT 11)              *
084300*              58 = TOTAL CHARGES NOT NUMERIC                 *
084400*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
084500*                   OR BILL-LTR-DAYS > 60                     *
084600*              62 = INVALID NUMBER OF COVERED DAYS            *
084700*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
084800*                   SPECIFIC FILE FOR CAPITAL                 *
084900*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
085000*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
085100*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
085200***************************************************************
085300 01  PPS-DATA.
085400         10  PPS-RTC                PIC 9(02).
085500         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
085600         10  PPS-OUTLIER-DAYS       PIC 9(03).
085700         10  PPS-AVG-LOS            PIC 9(02)V9(01).
085800         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
085900         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
086000         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
086100         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
086200         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
086300         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
086400         10  PPS-REG-DAYS-USED      PIC 9(03).
086500         10  PPS-LTR-DAYS-USED      PIC 9(02).
086600         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
086700         10  PPS-CALC-VERS          PIC X(05).
086800
086900******************************************************************
087000*            THESE ARE THE VERSIONS OF THE PPCAL
087100*           PROGRAMS THAT WILL BE PASSED BACK----
087200*          ASSOCIATED WITH THE BILL BEING PROCESSED
087300******************************************************************
087400 01  PRICER-OPT-VERS-SW.
087500     02  PRICER-OPTION-SW          PIC X(01).
087600         88  ALL-TABLES-PASSED          VALUE 'A'.
087700         88  PROV-RECORD-PASSED         VALUE 'P'.
087800         88  ADDITIONAL-VARIABLES       VALUE 'M'.
087900         88  PC-PRICER                  VALUE 'C'.
088000     02  PPS-VERSIONS.
088100         10  PPDRV-VERSION         PIC X(05).
088200
088300******************************************************************
088400*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
088500*          ASSOCIATED WITH THE BILL BEING PROCESSED
088600******************************************************************
088700 01  PPS-ADDITIONAL-VARIABLES.
088800     05  PPS-HSP-PCT                PIC 9(01)V9(02).
088900     05  PPS-FSP-PCT                PIC 9(01)V9(02).
089000     05  PPS-NAT-PCT                PIC 9(01)V9(02).
089100     05  PPS-REG-PCT                PIC 9(01)V9(02).
089200     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
089300     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
089400     05  PPS-DRG-WT                 PIC 9(02)V9(04).
089500     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
089600     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
089700     05  PPS-REG-LABOR              PIC 9(05)V9(02).
089800     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
089900     05  PPS-OPER-COLA              PIC 9(01)V9(03).
090000     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
090100     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
090200     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
090300     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
090400     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
090500     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
090600     05  PPS-CAPITAL-VARIABLES.
090700         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
090800         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
090900         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
091000         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
091100         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
091200         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
091300         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
091400         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
091500     05  PPS-CAPITAL2-VARIABLES.
091600         10  PPS-CAPI2-PAY-CODE             PIC X(1).
091700         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
091800         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
091900
092000     05  PPS-OTHER-VARIABLES.
092100         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
092200         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
092300         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
092400         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
092500         10  PPS-HVBP-HRR-DATA.
092600             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
092700             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
092800             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
092900             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
093000         10  PPS-OPERATNG-DATA.
093100             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
093200             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
093300             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
093400
093500     05  PPS-PC-OTH-VARIABLES.
093600         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
093700         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
093800         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
093900         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
094000         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
094100         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
094200         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
094300         10  PPS-PC-HMO-FLAG                PIC X(01).
094400         10  PPS-PC-COT-FLAG                PIC X(01).
094500         10  PPS-FILLER                     PIC X(0998).
094600
094700**************************************************************
094800*      MILLINNIUM COMPATIBLE                                 *
094900*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *
095000*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
095100*      IN THE NEW FORMAT                                     *
095200**************************************************************
095300 01  PROV-NEW-HOLD.
095400     02  PROV-NEWREC-HOLD1.
095500         05  P-NEW-NPI10.
095600             10  P-NEW-NPI8             PIC X(08).
095700             10  P-NEW-NPI-FILLER       PIC X(02).
095800         05  P-NEW-PROVIDER-NO.
095900             10  P-NEW-STATE            PIC 9(02).
096000             10  FILLER                 PIC X(04).
096100         05  P-NEW-DATE-DATA.
096200             10  P-NEW-EFF-DATE.
096300                 15  P-NEW-EFF-DT-CC    PIC 9(02).
096400                 15  P-NEW-EFF-DT-YY    PIC 9(02).
096500                 15  P-NEW-EFF-DT-MM    PIC 9(02).
096600                 15  P-NEW-EFF-DT-DD    PIC 9(02).
096700             10  P-NEW-FY-BEGIN-DATE.
096800                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
096900                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
097000                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
097100                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
097200             10  P-NEW-REPORT-DATE.
097300                 15  P-NEW-REPORT-DT-CC PIC 9(02).
097400                 15  P-NEW-REPORT-DT-YY PIC 9(02).
097500                 15  P-NEW-REPORT-DT-MM PIC 9(02).
097600                 15  P-NEW-REPORT-DT-DD PIC 9(02).
097700             10  P-NEW-TERMINATION-DATE.
097800                 15  P-NEW-TERM-DT-CC   PIC 9(02).
097900                 15  P-NEW-TERM-DT-YY   PIC 9(02).
098000                 15  P-NEW-TERM-DT-MM   PIC 9(02).
098100                 15  P-NEW-TERM-DT-DD   PIC 9(02).
098200         05  P-NEW-WAIVER-CODE          PIC X(01).
098300             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
098400         05  P-NEW-INTER-NO             PIC 9(05).
098500         05  P-NEW-PROVIDER-TYPE        PIC X(02).
098600             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
098700             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
098800                                                  '15' '17'
098900                                                  '22'.
099000             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
099100             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
099200             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
099300             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
099400             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
099500             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
099600             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
099700             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
099800             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
099900             88  P-N-EACH                   VALUE '21' '22'.
100000             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
100100             88  P-N-NHCMQ-II-SNF           VALUE '32'.
100200             88  P-N-NHCMQ-III-SNF          VALUE '33'.
100300         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
100400             88  P-N-NEW-ENGLAND            VALUE  1.
100500             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
100600             88  P-N-SOUTH-ATLANTIC         VALUE  3.
100700             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
100800             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
100900             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
101000             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
101100             88  P-N-MOUNTAIN               VALUE  8.
101200             88  P-N-PACIFIC                VALUE  9.
101300         05  P-NEW-CURRENT-DIV   REDEFINES
101400                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
101500             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
101600         05  P-NEW-MSA-DATA.
101700             10  P-NEW-CHG-CODE-INDEX       PIC X.
101800             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
101900             10  P-NEW-GEO-LOC-MSA9   REDEFINES
102000                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
102100             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
102200             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
102300             10  P-NEW-STAND-AMT-LOC-MSA9
102400       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
102500                 15  P-NEW-RURAL-1ST.
102600                     20  P-NEW-STAND-RURAL  PIC XX.
102700                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
102800                 15  P-NEW-RURAL-2ND        PIC XX.
102900         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
103000                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
103100                 88  P-NEW-SCH-YR82       VALUE   '82'.
103200                 88  P-NEW-SCH-YR87       VALUE   '87'.
103300         05  P-NEW-LUGAR                    PIC X.
103400         05  P-NEW-TEMP-RELIEF-IND          PIC X.
103500         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
103600         05  FILLER                         PIC X(05).
103700     02  PROV-NEWREC-HOLD2.
103800         05  P-NEW-VARIABLES.
103900             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
104000             10  P-NEW-COLA              PIC  9(01)V9(03).
104100             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
104200             10  P-NEW-BED-SIZE          PIC  9(05).
104300             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
104400             10  P-NEW-CMI               PIC  9(01)V9(04).
104500             10  P-NEW-SSI-RATIO         PIC  V9(04).
104600             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
104700             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
104800             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
104900             10  P-NEW-DSH-PERCENT       PIC  V9(04).
105000             10  P-NEW-FYE-DATE          PIC  X(08).
105100         05  FILLER                      PIC  X(23).
105200     02  PROV-NEWREC-HOLD3.
105300         05  P-NEW-PASS-AMT-DATA.
105400             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
105500             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
105600             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
105700             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
105800         05  P-NEW-CAPI-DATA.
105900             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
106000             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
106100             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
106200             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
106300             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
106400             15  P-NEW-CAPI-NEW-HOSP       PIC X.
106500             15  P-NEW-CAPI-IME            PIC 9V9999.
106600             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
106700         05  P-HVBP-HRR-DATA.
106800             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
106900             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
107000             15  P-HOSP-READMISSION-REDUCTN PIC X.
107100             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
107200         05  P-MODEL1-BUNDLE-DATA.
107300             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
107400             15  P-HAC-REDUC-IND            PIC X.
107500             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
107600             15  P-EHR-REDUC-IND            PIC X.
107700         05  FILLER                         PIC X(09).
107800
107900************************************************************
108000******************************************************************
108100*      MILLINNIUM COMPATIBLE
108200*                   THIS IS THE WAGE-INDEX
108300*          ASSOCIATED WITH THE BILL BEING PROCESSED
108400******************************************************************
108500 01  WAGE-NEW-INDEX-RECORD.
108600     05  W-MSA                         PIC X(4).
108700     05  W-SIZE                        PIC X.
108800         88  LARGE-URBAN       VALUE 'L'.
108900         88  OTHER-URBAN       VALUE 'O'.
109000         88  ALL-RURAL         VALUE 'R'.
109100     05  W-EFF-DATE                    PIC X(8).
109200     05  FILLER                        PIC X.
109300     05  W-INDEX-RECORD                PIC S9(02)V9(04).
109400     05  W-PR-INDEX-RECORD             PIC S9(02)V9(04).
109500
109600
109700 PROCEDURE DIVISION  USING BILL-NEW-DATA
109800                           PPS-DATA
109900                           PRICER-OPT-VERS-SW
110000                           PPS-ADDITIONAL-VARIABLES
110100                           PROV-NEW-HOLD
110200                           WAGE-NEW-INDEX-RECORD.
110300
110400***************************************************************
110500*    PROCESSING:                                              *
110600*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
110700*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
110800*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
110900*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
111000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
111100*           GOBACK.                                           *
111200*        D. ASSEMBLE PRICING COMPONENTS.                      *
111300*        E. CALCULATE THE PRICE.                              *
111400***************************************************************
111500
111600     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
111700     MOVE 'N' TO TEMP-RELIEF-FLAG.
111800
111900     PERFORM 0200-MAINLINE-CONTROL.
112000
112100     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
112200     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
112300     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
112400     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
112500     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
112600     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
112700     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
112800     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
112900
113000     GOBACK.
113100
113200 0200-MAINLINE-CONTROL.
113300
113400     MOVE 'N' TO HMO-TAG.
113500
113600     IF PPS-PC-HMO-FLAG = 'Y' OR
113700               HMO-FLAG = 'Y'
113800        MOVE 'Y' TO HMO-TAG.
113900
114000     IF P-NEW-STATE NOT = 40
114100        MOVE ZEROES TO W-PR-INDEX-RECORD.
114200
114300     MOVE ALL '0' TO PPS-DATA
114400                     H-OPER-DSH-SCH
114500                     H-OPER-DSH-RRC
114600                     HOLD-PPS-COMPONENTS
114700                     HOLD-PPS-COMPONENTS
114800                     HOLD-ADDITIONAL-VARIABLES
114900                     HOLD-CAPITAL-VARIABLES
115000                     HOLD-CAPITAL2-VARIABLES
115100                     HOLD-OTHER-VARIABLES
115200                     HOLD-PC-OTH-VARIABLES.
115300
115400     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
115500        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
115600
115700     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
115800        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
115900
116000     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
116100        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
116200
116300     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
116400        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
116500
116600     PERFORM 1000-EDIT-THE-BILL-INFO.
116700
116800     IF  PPS-RTC = 00
116900         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
117000         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
117100
117200     IF PPS-RTC = 00
117300        IF H-PERDIEM-DAYS = H-ALOS OR
117400           H-PERDIEM-DAYS > H-ALOS
117500           MOVE 14 TO PPS-RTC.
117600
117700     IF PPS-RTC = 02
117800        IF H-PERDIEM-DAYS = H-ALOS OR
117900           H-PERDIEM-DAYS > H-ALOS
118000           MOVE 16 TO PPS-RTC.
118100
118200 1000-EDIT-THE-BILL-INFO.
118300***************************************************************
118400*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
118500*    AND DO NOT ATTEMPT TO PRICE.                             *
118600***************************************************************
118700
118800     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
118900     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
119000
119100     IF  PPS-RTC = 00
119200         IF  P-NEW-WAIVER-STATE
119300             MOVE 53 TO PPS-RTC.
119400
119500     IF  PPS-RTC = 00
119600         IF  B-DRG < 001 OR > 540
119700                                  OR = 004 OR = 005
119800                                  OR = 112
119900                                  OR = 214 OR = 215
120000                                  OR = 221 OR = 222
120100                                  OR = 231 OR = 400
120200                                  OR = 434 OR = 435
120300                                  OR = 436 OR = 437
120400                                  OR = 438 OR = 456
120500                                  OR = 457 OR = 458
120600                                  OR = 459 OR = 460
120700                                  OR = 469 OR = 470
120800                                  OR = 472 OR = 474
120900                                  OR = 514
121000             MOVE 54 TO PPS-RTC.
121100
121200     IF  PPS-RTC = 00
121300            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
121400                 (B-DISCHARGE-DATE < W-EFF-DATE))
121500                MOVE 55 TO PPS-RTC.
121600
121700     IF  PPS-RTC = 00
121800         IF P-NEW-TERMINATION-DATE > 00000000
121900            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
122000                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
122100                  MOVE 55 TO PPS-RTC.
122200
122300     IF  PPS-RTC = 00
122400         IF  B-LOS NOT NUMERIC
122500             MOVE 56 TO PPS-RTC
122600         ELSE
122700         IF  B-LOS = 0
122800             IF B-REVIEW-CODE NOT = 00 AND
122900                              NOT = 03 AND
123000                              NOT = 06 AND
123100                              NOT = 07 AND
123200                              NOT = 09 AND
123300                              NOT = 11
123400             MOVE 56 TO PPS-RTC.
123500
123600     IF  PPS-RTC = 00
123700         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
123800             MOVE 61 TO PPS-RTC
123900         ELSE
124000             MOVE B-LTR-DAYS TO H-LTR-DAYS.
124100
124200     IF  PPS-RTC = 00
124300         IF  B-COVERED-DAYS NOT NUMERIC
124400             MOVE 62 TO PPS-RTC
124500         ELSE
124600         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
124700             MOVE 62 TO PPS-RTC
124800         ELSE
124900             MOVE B-COVERED-DAYS TO H-COV-DAYS.
125000
125100     IF  PPS-RTC = 00
125200         IF  H-LTR-DAYS  > H-COV-DAYS
125300             MOVE 62 TO PPS-RTC
125400         ELSE
125500             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
125600
125700     IF  PPS-RTC = 00
125800         IF  NOT VALID-REVIEW-CODE
125900             MOVE 57 TO PPS-RTC.
126000
126100     IF  PPS-RTC = 00
126200         IF  B-CHARGES-CLAIMED NOT NUMERIC
126300             MOVE 58 TO PPS-RTC.
126400
126500     IF PPS-RTC = 00
126600           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
126700                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
126800                                            NOT = 'B' AND
126900                                            NOT = 'C'
127000                 MOVE 65 TO PPS-RTC.
127100
127200 2000-ASSEMBLE-PPS-VARIABLES.
127300***************************************************************
127400*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
127500*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
127600*    OF THAT VARIABLE.                                        *
127700***************************************************************
127800***  GET THE PROVIDER SPECIFIC VARIABLES.
127900***  GET THE PROVIDER SPECIFIC VARIABLES.
128000
128100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
128200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
128300
128400     IF  (P-NEW-STATE = 02 OR 12)
128500         MOVE P-NEW-COLA TO H-OPER-COLA
128600     ELSE
128700         MOVE 1.000  TO H-OPER-COLA.
128800
128900***************************************************************
129000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
129100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
129200
129300     PERFORM 2600-GET-DRG-WEIGHT
129400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
129500
129600***************************************************************
129700***  GET THE WAGE-INDEX
129800***  GET THE WAGE-INDEX
129900
130000     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
130100     MOVE W-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
130200
130300***************************************************************
130400***  GET THE LABOR, NON-LABOR STANDARD RATES
130500
130600     IF  P-NEW-STATE = 40
130700         MOVE 2 TO R2
130800         MOVE 3 TO R4
130900     ELSE
131000         MOVE 1 TO R2
131100         MOVE 1 TO R4.
131200
131300     IF  LARGE-URBAN
131400         MOVE 1 TO R3
131500     ELSE
131600         MOVE 2 TO R3.
131700
131800     IF B-DISCHARGE-DATE < 20031101
131900        PERFORM 2300-GET-LABOR-NLABOR-RATES
132000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
132100
132200     IF (B-DISCHARGE-DATE > 20031031 AND
132300         B-DISCHARGE-DATE < 20040401)
132400        PERFORM 2350-GET-LABOR-NLABOR-RATES2
132500             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
132600
132700     IF B-DISCHARGE-DATE > 20040331
132800        PERFORM 2360-GET-LABOR-NLABOR-RATES3
132900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
133000
133100      IF SE-AL-PROV
133200      COMPUTE H-TOT-REG-AL ROUNDED = H-REG-LABOR + H-REG-NONLABOR
133300      COMPUTE H-TOT-NAT-AL ROUNDED = H-NAT-LABOR + H-NAT-NONLABOR
133400      COMPUTE H-REG-LABOR ROUNDED  = H-TOT-REG-AL * 0.7079
133500      COMPUTE H-NAT-LABOR ROUNDED  = H-TOT-NAT-AL * 0.7079
133600      COMPUTE H-REG-NONLABOR ROUNDED = H-TOT-REG-AL * 0.2921
133700      COMPUTE H-NAT-NONLABOR ROUNDED = H-TOT-NAT-AL * 0.2921.
133800
133900***************************************************************
134000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
134100***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
134200
134300     MOVE 0.00  TO H-OPER-HSP-PCT.
134400     MOVE 1.00  TO H-OPER-FSP-PCT.
134500
134600***************************************************************
134700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
134800***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
134900
135000      MOVE 1.00 TO H-NAT-PCT.
135100      MOVE 0.00 TO H-REG-PCT.
135200
135300     IF  P-NEW-STATE = 40
135400         MOVE 0.50 TO H-NAT-PCT
135500         MOVE 0.50 TO H-REG-PCT
135600         IF B-DISCHARGE-DATE > 20040331
135700            MOVE 0.63 TO H-NAT-PCT
135800            MOVE 0.37 TO H-REG-PCT.
135900
136000     IF  P-N-SCH-REBASED-FY90 OR
136100         P-N-EACH OR
136200         P-N-MDH-REBASED-FY90
136300         MOVE 1.00 TO H-OPER-HSP-PCT.
136400
136500 2300-GET-LABOR-NLABOR-RATES.
136600
136700     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE (R1)
136800         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
136900         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
137000         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
137100         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
137200
137300
137400 2350-GET-LABOR-NLABOR-RATES2.
137500
137600     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE2 (R1)
137700         MOVE REG-LABOR2  (R1 R2 R3) TO H-REG-LABOR
137800         MOVE REG-NLABOR2 (R1 R2 R3) TO H-REG-NONLABOR
137900         MOVE REG-LABOR2  (R1 R4 R3) TO H-NAT-LABOR
138000         MOVE REG-NLABOR2 (R1 R4 R3) TO H-NAT-NONLABOR.
138100
138200 2360-GET-LABOR-NLABOR-RATES3.
138300
138400     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE3 (R1)
138500         MOVE REG-LABOR3  (R1 R2 R3) TO H-REG-LABOR
138600         MOVE REG-NLABOR3 (R1 R2 R3) TO H-REG-NONLABOR
138700         MOVE REG-LABOR3  (R1 R4 R3) TO H-NAT-LABOR
138800         MOVE REG-NLABOR3 (R1 R4 R3) TO H-NAT-NONLABOR.
138900
139000 2600-GET-DRG-WEIGHT.
139100
139200     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
139300         SET DX6 TO B-DRG
139400         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
139500         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
139600*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
139700         MOVE ZEROES                   TO H-DAYS-CUTOFF
139800         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
139900
140000 3000-CALC-PAYMENT.
140100***************************************************************
140200*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
140300*        CALCULATE THE STAY UTILIZATION.                      *
140400*        CALCULATE THE FEDERAL PORTION.                       *
140500*        CALCULATE THE HOSPITAL PORTION.                      *
140600*        CALCULATE THE COST-OUTLIER PORTION.                  *
140700*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
140800*        CALCULATE THE DSH ADJUSTMENT.                        *
140900*        CALCULATE THE IME TEACHING.                          *
141000***************************************************************
141100
141200     PERFORM 3100-CALC-STAY-UTILIZATION.
141300     PERFORM 3300-CALC-OPER-FSP-AMT.
141400
141500     IF B-DISCHARGE-DATE > 20040331
141600        PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT
141700     ELSE
141800        PERFORM 3900-CALC-OPER-DSH THRU 3900-EXIT.
141900
142000***********************************************************
142100***  OPERATING IME CALCULATION
142200***  OPERATING IME CALCULATION
142300
142400     IF B-DISCHARGE-DATE > 20040331
142500         COMPUTE H-OPER-IME-TEACH ROUNDED =
142600            1.47 * ((1 + H-INTERN-RATIO) ** .405  - 1)
142700     ELSE
142800         COMPUTE H-OPER-IME-TEACH ROUNDED =
142900            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
143000
143100***********************************************************
143200
143300     IF P-N-SCH-REBASED-FY90 OR
143400        P-N-EACH OR
143500        P-N-MDH-REBASED-FY90
143600         PERFORM 3450-CALC-ADDITIONAL-HSP.
143700
143800     MOVE 00                 TO  PPS-RTC.
143900     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
144000     MOVE H-ALOS             TO  PPS-AVG-LOS.
144100     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
144200
144300     MOVE B-LOS TO H-PERDIEM-DAYS.
144400     IF H-PERDIEM-DAYS < 1
144500         MOVE 1 TO H-PERDIEM-DAYS.
144600     ADD 1 TO H-PERDIEM-DAYS.
144700
144800     MOVE 1 TO H-DSCHG-FRCTN.
144900
145000     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
145100
145200     IF  (PAY-PERDIEM-DAYS OR
145300          PAY-XFER-NO-COST) OR
145400       (PAY-XFER-SPEC-DRG AND (B-DRG = 014 OR 113 OR 236 OR
145500                                       012 OR 024 OR 025 OR
145600                                       088 OR 089 OR 090 OR
145700                                       121 OR 122 OR 127 OR
145800                                       130 OR 131 OR 239 OR
145900                                       277 OR 278 OR 294 OR
146000                                       296 OR 297 OR 320 OR
146100                                       321 OR 395 OR 468 OR
146200                                       429 OR 483))
146300         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
146400         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
146500         IF H-DSCHG-FRCTN > 1
146600              MOVE 1 TO H-DSCHG-FRCTN
146700              MOVE 1 TO H-TRANSFER-ADJ
146800         ELSE
146900              COMPUTE H-DRG-WT-FRCTN ROUNDED =
147000                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
147100
147200     IF (PAY-XFER-SPEC-DRG AND (B-DRG = 209 OR 210 OR 211))
147300         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
147400         COMPUTE H-DSCHG-FRCTN  ROUNDED =
147500                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
147600         IF H-DSCHG-FRCTN > 1
147700              MOVE 1 TO H-DSCHG-FRCTN
147800              MOVE 1 TO H-TRANSFER-ADJ
147900         ELSE
148000              COMPUTE H-DRG-WT-FRCTN ROUNDED =
148100            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
148200
148300
148400***********************************************************
148500***  CAPITAL DSH CALCULATION
148600***  CAPITAL DSH CALCULATION
148700
148800     MOVE 0 TO H-CAPI-DSH.
148900
149000     IF P-NEW-BED-SIZE NOT NUMERIC
149100         MOVE 0 TO P-NEW-BED-SIZE.
149200
149300     IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
149400         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
149500                  (.2025 * (P-NEW-SSI-RATIO
149600                          + P-NEW-MEDICAID-RATIO)) - 1.
149700
149800***********************************************************
149900***  CAPITAL IME TEACH CALCULATION
150000***  CAPITAL IME TEACH CALCULATION
150100
150200     MOVE 0 TO H-WK-CAPI-IME-TEACH.
150300
150400     IF P-NEW-CAPI-IME NUMERIC
150500        IF P-NEW-CAPI-IME > 1.5000
150600           MOVE 1.5000 TO P-NEW-CAPI-IME.
150700
150800     IF P-NEW-CAPI-IME NUMERIC
150900        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
151000          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
151100
151200***********************************************************
151300******************************************************************
151400***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
151500***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
151600***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97
151700
151800     MOVE 0.00 TO H-DAYOUT-PCT.
151900******************************************************************
152000
152100     MOVE 0.80 TO H-CSTOUT-PCT.
152200
152300******************************************************************
152400*****THESE ARE BURNS DRG'S
152500     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR
152600                 509 OR 510 OR 511
152700             MOVE 0.90 TO H-CSTOUT-PCT.
152800
152900***     NATIONAL PERCENTAGE
153000     MOVE 0.7110   TO H-LABOR-PCT.
153100     MOVE 0.2890   TO H-NONLABOR-PCT.
153200
153300***     PUERTO RICO PERCENTAGE
153400     MOVE 0.7130   TO H-PR-LABOR-PCT.
153500     MOVE 0.2870   TO H-PR-NONLABOR-PCT.
153600
153700     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
153800             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
153900     ELSE
154000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
154100
154200     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
154300             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
154400     ELSE
154500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
154600
154700     IF SE-AL-PROV
154800     MOVE 0.7079   TO H-LABOR-PCT
154900     MOVE 0.2921   TO H-NONLABOR-PCT.
155000***********************************************************
155100***********************************************************
155200***  CAPITAL PAYMENT METHOD B
155300***  CAPITAL PAYMENT METHOD B
155400
155500     IF W-SIZE = 'L'
155600        MOVE 1.03 TO H-CAPI-LARG-URBAN
155700     ELSE
155800        MOVE 1.00 TO H-CAPI-LARG-URBAN.
155900
156000     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
156100     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
156200
156300     IF B-DISCHARGE-DATE > 20040331
156400        COMPUTE H-FEDERAL-RATE ROUNDED =
156500                                 (0413.48 * H-CAPI-GAF)
156600        COMPUTE H-PUERTO-RICO-RATE ROUNDED =
156700                                 (0202.96 * H-PR-CAPI-GAF)
156800     ELSE
156900        COMPUTE H-FEDERAL-RATE ROUNDED =
157000                                 (0414.18 * H-CAPI-GAF)
157100        COMPUTE H-PUERTO-RICO-RATE ROUNDED =
157200                                 (0203.17 * H-PR-CAPI-GAF).
157300
157400     COMPUTE H-CAPI-COLA ROUNDED =
157500                     (.3152 * (H-OPER-COLA - 1) + 1).
157600
157700     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
157800
157900     IF P-NEW-STATE = 40
158000        COMPUTE  H-CAPI-FED-RATE ROUNDED =
158100                 (H-NAT-PCT * H-FEDERAL-RATE) +
158200                 (H-REG-PCT * H-PUERTO-RICO-RATE)
158300        IF B-DISCHARGE-DATE > 20040331
158400            COMPUTE  H-CAPI-FED-RATE ROUNDED =
158500                    (.625 * H-FEDERAL-RATE) +
158600                    (.375 * H-PUERTO-RICO-RATE).
158700***********************************************************
158800***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001
158900***  CAPITAL HSP CALCULATION
159000***  CAPITAL HSP CALCULATION
159100*
159200*    IF B-DISCHARGE-DATE > 20010331
159300*        MOVE 1.0149 TO H-HSP-UPDATE01
159400*    ELSE
159500*        MOVE 1.0147 TO H-HSP-UPDATE01.
159600*
159700*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.
159800*
159900*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *
160000*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
160100***********************************************************
160200
160300***********************************************************
160400***  CAPITAL FSP CALCULATION
160500***  CAPITAL FSP CALCULATION
160600
160700     COMPUTE H-CAPI-FSP-PART ROUNDED =
160800                               H-DRG-WT * H-CAPI-FED-RATE *
160900                               H-CAPI-COLA *
161000                               H-CAPI-LARG-URBAN.
161100
161200***********************************************************
161300***  CAPITAL PAYMENT METHOD A
161400***  CAPITAL PAYMENT METHOD A
161500
161600     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
161700        MOVE 1.00 TO H-CAPI-SCH
161800     ELSE
161900        MOVE 0.85 TO H-CAPI-SCH.
162000
162100***********************************************************
162200***********  CAPITAL OLD-HARMLESS CALCULATION ***********
162300***********  CAPITAL OLD-HARMLESS CALCULATION ***********
162400
162500     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
162600                    (P-NEW-CAPI-OLD-HARM-RATE *
162700                    H-CAPI-SCH).
162800
162900***********************************************************
163000        IF PAY-PERDIEM-DAYS
163100            IF  H-PERDIEM-DAYS < H-ALOS
163200                IF  NOT (B-DRG = 385)
163300                    PERFORM 3500-CALC-PERDIEM-AMT
163400                    MOVE 03 TO PPS-RTC.
163500
163600        IF PAY-XFER-SPEC-DRG
163700            IF  H-PERDIEM-DAYS < H-ALOS
163800                IF  NOT (B-DRG = 385)
163900                    PERFORM 3550-CALC-PERDIEM-AMT.
164000
164100        IF  PAY-XFER-NO-COST
164200            MOVE 00 TO PPS-RTC
164300            IF H-PERDIEM-DAYS < H-ALOS
164400               IF  NOT (B-DRG = 385)
164500                   PERFORM 3500-CALC-PERDIEM-AMT
164600                   MOVE 06 TO PPS-RTC.
164700
164800     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
164900
165000     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
165100
165200     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
165300
165400        IF PAY-XFER-SPEC-DRG
165500            IF  H-PERDIEM-DAYS < H-ALOS
165600                IF  NOT (B-DRG = 385)
165700                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
165800
165900
166000        IF  PAY-PERDIEM-DAYS
166100            IF  H-OPER-OUTCST-PART > 0
166200                MOVE H-OPER-OUTCST-PART TO
166300                     H-OPER-OUTLIER-PART
166400                MOVE 05 TO PPS-RTC
166500            ELSE
166600            IF  PPS-RTC NOT = 03
166700                MOVE 00 TO PPS-RTC
166800                MOVE 0  TO H-OPER-OUTLIER-PART.
166900
167000        IF  PAY-PERDIEM-DAYS
167100            IF  H-CAPI-OUTCST-PART > 0
167200                MOVE H-CAPI-OUTCST-PART TO
167300                     H-CAPI-OUTLIER-PART
167400                MOVE 05 TO PPS-RTC
167500            ELSE
167600            IF  PPS-RTC NOT = 03
167700                MOVE 0  TO H-CAPI-OUTLIER-PART.
167800
167900
168000 3000-CONTINUE.
168100
168200***********************************************************
168300***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
168400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
168500
168600     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
168700
168800***********************************************************
168900
169000     IF  PPS-RTC = 67
169100         MOVE H-OPER-DOLLAR-THRESHOLD TO
169200              WK-H-OPER-DOLLAR-THRESHOLD.
169300
169400     IF  PPS-RTC < 50
169500         PERFORM 3800-CALC-TOT-AMT
169600     ELSE
169700         MOVE ALL '0' TO PPS-OPER-HSP-PART
169800                         PPS-OPER-FSP-PART
169900                         PPS-OPER-OUTLIER-PART
170000                         PPS-OUTLIER-DAYS
170100                         PPS-REG-DAYS-USED
170200                         PPS-LTR-DAYS-USED
170300                         PPS-TOTAL-PAYMENT
170400                         PPS-OPER-DSH-ADJ
170500                         PPS-OPER-IME-ADJ
170600                         H-DSCHG-FRCTN
170700                         H-DRG-WT-FRCTN
170800                         HOLD-ADDITIONAL-VARIABLES
170900                         HOLD-CAPITAL-VARIABLES
171000                         HOLD-CAPITAL2-VARIABLES
171100                         HOLD-OTHER-VARIABLES
171200                         HOLD-PC-OTH-VARIABLES.
171300
171400     IF  PPS-RTC = 67
171500         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
171600                 H-OPER-DOLLAR-THRESHOLD.
171700
171800 3000-EXIT.  EXIT.
171900
172000 3100-CALC-STAY-UTILIZATION.
172100
172200     MOVE 0 TO PPS-REG-DAYS-USED.
172300     MOVE 0 TO PPS-LTR-DAYS-USED.
172400
172500     IF H-REG-DAYS > 0
172600        IF H-REG-DAYS > B-LOS
172700           MOVE B-LOS TO PPS-REG-DAYS-USED
172800        ELSE
172900           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
173000     ELSE
173100        IF H-LTR-DAYS > B-LOS
173200           MOVE B-LOS TO PPS-LTR-DAYS-USED
173300        ELSE
173400           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
173500
173600
173700
173800 3300-CALC-OPER-FSP-AMT.
173900***********************************************************
174000***  OPERATING FSP CALCULATION
174100***  OPERATING FSP CALCULATION
174200
174300     COMPUTE H-OPER-FSP-PART ROUNDED =
174400           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
174500            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
174600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
174700
174800****CHECK FOR PUERTO RICO
174900     IF (P-NEW-STATE = 40 AND
175000          B-DISCHARGE-DATE < 20040401)
175100       COMPUTE H-OPER-FSP-PART ROUNDED =
175200           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
175300            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
175400                           +
175500           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
175600            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
175700                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
175800
175900     IF (P-NEW-STATE = 40 AND
176000          B-DISCHARGE-DATE > 20040331)
176100           COMPUTE H-OPER-FSP-PART ROUNDED =
176200              (.625 * (H-NAT-LABOR * H-WAGE-INDEX +
176300               H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
176400                              +
176500              (.375 * (H-REG-LABOR * H-PR-WAGE-INDEX +
176600               H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
176700                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
176800
176900 3450-CALC-ADDITIONAL-HSP.
177000***********************************************************
177100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
177200*    SOLE COMMUNITY
177300*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
177400*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
177500***********************************************************
177600**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
177700****    USE ACTUAL FEDERAL REGISTER NUMBER
177800
177900***************************************************************
178000***         GET THE UPDATING FACTOR
178100***         GET THE UPDATING FACTOR
178200
178300     MOVE 0.997174 TO H-BUDG-NUTR01.
178400     MOVE 0.995821 TO H-BUDG-NUTR02.
178500     MOVE 0.993111 TO H-BUDG-NUTR03.
178600
178700     IF B-DISCHARGE-DATE > 20040331
178800        MOVE 1.002628 TO H-BUDG-NUTR04
178900     ELSE
179000        MOVE 1.002588 TO H-BUDG-NUTR04.
179100
179200     MOVE 1.0340 TO H-UPDATE-01.
179300     MOVE 1.0275 TO H-UPDATE-02.
179400     MOVE 1.0295 TO H-UPDATE-03.
179500     MOVE 1.0340 TO H-UPDATE-04.
179600
179700     COMPUTE H-UPDATE-FACTOR ROUNDED =
179800                       (H-UPDATE-01 * H-UPDATE-02 *
179900                        H-UPDATE-03 * H-UPDATE-04 *
180000                        H-BUDG-NUTR01 * H-BUDG-NUTR02 *
180100                        H-BUDG-NUTR03 * H-BUDG-NUTR04).
180200
180300     COMPUTE H-HSP-RATE ROUNDED =
180400         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
180500***************************************************************
180600
180700***************************************************************
180800***     OUTLIER OFFSETS
180900***     OPERATING NATIONAL
181000***     OPERATING PUERTO RICO BLEND
181100
181200      IF B-DISCHARGE-DATE > 20040331
181300         MOVE 0.948997 TO H-OUTLIER-OFFSET-NAT
181400         MOVE 0.958823 TO H-OUTLIER-OFFSET-PR
181500      ELSE
181600         MOVE 0.949460 TO H-OUTLIER-OFFSET-NAT
181700         MOVE 0.963073 TO H-OUTLIER-OFFSET-PR.
181800
181900***************************************************************
182000     COMPUTE H-FSP-RATE ROUNDED =
182100         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
182200         H-NAT-NONLABOR * H-OPER-COLA))
182300                           *
182400     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
182500                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
182600
182700     IF (P-NEW-STATE = 40 AND
182800           B-DISCHARGE-DATE < 20040401)
182900       COMPUTE H-FSP-RATE ROUNDED =
183000         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
183100         H-NAT-NONLABOR * H-OPER-COLA))
183200                           +
183300          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
183400         H-REG-NONLABOR * H-OPER-COLA)))
183500                           *
183600      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
183700                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
183800
183900     IF (P-NEW-STATE = 40 AND
184000           B-DISCHARGE-DATE > 20040331)
184100           COMPUTE H-FSP-RATE ROUNDED =
184200             ((.625 * (H-NAT-LABOR * H-WAGE-INDEX +
184300                H-NAT-NONLABOR * H-OPER-COLA))
184400                           +
184500             (.375 * (H-REG-LABOR * H-PR-WAGE-INDEX +
184600                H-REG-NONLABOR * H-OPER-COLA)))
184700                           *
184800      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
184900                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
185000
185100     IF  H-HSP-RATE > H-FSP-RATE
185200           COMPUTE H-OPER-HSP-PART ROUNDED =
185300             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
185400                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
185500     ELSE
185600         MOVE 0 TO H-OPER-HSP-PART.
185700
185800***************************************************************
185900***         GET THE MDH REBASE
186000***     HAS BEEN REVIVED FOR 10/01/97
186100
186200     IF  H-HSP-RATE > H-FSP-RATE
186300         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
186400           COMPUTE H-OPER-HSP-PART ROUNDED =
186500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5
186600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
186700
186800 3500-CALC-PERDIEM-AMT.
186900***********************************************************
187000***  REVIEW CODE = 03 OR 06
187100***  OPERATING PERDIEM-AMT CALCULATION
187200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
187300
187400**    REMOVED AS OF APR 1 2004
187500***     COMPUTE H-OPER-HSP-PART ROUNDED =
187600***     H-OPER-HSP-PART * H-TRANSFER-ADJ
187700***     ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
187800***********************************************************
187900
188000        COMPUTE H-OPER-FSP-PART ROUNDED =
188100        H-OPER-FSP-PART * H-TRANSFER-ADJ
188200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
188300
188400***********************************************************
188500***********************************************************
188600***  REVIEW CODE = 03 OR 06
188700***  CAPITAL   PERDIEM-AMT CALCULATION
188800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
188900
189000***********************************************************
189100**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
189200*       COMPUTE H-CAPI-HSP-PART ROUNDED =
189300*       H-CAPI-HSP-PART * H-TRANSFER-ADJ
189400*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
189500***********************************************************
189600
189700        COMPUTE H-CAPI-FSP-PART ROUNDED =
189800        H-CAPI-FSP-PART * H-TRANSFER-ADJ
189900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
190000
190100***********************************************************
190200***  REVIEW CODE = 03 OR 06
190300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
190400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
190500
190600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
190700        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
190800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
190900
191000 3550-CALC-PERDIEM-AMT.
191100***********************************************************
191200***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
191300***  OPERATING PERDIEM-AMT CALCULATION
191400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
191500**    REMOVED AS OF APR 1 2004
191600*    IF (B-DRG = 209 OR 210 OR 211)
191700*       MOVE 10 TO PPS-RTC
191800*       COMPUTE H-OPER-HSP-PART ROUNDED =
191900*       H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
192000*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
192100
192200*    IF (B-DRG = 014 OR 113 OR 236 OR
192300*                012 OR 024 OR 025 OR
192400*                088 OR 089 OR 090 OR
192500*                121 OR 122 OR 127 OR
192600*                130 OR 131 OR 239 OR
192700*                277 OR 278 OR 294 OR
192800*                296 OR 297 OR 320 OR
192900*                321 OR 395 OR 468 OR
193000*                429 OR 483)
193100*       MOVE 12 TO PPS-RTC
193200*       COMPUTE H-OPER-HSP-PART ROUNDED =
193300*       H-OPER-HSP-PART *  H-TRANSFER-ADJ
193400*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
193500***********************************************************
193600
193700     IF (B-DRG = 209 OR 210 OR 211)
193800        MOVE 10 TO PPS-RTC
193900        COMPUTE H-OPER-FSP-PART ROUNDED =
194000        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
194100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
194200
194300     IF (B-DRG = 014 OR 113 OR 236 OR
194400                 012 OR 024 OR 025 OR
194500                 088 OR 089 OR 090 OR
194600                 121 OR 122 OR 127 OR
194700                 130 OR 131 OR 239 OR
194800                 277 OR 278 OR 294 OR
194900                 296 OR 297 OR 320 OR
195000                 321 OR 395 OR 468 OR
195100                 429 OR 483)
195200        MOVE 12 TO PPS-RTC
195300        COMPUTE H-OPER-FSP-PART ROUNDED =
195400        H-OPER-FSP-PART *  H-TRANSFER-ADJ
195500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
195600
195700***********************************************************
195800***  CAPITAL PERDIEM-AMT CALCULATION
195900***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
196000
196100***********************************************************
196200**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
196300*    IF (B-DRG = 209 OR 210 OR 211)
196400*       MOVE 10 TO PPS-RTC
196500*       COMPUTE H-CAPI-HSP-PART ROUNDED =
196600*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
196700*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
196800*
196900*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
197000*                264 OR 429 OR 483)
197100*       MOVE 12 TO PPS-RTC
197200*       COMPUTE H-CAPI-HSP-PART ROUNDED =
197300*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ
197400*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
197500***********************************************************
197600
197700     IF (B-DRG = 209 OR 210 OR 211)
197800        MOVE 10 TO PPS-RTC
197900        COMPUTE H-CAPI-FSP-PART ROUNDED =
198000        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
198100        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
198200
198300     IF (B-DRG = 014 OR 113 OR 236 OR
198400                 012 OR 024 OR 025 OR
198500                 088 OR 089 OR 090 OR
198600                 121 OR 122 OR 127 OR
198700                 130 OR 131 OR 239 OR
198800                 277 OR 278 OR 294 OR
198900                 296 OR 297 OR 320 OR
199000                 321 OR 395 OR 468 OR
199100                 429 OR 483)
199200        MOVE 12 TO PPS-RTC
199300        COMPUTE H-CAPI-FSP-PART ROUNDED =
199400        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
199500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
199600
199700***********************************************************
199800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
199900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
200000
200100     IF (B-DRG = 209 OR 210 OR 211)
200200        MOVE 10 TO PPS-RTC
200300        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
200400        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
200500        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
200600
200700     IF (B-DRG = 014 OR 113 OR 236 OR
200800                 012 OR 024 OR 025 OR
200900                 088 OR 089 OR 090 OR
201000                 121 OR 122 OR 127 OR
201100                 130 OR 131 OR 239 OR
201200                 277 OR 278 OR 294 OR
201300                 296 OR 297 OR 320 OR
201400                 321 OR 395 OR 468 OR
201500                 429 OR 483)
201600        MOVE 12 TO PPS-RTC
201700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
201800        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
201900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
202000
202100 3560-CHECK-RTN-CODE.
202200
202300     IF (B-DRG = 209 OR 210 OR 211)
202400        MOVE 10 TO PPS-RTC.
202500     IF (B-DRG = 014 OR 113 OR 236 OR
202600                 012 OR 024 OR 025 OR
202700                 088 OR 089 OR 090 OR
202800                 121 OR 122 OR 127 OR
202900                 130 OR 131 OR 239 OR
203000                 277 OR 278 OR 294 OR
203100                 296 OR 297 OR 320 OR
203200                 321 OR 395 OR 468 OR
203300                 429 OR 483)
203400        MOVE 12 TO PPS-RTC.
203500
203600 3560-EXIT.    EXIT.
203700
203800 3600-CALC-OUTLIER.
203900***********************************************************
204000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
204100***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
204200
204300     IF H-CAPI-CSTCHG-RATIO > 0 OR
204400       H-OPER-CSTCHG-RATIO > 0
204500        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
204600                H-OPER-CSTCHG-RATIO /
204700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
204800        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
204900                H-CAPI-CSTCHG-RATIO /
205000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
205100     ELSE
205200         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
205300                   H-CAPI-SHARE-DOLL-THRESHOLD.
205400
205500***********************************************************
205600***********************************************************
205700***********************************************************
205800***********************************************************
205900***********************************************************
206000***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
206100***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
206200***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
206300
206400***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
206500***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.
206600***********************************************************
206700***********************************************************
206800***********************************************************
206900***********************************************************
207000
207100
207200
207300***********************************************************
207400***  OUTLIER THRESHOLD AMOUNTS
207500***  OUTLIER THRESHOLD AMOUNTS
207600
207700     IF B-DISCHARGE-DATE > 20040331
207800        MOVE 30150.00 TO H-CST-THRESH
207900     ELSE
208000        MOVE 31000.00 TO H-CST-THRESH.
208100
208200     IF (B-REVIEW-CODE = '03') AND
208300         H-PERDIEM-DAYS < H-ALOS
208400        COMPUTE H-CST-THRESH ROUNDED =
208500                      (H-CST-THRESH * H-TRANSFER-ADJ)
208600                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
208700
208800     IF ((B-REVIEW-CODE = '09') AND
208900         (H-PERDIEM-DAYS < H-ALOS))
209000         IF (B-DRG = 014 OR 113 OR 236 OR
209100                     012 OR 024 OR 025 OR
209200                     088 OR 089 OR 090 OR
209300                     121 OR 122 OR 127 OR
209400                     130 OR 131 OR 239 OR
209500                     277 OR 278 OR 294 OR
209600                     296 OR 297 OR 320 OR
209700                     321 OR 395 OR 468 OR
209800                     429 OR 483)
209900            COMPUTE H-CST-THRESH ROUNDED =
210000                      (H-CST-THRESH * H-TRANSFER-ADJ)
210100                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
210200
210300     IF ((B-REVIEW-CODE = '09') AND
210400         (H-PERDIEM-DAYS < H-ALOS))
210500         IF (B-DRG = 209 OR 210 OR 211)
210600           COMPUTE H-CST-THRESH ROUNDED =
210700          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
210800                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
210900
211000     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
211100        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
211200         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
211300          H-OPER-SHARE-DOLL-THRESHOLD.
211400
211500     IF (P-NEW-STATE = 40 AND
211600           B-DISCHARGE-DATE < 20040401)
211700        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
211800           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
211900            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
212000             H-OPER-SHARE-DOLL-THRESHOLD
212100        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
212200               (H-OPER-DOLLAR-THRESHOLD +
212300                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
212400
212500     IF (P-NEW-STATE = 40 AND
212600           B-DISCHARGE-DATE > 20040331)
212700          COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
212800           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
212900            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
213000             H-OPER-SHARE-DOLL-THRESHOLD
213100          COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
213200               (H-OPER-DOLLAR-THRESHOLD * .625) +
213300               (H-OPER-PR-DOLLAR-THRESHOLD * .375).
213400***********************************************************
213500
213600     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
213700          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
213800          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
213900
214000
214100     IF (P-NEW-STATE = 40 AND
214200           B-DISCHARGE-DATE < 20040401)
214300        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
214400           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
214500           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
214600        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
214700               (H-CAPI-DOLLAR-THRESHOLD +
214800                H-CAPI-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
214900
215000     IF (P-NEW-STATE = 40 AND
215100           B-DISCHARGE-DATE > 20040331)
215200          COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
215300             H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
215400             H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
215500          COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
215600                 (H-CAPI-DOLLAR-THRESHOLD * .625) +
215700                 (H-CAPI-PR-DOLLAR-THRESHOLD * .375).
215800
215900     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
216000      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
216100                       +
216200             H-OPER-DOLLAR-THRESHOLD
216300                       +
216400                 H-NEW-TECH-PAY-ADD-ON.
216500
216600     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
216700      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
216800                       +
216900             H-CAPI-DOLLAR-THRESHOLD.
217000
217100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
217200         MOVE 0 TO H-CAPI-COST-OUTLIER.
217300
217400
217500***********************************************************
217600***  OPERATING COST CALCULATION
217700***  OPERATING COST CALCULATION
217800
217900     COMPUTE H-OPER-BILL-COSTS ROUNDED =
218000         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
218100         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
218200
218300
218400     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
218500         COMPUTE H-OPER-OUTCST-PART ROUNDED =
218600         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
218700                         H-OPER-COST-OUTLIER).
218800
218900     IF PAY-WITHOUT-COST OR
219000        PAY-XFER-NO-COST OR
219100        PAY-XFER-SPEC-DRG-NO-COST
219200         MOVE 0 TO H-OPER-OUTCST-PART.
219300
219400***********************************************************
219500***  CAPITAL COST CALCULATION
219600***  CAPITAL COST CALCULATION
219700
219800     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
219900             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
220000         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
220100
220200     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
220300         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
220400         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
220500                         H-CAPI-COST-OUTLIER).
220600
220700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
220800       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
220900              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
221000
221100     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
221200        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
221300               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
221400
221500     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
221600        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
221700        MOVE 0 TO H-CAPI-OUTCST-PART
221800                  H-OPER-OUTCST-PART.
221900
222000     IF PAY-WITHOUT-COST OR
222100        PAY-XFER-NO-COST OR
222200        PAY-XFER-SPEC-DRG-NO-COST
222300         MOVE 0 TO H-CAPI-OUTCST-PART.
222400
222500***********************************************************
222600***  DETERMINES THE BILL TO BE COST  OUTLIER
222700
222800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
222900         MOVE 0 TO H-CAPI-OUTDAY-PART
223000                   H-CAPI-OUTCST-PART.
223100
223200     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
223300                 MOVE H-OPER-OUTCST-PART TO
223400                      H-OPER-OUTLIER-PART
223500                 MOVE H-CAPI-OUTCST-PART TO
223600                      H-CAPI-OUTLIER-PART
223700                 MOVE 02 TO PPS-RTC.
223800
223900
224000***********************************************************
224100***  DETERMINES IF COST OUTLIER
224200***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
224300***         RETURN CODE OF 02
224400
224500     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
224600
224700     IF PPS-RTC = 02
224800             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
224900                     (H-CAPI-COST-OUTLIER  +
225000                      H-OPER-COST-OUTLIER)
225100                             /
225200                    (H-CAPI-CSTCHG-RATIO  +
225300                     H-OPER-CSTCHG-RATIO)
225400             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
225500
225600***********************************************************
225700***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
225800***         RETURN CODE OF 67
225900
226000     IF PPS-RTC = 02
226100         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
226200            PPS-PC-COT-FLAG = 'Y'
226300             MOVE 67 TO PPS-RTC.
226400***********************************************************
226500
226600***********************************************************
226700***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
226800***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
226900
227000     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
227100        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
227200                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
227300         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
227400
227500     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
227600        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
227700                H-CAPI-OUTLIER-PART.
227800
227900     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
228000        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
228100                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
228200         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
228300
228400 3600-EXIT.   EXIT.
228500***********************************************************
228600***********************************************************
228700
228800***********************************************************
228900 3800-CALC-TOT-AMT.
229000***********************************************************
229100***  CALCULATE TOTALS FOR CAPITAL
229200***  CALCULATE TOTALS FOR CAPITAL
229300
229400     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
229500
229600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
229700        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
229800        MOVE 0.00 TO H-CAPI-HSP-PCT.
229900
230000     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
230100        MOVE 0    TO H-CAPI-OLD-HARMLESS
230200        MOVE 1.00 TO H-CAPI-FSP-PCT
230300        MOVE 0.00 TO H-CAPI-HSP-PCT.
230400
230500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
230600        MOVE 0    TO H-CAPI-OLD-HARMLESS
230700        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
230800        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
230900
231000     COMPUTE H-CAPI-HSP ROUNDED =
231100         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
231200
231300     COMPUTE H-CAPI-FSP ROUNDED =
231400         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
231500
231600     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
231700
231800     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
231900
232000     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
232100             H-CAPI-FSP
232200              * H-CAPI-DSH.
232300
232400     COMPUTE H-CAPI-IME-ADJ ROUNDED =
232500          H-CAPI-FSP *
232600                 H-WK-CAPI-IME-TEACH.
232700
232800     COMPUTE H-CAPI-OUTLIER ROUNDED =
232900             1.00 * H-CAPI-OUTLIER-PART.
233000
233100     COMPUTE H-CAPI2-B-FSP ROUNDED =
233200             1.00 * H-CAPI2-B-FSP-PART.
233300
233400     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
233500             1.00 * H-CAPI2-B-OUTLIER-PART.
233600***********************************************************
233700***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
233800***        THIS ZEROES OUT ALL CAPITAL DATA
233900
234000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
234100        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
234200***********************************************************
234300
234400***********************************************************
234500***  CALCULATE FINAL TOTALS FOR OPERATING
234600***  CALCULATE FINAL TOTALS FOR OPERATING
234700
234800     IF (H-CAPI-OUTLIER > 0 AND
234900         PPS-OPER-OUTLIER-PART = 0)
235000            COMPUTE PPS-OPER-OUTLIER-PART =
235100                    PPS-OPER-OUTLIER-PART + .01.
235200
235300     COMPUTE PPS-OPER-FSP-PART ROUNDED =
235400             H-OPER-FSP-PCT * H-OPER-FSP-PART.
235500
235600     COMPUTE PPS-OPER-HSP-PART ROUNDED =
235700             H-OPER-HSP-PCT * H-OPER-HSP-PART.
235800
235900     MOVE ZERO TO PPS-OPER-DSH-ADJ.
236000
236100     IF  H-OPER-DSH NUMERIC
236200         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
236300              PPS-OPER-FSP-PART * H-OPER-DSH.
236400
236500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
236600             PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
236700
236800     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
236900             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
237000
237100     IF HMO-TAG  = 'Y'
237200        PERFORM 3850-HMO-IME-ADJ.
237300
237400***********************************************************
237500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
237600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
237700
237800     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
237900             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
238000             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
238100             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
238200
238300     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
238400
238500     COMPUTE PPS-TOTAL-PAYMENT ROUNDED =
238600             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
238700             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
238800                     PPS-OPER-IME-ADJ
238900                           +
239000                 PPS-NEW-TECH-PAY-ADD-ON
239100                           +
239200                 H-WK-PASS-AMT-PLUS-MISC
239300                           +
239400                   H-CAPI-TOTAL-PAY.
239500
239600 3850-HMO-IME-ADJ.
239700***********************************************************
239800***  HMO CALC FOR PASS-THRU ADDON
239900***  HMO CALC FOR PASS-THRU ADDON
240000
240100***  HMO DIR-MED-ED  ---- NO LONGER PAID AS OF 10/01/2002
240200
240300     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
240400          (P-NEW-PASS-AMT-PLUS-MISC -
240500           P-NEW-PASS-AMT-DIR-MED-ED) * B-LOS.
240600
240700***********************************************************
240800***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
240900
241000     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
241100                   PPS-OPER-IME-ADJ * .0.
241200
241300***********************************************************
241400
241500 3900-CALC-OPER-DSH.
241600
241700***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
241800***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
241900
242000      MOVE 0.0000 TO H-OPER-DSH.
242100
242200      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
242300                                     + P-NEW-MEDICAID-RATIO).
242400
242500***********************************************************
242600*****    0-99 BEDS
242700      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
242800                               AND H-WK-OPER-DSH > .1499
242900                               AND H-WK-OPER-DSH < .1923
243000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
243100                                      * .65 + .025.
243200
243300      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
243400                               AND H-WK-OPER-DSH > .1922
243500             MOVE .0525 TO H-OPER-DSH.
243600
243700***********************************************************
243800*****   100 + BEDS
243900
244000      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
244100                               AND H-WK-OPER-DSH > .1499
244200                               AND H-WK-OPER-DSH < .2021
244300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
244400                                      * .65 + .025.
244500
244600      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
244700                               AND H-WK-OPER-DSH > .202
244800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
244900                                      * .825 + .0588.
245000
245100***********************************************************
245200*****   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
245300
245400      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
245500                               AND H-WK-OPER-DSH > .1499
245600                               AND H-WK-OPER-DSH < .1923
245700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
245800                                 * .65 + .025.
245900
246000      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
246100                               AND H-WK-OPER-DSH > .1922
246200        MOVE .0525 TO H-OPER-DSH.
246300
246400***********************************************************
246500*****   OTHER RURAL HOSPITALS 500 BEDS +
246600
246700      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
246800                               AND H-WK-OPER-DSH > .1499
246900                               AND H-WK-OPER-DSH < .2021
247000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
247100                                 * .65 + .025.
247200
247300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
247400                               AND H-WK-OPER-DSH > .202
247500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
247600                                 * .825 + .0588.
247700
247800***********************************************************
247900*****   RURAL HOSPITALS SCH
248000
248100      IF W-SIZE = 'R'
248200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
248300                               AND H-WK-OPER-DSH > .1499
248400                               AND H-WK-OPER-DSH < .1923
248500         COMPUTE H-OPER-DSH-SCH ROUNDED = (H-WK-OPER-DSH - .15)
248600                                 * .65 + .025
248700         MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
248800      IF W-SIZE = 'R'
248900         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
249000                               AND H-WK-OPER-DSH > .1922
249100                               AND H-WK-OPER-DSH < .3000
249200         MOVE .0525 TO H-OPER-DSH-SCH
249300                       H-OPER-DSH.
249400      IF W-SIZE = 'R'
249500         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
249600                               AND H-WK-OPER-DSH > .2999
249700         MOVE .10 TO H-OPER-DSH-SCH
249800                     H-OPER-DSH.
249900***********************************************************
250000*****   RURAL HOSPITALS RRC
250100
250200      IF W-SIZE = 'R'
250300         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
250400                               AND H-WK-OPER-DSH > .1499
250500                               AND H-WK-OPER-DSH < .1923
250600         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .15)
250700                                 * .65 + .025.
250800      IF W-SIZE = 'R'
250900         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
251000                               AND H-WK-OPER-DSH > .1922
251100                               AND H-WK-OPER-DSH < .3000
251200         MOVE .0525 TO H-OPER-DSH-RRC.
251300
251400      IF W-SIZE = 'R'
251500         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
251600                               AND H-WK-OPER-DSH > .2999
251700         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .30)
251800                                 * .60 + .0525.
251900
252000***********************************************************
252100*****   RURAL HOSPITALS BOTH SCH AND RRC
252200
252300      IF W-SIZE = 'R'
252400         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')
252500                MOVE H-OPER-DSH-RRC TO H-OPER-DSH
252600             IF H-OPER-DSH-SCH > H-OPER-DSH-RRC
252700                MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
252800
252900***********************************************************
253000*** RRC ONLY
253100      IF W-SIZE = 'R'
253200         IF (P-NEW-PROVIDER-TYPE = '07')
253300                MOVE H-OPER-DSH-RRC TO H-OPER-DSH.
253400
253500***********************************************************
253600
253700      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
253800
253900 3900-EXIT.   EXIT.
254000
254100 3900A-CALC-OPER-DSH.
254200
254300***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2004
254400***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2004
254500
254600      MOVE 0.0000 TO H-OPER-DSH.
254700
254800      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
254900                                     + P-NEW-MEDICAID-RATIO).
255000
255100***********************************************************
255200**1**    0-99 BEDS
255300***   NOT TO EXCEED 12%
255400
255500      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
255600                               AND H-WK-OPER-DSH > .1499
255700                               AND H-WK-OPER-DSH < .2020
255800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
255900                                      * .65 + .025
256000        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
256100
256200      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
256300                               AND H-WK-OPER-DSH > .2019
256400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
256500                                      * .825 + .0588
256600        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
256700
256800***********************************************************
256900**2**   100 + BEDS
257000***  NO CAP >> CAN EXCEED 12%
257100
257200      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
257300                               AND H-WK-OPER-DSH > .1499
257400                               AND H-WK-OPER-DSH < .2020
257500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
257600                                      * .65 + .025.
257700
257800      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
257900                               AND H-WK-OPER-DSH > .2019
258000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
258100                                      * .825 + .0588.
258200
258300***********************************************************
258400**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
258500***   NOT TO EXCEED 12%
258600
258700      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
258800                               AND H-WK-OPER-DSH > .1499
258900                               AND H-WK-OPER-DSH < .2020
259000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
259100                                 * .65 + .025
259200        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
259300
259400      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
259500                               AND H-WK-OPER-DSH > .2019
259600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
259700                                 * .825 + .0588
259800        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
259900
260000***********************************************************
260100**4**   OTHER RURAL HOSPITALS 500 BEDS +
260200***  NO CAP >> CAN EXCEED 12%
260300
260400      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
260500                               AND H-WK-OPER-DSH > .1499
260600                               AND H-WK-OPER-DSH < .2020
260700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
260800                                 * .65 + .025.
260900
261000      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
261100                               AND H-WK-OPER-DSH > .2019
261200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
261300                                 * .825 + .0588.
261400
261500***********************************************************
261600**7**   RURAL HOSPITALS SCH
261700***   NOT TO EXCEED 12%
261800
261900      IF W-SIZE = 'R'
262000         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
262100                               AND H-WK-OPER-DSH > .1499
262200                               AND H-WK-OPER-DSH < .2020
262300         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
262400                                 * .65 + .025
262500         IF H-OPER-DSH > .1200
262600                          MOVE .1200 TO H-OPER-DSH.
262700
262800      IF W-SIZE = 'R'
262900         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
263000                               AND H-WK-OPER-DSH > .2019
263100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
263200                                 * .825 + .0588
263300         IF H-OPER-DSH > .1200
263400                          MOVE .1200 TO H-OPER-DSH.
263500***********************************************************
263600**6**   RURAL HOSPITALS RRC    RULE 5 AND 6 SAME
263700***   RRC OVERRIDES SCH CAP
263800***   REMOVED CHECK FOR RURAL ON RRC'S CR3784H1
263900***      MADE THIS CHG ON 03/06/2006
264000***   NO CAP >>  CAN EXCEED 12%
264100
264200***   IF W-SIZE = 'R'
264300         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
264400                                   '17' OR '22')
264500                               AND H-WK-OPER-DSH > .1499
264600                               AND H-WK-OPER-DSH < .2020
264700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
264800                                 * .65 + .025.
264900***   IF W-SIZE = 'R'
265000         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
265100                                   '17' OR '22')
265200                               AND H-WK-OPER-DSH > .2019
265300         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
265400                                 * .825 + .0588.
265500
265600***********************************************************
265700***********************************************************
265800
265900      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
266000
266100 3900A-EXIT.   EXIT.
266200
266300***********************************************************
266400***********************************************************
266500***********************************************************
266600***********************************************************
266700
266800 4000-CALC-TECH-ADDON.
266900
267000***********************************************************
267100***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
267200***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
267300***      CALCULATED FOR ADD ON DONE BEFORE OUTLER
267400***      CALCULATED FOR ADD ON DONE BEFORE SPECIAL DRGS
267500
267600     COMPUTE PPS-OPER-HSP-PART ROUNDED =
267700         H-OPER-HSP-PCT * H-OPER-HSP-PART.
267800
267900     COMPUTE PPS-OPER-FSP-PART ROUNDED =
268000         H-OPER-FSP-PCT * H-OPER-FSP-PART.
268100
268200     MOVE ZERO TO PPS-OPER-DSH-ADJ.
268300
268400     IF  H-OPER-DSH NUMERIC
268500             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
268600              PPS-OPER-FSP-PART
268700              * H-OPER-DSH.
268800
268900     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
269000             PPS-OPER-FSP-PART *
269100             H-OPER-IME-TEACH.
269200
269300     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
269400             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
269500             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
269600
269700***********************************************************
269800***       XIGRIS CASES
269900***********************************************************
270000     IF '0011   ' =  B-PRIN-PROC-CODE   OR
270100                     B-OTHER-PROC-CODE1 OR
270200                     B-OTHER-PROC-CODE2 OR
270300                     B-OTHER-PROC-CODE3 OR
270400                     B-OTHER-PROC-CODE4 OR
270500                     B-OTHER-PROC-CODE5
270600           NEXT SENTENCE
270700     ELSE
270800           MOVE ZEROES TO H-NEW-TECH-ADDON-XIGRIS
270900           GO TO 4000-CHECK-INFUSE-CASES.
271000
271100     MOVE  6800.00 TO H-CSTMED-XIGRIS.
271200
271300     COMPUTE H-LESSER-XIGRIS-1 ROUNDED =
271400             .5 * H-CSTMED-XIGRIS.
271500
271600     COMPUTE H-LESSER-XIGRIS-2 ROUNDED =
271700           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
271800                     H-BASE-DRG-PAYMENT) * .5.
271900
272000     IF H-LESSER-XIGRIS-2 > 0
272100        IF H-LESSER-XIGRIS-1 < H-LESSER-XIGRIS-2
272200           MOVE H-LESSER-XIGRIS-1 TO H-NEW-TECH-ADDON-XIGRIS
272300        ELSE
272400           MOVE H-LESSER-XIGRIS-2 TO H-NEW-TECH-ADDON-XIGRIS
272500     ELSE
272600        MOVE ZEROES          TO H-NEW-TECH-ADDON-XIGRIS.
272700
272800 4000-CHECK-INFUSE-CASES.
272900***********************************************************
273000***       INFUSE CASES
273100***********************************************************
273200     IF B-DRG = 497 OR 498
273300        NEXT SENTENCE
273400     ELSE
273500        MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
273600        GO TO 4000-ADD-TECH-CASES.
273700
273800     IF '8451   ' =  B-PRIN-PROC-CODE   OR
273900                     B-OTHER-PROC-CODE1 OR
274000                     B-OTHER-PROC-CODE2 OR
274100                     B-OTHER-PROC-CODE3 OR
274200                     B-OTHER-PROC-CODE4 OR
274300                     B-OTHER-PROC-CODE5
274400           NEXT SENTENCE
274500     ELSE
274600           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
274700           GO TO 4000-ADD-TECH-CASES.
274800
274900     IF '8452   ' =  B-PRIN-PROC-CODE   OR
275000                     B-OTHER-PROC-CODE1 OR
275100                     B-OTHER-PROC-CODE2 OR
275200                     B-OTHER-PROC-CODE3 OR
275300                     B-OTHER-PROC-CODE4 OR
275400                     B-OTHER-PROC-CODE5
275500           NEXT SENTENCE
275600     ELSE
275700           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
275800           GO TO 4000-ADD-TECH-CASES.
275900
276000     MOVE 8900.00 TO H-CSTMED-INFUSE.
276100
276200     COMPUTE H-LESSER-INFUSE-1 ROUNDED =
276300             .5 * H-CSTMED-INFUSE.
276400
276500     COMPUTE H-LESSER-INFUSE-2 ROUNDED =
276600           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
276700                     H-BASE-DRG-PAYMENT) * .5.
276800
276900     IF H-LESSER-INFUSE-2 > 0
277000        IF H-LESSER-INFUSE-1 < H-LESSER-INFUSE-2
277100           MOVE H-LESSER-INFUSE-1 TO H-NEW-TECH-ADDON-INFUSE
277200        ELSE
277300           MOVE H-LESSER-INFUSE-2 TO H-NEW-TECH-ADDON-INFUSE
277400     ELSE
277500        MOVE ZEROES          TO H-NEW-TECH-ADDON-INFUSE.
277600
277700 4000-ADD-TECH-CASES.
277800
277900     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
278000             H-NEW-TECH-ADDON-XIGRIS + H-NEW-TECH-ADDON-INFUSE.
278100
278200 4000-EXIT.    EXIT.
278300
278400******        L A S T   S O U R C E   S T A T E M E N T   *****
