IBYPSP1 ;ALB/CXW-IB*2.0*427 POST INIT: UPDATE REVENUE CODE CPT LINKS ; 01/12/10
;;2.0;INTEGRATED BILLING;**427**;21-MAR-94;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
;
RVD ; delete all Revenue Code - CPT links (363.33)
N IBA,IBSGFN,IBRVLN,IBCNT,DA,DIK,DIC,X,Y S IBCNT=0
;
S IBSGFN=$O(^IBE(363.32,"B","STANDARD RVCD LINKS",0)) I 'IBSGFN D MSG(" ** STANDARD RVCD LINKS Special Group not found, no links deleted.")
;
S IBRVLN=0 F S IBRVLN=$O(^IBE(363.33,IBRVLN)) Q:'IBRVLN D
. I +$P($G(^IBE(363.33,IBRVLN,0)),U,2)'=IBSGFN Q
. S DA=IBRVLN,DIK="^IBE(363.33," D ^DIK K DA,DIK S IBCNT=IBCNT+1
;
RVDQ S IBA(1)=" >> "_IBCNT_" Old Revenue Code - CPT Links deleted (363.33)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
RVL ; add Revenue Codes - CPT links
N IBA,IBLN,IBTX,IBJ,IBI,IBSGFN,IBRV,IBRVFN,IBRVLN,IBCPT1,IBCPT2,IBCPT1N,IBCPT2N,IBCNT,DD,DO,DIC,DIE,DA,DR,X,Y,DLAYGO
S IBCNT=0
;
S IBSGFN=$O(^IBE(363.32,"B","STANDARD RVCD LINKS",0))
I 'IBSGFN D MSG(" ** STANDARD RVCD LINKS Special Group not found, no links added.")
I +IBSGFN D
. F IBI=1:1 S IBTX=$P($T(FRVL+IBI),";;",2) Q:IBTX="" D
.. F IBJ=1:1 S IBLN=$P(IBTX,",",IBJ) Q:IBLN="" D RVLA
. D ^IBYPSP2,^IBYPSP3,^IBYPSP4
;
RVLQ S IBA(1)=" >> "_IBCNT_" New Revenue Code - CPT Links added(363.33)..." D MSG(" ")
D MES^XPDUTL(.IBA)
Q
;
RVLA ; add the links to (363.33)
S IBRV=$P(IBLN,U,1) Q:IBRV'?3N
;
S IBRVFN=$O(^DGCR(399.2,"B",IBRV,0)) Q:'IBRVFN
S IBRVLN=$G(^DGCR(399.2,+IBRVFN,0)) Q:IBRVLN=""
I $P(IBRVLN,U,2)["*RESERVED" Q
;
Q:$P(IBLN,U,2)=""
S IBCPT1=$P(IBLN,U,2),IBCPT1N=+$$CPT^ICPTCOD(IBCPT1,DT) I IBCPT1N<1 Q
S IBCPT2=$P(IBLN,U,3),IBCPT2N="" I IBCPT2'="" S IBCPT2N=+$$CPT^ICPTCOD(IBCPT2,DT) I IBCPT2N<1 Q
;
I $O(^IBE(363.33,"AGP",IBSGFN,+IBCPT1N,0)) D MSG(" ** "_IBLN_" not added, a link already exists for "_IBCPT1) Q
;
S DIC("DR")=".02////"_+IBSGFN_";.03////"_+IBCPT1N I +IBCPT2N S DIC("DR")=DIC("DR")_";.04////"_+IBCPT2N
K DD,DO S DLAYGO=363.33,DIC="^IBE(363.33,",DIC(0)="L",X=+IBRVFN D FILE^DICN K DIC,X,Y,DD,DO S IBCNT=IBCNT+1
;
Q
;
MSG(X) ;
N IBX S IBX=$O(IBA(999999),-1) S:'IBX IBX=1 S IBX=IBX+1
S IBA(IBX)=$G(X)
Q
;
FRVL ; revenue code - CPT links
;;160^S0201^,240^G0384^,250^64612^64614,250^64650^64653,250^99605^99607,
;;250^C9113^,250^J0120^,250^J0133^,250^J0170^,250^J0275^,
;;250^J0280^,250^J0285^,250^J0295^,250^J0360^,250^J0456^,
;;250^J0500^,250^J0570^,250^J0595^,250^J0610^,250^J0690^,
;;250^J0694^,250^J0697^,250^J0702^,250^J0706^J0715,250^J0720^,
;;250^J0743^J0745,250^J0760^,250^J0780^,250^J0895^J0900,250^J0945^,
;;250^J1000^,250^J1020^J1040,250^J1051^J1080,250^J1094^,250^J1100^J1120,
;;250^J1160^,250^J1165^J1180,250^J1200^,250^J1230^J1250,250^J1265^,
;;250^J1270^,250^J1325^,250^J1335^,250^J1364^,250^J1380^J1390,
;;250^J1435^,250^J1450^,250^J1570^,250^J1580^,250^J1600^,
;;250^J1630^J1631,250^J1642^J1650,250^J1700^J1720,250^J1790^J1817,250^J1825^,
;;250^J1840^J1850,250^J1885^J1890,250^J1940^,250^J1955^J1956,250^J1980^J1990,
;;250^J2001^J2010,250^J2060^,250^J2150^,250^J2170^J2185,250^J2210^,
;;250^J2250^J2275,250^J2280^,250^J2300^J2310,250^J2320^J2322,250^J2354^,
;;250^J2360^J2370,250^J2400^,250^J2410^,250^J2440^,250^J2501^,
;;250^J2510^,250^J2540^J2543,250^J2550^J2560,250^J2597^,250^J2650^,
;;250^J2680^J2720,250^J2760^J2765,250^J2780^,250^J2795^,250^J2800^,
;;250^J2810^,250^J2910^,250^J2950^,250^J3105^J3150,250^J3230^,
;;250^J3250^J3265,250^J3301^J3303,250^J3310^,250^J3360^J3364,250^J3370^,
;;250^J3410^J3430,250^J3470^J3471,250^J3475^J3486,250^J3490^,250^J3535^,
;;250^J3590^,250^J7300^J7302,250^J7330^,250^J7500^,250^J7506^,
;;250^J7509^J7510,250^J7599^,250^J7609^,250^J7611^J7615,250^J7620^,
;;250^J7635^J7638,250^J7640^,250^J7642^J7645,250^J7668^J7669,250^J7674^,
;;250^J7680^,250^J7683^,250^J7699^J7799,250^J8499^,250^J8530^J8540,
;;250^J8597^,250^J8610^,250^J8999^J9000,250^J9040^,250^J9045^,
;;250^J9060^J9062,250^J9070^J9092,250^J9094^J9097,250^J9100^,250^J9130^J9140,
;;250^J9181^,250^J9190^,250^J9212^,250^J9230^,250^J9250^,
;;250^J9360^J9380,250^J9999^,250^Q2004^,250^Q3025^,250^S5550^S5551,
;;251^90692^,251^S0020^,251^S0023^,251^S0028^,251^S0030^S0032,
;;251^S0039^S0040,251^S0073^S0078,251^S0080^S0081,251^S0091^S0093,251^S0108^S0109,
;;251^S0122^,251^S0132^,251^S0145^S0146,251^S0164^,251^S0166^,
;;251^S0171^,251^S0181^S0183,251^S5000^,252^S0136^,252^S0178^,
;;252^S5010^,257^A9150^,258^S5012^S5013,259^S9430^,260^C8957^,
;;264^S1015^S1016,270^99070^,270^A4220^A4231,270^A4233^,270^A4235^,
;;270^A4248^A4250,270^A4256^,270^A4265^,270^A4270^A4280,270^A4290^,
;;270^A4367^,270^A4371^,270^A4490^A4510,270^A4550^A4554,270^A6154^,
;;270^Q4006^,270^Q4009^Q4010,270^Q4013^Q4014,270^Q4018^,270^Q4021^Q4022,
;;270^Q4038^,270^Q4040^,270^Q4045^Q4046,270^Q4049^Q4051,271^99071^,
;;271^A4561^A4562,271^A6411^A6412,271^A6442^,271^L8622^,272^A4206^,
;;272^A4208^A4209,272^A4212^A4213,272^A4215^A4218,272^A4232^,272^A4245^,
;;272^A4305^A4311,272^A4313^A4316,272^A4320^A4322,272^A4331^A4335,272^A4338^A4340,
;;272^A4344^,272^A4346^,272^A4349^,272^A4351^A4358,272^A4362^,
;;272^A4364^,272^A4393^A4394,272^A4396^,272^A4398^A4399,272^A4402^,
;;272^A4406^,272^A4414^,272^A4421^,272^A4424^,272^A4450^A4452,
;;272^A4455^,272^A4461^,272^A4465^,272^A4481^A4483,272^A4606^A4608,
;;272^A4623^A4624,272^A4649^,272^A4657^,272^A5081^,272^A6000^,
;;272^A6021^A6022,272^A6024^A6025,272^A6196^A6197,272^A6203^A6213,272^A6216^,
;;272^A6218^A6228,272^A6230^A6231,272^A6233^A6235,272^A6237^A6238,272^A6242^,
;;272^A6245^,272^A6248^,272^A6251^A6255,272^A6257^,272^A6266^A6404,
;;272^A6407^A6410,272^A6441^,272^A6445^A6446,272^A6448^A6450,272^A6452^,
;;272^A6454^A6457,272^A6533^A6541,272^A6544^,272^A6549^A6550,272^A7000^A7017,
;;272^A7026^A7039,272^A7041^,272^A7043^A7046,272^B4081^,272^B4087^,
;;272^B4150^,272^B4178^,272^B4185^,272^B4189^,272^B4199^,
;;272^B9000^B9004,272^B9998^,272^C1725^,272^C1753^,272^C1874^C1877,
;;272^C1885^,272^C9727^,272^Q9960^,272^Q9964^,273^A4211^,
;;273^A4253^,273^A4258^A4259,273^S5199^,273^S8420^S8421,273^S8424^,
;;273^S8427^,273^S8429^S8431,273^S8490^,274^0108T^,274^A4565^,
;;274^A4625^A4629,274^A5051^,274^A5055^,274^A5102^A5112,274^A5114^,
;;274^A5120^,274^A5126^,274^A5200^A5501,274^A5503^A5508,274^A5510^,
;;274^A5512^A5513,274^A6530^A6532,274^A7503^A7505,274^A7507^A7527,274^A9281^,
;;274^E1700^,274^E1800^E1801,274^E1805^E1810,274^E1812^E1820,274^E1825^E1841,
;;274^E1902^,274^L0120^L0190,274^L0220^,274^L0450^L0454,274^L0460^L0464,
;;274^L0468^L0472,274^L0480^L0488,274^L0491^L0492,274^L0621^L0631,274^L0633^L0635,
;;274^L0637^L0640,274^L0970^L0976,274^L0980^L0984,274^L0999^,274^L1030^L1040,
;;274^L1080^,274^L1090^,274^L1120^,274^L1250^,274^L1270^L1300,
;;274^L1499^,274^L1510^,274^L1600^,274^L1640^,274^L1686^L1690,
;;274^L1810^,274^L1820^,274^L1830^L1850,274^L1860^,274^L1900^,
;;274^L1902^L2000,274^L2010^L2030,274^L2036^L2038,274^L2060^,274^L2108^,
;;274^L2112^L2114,274^L2128^,274^L2180^,274^L2190^,274^L2200^L2232,
;;274^L2250^L2300,274^L2320^L2330,274^L2340^L2360,274^L2380^L2397,274^L2405^,
;;274^L2415^,274^L2425^L2430,274^L2550^,274^L2580^,274^L2624^,
;;274^L2680^,274^L2755^L2760,274^L2780^,274^L2795^L2850,274^L2999^,
;;274^L3001^L3100,274^L3160^L3170,274^L3206^,274^L3211^,274^L3215^L3217,
;;274^L3219^L3222,274^L3224^L3320,274^L3332^L3370,274^L3390^L3450,274^L3460^L3465,
;;274^L3480^L3540,274^L3560^L3630,274^L3649^L3650,274^L3660^L3670,274^L3675^L3677,
;;274^L3702^L3720,274^L3760^L3764,274^L3806^L3808,274^L3900^L3901,274^L3904^L3906,
;;274^L3908^,274^L3912^L3913,274^L3915^,274^L3917^,274^L3919^,
;;274^L3923^,274^L3925^,274^L3927^,274^L3929^,274^L3931^,
;;274^L3933^,274^L3980^L3984,274^L3995^L4002,274^L4050^L4055,274^L4205^L4210,
;;274^L4350^L4386,274^L4392^L5000,274^L5020^,274^L5100^,274^L5150^,
;;274^L5200^,274^L5250^L5280,274^L5301^,274^L5311^,274^L5321^,
;;274^L5400^,274^L5500^,274^L5530^,274^L5540^,274^L5590^,
;;274^L5611^,274^L5616^,274^L5620^,274^L5624^,274^L5629^,
;;274^L5631^L5632,274^L5637^,274^L5645^,274^L5647^,274^L5649^L5652,
;;274^L5655^,274^L5665^L5666,274^L5668^,274^L5670^L5671,274^L5673^,
;;274^L5679^L5681,274^L5683^L5685,274^L5688^,274^L5695^L5696,274^L5698^,
;;274^L5700^L5702,274^L5704^L5706,274^L5728^,274^L5781^L5785,274^L5812^L5814,
;;274^L5824^,274^L5828^,274^L5845^,274^L5848^L5850,274^L5856^,
;;274^L5910^L5950,274^L5962^L5964,274^L5970^,274^L5972^,274^L5974^L5981,
;;274^L5984^,274^L5986^L5988,274^L5990^,274^L5999^L6000,274^L6050^,
;;274^L6100^,274^L6250^,274^L6310^,274^L6400^,274^L6580^,
;;274^L6605^L6620,274^L6624^,274^L6629^,274^L6632^,274^L6640^L6641,
;;274^L6645^,274^L6660^L6676,274^L6680^,274^L6686^L6687,274^L6691^L6692,
;;274^L6703^,274^L6706^,274^L6722^,274^L6881^L6882,274^L6890^L6900,
;;274^L6935^,274^L7009^,274^L7040^,274^L7274^,274^L7360^,
;;274^L7364^L7368,274^L7401^,274^L7403^L7404,274^L7499^L7600,274^L7900^L8001,
;;274^L8010^,274^L8020^L8030,274^L8039^,274^L8300^L8485,274^L8499^L8511,
;;274^L8513^,274^L8619^,274^L8681^,274^L8687^,274^L8689^L8691,
;;274^L9900^,274^Q0481^,274^S0500^S0510,274^S0580^,274^V2410^V2500,
;;274^V2510^,274^V2513^V2522,274^V2599^,274^V2615^,274^V2623^V2624,
;;274^V2627^V2629,274^V5268^V5269,274^V5273^V5274,274^V5298^,274^V5336^,
;;275^C1721^C1722,275^C1777^,275^C1779^,275^C1785^C1786,275^C1882^,
;;275^C1895^C1896,275^C1898^C1900,275^C2619^C2621,276^C1780^,276^V2630^V2632,
;;277^S8120^S8121,278^C1713^,278^C1716^,278^C1726^C1727,278^C1729^C1752,
;;278^C1755^,278^C1757^C1764,278^C1766^C1772,278^C1776^,278^C1778^,
;;278^C1781^,278^C1783^C1784,278^C1787^C1789,278^C1813^,278^C1815^C1816,
;;278^C1819^C1820,278^C1878^C1881,278^C1887^,278^C1892^C1894,278^C1897^,
;;278^C2617^C2618,278^C2622^C2631,278^C2634^C2635,278^C2638^C2639,278^C2641^,
;;278^E0785^,278^L8600^L8603,278^L8606^,278^L8610^,278^L8612^L8615,
;;278^L8630^,278^L8641^L8642,278^L8658^,278^L8670^L8680,278^L8699^,
;;278^V2788^,279^A5073^,279^A9270^,279^A9275^,279^A9279^,
;;279^S8185^S8189,279^S8450^S8452,279^T2029^,279^V5266^V5267,290^A9280^,
;;290^A9282^,290^A9300^,290^E0100^E0114,290^E0116^E0118,290^E0130^E0141,
;;290^E0143^E0144,290^E0147^E0149,290^E0153^E0163,290^E0165^,290^E0167^E0168,
;;290^E0170^E0172,290^E0181^E0182,290^E0184^E0186,290^E0188^E0191,290^E0193^E0194,
;;290^E0196^E0218,290^E0221^E0230,290^E0235^E0236,290^E0238^E0251,290^E0255^E0280,
;;290^E0295^E0297,290^E0301^E0316,290^E0325^E0326,290^E0370^E0373,290^E0424^E0431,
;;290^E0434^E0450,290^E0457^,290^E0460^E0461,290^E0464^E0484,290^E0487^E0500,
;;290^E0555^E0571,290^E0580^E0585,290^E0600^E0601,290^E0603^E0605,290^E0607^,
;;290^E0610^E0615,290^E0617^E0619,290^E0621^E0652,290^E0660^,290^E0667^E0669,
;;290^E0671^E0672,290^E0675^,290^E0691^,290^E0700^,290^E0705^E0731,
;;290^E0745^,290^E0747^E0748,290^E0762^E0776,290^E0779^,290^E0781^,
;;290^E0784^,290^E0791^,290^E0840^E0912,290^E0930^E0941,290^E0944^E0945,
;;290^E0955^E0961,290^E0966^E0971,290^E0973^E0974,290^E0978^,290^E0980^E0990,
;;290^E0992^,290^E0994^E0995,290^E1002^E1005,290^E1007^E1008,290^E1010^,
;;290^E1015^,290^E1020^,290^E1028^E1029,290^E1031^E1035,290^E1038^E1039,
;;290^E1050^E1060,290^E1070^,290^E1083^E1090,290^E1092^E1110,290^E1130^E1170,
;;290^E1172^E1200,290^E1220^E1221,290^E1223^E1226,290^E1228^,290^E1230^,
;;290^E1240^E1298,290^E1300^,290^E1353^,290^E1355^,290^E1390^E1392,
;;290^E1399^,290^E1405^E1406,290^E2100^,290^E2201^,290^E2203^E2216,
;;290^E2218^E2222,290^E2224^E2226,290^E2231^,290^E2300^,290^E2310^E2313,
;;290^E2321^E2326,290^E2331^E2371,290^E2373^E2374,290^E2376^E2387,290^E2391^,
;;290^E2394^,290^E2396^E2397,290^E2402^E2500,290^E2504^,290^E2508^E2615,
;;290^E2617^,290^E2619^E2621,290^K0001^,290^K0003^K0007,290^K0009^K0012,
;;290^K0014^,290^K0800^K0813,290^K0822^K0823,290^K0835^K0837,290^K0848^K0852,
;;290^K0856^,290^K0861^,290^K0869^,290^K0884^,290^K0891^K0899,
;;290^V5270^,290^V5272^,292^A5072^,292^K0015^,292^K0017^K0020,
;;292^K0037^K0047,292^K0051^K0053,292^K0056^,292^K0065^,292^K0069^K0073,
;;292^K0077^,292^K0108^,292^K0195^,292^K0601^,292^K0606^K0607,
;;292^K0609^,292^K0669^,292^K0733^K0737,292^L3969^L3970,292^L3974^,
;;292^S8096^,292^S8100^S8101,292^V2020^V2025,292^V2100^,292^V2200^V2201,
;;292^V2203^,292^V2220^,292^V2300^,292^V2319^,292^V2399^,
;;292^V2600^V2610,292^V2700^V2702,292^V2715^V2718,292^V2744^V2745,292^V2781^,
;;292^V2784^V2785,292^V2797^,292^V5050^V5060,292^V5090^,292^V5100^V5110,
;;292^V5130^V5140,292^V5160^,292^V5180^,292^V5200^,292^V5241^,
;;292^V5245^V5247,292^V5250^V5253,292^V5255^V5261,292^V5263^V5265,292^V5271^,
;;294^A4556^A4558,294^A4570^,294^A4580^,294^A4590^,294^A4595^,
;;294^A4600^,294^A4611^,294^A4613^A4618,294^A4620^,294^A4630^,
;;294^A4633^,294^A4635^A4637,294^A4639^A4640,294^A4648^,294^E0950^E0952,
;;294^J7622^,299^A8000^A8001,299^A9900^A9999,300^89050^89100,300^89125^,
;;300^89140^89141,300^89190^,300^89220^,300^89230^,300^89240^,
;;300^89260^,300^89300^89322,300^89329^,300^99000^,300^G0103^,
;;300^G0306^,301^80047^80048,301^80050^80051,301^80053^,301^80055^,
;;301^80061^,301^80069^,301^80074^,301^80076^,301^80100^80166,
;;301^80170^80400,301^80406^80414,301^80416^,301^80418^80422,301^80426^80428,
;;301^80432^,301^80435^,301^80438^80440,301^82000^82003,301^82009^82010,
;;301^82013^,301^82024^82030,301^82040^82055,301^82075^,301^82085^,
;;301^82088^,301^82101^82108,301^82120^,301^82127^,301^82131^,
;;301^82135^,301^82139^82140,301^82143^82150,301^82157^,301^82160^82164,
;;301^82172^,301^82175^82205,301^82232^,301^82239^82240,301^82247^82248,
;;301^82261^,301^82270^82272,301^82274^,301^82300^,301^82306^,
;;301^82308^82310,301^82330^82331,301^82340^,301^82355^82370,301^82373^82397,
;;301^82415^,301^82435^82436,301^82438^,301^82465^,301^82480^82482,
;;301^82485^82486,301^82488^82489,301^82491^82495,301^82507^,301^82520^82525,
;;301^82528^,301^82530^,301^82533^,301^82540^82544,301^82550^82554,
;;301^82565^82600,301^82607^82610,301^82615^,301^82626^82627,301^82633^82634,
;;301^82646^82658,301^82664^82672,301^82677^,301^82679^82690,301^82705^82715,
;;301^82725^82726,301^82728^,301^82731^82735,301^82742^,301^82746^82747,
;;301^82757^82759,301^82784^82785,301^82787^,301^82800^,301^82803^,
;;301^82805^82810,301^82820^82926,301^82938^82941,301^82943^,301^82945^82948,
;;301^82950^82953,301^82955^82960,301^82962^82977,301^82979^,301^82985^,
;;301^83001^83003,301^83009^83010,301^83012^83018,301^83020^83037,301^83045^83051,
;;301^83060^83070,301^83088^83090,301^83150^,301^83491^,301^83497^83498,
;;301^83500^83505,301^83525^,301^83527^83528,301^83540^,301^83550^,
;;
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYPSP1 14819 printed Oct 16, 2024@18:37:25 Page 2
IBYPSP1 ;ALB/CXW-IB*2.0*427 POST INIT: UPDATE REVENUE CODE CPT LINKS ; 01/12/10
+1 ;;2.0;INTEGRATED BILLING;**427**;21-MAR-94;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ;
RVD ; delete all Revenue Code - CPT links (363.33)
+1 NEW IBA,IBSGFN,IBRVLN,IBCNT,DA,DIK,DIC,X,Y
SET IBCNT=0
+2 ;
+3 SET IBSGFN=$ORDER(^IBE(363.32,"B","STANDARD RVCD LINKS",0))
IF 'IBSGFN
DO MSG(" ** STANDARD RVCD LINKS Special Group not found, no links deleted.")
+4 ;
+5 SET IBRVLN=0
FOR
SET IBRVLN=$ORDER(^IBE(363.33,IBRVLN))
if 'IBRVLN
QUIT
Begin DoDot:1
+6 IF +$PIECE($GET(^IBE(363.33,IBRVLN,0)),U,2)'=IBSGFN
QUIT
+7 SET DA=IBRVLN
SET DIK="^IBE(363.33,"
DO ^DIK
KILL DA,DIK
SET IBCNT=IBCNT+1
End DoDot:1
+8 ;
RVDQ SET IBA(1)=" >> "_IBCNT_" Old Revenue Code - CPT Links deleted (363.33)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVL ; add Revenue Codes - CPT links
+1 NEW IBA,IBLN,IBTX,IBJ,IBI,IBSGFN,IBRV,IBRVFN,IBRVLN,IBCPT1,IBCPT2,IBCPT1N,IBCPT2N,IBCNT,DD,DO,DIC,DIE,DA,DR,X,Y,DLAYGO
+2 SET IBCNT=0
+3 ;
+4 SET IBSGFN=$ORDER(^IBE(363.32,"B","STANDARD RVCD LINKS",0))
+5 IF 'IBSGFN
DO MSG(" ** STANDARD RVCD LINKS Special Group not found, no links added.")
+6 IF +IBSGFN
Begin DoDot:1
+7 FOR IBI=1:1
SET IBTX=$PIECE($TEXT(FRVL+IBI),";;",2)
if IBTX=""
QUIT
Begin DoDot:2
+8 FOR IBJ=1:1
SET IBLN=$PIECE(IBTX,",",IBJ)
if IBLN=""
QUIT
DO RVLA
End DoDot:2
+9 DO ^IBYPSP2
DO ^IBYPSP3
DO ^IBYPSP4
End DoDot:1
+10 ;
RVLQ SET IBA(1)=" >> "_IBCNT_" New Revenue Code - CPT Links added(363.33)..."
DO MSG(" ")
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
+3 ;
RVLA ; add the links to (363.33)
+1 SET IBRV=$PIECE(IBLN,U,1)
if IBRV'?3N
QUIT
+2 ;
+3 SET IBRVFN=$ORDER(^DGCR(399.2,"B",IBRV,0))
if 'IBRVFN
QUIT
+4 SET IBRVLN=$GET(^DGCR(399.2,+IBRVFN,0))
if IBRVLN=""
QUIT
+5 IF $PIECE(IBRVLN,U,2)["*RESERVED"
QUIT
+6 ;
+7 if $PIECE(IBLN,U,2)=""
QUIT
+8 SET IBCPT1=$PIECE(IBLN,U,2)
SET IBCPT1N=+$$CPT^ICPTCOD(IBCPT1,DT)
IF IBCPT1N<1
QUIT
+9 SET IBCPT2=$PIECE(IBLN,U,3)
SET IBCPT2N=""
IF IBCPT2'=""
SET IBCPT2N=+$$CPT^ICPTCOD(IBCPT2,DT)
IF IBCPT2N<1
QUIT
+10 ;
+11 IF $ORDER(^IBE(363.33,"AGP",IBSGFN,+IBCPT1N,0))
DO MSG(" ** "_IBLN_" not added, a link already exists for "_IBCPT1)
QUIT
+12 ;
+13 SET DIC("DR")=".02////"_+IBSGFN_";.03////"_+IBCPT1N
IF +IBCPT2N
SET DIC("DR")=DIC("DR")_";.04////"_+IBCPT2N
+14 KILL DD,DO
SET DLAYGO=363.33
SET DIC="^IBE(363.33,"
SET DIC(0)="L"
SET X=+IBRVFN
DO FILE^DICN
KILL DIC,X,Y,DD,DO
SET IBCNT=IBCNT+1
+15 ;
+16 QUIT
+17 ;
MSG(X) ;
+1 NEW IBX
SET IBX=$ORDER(IBA(999999),-1)
if 'IBX
SET IBX=1
SET IBX=IBX+1
+2 SET IBA(IBX)=$GET(X)
+3 QUIT
+4 ;
FRVL ; revenue code - CPT links
+1 ;;160^S0201^,240^G0384^,250^64612^64614,250^64650^64653,250^99605^99607,
+2 ;;250^C9113^,250^J0120^,250^J0133^,250^J0170^,250^J0275^,
+3 ;;250^J0280^,250^J0285^,250^J0295^,250^J0360^,250^J0456^,
+4 ;;250^J0500^,250^J0570^,250^J0595^,250^J0610^,250^J0690^,
+5 ;;250^J0694^,250^J0697^,250^J0702^,250^J0706^J0715,250^J0720^,
+6 ;;250^J0743^J0745,250^J0760^,250^J0780^,250^J0895^J0900,250^J0945^,
+7 ;;250^J1000^,250^J1020^J1040,250^J1051^J1080,250^J1094^,250^J1100^J1120,
+8 ;;250^J1160^,250^J1165^J1180,250^J1200^,250^J1230^J1250,250^J1265^,
+9 ;;250^J1270^,250^J1325^,250^J1335^,250^J1364^,250^J1380^J1390,
+10 ;;250^J1435^,250^J1450^,250^J1570^,250^J1580^,250^J1600^,
+11 ;;250^J1630^J1631,250^J1642^J1650,250^J1700^J1720,250^J1790^J1817,250^J1825^,
+12 ;;250^J1840^J1850,250^J1885^J1890,250^J1940^,250^J1955^J1956,250^J1980^J1990,
+13 ;;250^J2001^J2010,250^J2060^,250^J2150^,250^J2170^J2185,250^J2210^,
+14 ;;250^J2250^J2275,250^J2280^,250^J2300^J2310,250^J2320^J2322,250^J2354^,
+15 ;;250^J2360^J2370,250^J2400^,250^J2410^,250^J2440^,250^J2501^,
+16 ;;250^J2510^,250^J2540^J2543,250^J2550^J2560,250^J2597^,250^J2650^,
+17 ;;250^J2680^J2720,250^J2760^J2765,250^J2780^,250^J2795^,250^J2800^,
+18 ;;250^J2810^,250^J2910^,250^J2950^,250^J3105^J3150,250^J3230^,
+19 ;;250^J3250^J3265,250^J3301^J3303,250^J3310^,250^J3360^J3364,250^J3370^,
+20 ;;250^J3410^J3430,250^J3470^J3471,250^J3475^J3486,250^J3490^,250^J3535^,
+21 ;;250^J3590^,250^J7300^J7302,250^J7330^,250^J7500^,250^J7506^,
+22 ;;250^J7509^J7510,250^J7599^,250^J7609^,250^J7611^J7615,250^J7620^,
+23 ;;250^J7635^J7638,250^J7640^,250^J7642^J7645,250^J7668^J7669,250^J7674^,
+24 ;;250^J7680^,250^J7683^,250^J7699^J7799,250^J8499^,250^J8530^J8540,
+25 ;;250^J8597^,250^J8610^,250^J8999^J9000,250^J9040^,250^J9045^,
+26 ;;250^J9060^J9062,250^J9070^J9092,250^J9094^J9097,250^J9100^,250^J9130^J9140,
+27 ;;250^J9181^,250^J9190^,250^J9212^,250^J9230^,250^J9250^,
+28 ;;250^J9360^J9380,250^J9999^,250^Q2004^,250^Q3025^,250^S5550^S5551,
+29 ;;251^90692^,251^S0020^,251^S0023^,251^S0028^,251^S0030^S0032,
+30 ;;251^S0039^S0040,251^S0073^S0078,251^S0080^S0081,251^S0091^S0093,251^S0108^S0109,
+31 ;;251^S0122^,251^S0132^,251^S0145^S0146,251^S0164^,251^S0166^,
+32 ;;251^S0171^,251^S0181^S0183,251^S5000^,252^S0136^,252^S0178^,
+33 ;;252^S5010^,257^A9150^,258^S5012^S5013,259^S9430^,260^C8957^,
+34 ;;264^S1015^S1016,270^99070^,270^A4220^A4231,270^A4233^,270^A4235^,
+35 ;;270^A4248^A4250,270^A4256^,270^A4265^,270^A4270^A4280,270^A4290^,
+36 ;;270^A4367^,270^A4371^,270^A4490^A4510,270^A4550^A4554,270^A6154^,
+37 ;;270^Q4006^,270^Q4009^Q4010,270^Q4013^Q4014,270^Q4018^,270^Q4021^Q4022,
+38 ;;270^Q4038^,270^Q4040^,270^Q4045^Q4046,270^Q4049^Q4051,271^99071^,
+39 ;;271^A4561^A4562,271^A6411^A6412,271^A6442^,271^L8622^,272^A4206^,
+40 ;;272^A4208^A4209,272^A4212^A4213,272^A4215^A4218,272^A4232^,272^A4245^,
+41 ;;272^A4305^A4311,272^A4313^A4316,272^A4320^A4322,272^A4331^A4335,272^A4338^A4340,
+42 ;;272^A4344^,272^A4346^,272^A4349^,272^A4351^A4358,272^A4362^,
+43 ;;272^A4364^,272^A4393^A4394,272^A4396^,272^A4398^A4399,272^A4402^,
+44 ;;272^A4406^,272^A4414^,272^A4421^,272^A4424^,272^A4450^A4452,
+45 ;;272^A4455^,272^A4461^,272^A4465^,272^A4481^A4483,272^A4606^A4608,
+46 ;;272^A4623^A4624,272^A4649^,272^A4657^,272^A5081^,272^A6000^,
+47 ;;272^A6021^A6022,272^A6024^A6025,272^A6196^A6197,272^A6203^A6213,272^A6216^,
+48 ;;272^A6218^A6228,272^A6230^A6231,272^A6233^A6235,272^A6237^A6238,272^A6242^,
+49 ;;272^A6245^,272^A6248^,272^A6251^A6255,272^A6257^,272^A6266^A6404,
+50 ;;272^A6407^A6410,272^A6441^,272^A6445^A6446,272^A6448^A6450,272^A6452^,
+51 ;;272^A6454^A6457,272^A6533^A6541,272^A6544^,272^A6549^A6550,272^A7000^A7017,
+52 ;;272^A7026^A7039,272^A7041^,272^A7043^A7046,272^B4081^,272^B4087^,
+53 ;;272^B4150^,272^B4178^,272^B4185^,272^B4189^,272^B4199^,
+54 ;;272^B9000^B9004,272^B9998^,272^C1725^,272^C1753^,272^C1874^C1877,
+55 ;;272^C1885^,272^C9727^,272^Q9960^,272^Q9964^,273^A4211^,
+56 ;;273^A4253^,273^A4258^A4259,273^S5199^,273^S8420^S8421,273^S8424^,
+57 ;;273^S8427^,273^S8429^S8431,273^S8490^,274^0108T^,274^A4565^,
+58 ;;274^A4625^A4629,274^A5051^,274^A5055^,274^A5102^A5112,274^A5114^,
+59 ;;274^A5120^,274^A5126^,274^A5200^A5501,274^A5503^A5508,274^A5510^,
+60 ;;274^A5512^A5513,274^A6530^A6532,274^A7503^A7505,274^A7507^A7527,274^A9281^,
+61 ;;274^E1700^,274^E1800^E1801,274^E1805^E1810,274^E1812^E1820,274^E1825^E1841,
+62 ;;274^E1902^,274^L0120^L0190,274^L0220^,274^L0450^L0454,274^L0460^L0464,
+63 ;;274^L0468^L0472,274^L0480^L0488,274^L0491^L0492,274^L0621^L0631,274^L0633^L0635,
+64 ;;274^L0637^L0640,274^L0970^L0976,274^L0980^L0984,274^L0999^,274^L1030^L1040,
+65 ;;274^L1080^,274^L1090^,274^L1120^,274^L1250^,274^L1270^L1300,
+66 ;;274^L1499^,274^L1510^,274^L1600^,274^L1640^,274^L1686^L1690,
+67 ;;274^L1810^,274^L1820^,274^L1830^L1850,274^L1860^,274^L1900^,
+68 ;;274^L1902^L2000,274^L2010^L2030,274^L2036^L2038,274^L2060^,274^L2108^,
+69 ;;274^L2112^L2114,274^L2128^,274^L2180^,274^L2190^,274^L2200^L2232,
+70 ;;274^L2250^L2300,274^L2320^L2330,274^L2340^L2360,274^L2380^L2397,274^L2405^,
+71 ;;274^L2415^,274^L2425^L2430,274^L2550^,274^L2580^,274^L2624^,
+72 ;;274^L2680^,274^L2755^L2760,274^L2780^,274^L2795^L2850,274^L2999^,
+73 ;;274^L3001^L3100,274^L3160^L3170,274^L3206^,274^L3211^,274^L3215^L3217,
+74 ;;274^L3219^L3222,274^L3224^L3320,274^L3332^L3370,274^L3390^L3450,274^L3460^L3465,
+75 ;;274^L3480^L3540,274^L3560^L3630,274^L3649^L3650,274^L3660^L3670,274^L3675^L3677,
+76 ;;274^L3702^L3720,274^L3760^L3764,274^L3806^L3808,274^L3900^L3901,274^L3904^L3906,
+77 ;;274^L3908^,274^L3912^L3913,274^L3915^,274^L3917^,274^L3919^,
+78 ;;274^L3923^,274^L3925^,274^L3927^,274^L3929^,274^L3931^,
+79 ;;274^L3933^,274^L3980^L3984,274^L3995^L4002,274^L4050^L4055,274^L4205^L4210,
+80 ;;274^L4350^L4386,274^L4392^L5000,274^L5020^,274^L5100^,274^L5150^,
+81 ;;274^L5200^,274^L5250^L5280,274^L5301^,274^L5311^,274^L5321^,
+82 ;;274^L5400^,274^L5500^,274^L5530^,274^L5540^,274^L5590^,
+83 ;;274^L5611^,274^L5616^,274^L5620^,274^L5624^,274^L5629^,
+84 ;;274^L5631^L5632,274^L5637^,274^L5645^,274^L5647^,274^L5649^L5652,
+85 ;;274^L5655^,274^L5665^L5666,274^L5668^,274^L5670^L5671,274^L5673^,
+86 ;;274^L5679^L5681,274^L5683^L5685,274^L5688^,274^L5695^L5696,274^L5698^,
+87 ;;274^L5700^L5702,274^L5704^L5706,274^L5728^,274^L5781^L5785,274^L5812^L5814,
+88 ;;274^L5824^,274^L5828^,274^L5845^,274^L5848^L5850,274^L5856^,
+89 ;;274^L5910^L5950,274^L5962^L5964,274^L5970^,274^L5972^,274^L5974^L5981,
+90 ;;274^L5984^,274^L5986^L5988,274^L5990^,274^L5999^L6000,274^L6050^,
+91 ;;274^L6100^,274^L6250^,274^L6310^,274^L6400^,274^L6580^,
+92 ;;274^L6605^L6620,274^L6624^,274^L6629^,274^L6632^,274^L6640^L6641,
+93 ;;274^L6645^,274^L6660^L6676,274^L6680^,274^L6686^L6687,274^L6691^L6692,
+94 ;;274^L6703^,274^L6706^,274^L6722^,274^L6881^L6882,274^L6890^L6900,
+95 ;;274^L6935^,274^L7009^,274^L7040^,274^L7274^,274^L7360^,
+96 ;;274^L7364^L7368,274^L7401^,274^L7403^L7404,274^L7499^L7600,274^L7900^L8001,
+97 ;;274^L8010^,274^L8020^L8030,274^L8039^,274^L8300^L8485,274^L8499^L8511,
+98 ;;274^L8513^,274^L8619^,274^L8681^,274^L8687^,274^L8689^L8691,
+99 ;;274^L9900^,274^Q0481^,274^S0500^S0510,274^S0580^,274^V2410^V2500,
+100 ;;274^V2510^,274^V2513^V2522,274^V2599^,274^V2615^,274^V2623^V2624,
+101 ;;274^V2627^V2629,274^V5268^V5269,274^V5273^V5274,274^V5298^,274^V5336^,
+102 ;;275^C1721^C1722,275^C1777^,275^C1779^,275^C1785^C1786,275^C1882^,
+103 ;;275^C1895^C1896,275^C1898^C1900,275^C2619^C2621,276^C1780^,276^V2630^V2632,
+104 ;;277^S8120^S8121,278^C1713^,278^C1716^,278^C1726^C1727,278^C1729^C1752,
+105 ;;278^C1755^,278^C1757^C1764,278^C1766^C1772,278^C1776^,278^C1778^,
+106 ;;278^C1781^,278^C1783^C1784,278^C1787^C1789,278^C1813^,278^C1815^C1816,
+107 ;;278^C1819^C1820,278^C1878^C1881,278^C1887^,278^C1892^C1894,278^C1897^,
+108 ;;278^C2617^C2618,278^C2622^C2631,278^C2634^C2635,278^C2638^C2639,278^C2641^,
+109 ;;278^E0785^,278^L8600^L8603,278^L8606^,278^L8610^,278^L8612^L8615,
+110 ;;278^L8630^,278^L8641^L8642,278^L8658^,278^L8670^L8680,278^L8699^,
+111 ;;278^V2788^,279^A5073^,279^A9270^,279^A9275^,279^A9279^,
+112 ;;279^S8185^S8189,279^S8450^S8452,279^T2029^,279^V5266^V5267,290^A9280^,
+113 ;;290^A9282^,290^A9300^,290^E0100^E0114,290^E0116^E0118,290^E0130^E0141,
+114 ;;290^E0143^E0144,290^E0147^E0149,290^E0153^E0163,290^E0165^,290^E0167^E0168,
+115 ;;290^E0170^E0172,290^E0181^E0182,290^E0184^E0186,290^E0188^E0191,290^E0193^E0194,
+116 ;;290^E0196^E0218,290^E0221^E0230,290^E0235^E0236,290^E0238^E0251,290^E0255^E0280,
+117 ;;290^E0295^E0297,290^E0301^E0316,290^E0325^E0326,290^E0370^E0373,290^E0424^E0431,
+118 ;;290^E0434^E0450,290^E0457^,290^E0460^E0461,290^E0464^E0484,290^E0487^E0500,
+119 ;;290^E0555^E0571,290^E0580^E0585,290^E0600^E0601,290^E0603^E0605,290^E0607^,
+120 ;;290^E0610^E0615,290^E0617^E0619,290^E0621^E0652,290^E0660^,290^E0667^E0669,
+121 ;;290^E0671^E0672,290^E0675^,290^E0691^,290^E0700^,290^E0705^E0731,
+122 ;;290^E0745^,290^E0747^E0748,290^E0762^E0776,290^E0779^,290^E0781^,
+123 ;;290^E0784^,290^E0791^,290^E0840^E0912,290^E0930^E0941,290^E0944^E0945,
+124 ;;290^E0955^E0961,290^E0966^E0971,290^E0973^E0974,290^E0978^,290^E0980^E0990,
+125 ;;290^E0992^,290^E0994^E0995,290^E1002^E1005,290^E1007^E1008,290^E1010^,
+126 ;;290^E1015^,290^E1020^,290^E1028^E1029,290^E1031^E1035,290^E1038^E1039,
+127 ;;290^E1050^E1060,290^E1070^,290^E1083^E1090,290^E1092^E1110,290^E1130^E1170,
+128 ;;290^E1172^E1200,290^E1220^E1221,290^E1223^E1226,290^E1228^,290^E1230^,
+129 ;;290^E1240^E1298,290^E1300^,290^E1353^,290^E1355^,290^E1390^E1392,
+130 ;;290^E1399^,290^E1405^E1406,290^E2100^,290^E2201^,290^E2203^E2216,
+131 ;;290^E2218^E2222,290^E2224^E2226,290^E2231^,290^E2300^,290^E2310^E2313,
+132 ;;290^E2321^E2326,290^E2331^E2371,290^E2373^E2374,290^E2376^E2387,290^E2391^,
+133 ;;290^E2394^,290^E2396^E2397,290^E2402^E2500,290^E2504^,290^E2508^E2615,
+134 ;;290^E2617^,290^E2619^E2621,290^K0001^,290^K0003^K0007,290^K0009^K0012,
+135 ;;290^K0014^,290^K0800^K0813,290^K0822^K0823,290^K0835^K0837,290^K0848^K0852,
+136 ;;290^K0856^,290^K0861^,290^K0869^,290^K0884^,290^K0891^K0899,
+137 ;;290^V5270^,290^V5272^,292^A5072^,292^K0015^,292^K0017^K0020,
+138 ;;292^K0037^K0047,292^K0051^K0053,292^K0056^,292^K0065^,292^K0069^K0073,
+139 ;;292^K0077^,292^K0108^,292^K0195^,292^K0601^,292^K0606^K0607,
+140 ;;292^K0609^,292^K0669^,292^K0733^K0737,292^L3969^L3970,292^L3974^,
+141 ;;292^S8096^,292^S8100^S8101,292^V2020^V2025,292^V2100^,292^V2200^V2201,
+142 ;;292^V2203^,292^V2220^,292^V2300^,292^V2319^,292^V2399^,
+143 ;;292^V2600^V2610,292^V2700^V2702,292^V2715^V2718,292^V2744^V2745,292^V2781^,
+144 ;;292^V2784^V2785,292^V2797^,292^V5050^V5060,292^V5090^,292^V5100^V5110,
+145 ;;292^V5130^V5140,292^V5160^,292^V5180^,292^V5200^,292^V5241^,
+146 ;;292^V5245^V5247,292^V5250^V5253,292^V5255^V5261,292^V5263^V5265,292^V5271^,
+147 ;;294^A4556^A4558,294^A4570^,294^A4580^,294^A4590^,294^A4595^,
+148 ;;294^A4600^,294^A4611^,294^A4613^A4618,294^A4620^,294^A4630^,
+149 ;;294^A4633^,294^A4635^A4637,294^A4639^A4640,294^A4648^,294^E0950^E0952,
+150 ;;294^J7622^,299^A8000^A8001,299^A9900^A9999,300^89050^89100,300^89125^,
+151 ;;300^89140^89141,300^89190^,300^89220^,300^89230^,300^89240^,
+152 ;;300^89260^,300^89300^89322,300^89329^,300^99000^,300^G0103^,
+153 ;;300^G0306^,301^80047^80048,301^80050^80051,301^80053^,301^80055^,
+154 ;;301^80061^,301^80069^,301^80074^,301^80076^,301^80100^80166,
+155 ;;301^80170^80400,301^80406^80414,301^80416^,301^80418^80422,301^80426^80428,
+156 ;;301^80432^,301^80435^,301^80438^80440,301^82000^82003,301^82009^82010,
+157 ;;301^82013^,301^82024^82030,301^82040^82055,301^82075^,301^82085^,
+158 ;;301^82088^,301^82101^82108,301^82120^,301^82127^,301^82131^,
+159 ;;301^82135^,301^82139^82140,301^82143^82150,301^82157^,301^82160^82164,
+160 ;;301^82172^,301^82175^82205,301^82232^,301^82239^82240,301^82247^82248,
+161 ;;301^82261^,301^82270^82272,301^82274^,301^82300^,301^82306^,
+162 ;;301^82308^82310,301^82330^82331,301^82340^,301^82355^82370,301^82373^82397,
+163 ;;301^82415^,301^82435^82436,301^82438^,301^82465^,301^82480^82482,
+164 ;;301^82485^82486,301^82488^82489,301^82491^82495,301^82507^,301^82520^82525,
+165 ;;301^82528^,301^82530^,301^82533^,301^82540^82544,301^82550^82554,
+166 ;;301^82565^82600,301^82607^82610,301^82615^,301^82626^82627,301^82633^82634,
+167 ;;301^82646^82658,301^82664^82672,301^82677^,301^82679^82690,301^82705^82715,
+168 ;;301^82725^82726,301^82728^,301^82731^82735,301^82742^,301^82746^82747,
+169 ;;301^82757^82759,301^82784^82785,301^82787^,301^82800^,301^82803^,
+170 ;;301^82805^82810,301^82820^82926,301^82938^82941,301^82943^,301^82945^82948,
+171 ;;301^82950^82953,301^82955^82960,301^82962^82977,301^82979^,301^82985^,
+172 ;;301^83001^83003,301^83009^83010,301^83012^83018,301^83020^83037,301^83045^83051,
+173 ;;301^83060^83070,301^83088^83090,301^83150^,301^83491^,301^83497^83498,
+174 ;;301^83500^83505,301^83525^,301^83527^83528,301^83540^,301^83550^,
+175 ;;
+176 ;
+177 QUIT
