000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL069.
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     'PPCAL069      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C06.9'.
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  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
003800 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
003900 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
004000 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
004100 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.
004200 01  R1                             PIC S9(04) COMP SYNC.
004300 01  R2                             PIC S9(04) COMP SYNC.
004400 01  R3                             PIC S9(04) COMP SYNC.
004500 01  R4                             PIC S9(04) COMP SYNC.
004600
004700 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).
004800 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).
004900
005000***************************************************************
005100***************************************************************
005200*    4 SETS OF LABOR AND NONLABOR RATES                       *
005300*    LAYUP TABLES AREA FOR FY2006 RATES                       *
005400***************************************************************
005500***************************************************************
005600* TABLE 1                                                     *
005700*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
005800*    (FULL UPDATE (.697)                                      *
005900*    (QUALITY = 1 WAGE INDEX > 1)                             *
006000***************************************************************
006100 01  TB1-RATE-TABLE.
006200     02  TB1-RATE-WORK.
006300*RATE 20051001 REGION  LABOR AND NON-LABOR RATES
006400*                  R3=1     /     R3=2
006500*               LARGE URBAN / OTHER URBAN
006600*               LABOR / NON / LABOR / NON
006700*                     /LABOR/       /LABOR
006800*             --------------------------------------------
006900         05  FILLER PIC X(08) VALUE '20051001'.
007000         05  TB1-NAT    PIC X(30) VALUE
007100            ' 0329784 143363 0329784 143363'.
007200         05  TB1-PR     PIC X(30) VALUE
007300            ' 0140246 085957 0140246 085957'.
007400         05  TB1-NATPR  PIC X(30) VALUE
007500            ' 0329784 143363 0329784 143363'.
007600***************************************************************
007700     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
007800         05  TB1-RATE-PERIOD            OCCURS 1.
007900             10  TB1-RATE-EFF-DATE      PIC X(08).
008000             10  TB1-REG-NAT            OCCURS 3.
008100                 15  TB1-LARGE-OTHER    OCCURS 2.
008200                     20  FILLER         PIC X(01).
008300                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
008400                     20  FILLER         PIC X(01).
008500                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
008600
008700***************************************************************
008800***************************************************************
008900* TABLE 2                                                     *
009000*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
009100*    (REDUCED UPDATE (.697)                                   *
009200*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *
009300***************************************************************
009400 01  TB2-RATE-TABLE.
009500     02  TB2-RATE-WORK.
009600*RATE 20051001 REGION  LABOR AND NON-LABOR RATES
009700*                  R3=1     /     R3=2
009800*               LARGE URBAN / OTHER URBAN
009900*               LABOR / NON / LABOR / NON
010000*                     /LABOR/       /LABOR
010100*             --------------------------------------------
010200         05  FILLER PIC X(08) VALUE '20051001'.
010300         05  TB2-NAT    PIC X(30) VALUE
010400            ' 0328512 142810 0328512 142810'.
010500         05  TB2-PR     PIC X(30) VALUE
010600            ' 0139705 085626 0139795 085626'.
010700         05  TB2-NATPR  PIC X(30) VALUE
010800            ' 0328512 142810 0328512 142810'.
010900***************************************************************
011000     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
011100         05  TB2-RATE-PERIOD             OCCURS 1.
011200             10  TB2-RATE-EFF-DATE       PIC X(08).
011300             10  TB2-REG-NAT             OCCURS 3.
011400                 15  TB2-LARGE-OTHER     OCCURS 2.
011500                     20  FILLER          PIC X(01).
011600                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
011700                     20  FILLER          PIC X(01).
011800                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
011900***************************************************************
012000***************************************************************
012100* TABLE 3                                                     *
012200*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
012300*    (FULL UPDATE (.62%)                                      *
012400*    (QUALITY = 1 WAGE INDEX <= 1)                            *
012500***************************************************************
012600 01  TB3-RATE-TABLE.
012700     02  TB3-RATE-WORK.
012800*RATE 20051001 REGION  LABOR AND NON-LABOR RATES
012900*                  R3=1     /     R3=2
013000*               LARGE URBAN / OTHER URBAN
013100*               LABOR / NON / LABOR / NON
013200*                     /LABOR/       /LABOR
013300*             --------------------------------------------
013400         05  FILLER PIC X(08) VALUE '20051001'.
013500         05  TB3-NAT    PIC X(30) VALUE
013600            ' 0293352 179795 0293352 179795'.
013700         05  TB3-PR     PIC X(30) VALUE
013800            ' 0132781 093422 0132781 093422'.
013900         05  TB3-NATPR  PIC X(30) VALUE
014000            ' 0293352 179795 0293352 179795'.
014100***************************************************************
014200     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
014300         05  TB3-RATE-PERIOD            OCCURS 1.
014400             10  TB3-RATE-EFF-DATE      PIC X(08).
014500             10  TB3-REG-NAT            OCCURS 3.
014600                 15  TB3-LARGE-OTHER    OCCURS 2.
014700                     20  FILLER         PIC X(01).
014800                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
014900                     20  FILLER         PIC X(01).
015000                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
015100
015200***************************************************************
015300***************************************************************
015400* TABLE 4                                                     *
015500*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
015600*    (REDUCED UPDATE (.62%)                                   *
015700*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *
015800***************************************************************
015900 01  TB4-RATE-TABLE.
016000     02  TB4-RATE-WORK.
016100*RATE 20051001 REGION  LABOR AND NON-LABOR RATES
016200*                  R3=1     /     R3=2
016300*               LARGE URBAN / OTHER URBAN
016400*               LABOR / NON / LABOR / NON
016500*                     /LABOR/       /LABOR
016600*             --------------------------------------------
016700         05  FILLER PIC X(08) VALUE '20051001'.
016800         05  TB4-NAT    PIC X(30) VALUE
016900            ' 0292220 179102 0292220 179102'.
017000         05  TB4-PR     PIC X(30) VALUE
017100            ' 0132269 093062 0132269 093062'.
017200         05  TB4-NATPR  PIC X(30) VALUE
017300            ' 0292220 179102 0292220 179102'.
017400***************************************************************
017500     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
017600         05  TB4-RATE-PERIOD             OCCURS 1.
017700             10  TB4-RATE-EFF-DATE       PIC X(08).
017800             10  TB4-REG-NAT             OCCURS 3.
017900                 15  TB4-LARGE-OTHER     OCCURS 2.
018000                     20  FILLER          PIC X(01).
018100                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
018200                     20  FILLER          PIC X(01).
018300                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
018400***************************************************************
018500***************************************************************
018600***************************************************************
018700***************************************************************
018800
018900***************************************************************
019000*    LAYUP TABLE AREA FOR FY2006 DRGS                         *
019100***************************************************************
019200 01  DRG-TABLE.
019300     05  D-TAB.
019400        10  FILLER                PIC X(08) VALUE
019500        '20051001'.
019600      10  FILLER                  PIC X(56) VALUE
019700     '03434707600101019587035000460198601270012700000000000000'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '00000000000000007878022000300269780670009701563502000030'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '01404504500064012222046000620087360290003800899804300055'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '00857504000050012456045000580094210370004601335105000065'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '00722902500032009903041000530070770270003502786508000104'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '01445104900063011304040000520077120300003900997003600048'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '00618002500031018191034000630135310320005201335304400059'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '00721202600034003359020000200095670300004000619401900024'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '00210901600016010062037000480062410240003000728801300016'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '01185802700042006975025000350071080170002400962703000041'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00341901600016007852020000280061410240003100687403900048'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00747402500031007524032000420052030230002900301202900029'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '01636103100044008690015000180088090190002800834801500019'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '01326902400039004882032000320095970200003100871101800026'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '01042802300036002772015000150080820180002600211001500015'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '01286703300054002989013000130139830300004501166304100061'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '00599102300028005958024000310077250290003700661103200040'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '00485002500030004210021000230075240320004000744902600034'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '00852703300044003398021000210307320760009902883008400111'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '01185703300047012427054000640162380670008500894704400055'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '01538306100061013936051000680098280420005300579902600032'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '01240504800063006974028000360136540490006400877804000049'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '01032004700057006104032000380081240340004401185304800061'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00715003100039011354046000620060350290003600730303600044'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '00536402800034005560037000370070940240003100538201700021'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '00873303300043005402020000251856172370037708220112700149'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '06019208400102070346095001120000001350013505878908600110'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '00000012100121038417057000840248400260003400000000000000'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '03168210800137017354067000890000001580015800000009300093'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '01322302600042016380021000300134560330005502385305900092'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '01613605300066009847028000350154070290004801442503300044'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '01094802100027027440094001200103450410005200694904400052'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '01040401700026009425044000550055660320003900627302200028'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '00533701800022006068024000310089170320004300621402200028'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '00828803300033008287030000390052270200002400511602000024'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '00752102700035005852020000250056590170002101276104100058'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '00583502100026026621086001000147810520005803447910000123'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '01432405400060028061089001100126410400005101878306700080'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '01082104500050040399099001330128890310004100853506000060'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '01335604100058006657021000260140810380005100843102200027'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '01193103100044006785017000210067230220002902247606600080'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '01186803600042014521033000450089290190002201266203300049'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '00729701800023029612078001100119050310004101412505100070'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '00744302700036010060038000470056460240002901124604100052'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '00916603600044007013026000310109110450005900978404200054'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '00561402800033008413034000440058480230002900566302500033'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '00870203200045003253029000290083630310004201129004200056'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '00606402400031006179031000440396800900012901679304300057'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '03281809900121015748056000670305300880010601603104900057'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '02542507500092011604037000430240730680009502786806500098'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '03733909900137013318047000620135520490006501124904200056'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '01205904400060007292030000390117460410005300689502300029'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '00000017100171019059061000690126900440004701287702400029'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '02042807200097000000000000000000000000000001913103300058'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '03059609300132016648044000560104430260003100591305300053'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00000000000000000000000000000111640230003200818501600019'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '01225103700052015884045000650083110210002601145902800041'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00697601900025013174037000560000000000000000970201800028'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '01918404600068012219020000280077680380004800740703800046'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '00609003000037014401067000870107670500006201405105000067'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '00662903000037011504051000670076580360004500720003600045'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '00458302500031005932028000360057950260003300855403800048'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '00709502700039006974032000390047490230002800256701800018'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '00774703800046004588026000310029900290002900850903900051'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '00896702000026007138015000170096710180002800703201200014'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '00973201600022009766033000480211300860011401063505000065'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '01659304400068008637023000320089620280004201132602400035'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '01835206200086008313027000390101950560007100986004500059'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '00553902900037011294047000630053400240003300689203500045'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '00867604600056005391034000410078220420004200731303200041'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '00491302300029002600022000220074230350004600456302400030'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '02183108200105019390040000550194700780010402038403200041'.
034000       10  FILLER                  PIC X(56) VALUE
034100     '00931501700026008891016000210108770160002802639507300103'.
034200       10  FILLER                  PIC X(56) VALUE
034300     '01347203200045007652033000430072670280003700818703700048'.
034400       10  FILLER                  PIC X(56) VALUE
034500     '00487902500031005486025000390103290370005201092204600060'.
034600       10  FILLER                  PIC X(56) VALUE
034700     '00611802700034031679070000820221830580007402376106100086'.
034800       10  FILLER                  PIC X(56) VALUE
034900     '01159502600032012700036000550062020170002101634903900061'.
035000       10  FILLER                  PIC X(56) VALUE
035100     '00908501600020011898030000450064320150001901115903200048'.
035200       10  FILLER                  PIC X(56) VALUE
035300     '00678301700022005012023000230208230360006801269204900064'.
035400       10  FILLER                  PIC X(56) VALUE
035500     '00794202400035011539042000580063850210002800865804200052'.
035600       10  FILLER                  PIC X(56) VALUE
035700     '00565203000036005498029000340082140230003100505001600019'.
035800       10  FILLER                  PIC X(56) VALUE
035900     '00643602900037004391021000260037480310003100707902600035'.
036000       10  FILLER                  PIC X(56) VALUE
036100     '00470101500018003227016000160106190410005500616002400031'.
036200       10  FILLER                  PIC X(56) VALUE
036300     '00966903500053014368035000430110040240002700842502500033'.
036400       10  FILLER                  PIC X(56) VALUE
036500     '00574701700019013772039000620118660320005100286802400024'.
036600       10  FILLER                  PIC X(56) VALUE
036700     '01262201900032008737025000340015590170001701247501700027'.
036800       10  FILLER                  PIC X(56) VALUE
036900     '01147203100048010441042000570061040220003100718803200041'.
037000       10  FILLER                  PIC X(56) VALUE
037100     '00421001900024007289035000450023920130001300736002900040'.
037200       10  FILLER                  PIC X(56) VALUE
037300     '01850404700063015135046000570088240280003100742801700019'.
037400       10  FILLER                  PIC X(56) VALUE
037500     '02223706500081011448032000400079480220002400858202000026'.
037600       10  FILLER                  PIC X(56) VALUE
037700     '01084702200030003057014000140097280270003800870903000042'.
037800       10  FILLER                  PIC X(56) VALUE
037900     '02040805300077012348048000660057280230003001168405200067'.
038000       10  FILLER                  PIC X(56) VALUE
038100     '00631002400033008974041000520060660310003400502702500032'.
038200       10  FILLER                  PIC X(56) VALUE
038300     '00355602000022006712025000280058370440004400524202600034'.
038400       10  FILLER                  PIC X(56) VALUE
038500     '01699602900045007472019000230035780200002800392501600021'.
038600       10  FILLER                  PIC X(56) VALUE
038700     '00603401600022002070013000140050530260003700322501800026'.
038800       10  FILLER                  PIC X(56) VALUE
038900     '01393001800018045935179001790313721330013301892908600086'.
039000       10  FILLER                  PIC X(56) VALUE
039100     '03222604700047011406034000340015440310003103045906500092'.
039200       10  FILLER                  PIC X(56) VALUE
039300     '01364509100091019109045000740083280320004300832302600043'.
039400       10  FILLER                  PIC X(56) VALUE
039500     '01298603700051012082044000570066740270003300000000000000'.
039600       10  FILLER                  PIC X(56) VALUE
039700     '02967808000113011810028000410184320580008100926503000042'.
039800       10  FILLER                  PIC X(56) VALUE
039900     '01934604900049027897070000990122890300003802246004800082'.
040000       10  FILLER                  PIC X(56) VALUE
040100     '01207404300058011069030000380036350250003300845101800028'.
040200       10  FILLER                  PIC X(56) VALUE
040300     '01304805000068007788030000400398901100014801677405600075'.
040400       10  FILLER                  PIC X(56) VALUE
040500     '01168903200041010716048000620084530340004400607702700034'.
040600       10  FILLER                  PIC X(56) VALUE
040700     '00766403100041006171026000370191960600008402277307300124'.
040800       10  FILLER                  PIC X(56) VALUE
040900     '00619102600035004656030000410051350320004700698104600073'.
041000       10  FILLER                  PIC X(56) VALUE
041100     '00791904300056006483058000790051780400005900628202900043'.
041200       10  FILLER                  PIC X(56) VALUE
041300     '00277602200030000000000000000000000000000000000000000000'.
041400       10  FILLER                  PIC X(56) VALUE
041500     '00000000000000000000000000000193980540008901945705900092'.
041600       10  FILLER                  PIC X(56) VALUE
041700     '00938202300034025660060000890099430260003400755603200041'.
041800       10  FILLER                  PIC X(56) VALUE
041900     '00503302200028002999024000240055690190002600098702900029'.
042000       10  FILLER                  PIC X(56) VALUE
042100     '00852902600037004282016000200026630210002101046203500049'.
042200       10  FILLER                  PIC X(56) VALUE
042300     '00528502200028008141029000410047250170002200000000000000'.
042400       10  FILLER                  PIC X(56) VALUE
042500     '00000000000000000000000000000000000000000000000000000000'.
042600       10  FILLER                  PIC X(56) VALUE
042700     '01397403000051008700089001080069600310003900505502400029'.
042800       10  FILLER                  PIC X(56) VALUE
042900     '00622402400038007806028000530048030200002704003109700132'.
043000       10  FILLER                  PIC X(56) VALUE
043100     '00000000000000000000000000000313910450005100000000000000'.
043200       10  FILLER                  PIC X(56) VALUE
043300     '03423107400127000000000000000360910810011302182207400105'.
043400       10  FILLER                  PIC X(56) VALUE
043500     '02060705800087000000000000000144340210002808969313700180'.
043600       10  FILLER                  PIC X(56) VALUE
043700     '06232118200217033387096001210000000000000005143809300128'.
043800       10  FILLER                  PIC X(56) VALUE
043900     '03495208400102047323085001250194590530007304435311800164'.
044000       10  FILLER                  PIC X(56) VALUE
044100     '01805805900084010639038000540167800260003103592608800137'.
044200       10  FILLER                  PIC X(56) VALUE
044300     '01833304500061010285021000270857361400017306093206400088'.
044400       10  FILLER                  PIC X(56) VALUE
044500     '03622405000059027791034000380138310310004300904601800022'.
044600       10  FILLER                  PIC X(56) VALUE
044700     '02646208500104014462049000590120380290003811801821700273'.
044800       10  FILLER                  PIC X(56) VALUE
044900     '02295302400046040939112001590173690580008501276705100074'.
045000       10  FILLER                  PIC X(56) VALUE
045100     '00821703600052011817044000640074240260004105366010700128'.
045200       10  FILLER                  PIC X(56) VALUE
045300     '05966908900099000000000000000552050260004300000000000000'.
045400       10  FILLER                  PIC X(56) VALUE
045500     '00000000000000016544018000250246950300004801678801600020'.
045600       10  FILLER                  PIC X(56) VALUE
045700     '00693904200056004794077000960037930320003900728802600032'.
045800       10  FILLER                  PIC X(56) VALUE
045900     '11428207200136000000000000000000000000000007050513800172'.
046000       10  FILLER                  PIC X(56) VALUE
046100     '02316005300083012041024000310312790650009601419502800037'.
046200       10  FILLER                  PIC X(56) VALUE
046300     '01576702400038010201015000180797380790010306914405900076'.
046400       10  FILLER                  PIC X(56) VALUE
046500     '01836004800069009833021000280327820700010801194002600036'.
046600       10  FILLER                  PIC X(56) VALUE
046700     '19803838100457128719291003510441840850012301964304100045'.
046800       10  FILLER                  PIC X(56) VALUE
046900     '02482704500052050739071000880619481080012304719808200090'.
047000       10  FILLER                  PIC X(56) VALUE
047100     '05098008700103036151062000690310070440006402099602500035'.
047200       10  FILLER                  PIC X(56) VALUE
047300     '03095706600097020721040000590243150340004701913201600021'.
047400       10  FILLER                  PIC X(56) VALUE
047500     '02871703000041022108015000190224730580007200000000000000'.
047600     05  DRGX-TAB REDEFINES D-TAB.
047700         10  DRGX-PERIOD               OCCURS 1
047800                                        INDEXED BY DX5.
047900             15  DRGX-EFF-DATE         PIC X(08).
048000             15  DRG-DATA              OCCURS 560
048100                                        INDEXED BY DX6.
048200                 20  DRG-WT            PIC 9(02)V9(04).
048300                 20  DRG-ALOS          PIC 9(02)V9(01).
048400                 20  DRG-DAYS-TRIM     PIC 9(02).
048500                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
048600
048700 01  HOLD-AREA.
048800     02  HOLD-PPS-COMPONENTS.
048900         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
049000         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
049100
049200         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
049300         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
049400
049500         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
049600         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
049700         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
049800
049900         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
050000         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
050100         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
050200
050300         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
050400         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
050500
050600         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
050700         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
050800
050900         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
051000         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
051100
051200         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
051300         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
051400         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
051500         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
051600         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
051700         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
051800         05  H-CAPI-COLA                  PIC 9(01)V9(03).
051900         05  H-CAPI-SCH                   PIC 9(05)V9(02).
052000         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
052100         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
052200         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
052300         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
052400         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
052500         05  H-CAPI-GAF                   PIC 9(05)V9(04).
052600         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
052700         05  H-BLEND-GAF                  PIC 9(05)V9(04).
052800         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
052900         05  H-COV-DAYS                   PIC 9(3).
053000         05  H-PERDIEM-DAYS               PIC 9(3).
053100         05  H-REG-DAYS                   PIC 9(3).
053200         05  H-LTR-DAYS                   PIC 9(3).
053300         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
053400         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
053500         05  H-ALOS                       PIC 9(02)V9(01).
053600         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
053700         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
053800         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
053900         05  H-CST-THRESH                 PIC 9(05)V9(02).
054000         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
054100         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
054200         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
054300         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
054400         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
054500         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
054600         05  H-BUDG-NUTR06                PIC 9(01)V9(06).
054700         05  H-UPDATE-01                  PIC 9(01)V9(04).
054800         05  H-UPDATE-02                  PIC 9(01)V9(04).
054900         05  H-UPDATE-03                  PIC 9(01)V9(04).
055000         05  H-UPDATE-04                  PIC 9(01)V9(04).
055100         05  H-UPDATE-05                  PIC 9(01)V9(04).
055200         05  H-UPDATE-06                  PIC 9(01)V9(04).
055300         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
055400         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
055500         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
055600         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
055700         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
055800         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
055900         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
056000         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
056100         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
056200         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
056300         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
056400         05  H-LABOR-PCT                  PIC 9(01)V9(04).
056500         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
056600         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
056700         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
056800         05  H-HSP-RATE                   PIC 9(06)V9(09).
056900         05  H-FSP-RATE                   PIC 9(06)V9(09).
057000         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
057100         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
057200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
057300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
057400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
057500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
057600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
057700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
057800         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
057900         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
058000         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
058100         05  H-NEW-TECH-ADDON-KINETRA     PIC S9(07)V99.
058200
058300         05  H-LESSER-NEURO-1             PIC S9(07)V99.
058400         05  H-LESSER-NEURO-2             PIC S9(07)V99.
058500
058600         05  H-LESSER-GRAFT-1             PIC S9(07)V99.
058700         05  H-LESSER-GRAFT-2             PIC S9(07)V99.
058800
058900         05  H-LESSER-KINETRA-1           PIC S9(07)V99.
059000         05  H-LESSER-KINETRA-2           PIC S9(07)V99.
059100
059200
059300         05  H-CSTMED-NEURO               PIC S9(07)V99.
059400         05  H-CSTMED-GRAFT               PIC S9(07)V99.
059500         05  H-CSTMED-KINETRA             PIC S9(07)V99.
059600
059700
059800     02  HOLD-ADDITIONAL-VARIABLES.
059900         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
060000         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
060100         05  H-NAT-PCT                    PIC 9(01)V9(02).
060200         05  H-REG-PCT                    PIC 9(01)V9(02).
060300         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
060400         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
060500         05  H-DRG-WT                     PIC 9(02)V9(04).
060600         05  H-NAT-LABOR                  PIC 9(05)V9(02).
060700         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
060800         05  H-REG-LABOR                  PIC 9(05)V9(02).
060900         05  H-REG-NONLABOR               PIC 9(05)V9(02).
061000         05  H-OPER-COLA                  PIC 9(01)V9(03).
061100         05  H-INTERN-RATIO               PIC 9(01)V9(04).
061200         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
061300         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
061400         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
061500
061600     02  HOLD-CAPITAL-VARIABLES.
061700         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
061800         05  H-CAPI-HSP                   PIC 9(07)V9(02).
061900         05  H-CAPI-FSP                   PIC 9(07)V9(02).
062000         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
062100         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
062200         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
062300         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
062400         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
062500
062600     02  HOLD-CAPITAL2-VARIABLES.
062700         05  H-CAPI2-PAY-CODE             PIC X(1).
062800         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
062900         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
063000
063100     02  HOLD-OTHER-VARIABLES.
063200         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
063300         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
063400         05  H-LOW-VOL-PAYMENT              PIC 9(07)V9(02).
063500         05  H-HVBP-HRR-DATA.
063600             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
063700             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
063800             10  H-HOSP-READMISS-REDUCTN      PIC X.
063900             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
064000         05  H-OPERATNG-DATA.
064100             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
064200             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
064300             10  H-OPER-HSP-AMT              PIC 9(08)V99.
064400
064500     02  HOLD-PC-OTH-VARIABLES.
064600         05  H-OPER-DSH                   PIC 9(01)V9(04).
064700         05  H-CAPI-DSH                   PIC 9(01)V9(04).
064800         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
064900         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
065000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
065100         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
065200         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
065300         05  H-PC-HMO-FLAG                PIC X(01).
065400         05  H-PC-COT-FLAG                PIC X(01).
065500         05  H-FILLER                        PIC X(0998).
065600
065700 01  HLD-PPS-DATA.
065800         10  HLD-PPS-RTC                PIC 9(02).
065900         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
066000         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
066100         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
066200         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
066300         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
066400         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
066500         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
066600         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
066700         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
066800         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
066900         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
067000         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
067100         10  HLD-PPS-CALC-VERS          PIC X(05).
067200
067300 LINKAGE SECTION.
067400***************************************************************
067500*                 * * * * * * * * *                           *
067600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
067700*    IN HOW TO PAY THE BILL.                                  *
067800*                         *****                               *
067900*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
068000*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
068100*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
068200*                 OUTLIER COMPUTATION.                        *
068300*                         *****                               *
068400*         REVIEW-CODE:                                        *
068500*            00 = PAY-WITH-OUTLIER.                           *
068600*                 WILL CALCULATE THE STANDARD PAYMENT.        *
068700*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
068800*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
068900*            03 = PAY-PERDIEM-DAYS.                           *
069000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
069100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
069200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
069300*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
069400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
069500*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
069600*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
069700*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
069800*                 BILL EXCEED THE COST THRESHOLD.             *
069900*            06 = PAY-XFER-NO-COST                            *
070000*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
070100*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
070200*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
070300*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
070400*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
070500*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
070600*                 CALCULATE ANY COST OUTLIER PORTION          *
070700*                 OF THE PAYMENT.                             *
070800*            07 = PAY-WITHOUT-COST.                           *
070900*                 WILL CALCULATE THE STANDARD PAYMENT         *
071000*                 WITHOUT COST PORTION.                       *
071100*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
071200*                 50-50> 7   8   210 211 233 234 471 497
071300*                        498 544 545 549 550
071400*         FULL PERDIEM > 1    2    10   11   12   13   14
071500*                        15   16   17   18   19   20   24   25
071600*                        28   29   34   35   73   75   76   77
071700*                        78   79   80   82   83   84   85   86
071800*                        89   90   92   93   101  102  104  105
071900*                             108       113  114  120  121
072000*                        126  127  130  131  144  145  146
072100*                        147  148  149  150  151  154  155
072200*                        157  158  170  171  172  173  176
072300*                        180  181  188  189  191  192  197
072400*                        198  205  206  213  216
072500*                        217  218  219  225  226  227
072600*                        235  236  238  239  240  241
072700*                        244  245  250  251  253  254  256
072800*                        263  264  265  266  269  270  271
072900*                        272  273  277  278  280  281  283
073000*                        284  285  287  292  293  294  296
073100*                        297  300  301  304  305  316  320
073200*                        321  331  332  395  401  402  403
073300*                        404  415  416  418  423  429  430
073400*                        440  442  443  444  445  462  463
073500*                        464  468  475  477       482
073600*                        485  487  501  502  521
073700*                        522  529  530  531  532  537  538
073800*                        541  542  543  547  548
073900*                        553  554
074000*                               POST-ACUTE TRANSFERS          *
074100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
074200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
074300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
074400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
074500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
074600*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
074700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
074800*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
074900*                 BILL EXCEED THE COST THRESHOLD.             *
075000*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
075100*                 POST-ACUTE TRANSFERS                        *
075200*                 50-50> 7   8   210 211 233 234 471 497
075300*                        498 544 545 549 550
075400*         FULL PERDIEM > 1    2    10   11   12   13   14
075500*                        15   16   17   18   19   20   24   25
075600*                        28   29   34   35   73   75   76   77
075700*                        78   79   80   82   83   84   85   86
075800*                        89   90   92   93   101  102  104  105
075900*                             108       113  114  120  121
076000*                        126  127  130  131  144  145  146
076100*                        147  148  149  150  151  154  155
076200*                        157  158  170  171  172  173  176
076300*                        180  181  188  189  191  192  197
076400*                        198  205  206  213  216
076500*                        217  218  219  225  226  227
076600*                        235  236  238  239  240  241
076700*                        244  245  250  251  253  254  256
076800*                        263  264  265  266  269  270  271
076900*                        272  273  277  278  280  281  283
077000*                        284  285  287  292  293  294  296
077100*                        297  300  301  304  305  316  320
077200*                        321  331  332  395  401  402  403
077300*                        404  415  416  418  423  429  430
077400*                        440  442  443  444  445  462  463
077500*                        464  468  475  477       482
077600*                        485  487  501  502  521
077700*                        522  529  530  531  532  537  538
077800*                        541  542  543  547  548
077900*                        553  554
078000*                               POST-ACUTE TRANSFERS          *
078100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
078200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
078300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
078400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
078500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
078600*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
078700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
078800*                 PAYMENT.                                    *
078900***************************************************************
079000
079100**************************************************************
079200*      MILLINNIUM COMPATIBLE                                 *
079300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
079400*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
079500*      IN THE NEW FORMAT                                     *
079600**************************************************************
079700 01  BILL-NEW-DATA.
079800         10  B-NPI10.
079900             15  B-NPI8             PIC X(08).
080000             15  B-NPI-FILLER       PIC X(02).
080100         10  B-PROVIDER-NO          PIC X(06).
080200         10  B-REVIEW-CODE          PIC 9(02).
080300             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
080400             88  PAY-WITH-OUTLIER     VALUE 00 07.
080500             88  PAY-PERDIEM-DAYS     VALUE 03.
080600             88  PAY-XFER-NO-COST     VALUE 06.
080700             88  PAY-WITHOUT-COST     VALUE 07.
080800             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
080900             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
081000         10  B-DRG                  PIC 9(03).
081100             88  B-DRG-POSTACUTE-50-50
081200                   VALUE   7   8 210 211 233 234 471 497
081300                         498 544 545 549 550.
081400             88  B-DRG-POSTACUTE-PERDIEM
081500                   VALUE 1    2    10   11   12   13   14
081600                         15   16   17   18   19   20   24   25
081700                         28   29   34   35   73   75   76   77
081800                         78   79   80   82   83   84   85   86
081900                         89   90   92   93   101  102  104  105
082000                              108       113  114  120  121
082100                         126  127  130  131  144  145  146
082200                         147  148  149  150  151  154  155
082300                         157  158  170  171  172  173  176
082400                         180  181  188  189  191  192  197
082500                         198  205  206  213  216
082600                         217  218  219  225  226  227
082700                         235  236  238  239  240  241
082800                         244  245  250  251  253  254  256
082900                         263  264  265  266  269  270  271
083000                         272  273  277  278  280  281  283
083100                         284  285  287  292  293  294  296
083200                         297  300  301  304  305  316  320
083300                         321  331  332  395  401  402  403
083400                         404  415  416  418  423  429  430
083500                         440  442  443  444  445  462  463
083600                         464  468  475  477       482
083700                         485  487  501  502  521
083800                         522  529  530  531  532  537  538
083900                         541  542  543  547  548
084000                         553  554.
084100         10  B-LOS                  PIC 9(03).
084200         10  B-COVERED-DAYS         PIC 9(03).
084300         10  B-LTR-DAYS             PIC 9(02).
084400         10  B-DISCHARGE-DATE.
084500             15  B-DISCHG-CC        PIC 9(02).
084600             15  B-DISCHG-YY        PIC 9(02).
084700             15  B-DISCHG-MM        PIC 9(02).
084800             15  B-DISCHG-DD        PIC 9(02).
084900         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
085000         10  B-PRIN-PROC-CODE       PIC X(07).
085100         10  B-OTHER-PROC-CODE1     PIC X(07).
085200         10  B-OTHER-PROC-CODE2     PIC X(07).
085300         10  B-OTHER-PROC-CODE3     PIC X(07).
085400         10  B-OTHER-PROC-CODE4     PIC X(07).
085500         10  B-OTHER-PROC-CODE5     PIC X(07).
085600         10  B-OTHER-PROC-CODE6     PIC X(07).
085700         10  B-OTHER-PROC-CODE7     PIC X(07).
085800         10  B-OTHER-PROC-CODE8     PIC X(07).
085900         10  B-OTHER-PROC-CODE9     PIC X(07).
086000         10  B-OTHER-PROC-CODE10    PIC X(07).
086100         10  B-OTHER-PROC-CODE11    PIC X(07).
086200         10  B-OTHER-PROC-CODE12    PIC X(07).
086300         10  B-OTHER-PROC-CODE13    PIC X(07).
086400         10  B-OTHER-PROC-CODE14    PIC X(07).
086500         10  B-OTHER-PROC-CODE15    PIC X(07).
086600         10  B-OTHER-PROC-CODE16    PIC X(07).
086700         10  B-OTHER-PROC-CODE17    PIC X(07).
086800         10  B-OTHER-PROC-CODE18    PIC X(07).
086900         10  B-OTHER-PROC-CODE19    PIC X(07).
087000         10  B-OTHER-PROC-CODE20    PIC X(07).
087100         10  B-OTHER-PROC-CODE21    PIC X(07).
087200         10  B-OTHER-PROC-CODE22    PIC X(07).
087300         10  B-OTHER-PROC-CODE23    PIC X(07).
087400         10  B-OTHER-PROC-CODE24    PIC X(07).
087500         10  B-OTHER-DIAG-CODE1     PIC X(07).
087600         10  B-OTHER-DIAG-CODE2     PIC X(07).
087700         10  B-OTHER-DIAG-CODE3     PIC X(07).
087800         10  B-OTHER-DIAG-CODE4     PIC X(07).
087900         10  B-OTHER-DIAG-CODE5     PIC X(07).
088000         10  B-OTHER-DIAG-CODE6     PIC X(07).
088100         10  B-OTHER-DIAG-CODE7     PIC X(07).
088200         10  B-OTHER-DIAG-CODE8     PIC X(07).
088300         10  B-OTHER-DIAG-CODE9     PIC X(07).
088400         10  B-OTHER-DIAG-CODE10    PIC X(07).
088500         10  B-OTHER-DIAG-CODE11    PIC X(07).
088600         10  B-OTHER-DIAG-CODE12    PIC X(07).
088700         10  B-OTHER-DIAG-CODE13    PIC X(07).
088800         10  B-OTHER-DIAG-CODE14    PIC X(07).
088900         10  B-OTHER-DIAG-CODE15    PIC X(07).
089000         10  B-OTHER-DIAG-CODE16    PIC X(07).
089100         10  B-OTHER-DIAG-CODE17    PIC X(07).
089200         10  B-OTHER-DIAG-CODE18    PIC X(07).
089300         10  B-OTHER-DIAG-CODE19    PIC X(07).
089400         10  B-OTHER-DIAG-CODE20    PIC X(07).
089500         10  B-OTHER-DIAG-CODE21    PIC X(07).
089600         10  B-OTHER-DIAG-CODE22    PIC X(07).
089700         10  B-OTHER-DIAG-CODE23    PIC X(07).
089800         10  B-OTHER-DIAG-CODE24    PIC X(07).
089900         10  B-OTHER-DIAG-CODE25    PIC X(07).
090000         10  BILL-DEMO-DATA.
090100             15  BILL-DEMO-CODE1        PIC X(02).
090200             15  BILL-DEMO-CODE2        PIC X(02).
090300             15  BILL-DEMO-CODE3        PIC X(02).
090400             15  BILL-DEMO-CODE4        PIC X(02).
090500         10  BILL-NDC-DATA.
090600             15  BILL-NDC-NUMBER        PIC X(11).
090700         10  FILLER                     PIC X(73).
090800
090900
091000
091100***************************************************************
091200*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
091300*    AND PASSED BACK TO THE CALLING PROGRAM                   *
091400*            RETURN CODE VALUES (PPS-RTC)                     *
091500*                                                             *
091600*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
091700*                                                             *
091800*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
091900*                                                             *
092000*           30,00 = PAID NORMAL DRG PAYMENT                   *
092100*                                                             *
092200*              01 = PAID AS A DAY-OUTLIER.                    *
092300*                   NOTE:                                     *
092400*                     DAY-OUTLIER NO LONGER BEING PAID        *
092500*                         AS OF 10/01/97                      *
092600*                                                             *
092700*              02 = PAID AS A COST-OUTLIER.                   *
092800*                                                             *
092900*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
093000*                   AND INCLUDING THE FULL DRG.               *
093100*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
093200*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
093300*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
093400*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
093500*                   AND INCLUDING THE FULL DRG. PROVIDER      *
093600*                   REFUSED COST OUTLIER.                     *
093700*           40,10 = POST-ACUTE TRANSFER                       *
093800*                   DRG =  7   8 210 211 233 234 471 497
093900*                        498 544 545 549 550
094000*           42,12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *
094100*                       THE FOLLOWING DRG'S                   *
094200*                   DRG =1    2    10   11   12   13   14
094300*                        15   16   17   18   19   20   24   25
094400*                        28   29   34   35   73   75   76   77
094500*                        78   79   80   82   83   84   85   86
094600*                        89   90   92   93   101  102  104  105
094700*                             108       113  114  120  121
094800*                        126  127  130  131  144  145  146
094900*                        147  148  149  150  151  154  155
095000*                        157  158  170  171  172  173  176
095100*                        180  181  188  189  191  192  197
095200*                        198  205  206  213  216
095300*                        217  218  219  225  226  227
095400*                        235  236  238  239  240  241
095500*                        244  245  250  251  253  254  256
095600*                        263  264  265  266  269  270  271
095700*                        272  273  277  278  280  281  283
095800*                        284  285  287  292  293  294  296
095900*                        297  300  301  304  305  316  320
096000*                        321  331  332  395  401  402  403
096100*                        404  415  416  418  423  429  430
096200*                        440  442  443  444  445  462  463
096300*                        464  468  475  477       482
096400*                        485  487  501  502  521
096500*                        522  529  530  531  532  537  538
096600*                        541  542  543  547  548
096700*                        553  554.
096800*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
096900*                    PERDIEM DAYS = OR > GM  ALOS             *
097000*              16 = PAID AS A COST-OUTLIER WITH               *
097100*                    PERDIEM DAYS = OR > GM  ALOS             *
097200*                                                             *
097300*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
097400*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
097500*              52 = INVALID CBSA# IN PROVIDER FILE            *
097600*                   OR INVALID WAGE INDEX                     *
097700*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
097800*              54 = DRG < 001 OR > 559,                       *
097900*                                 OR = 004 OR = 005           *
098000*                                 OR = 107 OR = 109           *
098100*                                 OR = 112 OR = 115
098200*                                 OR = 116 OR = 209
098300*                                 OR = 214 OR = 215
098400*                                 OR = 221 OR = 222
098500*                                 OR = 231 OR = 400
098600*                                 OR = 434 OR = 435
098700*                                 OR = 436 OR = 437
098800*                                 OR = 438 OR = 456
098900*                                 OR = 457 OR = 458
099000*                                 OR = 459 OR = 460
099100*                                 OR = 469 OR = 470
099200*                                 OR = 472 OR = 474
099300*                                 OR = 478 OR = 483
099400*                                 OR = 514 OR = 516
099500*                                 OR = 517 OR = 526
099600*                                 OR = 527
099700*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
099800*                                      OR                     *
099900*                   DISCHARGE DATE < CBSA EFF START DATE      *
100000*                   FOR PPS                                   *
100100*                                      OR                     *
100200*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
100300*                   DISCHARGE DATE                            *
100400*              56 = INVALID LENGTH OF STAY                    *
100500*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
100600*                                        NOT 11)              *
100700*              58 = TOTAL CHARGES NOT NUMERIC                 *
100800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
100900*                   OR BILL-LTR-DAYS > 60                     *
101000*              62 = INVALID NUMBER OF COVERED DAYS            *
101100*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
101200*                   SPECIFIC FILE FOR CAPITAL                 *
101300*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
101400*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
101500*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
101600***************************************************************
101700 01  PPS-DATA.
101800         10  PPS-RTC                PIC 9(02).
101900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
102000         10  PPS-OUTLIER-DAYS       PIC 9(03).
102100         10  PPS-AVG-LOS            PIC 9(02)V9(01).
102200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
102300         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
102400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
102500         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
102600         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
102700         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
102800         10  PPS-REG-DAYS-USED      PIC 9(03).
102900         10  PPS-LTR-DAYS-USED      PIC 9(02).
103000         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
103100         10  PPS-CALC-VERS          PIC X(05).
103200
103300******************************************************************
103400*            THESE ARE THE VERSIONS OF THE PPCAL
103500*           PROGRAMS THAT WILL BE PASSED BACK----
103600*          ASSOCIATED WITH THE BILL BEING PROCESSED
103700******************************************************************
103800 01  PRICER-OPT-VERS-SW.
103900     02  PRICER-OPTION-SW          PIC X(01).
104000         88  ALL-TABLES-PASSED          VALUE 'A'.
104100         88  PROV-RECORD-PASSED         VALUE 'P'.
104200         88  ADDITIONAL-VARIABLES       VALUE 'M'.
104300         88  PC-PRICER                  VALUE 'C'.
104400     02  PPS-VERSIONS.
104500         10  PPDRV-VERSION         PIC X(05).
104600
104700******************************************************************
104800*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
104900*          ASSOCIATED WITH THE BILL BEING PROCESSED
105000******************************************************************
105100 01  PPS-ADDITIONAL-VARIABLES.
105200     05  PPS-HSP-PCT                PIC 9(01)V9(02).
105300     05  PPS-FSP-PCT                PIC 9(01)V9(02).
105400     05  PPS-NAT-PCT                PIC 9(01)V9(02).
105500     05  PPS-REG-PCT                PIC 9(01)V9(02).
105600     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
105700     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
105800     05  PPS-DRG-WT                 PIC 9(02)V9(04).
105900     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
106000     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
106100     05  PPS-REG-LABOR              PIC 9(05)V9(02).
106200     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
106300     05  PPS-OPER-COLA              PIC 9(01)V9(03).
106400     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
106500     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
106600     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
106700     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
106800     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
106900     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
107000     05  PPS-CAPITAL-VARIABLES.
107100         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
107200         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
107300         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
107400         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
107500         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
107600         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
107700         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
107800         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
107900     05  PPS-CAPITAL2-VARIABLES.
108000         10  PPS-CAPI2-PAY-CODE             PIC X(1).
108100         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
108200         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
108300
108400     05  PPS-OTHER-VARIABLES.
108500         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
108600         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
108700         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
108800         10  PPS-HVBP-HRR-DATA.
108900             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
109000             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
109100             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
109200             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
109300         10  PPS-OPERATNG-DATA.
109400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
109500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
109600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
109700
109800     05  PPS-PC-OTH-VARIABLES.
109900         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
110000         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
110100         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
110200         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
110300         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
110400         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
110500         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
110600         10  PPS-PC-HMO-FLAG                PIC X(01).
110700         10  PPS-PC-COT-FLAG                PIC X(01).
110800         10  PPS-FILLER                     PIC X(0998).
110900
111000**************************************************************
111100*      MILLINNIUM COMPATIBLE                                 *
111200*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *
111300*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
111400*      IN THE NEW FORMAT                                     *
111500**************************************************************
111600 01  PROV-NEW-HOLD.
111700     02  PROV-NEWREC-HOLD1.
111800         05  P-NEW-NPI10.
111900             10  P-NEW-NPI8             PIC X(08).
112000             10  P-NEW-NPI-FILLER       PIC X(02).
112100         05  P-NEW-PROVIDER-NO.
112200             88  P-NEW-DSH-ADJ-PROVIDERS
112300                             VALUE '180049' '190044' '190144'
112400                                   '190191' '330047' '340085'
112500                                   '370016' '370149' '420043'.
112600             10  P-NEW-STATE            PIC 9(02).
112700             10  FILLER                 PIC X(04).
112800         05  P-NEW-DATE-DATA.
112900             10  P-NEW-EFF-DATE.
113000                 15  P-NEW-EFF-DT-CC    PIC 9(02).
113100                 15  P-NEW-EFF-DT-YY    PIC 9(02).
113200                 15  P-NEW-EFF-DT-MM    PIC 9(02).
113300                 15  P-NEW-EFF-DT-DD    PIC 9(02).
113400             10  P-NEW-FY-BEGIN-DATE.
113500                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
113600                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
113700                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
113800                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
113900             10  P-NEW-REPORT-DATE.
114000                 15  P-NEW-REPORT-DT-CC PIC 9(02).
114100                 15  P-NEW-REPORT-DT-YY PIC 9(02).
114200                 15  P-NEW-REPORT-DT-MM PIC 9(02).
114300                 15  P-NEW-REPORT-DT-DD PIC 9(02).
114400             10  P-NEW-TERMINATION-DATE.
114500                 15  P-NEW-TERM-DT-CC   PIC 9(02).
114600                 15  P-NEW-TERM-DT-YY   PIC 9(02).
114700                 15  P-NEW-TERM-DT-MM   PIC 9(02).
114800                 15  P-NEW-TERM-DT-DD   PIC 9(02).
114900         05  P-NEW-WAIVER-CODE          PIC X(01).
115000             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
115100         05  P-NEW-INTER-NO             PIC 9(05).
115200         05  P-NEW-PROVIDER-TYPE        PIC X(02).
115300             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
115400             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
115500                                                  '15' '17'
115600                                                  '22'.
115700             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
115800             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
115900             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
116000             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
116100             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
116200             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
116300             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
116400             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
116500             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
116600             88  P-N-EACH                   VALUE '21' '22'.
116700             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
116800             88  P-N-NHCMQ-II-SNF           VALUE '32'.
116900             88  P-N-NHCMQ-III-SNF          VALUE '33'.
117000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
117100             88  P-N-NEW-ENGLAND            VALUE  1.
117200             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
117300             88  P-N-SOUTH-ATLANTIC         VALUE  3.
117400             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
117500             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
117600             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
117700             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
117800             88  P-N-MOUNTAIN               VALUE  8.
117900             88  P-N-PACIFIC                VALUE  9.
118000         05  P-NEW-CURRENT-DIV   REDEFINES
118100                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
118200             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
118300         05  P-NEW-MSA-DATA.
118400             10  P-NEW-CHG-CODE-INDEX       PIC X.
118500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
118600             10  P-NEW-GEO-LOC-MSA9   REDEFINES
118700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
118800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
118900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
119000             10  P-NEW-STAND-AMT-LOC-MSA9
119100       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
119200                 15  P-NEW-RURAL-1ST.
119300                     20  P-NEW-STAND-RURAL  PIC XX.
119400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
119500                 15  P-NEW-RURAL-2ND        PIC XX.
119600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
119700                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
119800                 88  P-NEW-SCH-YR82       VALUE   '82'.
119900                 88  P-NEW-SCH-YR87       VALUE   '87'.
120000         05  P-NEW-LUGAR                    PIC X.
120100         05  P-NEW-TEMP-RELIEF-IND          PIC X.
120200         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
120300         05  FILLER                         PIC X(05).
120400     02  PROV-NEWREC-HOLD2.
120500         05  P-NEW-VARIABLES.
120600             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
120700             10  P-NEW-COLA              PIC  9(01)V9(03).
120800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
120900             10  P-NEW-BED-SIZE          PIC  9(05).
121000             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
121100             10  P-NEW-CMI               PIC  9(01)V9(04).
121200             10  P-NEW-SSI-RATIO         PIC  V9(04).
121300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
121400             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
121500             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
121600             10  P-NEW-DSH-PERCENT       PIC  V9(04).
121700             10  P-NEW-FYE-DATE          PIC  X(08).
121800         05  P-NEW-CBSA-DATA.
121900             10  FILLER                    PIC X.
122000             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
122100             10  FILLER                    PIC X(21).
122200     02  PROV-NEWREC-HOLD3.
122300         05  P-NEW-PASS-AMT-DATA.
122400             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
122500             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
122600             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
122700             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
122800         05  P-NEW-CAPI-DATA.
122900             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
123000             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
123100             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
123200             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
123300             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
123400             15  P-NEW-CAPI-NEW-HOSP       PIC X.
123500             15  P-NEW-CAPI-IME            PIC 9V9999.
123600             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
123700         05  P-HVBP-HRR-DATA.
123800             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
123900             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
124000             15  P-HOSP-READMISSION-REDUCTN PIC X.
124100             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
124200         05  P-MODEL1-BUNDLE-DATA.
124300             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
124400             15  P-HAC-REDUC-IND            PIC X.
124500             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
124600             15  P-EHR-REDUC-IND            PIC X.
124700         05  FILLER                         PIC X(09).
124800
124900************************************************************
125000******************************************************************
125100*      MILLINNIUM COMPATIBLE
125200*                   THIS IS THE WAGE-INDEX
125300*          ASSOCIATED WITH THE BILL BEING PROCESSED
125400******************************************************************
125500 01  WAGE-NEW-CBSA-INDEX-RECORD.
125600     05  W-CBSA                        PIC X(5).
125700     05  W-CBSA-SIZE                   PIC X.
125800         88  LARGE-URBAN       VALUE 'L'.
125900         88  OTHER-URBAN       VALUE 'O'.
126000         88  ALL-RURAL         VALUE 'R'.
126100     05  W-CBSA-EFF-DATE               PIC X(8).
126200     05  FILLER                        PIC X.
126300     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
126400     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
126500
126600
126700 PROCEDURE DIVISION  USING BILL-NEW-DATA
126800                           PPS-DATA
126900                           PRICER-OPT-VERS-SW
127000                           PPS-ADDITIONAL-VARIABLES
127100                           PROV-NEW-HOLD
127200                           WAGE-NEW-CBSA-INDEX-RECORD.
127300
127400***************************************************************
127500*    PROCESSING:                                              *
127600*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
127700*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
127800*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
127900*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
128000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
128100*           GOBACK.                                           *
128200*        D. ASSEMBLE PRICING COMPONENTS.                      *
128300*        E. CALCULATE THE PRICE.                              *
128400***************************************************************
128500
128600     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
128700     MOVE 'N' TO TEMP-RELIEF-FLAG.
128800     MOVE 'N' TO OUTLIER-RECON-FLAG.
128900
129000     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
129100
129200     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
129300     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
129400     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
129500     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
129600     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
129700     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
129800     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
129900     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
130000
130100     IF (PPS-RTC = '00' OR '03' OR '10' OR
130200                   '12' OR '14')
130300        MOVE 'Y' TO OUTLIER-RECON-FLAG
130400        MOVE PPS-DATA TO HLD-PPS-DATA
130500        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
130600        MOVE HLD-PPS-DATA TO PPS-DATA.
130700
130800     GOBACK.
130900
131000 0200-MAINLINE-CONTROL.
131100
131200     MOVE 'N' TO HMO-TAG.
131300
131400     IF PPS-PC-HMO-FLAG = 'Y' OR
131500               HMO-FLAG = 'Y'
131600        MOVE 'Y' TO HMO-TAG.
131700
131800     IF P-NEW-STATE NOT = 40
131900        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
132000
132100     MOVE ALL '0' TO PPS-DATA
132200                     H-OPER-DSH-SCH
132300                     H-OPER-DSH-RRC
132400                     HOLD-PPS-COMPONENTS
132500                     HOLD-PPS-COMPONENTS
132600                     HOLD-ADDITIONAL-VARIABLES
132700                     HOLD-CAPITAL-VARIABLES
132800                     HOLD-CAPITAL2-VARIABLES
132900                     HOLD-OTHER-VARIABLES
133000                     HOLD-PC-OTH-VARIABLES.
133100
133200     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
133300        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
133400
133500     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
133600        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
133700
133800     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
133900        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
134000
134100     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
134200        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
134300
134400
134500     PERFORM 1000-EDIT-THE-BILL-INFO.
134600
134700     IF  PPS-RTC = 00
134800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
134900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
135000
135100     IF OUTLIER-RECON-FLAG = 'Y'
135200        MOVE 'N' TO OUTLIER-RECON-FLAG
135300        GO TO 0200-EXIT.
135400
135500     IF PPS-RTC = 00
135600        IF H-PERDIEM-DAYS = H-ALOS OR
135700           H-PERDIEM-DAYS > H-ALOS
135800           MOVE 14 TO PPS-RTC.
135900
136000     IF PPS-RTC = 02
136100        IF H-PERDIEM-DAYS = H-ALOS OR
136200           H-PERDIEM-DAYS > H-ALOS
136300           MOVE 16 TO PPS-RTC.
136400
136500 0200-EXIT.   EXIT.
136600
136700 1000-EDIT-THE-BILL-INFO.
136800***************************************************************
136900*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
137000*    AND DO NOT ATTEMPT TO PRICE.                             *
137100***************************************************************
137200
137300     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
137400     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
137500
137600     IF  PPS-RTC = 00
137700         IF  P-NEW-WAIVER-STATE
137800             MOVE 53 TO PPS-RTC.
137900
138000     IF  PPS-RTC = 00
138100         IF  B-DRG < 001 OR > 559
138200                                  OR = 004 OR = 005
138300                                  OR = 107 OR = 109
138400                                  OR = 112 OR = 115
138500                                  OR = 116 OR = 209
138600                                  OR = 214 OR = 215
138700                                  OR = 221 OR = 222
138800                                  OR = 231 OR = 400
138900                                  OR = 434 OR = 435
139000                                  OR = 436 OR = 437
139100                                  OR = 438 OR = 456
139200                                  OR = 457 OR = 458
139300                                  OR = 459 OR = 460
139400                                  OR = 469 OR = 470
139500                                  OR = 472 OR = 474
139600                                  OR = 478 OR = 483
139700                                  OR = 514 OR = 516
139800                                  OR = 517 OR = 526
139900                                  OR = 527
140000             MOVE 54 TO PPS-RTC.
140100
140200     IF  PPS-RTC = 00
140300            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
140400                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
140500                MOVE 55 TO PPS-RTC.
140600
140700     IF  PPS-RTC = 00
140800         IF P-NEW-TERMINATION-DATE > 00000000
140900            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
141000                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
141100                  MOVE 55 TO PPS-RTC.
141200
141300     IF  PPS-RTC = 00
141400         IF  B-LOS NOT NUMERIC
141500             MOVE 56 TO PPS-RTC
141600         ELSE
141700         IF  B-LOS = 0
141800             IF B-REVIEW-CODE NOT = 00 AND
141900                              NOT = 03 AND
142000                              NOT = 06 AND
142100                              NOT = 07 AND
142200                              NOT = 09 AND
142300                              NOT = 11
142400             MOVE 56 TO PPS-RTC.
142500
142600     IF  PPS-RTC = 00
142700         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
142800             MOVE 61 TO PPS-RTC
142900         ELSE
143000             MOVE B-LTR-DAYS TO H-LTR-DAYS.
143100
143200     IF  PPS-RTC = 00
143300         IF  B-COVERED-DAYS NOT NUMERIC
143400             MOVE 62 TO PPS-RTC
143500         ELSE
143600         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
143700             MOVE 62 TO PPS-RTC
143800         ELSE
143900             MOVE B-COVERED-DAYS TO H-COV-DAYS.
144000
144100     IF  PPS-RTC = 00
144200         IF  H-LTR-DAYS  > H-COV-DAYS
144300             MOVE 62 TO PPS-RTC
144400         ELSE
144500             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
144600
144700     IF  PPS-RTC = 00
144800         IF  NOT VALID-REVIEW-CODE
144900             MOVE 57 TO PPS-RTC.
145000
145100     IF  PPS-RTC = 00
145200         IF  B-CHARGES-CLAIMED NOT NUMERIC
145300             MOVE 58 TO PPS-RTC.
145400
145500     IF PPS-RTC = 00
145600           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
145700                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
145800                                            NOT = 'B' AND
145900                                            NOT = 'C'
146000                 MOVE 65 TO PPS-RTC.
146100
146200 2000-ASSEMBLE-PPS-VARIABLES.
146300***************************************************************
146400*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
146500*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
146600*    OF THAT VARIABLE.                                        *
146700***************************************************************
146800***  GET THE PROVIDER SPECIFIC VARIABLES.
146900***  GET THE PROVIDER SPECIFIC VARIABLES.
147000
147100     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
147200     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
147300
147400     IF  (P-NEW-STATE = 02 OR 12)
147500         MOVE P-NEW-COLA TO H-OPER-COLA
147600     ELSE
147700         MOVE 1.000  TO H-OPER-COLA.
147800
147900***************************************************************
148000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
148100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
148200
148300     PERFORM 2600-GET-DRG-WEIGHT
148400             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
148500
148600***************************************************************
148700***  GET THE WAGE-INDEX
148800***  GET THE WAGE-INDEX
148900
149000     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
149100     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
149200
149300***************************************************************
149400***  GET THE LABOR, NON-LABOR STANDARD RATES
149500
149600     IF  P-NEW-STATE = 40
149700         MOVE 2 TO R2
149800         MOVE 3 TO R4
149900     ELSE
150000         MOVE 1 TO R2
150100         MOVE 1 TO R4.
150200
150300     IF  LARGE-URBAN
150400         MOVE 1 TO R3
150500     ELSE
150600         MOVE 2 TO R3.
150700
150800     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
150900        (H-WAGE-INDEX > 01.0000))
151000        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
151100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
151200
151300     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
151400         (H-WAGE-INDEX > 01.0000))
151500        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
151600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
151700
151800     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
151900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
152000        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
152100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
152200
152300     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
152400         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
152500        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
152600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
152700
152800     IF P-NEW-STATE = 40
152900        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
153000            (H-PR-WAGE-INDEX > 01.0000))
153100             PERFORM 2300-GET-PR-LAB-TB1-RATES
153200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
153300
153400
153500     IF P-NEW-STATE = 40
153600        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
153700             (H-PR-WAGE-INDEX > 01.0000))
153800              PERFORM 2300-GET-PR-LAB-TB2-RATES
153900                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
154000
154100     IF P-NEW-STATE = 40
154200        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
154300         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
154400          PERFORM 2300-GET-PR-LAB-TB3-RATES
154500              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
154600
154700     IF P-NEW-STATE = 40
154800        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
154900         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
155000          PERFORM 2300-GET-PR-LAB-TB4-RATES
155100              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
155200
155300***************************************************************
155400***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
155500***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
155600
155700     MOVE 0.00  TO H-OPER-HSP-PCT.
155800     MOVE 1.00  TO H-OPER-FSP-PCT.
155900
156000***************************************************************
156100***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
156200***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
156300
156400      MOVE 1.00 TO H-NAT-PCT.
156500      MOVE 0.00 TO H-REG-PCT.
156600
156700     IF  P-NEW-STATE = 40
156800         MOVE 0.75 TO H-NAT-PCT
156900         MOVE 0.25 TO H-REG-PCT.
157000
157100     IF  P-N-SCH-REBASED-FY90 OR
157200         P-N-EACH OR
157300         P-N-MDH-REBASED-FY90
157400         MOVE 1.00 TO H-OPER-HSP-PCT.
157500
157600 2300-GET-LAB-NONLAB-TB1-RATES.
157700
157800     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
157900         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
158000         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
158100         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
158200         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
158300
158400 2300-GET-LAB-NONLAB-TB2-RATES.
158500
158600     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
158700         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
158800         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
158900         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
159000         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
159100
159200 2300-GET-LAB-NONLAB-TB3-RATES.
159300
159400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
159500         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
159600         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
159700         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
159800         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
159900
160000 2300-GET-LAB-NONLAB-TB4-RATES.
160100
160200     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
160300         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
160400         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
160500         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
160600         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
160700
160800 2300-GET-PR-LAB-TB1-RATES.
160900
161000     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
161100         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
161200         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
161300
161400 2300-GET-PR-LAB-TB2-RATES.
161500
161600     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
161700         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
161800         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
161900
162000 2300-GET-PR-LAB-TB3-RATES.
162100
162200     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
162300         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
162400         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
162500
162600 2300-GET-PR-LAB-TB4-RATES.
162700
162800     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
162900         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
163000         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
163100
163200
163300 2600-GET-DRG-WEIGHT.
163400
163500     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
163600         SET DX6 TO B-DRG
163700         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
163800         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
163900*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
164000         MOVE ZEROES                   TO H-DAYS-CUTOFF
164100         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
164200
164300 3000-CALC-PAYMENT.
164400***************************************************************
164500*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
164600*        CALCULATE THE STAY UTILIZATION.                      *
164700*        CALCULATE THE FEDERAL PORTION.                       *
164800*        CALCULATE THE HOSPITAL PORTION.                      *
164900*        CALCULATE THE COST-OUTLIER PORTION.                  *
165000*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
165100*        CALCULATE THE DSH ADJUSTMENT.                        *
165200*        CALCULATE THE IME TEACHING.                          *
165300***************************************************************
165400
165500     PERFORM 3100-CALC-STAY-UTILIZATION.
165600     PERFORM 3300-CALC-OPER-FSP-AMT.
165700
165800     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
165900
166000***********************************************************
166100***  OPERATING IME CALCULATION
166200***  OPERATING IME CALCULATION
166300
166400     COMPUTE H-OPER-IME-TEACH ROUNDED =
166500            1.37 * ((1 + H-INTERN-RATIO) ** .405  - 1).
166600
166700***********************************************************
166800
166900     IF P-N-SCH-REBASED-FY90 OR
167000        P-N-EACH OR
167100        P-N-MDH-REBASED-FY90
167200         PERFORM 3450-CALC-ADDITIONAL-HSP.
167300
167400     MOVE 00                 TO  PPS-RTC.
167500     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
167600     MOVE H-ALOS             TO  PPS-AVG-LOS.
167700     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
167800
167900     MOVE B-LOS TO H-PERDIEM-DAYS.
168000     IF H-PERDIEM-DAYS < 1
168100         MOVE 1 TO H-PERDIEM-DAYS.
168200     ADD 1 TO H-PERDIEM-DAYS.
168300
168400     MOVE 1 TO H-DSCHG-FRCTN.
168500
168600     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
168700
168800     IF (PAY-PERDIEM-DAYS  OR
168900         PAY-XFER-NO-COST) OR
169000        (PAY-XFER-SPEC-DRG AND
169100         B-DRG-POSTACUTE-PERDIEM)
169200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
169300         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
169400         IF H-DSCHG-FRCTN > 1
169500              MOVE 1 TO H-DSCHG-FRCTN
169600              MOVE 1 TO H-TRANSFER-ADJ
169700         ELSE
169800              COMPUTE H-DRG-WT-FRCTN ROUNDED =
169900                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
170000
170100     IF (PAY-XFER-SPEC-DRG AND
170200         B-DRG-POSTACUTE-50-50)
170300         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
170400         COMPUTE H-DSCHG-FRCTN  ROUNDED =
170500                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
170600         IF H-DSCHG-FRCTN > 1
170700              MOVE 1 TO H-DSCHG-FRCTN
170800              MOVE 1 TO H-TRANSFER-ADJ
170900         ELSE
171000              COMPUTE H-DRG-WT-FRCTN ROUNDED =
171100            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
171200
171300
171400***********************************************************
171500***  CAPITAL DSH CALCULATION
171600***  CAPITAL DSH CALCULATION
171700
171800     MOVE 0 TO H-CAPI-DSH.
171900
172000     IF P-NEW-BED-SIZE NOT NUMERIC
172100         MOVE 0 TO P-NEW-BED-SIZE.
172200
172300     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
172400         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
172500                  (.2025 * (P-NEW-SSI-RATIO
172600                          + P-NEW-MEDICAID-RATIO)) - 1.
172700
172800***********************************************************
172900***  CAPITAL IME TEACH CALCULATION
173000***  CAPITAL IME TEACH CALCULATION
173100
173200     MOVE 0 TO H-WK-CAPI-IME-TEACH.
173300
173400     IF P-NEW-CAPI-IME NUMERIC
173500        IF P-NEW-CAPI-IME > 1.5000
173600           MOVE 1.5000 TO P-NEW-CAPI-IME.
173700
173800     IF P-NEW-CAPI-IME NUMERIC
173900        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
174000          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
174100
174200***********************************************************
174300******************************************************************
174400***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
174500***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
174600***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97
174700
174800     MOVE 0.00 TO H-DAYOUT-PCT.
174900******************************************************************
175000
175100     MOVE 0.80 TO H-CSTOUT-PCT.
175200
175300******************************************************************
175400*****THESE ARE BURNS DRG'S
175500     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR
175600                 509 OR 510 OR 511
175700             MOVE 0.90 TO H-CSTOUT-PCT.
175800
175900***     NATIONAL PERCENTAGE
176000     MOVE 0.6970   TO H-LABOR-PCT.
176100     MOVE 0.3030   TO H-NONLABOR-PCT.
176200
176300***     PUERTO RICO PERCENTAGE
176400     MOVE 0.6200   TO H-PR-LABOR-PCT.
176500     MOVE 0.3800   TO H-PR-NONLABOR-PCT.
176600
176700     IF (H-WAGE-INDEX < 01.0000 OR
176800         H-WAGE-INDEX = 01.0000)
176900        MOVE 0.6200 TO H-LABOR-PCT
177000        MOVE 0.3800 TO H-NONLABOR-PCT.
177100
177200     IF P-NEW-STATE = 40
177300       IF (H-PR-WAGE-INDEX < 01.0000 OR
177400           H-PR-WAGE-INDEX = 01.0000)
177500          MOVE 0.5870 TO H-PR-LABOR-PCT
177600          MOVE 0.4130 TO H-PR-NONLABOR-PCT.
177700
177800
177900     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
178000             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
178100     ELSE
178200             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
178300
178400     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
178500             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
178600     ELSE
178700             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
178800
178900***********************************************************
179000***  CAPITAL PAYMENT METHOD B
179100***  CAPITAL PAYMENT METHOD B
179200
179300     IF W-CBSA-SIZE = 'L'
179400        MOVE 1.03 TO H-CAPI-LARG-URBAN
179500     ELSE
179600        MOVE 1.00 TO H-CAPI-LARG-URBAN.
179700
179800     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
179900     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
180000
180100     COMPUTE H-FEDERAL-RATE ROUNDED =
180200                                 (0420.65 * H-CAPI-GAF).
180300     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
180400                                 (0201.93 * H-PR-CAPI-GAF).
180500
180600     COMPUTE H-CAPI-COLA ROUNDED =
180700                     (.3152 * (H-OPER-COLA - 1) + 1).
180800
180900     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
181000
181100     IF P-NEW-STATE = 40
181200        COMPUTE  H-CAPI-FED-RATE ROUNDED =
181300                 (H-NAT-PCT * H-FEDERAL-RATE) +
181400                 (H-REG-PCT * H-PUERTO-RICO-RATE).
181500***********************************************************
181600***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001
181700***  CAPITAL HSP CALCULATION
181800***  CAPITAL HSP CALCULATION
181900*
182000*    IF B-DISCHARGE-DATE > 20010331
182100*        MOVE 1.0149 TO H-HSP-UPDATE01
182200*    ELSE
182300*        MOVE 1.0147 TO H-HSP-UPDATE01.
182400*
182500*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.
182600*
182700*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *
182800*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
182900***********************************************************
183000
183100***********************************************************
183200***  CAPITAL FSP CALCULATION
183300***  CAPITAL FSP CALCULATION
183400
183500     COMPUTE H-CAPI-FSP-PART ROUNDED =
183600                               H-DRG-WT * H-CAPI-FED-RATE *
183700                               H-CAPI-COLA *
183800                               H-CAPI-LARG-URBAN.
183900
184000***********************************************************
184100***  CAPITAL PAYMENT METHOD A
184200***  CAPITAL PAYMENT METHOD A
184300
184400     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
184500        MOVE 1.00 TO H-CAPI-SCH
184600     ELSE
184700        MOVE 0.85 TO H-CAPI-SCH.
184800
184900***********************************************************
185000***********  CAPITAL OLD-HARMLESS CALCULATION ***********
185100***********  CAPITAL OLD-HARMLESS CALCULATION ***********
185200
185300     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
185400                    (P-NEW-CAPI-OLD-HARM-RATE *
185500                    H-CAPI-SCH).
185600
185700***********************************************************
185800        IF PAY-PERDIEM-DAYS
185900            IF  H-PERDIEM-DAYS < H-ALOS
186000                IF  NOT (B-DRG = 385)
186100                    PERFORM 3500-CALC-PERDIEM-AMT
186200                    MOVE 03 TO PPS-RTC.
186300
186400        IF PAY-XFER-SPEC-DRG
186500            IF  H-PERDIEM-DAYS < H-ALOS
186600                IF  NOT (B-DRG = 385)
186700                    PERFORM 3550-CALC-PERDIEM-AMT.
186800
186900        IF  PAY-XFER-NO-COST
187000            MOVE 00 TO PPS-RTC
187100            IF H-PERDIEM-DAYS < H-ALOS
187200               IF  NOT (B-DRG = 385)
187300                   PERFORM 3500-CALC-PERDIEM-AMT
187400                   MOVE 06 TO PPS-RTC.
187500
187600     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
187700
187800     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
187900
188000     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
188100
188200     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
188300
188400        IF PAY-XFER-SPEC-DRG
188500            IF  H-PERDIEM-DAYS < H-ALOS
188600                IF  NOT (B-DRG = 385)
188700                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
188800
188900
189000        IF  PAY-PERDIEM-DAYS
189100            IF  H-OPER-OUTCST-PART > 0
189200                MOVE H-OPER-OUTCST-PART TO
189300                     H-OPER-OUTLIER-PART
189400                MOVE 05 TO PPS-RTC
189500            ELSE
189600            IF  PPS-RTC NOT = 03
189700                MOVE 00 TO PPS-RTC
189800                MOVE 0  TO H-OPER-OUTLIER-PART.
189900
190000        IF  PAY-PERDIEM-DAYS
190100            IF  H-CAPI-OUTCST-PART > 0
190200                MOVE H-CAPI-OUTCST-PART TO
190300                     H-CAPI-OUTLIER-PART
190400                MOVE 05 TO PPS-RTC
190500            ELSE
190600            IF  PPS-RTC NOT = 03
190700                MOVE 0  TO H-CAPI-OUTLIER-PART.
190800
190900
191000 3000-CONTINUE.
191100
191200***********************************************************
191300***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
191400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
191500
191600     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
191700
191800***********************************************************
191900
192000     IF  PPS-RTC = 67
192100         MOVE H-OPER-DOLLAR-THRESHOLD TO
192200              WK-H-OPER-DOLLAR-THRESHOLD.
192300
192400     IF  PPS-RTC < 50
192500         PERFORM 3800-CALC-TOT-AMT
192600     ELSE
192700         MOVE ALL '0' TO PPS-OPER-HSP-PART
192800                         PPS-OPER-FSP-PART
192900                         PPS-OPER-OUTLIER-PART
193000                         PPS-OUTLIER-DAYS
193100                         PPS-REG-DAYS-USED
193200                         PPS-LTR-DAYS-USED
193300                         PPS-TOTAL-PAYMENT
193400                         PPS-OPER-DSH-ADJ
193500                         PPS-OPER-IME-ADJ
193600                         H-DSCHG-FRCTN
193700                         H-DRG-WT-FRCTN
193800                         HOLD-ADDITIONAL-VARIABLES
193900                         HOLD-CAPITAL-VARIABLES
194000                         HOLD-CAPITAL2-VARIABLES
194100                         HOLD-OTHER-VARIABLES
194200                         HOLD-PC-OTH-VARIABLES.
194300
194400     IF  PPS-RTC = 67
194500         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
194600                 H-OPER-DOLLAR-THRESHOLD.
194700
194800 3000-EXIT.  EXIT.
194900
195000 3100-CALC-STAY-UTILIZATION.
195100
195200     MOVE 0 TO PPS-REG-DAYS-USED.
195300     MOVE 0 TO PPS-LTR-DAYS-USED.
195400
195500     IF H-REG-DAYS > 0
195600        IF H-REG-DAYS > B-LOS
195700           MOVE B-LOS TO PPS-REG-DAYS-USED
195800        ELSE
195900           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
196000     ELSE
196100        IF H-LTR-DAYS > B-LOS
196200           MOVE B-LOS TO PPS-LTR-DAYS-USED
196300        ELSE
196400           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
196500
196600
196700
196800 3300-CALC-OPER-FSP-AMT.
196900***********************************************************
197000***  OPERATING FSP CALCULATION
197100***  OPERATING FSP CALCULATION
197200
197300     COMPUTE H-OPER-FSP-PART ROUNDED =
197400           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
197500            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
197600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
197700
197800****CHECK FOR PUERTO RICO
197900     IF P-NEW-STATE = 40
198000       COMPUTE H-OPER-FSP-PART ROUNDED =
198100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
198200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
198300                           +
198400           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
198500            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
198600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
198700
198800
198900 3450-CALC-ADDITIONAL-HSP.
199000***********************************************************
199100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
199200*    SOLE COMMUNITY
199300*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
199400*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
199500***********************************************************
199600**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
199700****    USE ACTUAL FEDERAL REGISTER NUMBER
199800
199900***************************************************************
200000***         GET THE UPDATING FACTOR
200100***         GET THE UPDATING FACTOR
200200
200300     MOVE 0.997174 TO H-BUDG-NUTR01.
200400     MOVE 0.995821 TO H-BUDG-NUTR02.
200500     MOVE 0.993111 TO H-BUDG-NUTR03.
200600     MOVE 1.002608 TO H-BUDG-NUTR04.
200700     MOVE 0.999876 TO H-BUDG-NUTR05.
200800     MOVE 0.998993 TO H-BUDG-NUTR06.
200900
201000     MOVE 1.0340 TO H-UPDATE-01.
201100     MOVE 1.0275 TO H-UPDATE-02.
201200     MOVE 1.0295 TO H-UPDATE-03.
201300     MOVE 1.0340 TO H-UPDATE-04.
201400     MOVE 1.0330 TO H-UPDATE-05.
201500
201600     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
201700        MOVE 1.0370 TO H-UPDATE-06
201800     ELSE
201900        MOVE 1.0330 TO H-UPDATE-06.
202000
202100     COMPUTE H-UPDATE-FACTOR ROUNDED =
202200                       (H-UPDATE-01 * H-UPDATE-02 *
202300                        H-UPDATE-03 * H-UPDATE-04 *
202400                        H-UPDATE-05 * H-UPDATE-06 *
202500                        H-BUDG-NUTR01 * H-BUDG-NUTR02 *
202600                        H-BUDG-NUTR03 * H-BUDG-NUTR04 *
202700                        H-BUDG-NUTR05 * H-BUDG-NUTR06).
202800
202900     COMPUTE H-HSP-RATE ROUNDED =
203000         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
203100***************************************************************
203200
203300***************************************************************
203400***     OUTLIER OFFSETS
203500***     OPERATING NATIONAL
203600***     OPERATING PUERTO RICO BLEND
203700
203800      MOVE 0.948990 TO H-OUTLIER-OFFSET-NAT
203900      MOVE 0.955467 TO H-OUTLIER-OFFSET-PR.
204000
204100***************************************************************
204200     COMPUTE H-FSP-RATE ROUNDED =
204300         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
204400         H-NAT-NONLABOR * H-OPER-COLA))
204500                           *
204600     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
204700                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
204800
204900     IF P-NEW-STATE = 40
205000       COMPUTE H-FSP-RATE ROUNDED =
205100         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
205200         H-NAT-NONLABOR * H-OPER-COLA))
205300                           +
205400          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
205500         H-REG-NONLABOR * H-OPER-COLA)))
205600                           *
205700      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
205800                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
205900
206000
206100     IF  H-HSP-RATE > H-FSP-RATE
206200           COMPUTE H-OPER-HSP-PART ROUNDED =
206300             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
206400                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
206500     ELSE
206600         MOVE 0 TO H-OPER-HSP-PART.
206700
206800***************************************************************
206900***         GET THE MDH REBASE
207000***     HAS BEEN REVIVED FOR 10/01/97
207100
207200     IF  H-HSP-RATE > H-FSP-RATE
207300         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
207400           COMPUTE H-OPER-HSP-PART ROUNDED =
207500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5
207600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
207700
207800 3500-CALC-PERDIEM-AMT.
207900***********************************************************
208000***  REVIEW CODE = 03 OR 06
208100***  OPERATING PERDIEM-AMT CALCULATION
208200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
208300
208400**    REMOVED AS OF APR 1 2004
208500***     COMPUTE H-OPER-HSP-PART ROUNDED =
208600***     H-OPER-HSP-PART * H-TRANSFER-ADJ
208700***     ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
208800***********************************************************
208900
209000        COMPUTE H-OPER-FSP-PART ROUNDED =
209100        H-OPER-FSP-PART * H-TRANSFER-ADJ
209200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
209300
209400***********************************************************
209500***********************************************************
209600***  REVIEW CODE = 03 OR 06
209700***  CAPITAL   PERDIEM-AMT CALCULATION
209800***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
209900
210000***********************************************************
210100**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
210200*       COMPUTE H-CAPI-HSP-PART ROUNDED =
210300*       H-CAPI-HSP-PART * H-TRANSFER-ADJ
210400*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
210500***********************************************************
210600
210700        COMPUTE H-CAPI-FSP-PART ROUNDED =
210800        H-CAPI-FSP-PART * H-TRANSFER-ADJ
210900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
211000
211100***********************************************************
211200***  REVIEW CODE = 03 OR 06
211300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
211400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
211500
211600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
211700        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
211800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
211900
212000 3550-CALC-PERDIEM-AMT.
212100***********************************************************
212200***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
212300***  OPERATING PERDIEM-AMT CALCULATION
212400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
212500**    REMOVED AS OF APR 1 2004
212600*    IF (B-DRG = 209 OR 210 OR 211)
212700*       MOVE 10 TO PPS-RTC
212800*       COMPUTE H-OPER-HSP-PART ROUNDED =
212900*       H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
213000*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
213100
213200*    IF (B-DRG = 014 OR 113 OR 236 OR
213300*                012 OR 024 OR 025 OR
213400*                088 OR 089 OR 090 OR
213500*                121 OR 122 OR 127 OR
213600*                130 OR 131 OR 239 OR
213700*                277 OR 278 OR 294 OR
213800*                296 OR 297 OR 320 OR
213900*                321 OR 395 OR 468 OR
214000*                429 OR 541 OR 542)
214100*       MOVE 12 TO PPS-RTC
214200*       COMPUTE H-OPER-HSP-PART ROUNDED =
214300*       H-OPER-HSP-PART *  H-TRANSFER-ADJ
214400*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
214500***********************************************************
214600
214700     IF (B-DRG-POSTACUTE-50-50)
214800        MOVE 10 TO PPS-RTC
214900        COMPUTE H-OPER-FSP-PART ROUNDED =
215000        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
215100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
215200
215300     IF (B-DRG-POSTACUTE-PERDIEM)
215400        MOVE 12 TO PPS-RTC
215500        COMPUTE H-OPER-FSP-PART ROUNDED =
215600        H-OPER-FSP-PART *  H-TRANSFER-ADJ
215700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
215800
215900***********************************************************
216000***  CAPITAL PERDIEM-AMT CALCULATION
216100***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
216200
216300***********************************************************
216400**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
216500*    IF (B-DRG-POSTACUTE-50-50)
216600*       MOVE 10 TO PPS-RTC
216700*       COMPUTE H-CAPI-HSP-PART ROUNDED =
216800*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
216900*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
217000*
217100*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
217200*                264 OR 429 OR 483)
217300*       MOVE 12 TO PPS-RTC
217400*       COMPUTE H-CAPI-HSP-PART ROUNDED =
217500*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ
217600*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
217700***********************************************************
217800
217900     IF (B-DRG-POSTACUTE-50-50)
218000        MOVE 10 TO PPS-RTC
218100        COMPUTE H-CAPI-FSP-PART ROUNDED =
218200        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
218300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
218400
218500     IF (B-DRG-POSTACUTE-PERDIEM)
218600        MOVE 12 TO PPS-RTC
218700        COMPUTE H-CAPI-FSP-PART ROUNDED =
218800        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
218900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
219000
219100***********************************************************
219200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
219300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
219400
219500     IF (B-DRG-POSTACUTE-50-50)
219600        MOVE 10 TO PPS-RTC
219700        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
219800        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
219900        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
220000
220100     IF (B-DRG-POSTACUTE-PERDIEM)
220200        MOVE 12 TO PPS-RTC
220300        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
220400        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
220500        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
220600
220700 3560-CHECK-RTN-CODE.
220800
220900     IF (B-DRG-POSTACUTE-50-50)
221000        MOVE 10 TO PPS-RTC.
221100     IF (B-DRG-POSTACUTE-PERDIEM)
221200        MOVE 12 TO PPS-RTC.
221300
221400 3560-EXIT.    EXIT.
221500
221600 3600-CALC-OUTLIER.
221700***********************************************************
221800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
221900***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
222000
222100     IF OUTLIER-RECON-FLAG = 'Y'
222200        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
222300               (H-OPER-CSTCHG-RATIO + .2).
222400
222500     IF H-CAPI-CSTCHG-RATIO > 0 OR
222600       H-OPER-CSTCHG-RATIO > 0
222700        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
222800                H-OPER-CSTCHG-RATIO /
222900               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
223000        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
223100                H-CAPI-CSTCHG-RATIO /
223200               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
223300     ELSE
223400         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
223500                   H-CAPI-SHARE-DOLL-THRESHOLD.
223600
223700***********************************************************
223800***********************************************************
223900***********************************************************
224000***********************************************************
224100***********************************************************
224200***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
224300***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
224400***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
224500
224600***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
224700***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.
224800***********************************************************
224900***********************************************************
225000***********************************************************
225100***********************************************************
225200
225300
225400
225500***********************************************************
225600***  OUTLIER THRESHOLD AMOUNTS
225700***  OUTLIER THRESHOLD AMOUNTS
225800
225900     MOVE 23600.00 TO H-CST-THRESH.
226000
226100     IF (B-REVIEW-CODE = '03') AND
226200         H-PERDIEM-DAYS < H-ALOS
226300        COMPUTE H-CST-THRESH ROUNDED =
226400                      (H-CST-THRESH * H-TRANSFER-ADJ)
226500                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
226600
226700     IF ((B-REVIEW-CODE = '09') AND
226800         (H-PERDIEM-DAYS < H-ALOS))
226900         IF (B-DRG-POSTACUTE-PERDIEM)
227000            COMPUTE H-CST-THRESH ROUNDED =
227100                      (H-CST-THRESH * H-TRANSFER-ADJ)
227200                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
227300
227400     IF ((B-REVIEW-CODE = '09') AND
227500         (H-PERDIEM-DAYS < H-ALOS))
227600         IF (B-DRG-POSTACUTE-50-50)
227700           COMPUTE H-CST-THRESH ROUNDED =
227800          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
227900                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
228000
228100     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
228200        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
228300         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
228400          H-OPER-SHARE-DOLL-THRESHOLD.
228500
228600     IF P-NEW-STATE = 40
228700        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
228800           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
228900            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
229000             H-OPER-SHARE-DOLL-THRESHOLD
229100        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
229200               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
229300               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
229400
229500***********************************************************
229600
229700     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
229800          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
229900          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
230000
230100
230200     IF P-NEW-STATE = 40
230300        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
230400           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
230500           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
230600        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
230700               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
230800               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
230900
231000
231100     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
231200      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
231300                       +
231400             H-OPER-DOLLAR-THRESHOLD
231500                       +
231600                 H-NEW-TECH-PAY-ADD-ON.
231700
231800     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
231900      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
232000                       +
232100             H-CAPI-DOLLAR-THRESHOLD.
232200
232300     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
232400         MOVE 0 TO H-CAPI-COST-OUTLIER.
232500
232600
232700***********************************************************
232800***  OPERATING COST CALCULATION
232900***  OPERATING COST CALCULATION
233000
233100     COMPUTE H-OPER-BILL-COSTS ROUNDED =
233200         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
233300         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
233400
233500
233600     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
233700         COMPUTE H-OPER-OUTCST-PART ROUNDED =
233800         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
233900                         H-OPER-COST-OUTLIER).
234000
234100     IF PAY-WITHOUT-COST OR
234200        PAY-XFER-NO-COST OR
234300        PAY-XFER-SPEC-DRG-NO-COST
234400         MOVE 0 TO H-OPER-OUTCST-PART.
234500
234600***********************************************************
234700***  CAPITAL COST CALCULATION
234800***  CAPITAL COST CALCULATION
234900
235000     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
235100             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
235200         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
235300
235400     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
235500         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
235600         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
235700                         H-CAPI-COST-OUTLIER).
235800
235900     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
236000       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
236100              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
236200
236300     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
236400        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
236500               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
236600
236700     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
236800        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
236900        MOVE 0 TO H-CAPI-OUTCST-PART
237000                  H-OPER-OUTCST-PART.
237100
237200     IF PAY-WITHOUT-COST OR
237300        PAY-XFER-NO-COST OR
237400        PAY-XFER-SPEC-DRG-NO-COST
237500         MOVE 0 TO H-CAPI-OUTCST-PART.
237600
237700***********************************************************
237800***  DETERMINES THE BILL TO BE COST  OUTLIER
237900
238000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
238100         MOVE 0 TO H-CAPI-OUTDAY-PART
238200                   H-CAPI-OUTCST-PART.
238300
238400     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
238500                 MOVE H-OPER-OUTCST-PART TO
238600                      H-OPER-OUTLIER-PART
238700                 MOVE H-CAPI-OUTCST-PART TO
238800                      H-CAPI-OUTLIER-PART
238900                 MOVE 02 TO PPS-RTC.
239000
239100     IF OUTLIER-RECON-FLAG = 'Y'
239200        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
239300           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
239400           GO TO 3600-EXIT
239500        ELSE
239600           GO TO 3600-EXIT
239700     ELSE
239800        NEXT SENTENCE.
239900
240000
240100***********************************************************
240200***  DETERMINES IF COST OUTLIER
240300***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
240400***         RETURN CODE OF 02
240500
240600     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
240700
240800     IF PPS-RTC = 02
240900             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
241000                     (H-CAPI-COST-OUTLIER  +
241100                      H-OPER-COST-OUTLIER)
241200                             /
241300                    (H-CAPI-CSTCHG-RATIO  +
241400                     H-OPER-CSTCHG-RATIO)
241500             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
241600
241700***********************************************************
241800***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
241900***         RETURN CODE OF 67
242000
242100     IF PPS-RTC = 02
242200         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
242300            PPS-PC-COT-FLAG = 'Y'
242400             MOVE 67 TO PPS-RTC.
242500***********************************************************
242600
242700***********************************************************
242800***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
242900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
243000
243100     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
243200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
243300                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
243400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
243500
243600     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
243700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
243800                H-CAPI-OUTLIER-PART.
243900
244000     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
244100        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
244200                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
244300         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
244400
244500 3600-EXIT.   EXIT.
244600***********************************************************
244700***********************************************************
244800
244900***********************************************************
245000 3800-CALC-TOT-AMT.
245100***********************************************************
245200***  CALCULATE TOTALS FOR CAPITAL
245300***  CALCULATE TOTALS FOR CAPITAL
245400
245500     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
245600
245700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
245800        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
245900        MOVE 0.00 TO H-CAPI-HSP-PCT.
246000
246100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
246200        MOVE 0    TO H-CAPI-OLD-HARMLESS
246300        MOVE 1.00 TO H-CAPI-FSP-PCT
246400        MOVE 0.00 TO H-CAPI-HSP-PCT.
246500
246600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
246700        MOVE 0    TO H-CAPI-OLD-HARMLESS
246800        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
246900        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
247000
247100     COMPUTE H-CAPI-HSP ROUNDED =
247200         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
247300
247400     COMPUTE H-CAPI-FSP ROUNDED =
247500         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
247600
247700     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
247800
247900     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
248000
248100     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
248200             H-CAPI-FSP
248300              * H-CAPI-DSH.
248400
248500     COMPUTE H-CAPI-IME-ADJ ROUNDED =
248600          H-CAPI-FSP *
248700                 H-WK-CAPI-IME-TEACH.
248800
248900     COMPUTE H-CAPI-OUTLIER ROUNDED =
249000             1.00 * H-CAPI-OUTLIER-PART.
249100
249200     COMPUTE H-CAPI2-B-FSP ROUNDED =
249300             1.00 * H-CAPI2-B-FSP-PART.
249400
249500     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
249600             1.00 * H-CAPI2-B-OUTLIER-PART.
249700***********************************************************
249800***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
249900***        THIS ZEROES OUT ALL CAPITAL DATA
250000
250100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
250200        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
250300***********************************************************
250400
250500***********************************************************
250600***  CALCULATE FINAL TOTALS FOR OPERATING
250700***  CALCULATE FINAL TOTALS FOR OPERATING
250800
250900     IF (H-CAPI-OUTLIER > 0 AND
251000         PPS-OPER-OUTLIER-PART = 0)
251100            COMPUTE PPS-OPER-OUTLIER-PART =
251200                    PPS-OPER-OUTLIER-PART + .01.
251300
251400     MOVE 01.000 TO WK-LOW-VOL25PCT.
251500
251600     IF P-NEW-TEMP-RELIEF-IND = 'Y'
251700        MOVE 01.250 TO WK-LOW-VOL25PCT.
251800
251900     MOVE ZERO TO PPS-OPER-DSH-ADJ.
252000
252100     IF  H-OPER-DSH NUMERIC
252200         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
252300       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.
252400
252500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
252600      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.
252700
252800
252900     COMPUTE PPS-OPER-FSP-PART ROUNDED =
253000        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.
253100
253200     COMPUTE PPS-OPER-HSP-PART ROUNDED =
253300        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.
253400
253500     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
253600      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.
253700
253800     IF HMO-TAG  = 'Y'
253900        PERFORM 3850-HMO-IME-ADJ.
254000
254100***********************************************************
254200***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
254300***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
254400
254500     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
254600            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
254700             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
254800             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT.
254900
255000     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
255100             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).
255200
255300     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
255400
255500     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
255600               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
255700               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
255800                      PPS-OPER-IME-ADJ
255900                           +
256000                 PPS-NEW-TECH-PAY-ADD-ON
256100                           +
256200                 H-WK-PASS-AMT-PLUS-MISC
256300                           +
256400                   H-CAPI-TOTAL-PAY.
256500
256600 3850-HMO-IME-ADJ.
256700***********************************************************
256800***  HMO CALC FOR PASS-THRU ADDON
256900***  HMO CALC FOR PASS-THRU ADDON
257000
257100***  HMO DIR-MED-ED  ---- NO LONGER PAID AS OF 10/01/2002
257200***  HMO ORGAN-ACQ   ---- NO LONGER PAID AS OF 10/01/2005
257300
257400     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
257500          (P-NEW-PASS-AMT-PLUS-MISC -
257600          (P-NEW-PASS-AMT-ORGAN-ACQ +
257700           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
257800
257900***********************************************************
258000***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
258100
258200     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
258300                   PPS-OPER-IME-ADJ * .0.
258400
258500***********************************************************
258600
258700
258800 3900A-CALC-OPER-DSH.
258900
259000***  OPERATING DSH CALCULATION EFFECTIVE OCT 1, 2005
259100***  OPERATING DSH CALCULATION EFFECTIVE OCT 1, 2005
259200
259300      MOVE 0.0000 TO H-OPER-DSH.
259400
259500      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
259600                                     + P-NEW-MEDICAID-RATIO).
259700
259800***********************************************************
259900**1**    0-99 BEDS
260000***  NOT TO EXCEED 12%
260100
260200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
260300                               AND H-WK-OPER-DSH > .1499
260400                               AND H-WK-OPER-DSH < .2020
260500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
260600                                      * .65 + .025
260700        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
260800
260900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
261000                               AND H-WK-OPER-DSH > .2019
261100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
261200                                      * .825 + .0588
261300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
261400
261500***********************************************************
261600**2**   100 + BEDS
261700***  NO CAP >> CAN EXCEED 12%
261800
261900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
262000                               AND H-WK-OPER-DSH > .1499
262100                               AND H-WK-OPER-DSH < .2020
262200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
262300                                      * .65 + .025.
262400
262500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
262600                               AND H-WK-OPER-DSH > .2019
262700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
262800                                      * .825 + .0588.
262900
263000***********************************************************
263100**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
263200***  NOT TO EXCEED 12%
263300***  EXCEPT FOR URBAN TO RURAL HOSPITALS CR3459
263400
263500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
263600                               AND H-WK-OPER-DSH > .1499
263700                               AND H-WK-OPER-DSH < .2020
263800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
263900                                 * .65 + .025
264000        IF H-OPER-DSH > .1200
264100           IF P-NEW-DSH-ADJ-PROVIDERS
264200              IF P-NEW-BED-SIZE > 99
264300                 COMPUTE H-OPER-DSH ROUNDED =
264400                 (.1200 + ((H-OPER-DSH - .1200) * .3333))
264500              ELSE
264600                 MOVE .1200 TO H-OPER-DSH
264700           ELSE
264800              MOVE .1200 TO H-OPER-DSH
264900        ELSE
265000           NEXT SENTENCE
265100      ELSE
265200         NEXT SENTENCE.
265300
265400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
265500                               AND H-WK-OPER-DSH > .2019
265600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
265700                                 * .825 + .0588
265800        IF H-OPER-DSH > .1200
265900           IF P-NEW-DSH-ADJ-PROVIDERS
266000              IF P-NEW-BED-SIZE > 99
266100                 COMPUTE H-OPER-DSH ROUNDED =
266200                 (.1200 + ((H-OPER-DSH - .1200) * .3333))
266300              ELSE
266400                 MOVE .1200 TO H-OPER-DSH
266500           ELSE
266600              MOVE .1200 TO H-OPER-DSH
266700        ELSE
266800           NEXT SENTENCE
266900      ELSE
267000         NEXT SENTENCE.
267100***********************************************************
267200**4**   OTHER RURAL HOSPITALS 500 BEDS +
267300***  NO CAP >> CAN EXCEED 12%
267400
267500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
267600                               AND H-WK-OPER-DSH > .1499
267700                               AND H-WK-OPER-DSH < .2020
267800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
267900                                 * .65 + .025.
268000
268100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
268200                               AND H-WK-OPER-DSH > .2019
268300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
268400                                 * .825 + .0588.
268500
268600***********************************************************
268700**7**   RURAL HOSPITALS SCH
268800***  NOT TO EXCEED 12%
268900***  EXCEPT FOR URBAN TO RURAL HOSPITALS CR3459
269000
269100      IF W-CBSA-SIZE = 'R'
269200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
269300                               AND H-WK-OPER-DSH > .1499
269400                               AND H-WK-OPER-DSH < .2020
269500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
269600                                 * .65 + .025
269700        IF H-OPER-DSH > .1200
269800           IF P-NEW-DSH-ADJ-PROVIDERS
269900              IF P-NEW-BED-SIZE > 99
270000                 COMPUTE H-OPER-DSH ROUNDED =
270100                 (.1200 + ((H-OPER-DSH - .1200) * .3333))
270200              ELSE
270300                 MOVE .1200 TO H-OPER-DSH
270400           ELSE
270500              MOVE .1200 TO H-OPER-DSH
270600        ELSE
270700           NEXT SENTENCE
270800      ELSE
270900         NEXT SENTENCE.
271000
271100      IF W-CBSA-SIZE = 'R'
271200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
271300                               AND H-WK-OPER-DSH > .2019
271400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
271500                                 * .825 + .0588
271600        IF H-OPER-DSH > .1200
271700           IF P-NEW-DSH-ADJ-PROVIDERS
271800              IF P-NEW-BED-SIZE > 99
271900                 COMPUTE H-OPER-DSH ROUNDED =
272000                 (.1200 + ((H-OPER-DSH - .1200) * .3333))
272100              ELSE
272200                 MOVE .1200 TO H-OPER-DSH
272300           ELSE
272400              MOVE .1200 TO H-OPER-DSH
272500        ELSE
272600           NEXT SENTENCE
272700      ELSE
272800         NEXT SENTENCE.
272900***********************************************************
273000**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
273100***  RRC OVERRIDES SCH CAP
273200***  REMOVED CHECK FOR RURAL ON RRC'S CR3784H1
273300***     MADE THIS CHG ON 03/06/2006
273400***  NO CAP >> CAN EXCEED 12%
273500
273600***   IF W-CBSA-SIZE = 'R'
273700         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
273800                                   '17' OR '22')
273900                               AND H-WK-OPER-DSH > .1499
274000                               AND H-WK-OPER-DSH < .2020
274100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
274200                                 * .65 + .025.
274300***   IF W-CBSA-SIZE = 'R'
274400         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
274500                                   '17' OR '22')
274600                               AND H-WK-OPER-DSH > .2019
274700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
274800                                 * .825 + .0588.
274900
275000***********************************************************
275100
275200***********************************************************
275300***********************************************************
275400
275500      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
275600
275700 3900A-EXIT.   EXIT.
275800
275900***********************************************************
276000***********************************************************
276100***********************************************************
276200***********************************************************
276300
276400 4000-CALC-TECH-ADDON.
276500
276600***********************************************************
276700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
276800***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
276900***      CALCULATED FOR ADD ON DONE BEFORE OUTLER
277000***      CALCULATED FOR ADD ON DONE BEFORE SPECIAL DRGS
277100
277200     COMPUTE PPS-OPER-HSP-PART ROUNDED =
277300         H-OPER-HSP-PCT * H-OPER-HSP-PART.
277400
277500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
277600         H-OPER-FSP-PCT * H-OPER-FSP-PART.
277700
277800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
277900
278000     IF  H-OPER-DSH NUMERIC
278100             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
278200              PPS-OPER-FSP-PART
278300              * H-OPER-DSH.
278400
278500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
278600             PPS-OPER-FSP-PART *
278700             H-OPER-IME-TEACH.
278800
278900     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
279000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
279100             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
279200
279300***********************************************************
279400***       NEUROSTIMULATOR CASES
279500***********************************************************
279600
279700     IF '8698   ' =  B-PRIN-PROC-CODE   OR
279800                     B-OTHER-PROC-CODE1 OR
279900                     B-OTHER-PROC-CODE2 OR
280000                     B-OTHER-PROC-CODE3 OR
280100                     B-OTHER-PROC-CODE4 OR
280200                     B-OTHER-PROC-CODE5
280300           NEXT SENTENCE
280400     ELSE
280500           MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO
280600           GO TO 4000-CHECK-GRAFT-CASES.
280700
280800     MOVE 18640.00 TO H-CSTMED-NEURO.
280900
281000     COMPUTE H-LESSER-NEURO-1 ROUNDED =
281100             .5 * H-CSTMED-NEURO.
281200
281300     COMPUTE H-LESSER-NEURO-2 ROUNDED =
281400           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
281500                     H-BASE-DRG-PAYMENT) * .5.
281600
281700     IF H-LESSER-NEURO-2 > 0
281800        IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2
281900           MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO
282000        ELSE
282100           MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO
282200     ELSE
282300        MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.
282400
282500 4000-CHECK-GRAFT-CASES.
282600***********************************************************
282700***      GRAFT (GORE TAG) CASES
282800***********************************************************
282900
283000     IF '3973   ' =  B-PRIN-PROC-CODE   OR
283100                     B-OTHER-PROC-CODE1 OR
283200                     B-OTHER-PROC-CODE2 OR
283300                     B-OTHER-PROC-CODE3 OR
283400                     B-OTHER-PROC-CODE4 OR
283500                     B-OTHER-PROC-CODE5
283600           NEXT SENTENCE
283700     ELSE
283800           MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT
283900           GO TO 4000-CHECK-KINETRA-CASES.
284000
284100     MOVE 21198.00 TO H-CSTMED-GRAFT.
284200
284300     COMPUTE H-LESSER-GRAFT-1 ROUNDED =
284400             .5 * H-CSTMED-GRAFT.
284500
284600     COMPUTE H-LESSER-GRAFT-2 ROUNDED =
284700           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
284800                     H-BASE-DRG-PAYMENT) * .5.
284900
285000     IF H-LESSER-GRAFT-2 > 0
285100        IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2
285200           MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT
285300        ELSE
285400           MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT
285500     ELSE
285600        MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.
285700
285800 4000-CHECK-KINETRA-CASES.
285900***********************************************************
286000***      KINETRA CASES
286100***********************************************************
286200
286300     IF '0293   ' =  B-PRIN-PROC-CODE   OR
286400                     B-OTHER-PROC-CODE1 OR
286500                     B-OTHER-PROC-CODE2 OR
286600                     B-OTHER-PROC-CODE3 OR
286700                     B-OTHER-PROC-CODE4 OR
286800                     B-OTHER-PROC-CODE5
286900           NEXT SENTENCE
287000     ELSE
287100           MOVE ZEROES TO H-NEW-TECH-ADDON-KINETRA
287200           GO TO 4000-ADD-TECH-CASES.
287300
287400     IF '8695   ' =  B-PRIN-PROC-CODE   OR
287500                     B-OTHER-PROC-CODE1 OR
287600                     B-OTHER-PROC-CODE2 OR
287700                     B-OTHER-PROC-CODE3 OR
287800                     B-OTHER-PROC-CODE4 OR
287900                     B-OTHER-PROC-CODE5
288000           NEXT SENTENCE
288100     ELSE
288200           MOVE ZEROES TO H-NEW-TECH-ADDON-KINETRA
288300           GO TO 4000-ADD-TECH-CASES.
288400
288500     MOVE 16570.00 TO H-CSTMED-KINETRA.
288600
288700     COMPUTE H-LESSER-KINETRA-1 ROUNDED =
288800             .5 * H-CSTMED-KINETRA.
288900
289000     COMPUTE H-LESSER-KINETRA-2 ROUNDED =
289100           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
289200                     H-BASE-DRG-PAYMENT) * .5.
289300
289400     IF H-LESSER-KINETRA-2 > 0
289500        IF H-LESSER-KINETRA-1 < H-LESSER-KINETRA-2
289600         MOVE H-LESSER-KINETRA-1 TO H-NEW-TECH-ADDON-KINETRA
289700        ELSE
289800         MOVE H-LESSER-KINETRA-2 TO H-NEW-TECH-ADDON-KINETRA
289900     ELSE
290000        MOVE ZEROES          TO H-NEW-TECH-ADDON-KINETRA.
290100
290200
290300 4000-ADD-TECH-CASES.
290400
290500     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
290600             H-NEW-TECH-ADDON-NEURO  +
290700             H-NEW-TECH-ADDON-GRAFT +
290800             H-NEW-TECH-ADDON-KINETRA.
290900
291000 4000-EXIT.    EXIT.
291100
291200******        L A S T   S O U R C E   S T A T E M E N T   *****
