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