SR195UTL ;BIR/SJA - SR*3*195 UTILITY ROUTINE ;May 21, 2019@08:52:15
;;3.0;Surgery;**195**;24 Jun 93;Build 8
;
PRE ; -- pre-install process for SR*3*195
I '$D(^XTMP("PRE 2019-UPDATE BACKUP OF 137")) D
. N X1,X2,X
. S X1=DT,X2=120 D C^%DTC
. S ^XTMP("PRE 2019-UPDATE BACKUP OF 137",0)=$G(X)_"^"_$G(DT)_"^"_"Backup of file 137 before 2019 update is performed by Patch SR*3*195"
. D EN^DDIOL("Backing up the CPT EXCLUSIONS file (#137) to ^XTMP.","","!!?1")
. M ^XTMP("PRE 2019-UPDATE BACKUP OF 137",137)=^SRO(137)
. D EN^DDIOL("Backup complete","","!!?1")
;
D DATDEL ; delete data from file #137 prior to updating
Q
;
POST ; -- post-install process for SR*3*195
; -- populate the CPT EXCLUSIONS file (#137)
N SRI,SRJ,SRL,SRLIST,SRX,SRY,X
D MES^XPDUTL(" Populating CPT EXCLUSIONS file (#137)...")
F SRJ=0:1 S SRLIST=$P($T(LIST+SRJ)," ;;",2) Q:SRLIST="" F SRI=1:1 S SRX=$P(SRLIST,",",SRI) Q:SRX="" I $D(^ICPT("B",SRX)) D INT
D EX^SR195UT0,EX^SR195UT1,EX^SR195UT2
;
; -- The following CPT Code ranges are excluded: "00001-0051S", "0051U-0052S", "0052U-0053S", "0053U-0075S",
; "0075U-0076S", "0076U-0078S", "0078U-0095S", "0095U-0098S", "0098U-0171S", "0171U-0172S", "0172U-0184S"
; "0184U-01999", "70000-79999", "80000-89999", "90000-93589", "93593-99999"
S SRX="00001" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0051S")) D INT
S SRX="0051U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0052S")) D INT
S SRX="0052U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0053S")) D INT
S SRX="0053U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0075S")) D INT
S SRX="0075U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0076S")) D INT
S SRX="0076U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0078S")) D INT
S SRX="0078U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0095S")) D INT
S SRX="0095U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0098S")) D INT
S SRX="0098U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0171S")) D INT
S SRX="0171U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0172S")) D INT
S SRX="0172U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","0184S")) D INT
S SRX="0184U" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","01999")) D INT
S SRX="70000" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","79999")) D INT
S SRX="80000" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","89999")) D INT
S SRX="90000" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","93589")) D INT
S SRX="93593" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","99999")) D INT
;
; -- Exclude all CPT CODES that start with alphabets
S SRX="A" F S SRX=$O(^ICPT("B",SRX)) Q:SRX="" D INT
;
; -- Honor KIDS "No Delete" setting if called from a KIDS install.
; -- Delete routines SR195UT0, SR195UT1,& SR195UT2
I '$$GET^XUPARAM("XPD NO_EPP_DELETE") D
. F X="SR195UT0","SR195UT1","SR195UT2" X ^%ZOSF("TEST") I $T D
. .D MES^XPDUTL(" Deleting routine "_X_"...") X ^%ZOSF("DEL")
K DA,DIC,DD,DO,DINUM,X
Q
;
INT S SRY=0,SRY=$O(^ICPT("B",SRX,SRY)) Q:SRY=""
K DA,DIC,DD,DO,DINUM S (DINUM,X)=SRY,DIC="^SRO(137,",DIC(0)="L" D FILE^DICN
Q
;
DATDEL ; Delete all data from file #137
N SRTXT
S SRTXT="File #137 hasn't been set up yet, so no data to delete."
I '$D(^SRO(137,0))#2 D DISP Q
S SRTXT="File #137 doesn't have any data, so nothing to delete."
I '$O(^SRO(137,0)) D DISP Q
S SRTXT="Deleting data from file #137..."
D DISP
K ^SRO(137)
S ^SRO(137,0)="CPT EXCLUSIONS^137P^^0"
Q
;
DISP ;display one-line text either interactively or within KIDS installation
I '$D(XPDNM)#2 U 0 W !!?5,SRTXT
E D BMES^XPDUTL(SRTXT)
Q
;
LIST ;;0001F,0001U,0002U,0003U,0004U,0005F,0005U,0006U,0007U,0008U,0009U,00100,00102,00103,00104
;;0010U,0011U,00120,00124,00126,0012F,0012U,0013U,00140,00142,00144,00145,00147,00148,0014F,0014U
;;0015F,0015U,00160,00162,00164,0016U,00170,00172,00174,00176,0017U,0018U,00190,00192,0019U,0020U,00210
;;00211,00212,00214,00215,00216,00218,0021U,00220,00222,0022U,0023U,0024U,0025U,0026U,0027U,0028U,0029U
;;00300,0030U,0031U,00320,00322,00326,0032U,0033U,0034U,00350,00352,0035U,0036U,0037U,0038U,0039U,00400
;;00402,00404,00406,0040U,00410,0041U,0042T,0042U,0043U,0044U,00450,00454,0045U,0046U,00470,00472,00474
;;0047U,0048U,0049U,00500,0050U,0051U,00520,00522,00524,00528,00529,0052U,00530,00532,00534,00537,00539
;;0053U,00540,00541,00542,00546,00548,0054T,0054U,00550,0055T,0055U,00560,00561,00562,00563,00566,00567
;;0056U,0057U,00580,0058T,0058U,0059U,00600,00604,0060U,0061U,00620,00625,00626,00630,00632,00635,00640
;;00670,00700,00702,0071T,0072T,00730,00731,00732,00750,00752,00754,00756,00770,00790,00792,00794,00796
;;00797,00800,00802,00811,00812,00813,00820,00830,00832,00834,00836,00840,00842,00844,00846,00848,00851
;;0085T,00860,00862,00864,00865,00866,00868,00870,00872,00873,00880,00882,00902,00904,00906,00908,00910
;;00912,00914,00916,00918,00920,00921,00922,00924,00926,00928,00930,00932,00934,00936,00938,00940,00942
;;00944,00948,00950,00952,0100T,0101T,0102T,0106T,0107T,0108T,0109T,0110T,01112,0111T,01120,01130,01140
;;01150,01160,01170,01173,01200,0001F,01210,01212,01214,01215,01220,01230,01232,01234,01250,01260,0126T
;;01270,01272,01274,01320,01340,01360,01380,01382,01390,01392,01400,01402,01404,01420,01430,01432,01440
;;01442,01444,01462,01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,01520,01522,0159T
;;01610,01620,01622,01630,01634,01636,01638,0163T,0164T,01650,01652,01654,01656,0165T,01670,01680,01710
;;01712,01714,01716,01730,01732,01740,01742,01744,0174T,01756,01758,0175T,01760,01770,01772,01780,01782
;;01810,01820,01829,01830,01832,01840,01842,01844,01850,01852,01860,0188T,0189T,0190T,01916,0191T,01920
;;01922,01924,01925,01926,01930,01931,01932,01933,01935,01936,01951,01952,01953,01958,0195T,01960,01961
;;01962,01963,01965,01966,01967,01968,01969,0196T,0198T,01990,01991,01992,01996,01999,0200T,0201T,0206T
;;0207T,0208T,0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T,0217T,0218T,0228T,0229T,0230T,0231T,0232T
;;0249T,0253T,0263T,0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T,0272T,0273T,0275T,0278T,0290T,0295T
;;0296T,0297T,0298T,0308T,0312T,0313T,0314T,0315T,0316T,0317T,0329T,0330T,0331T,0332T,0333T,0335T,0337T
;;0338T,0339T,0341T,0342T,0345T,0346T,0347T,0348T,0349T,0350T,0351T,0352T,0353T,0354T,0355T,0356T,0357T
;;0358T,0359T,0360T,0361T,0362T,0363T,0364T,0365T,0366T,0367T,0368T,0369T,0370T,0371T,0372T,0373T,0374T
;;0376T,0377T,0378T,0379T,0380T,0381T,0382T,0383T,0384T,0385T,0386T,0387T,0388T,0389T,0390T,0391T,0394T
;;0395T,0396T,0397T,0398T,0399T,0400T,0401T,0402T,0403T,0404T,0405T,0406T,0407T,0408T,0409T,0410T,0411T
;;0412T,0413T,0414T,0415T,0416T,0417T,0418T,0419T,0420T,0422T,0423T,0424T,0425T,0426T,0427T,0428T,0429T
;;0430T,0431T,0432T,0433T,0434T,0435T,0436T,0437T,0439T,0440T,0441T,0442T,0443T,0444T,0445T,0446T,0447T
;;0448T,0449T,0450T,0462T,0463T,0464T,0465T,0466T,0467T,0468T,0469T,0470T,0471T,0472T,0473T,0474T,0475T
;;0476T,0477T,0478T,0479T,0480T,0481T,0482T,0485T,0486T,0487T,0488T,0489T,0490T,0491T,0492T,0493T,0494T
;;0495T,0496T,0497T,0498T,0499T,0500F,0500T,0501F,0501T,0502F,0502T,0503F,0503T,0504T,0505F,0505T,0506T
;;0507F,0507T,0508T,0509F,0509T,0510T,0511T,0512T,0513F,0513T,0514F,0514T,0515T,0516F,0516T,0517F,0517T
;;0518F,0518T,0519F,0519T,0520F,0520T,0521F,0521T,0522T,0523T,0524T,0525F,0525T,0526F,0526T,0527T,0528F
;;0528T,0529F,0529T,0530T,0531T,0532T,0533T,0534T,0535F,0535T,0536T,0537T,0538T,0539T,0540F,0540T,0541T
;;0542T,0545F,0550F,0551F,0555F,0556F,0557F,0575F,0580F,0581F,0582F,0583F,0584F,10004,10005,10006,10007
;;10008,10009,1000F,10010,10011,10012,10021,10022,1002F,10030,10035,10036,1003F,10040,1004F,1005F,10060
;;10061,1006F,1007F,10080,10081,1008F,1010F,1011F,10120,1012F,1015F,1018F,1019F,1022F,1026F,1030F,1031F
;;1032F,1033F,1034F,1035F,1036F,1038F,1039F,1040F,1050F,1052F,1055F,1060F,1061F,1065F,1066F,1070F,1071F
;;1090F,1091F,11000,1100F,1101F,11042,11043,11044,11045,11046,11047,11055,11056,11057,11100,11101,11102
;;11103,11104,11105,11106,11107,1110F,1111F,1116F,1118F,1119F,11200,11201,1121F,1123F,1124F,1125F,1126F
;;1127F,1128F,11300,11301,11302,11303,11305,11306,11307,11308,1130F,11310,11311,11312,11313,1134F,1135F
;;1136F,1137F,11400,11401,11402,11403,11404,11406,11420,11421,11422,11423,11424,11426,11440,11441,11442
;;11443,11444,11446,11450,11451,11462,11463,11470,11471,1150F,1151F,1152F,1153F,1157F,1158F,1159F,11600
;;11601,11602,11603,11604,11606,1160F,11620,11621,11622,11623,11624,11626,11640,11641,11642,11643,11644
;;11646,1170F,11719,11720,11721,11730,11732,11740,11750,11755,1175F,11760,11762,11765,11770,11771,11772
;;1180F,1181F,1182F,1183F,11900,11901,11920,11921,11922,11950,11951,11952,11954,11960,11970,11971,11976
;;11980,11981,11982,11983,12001,12002,12004,12005,12006,12007,1200F,12011,12013,12014,12015,12016,12017
;;12018,12020,12021,12031,12032,12034,12035,12036,12037,12041,12042,12044,12045,12046,12047,12051,12052
;;12053,12054,12055,12056,12057,1205F,1220F,13100,13101,13102,13120,13121,13122,13131,13132,13133,13151
;;13152,13153,13160,14000,14001,1400F,14020,14021,14040,14041,14060,14061,14301,14302,14350,1450F,1451F
;;1460F,1461F,1490F,1491F,1493F,1494F,15002,15003,15004,1500F,1501F,1502F,1503F,1504F,15050,1505F,15100
;;15101,15110,15111,15115,15116,15120,15121,15130,15131,15135,15136,15150,15151,15152,15155,15156,15157
;;15200,15201,15220,15221,15240,15241,15260,15261,15271,15272,15273,15274,15275,15276,15277,15278,15570
;;15572,15574,15576,15730,15733,15775,15776,15777,15780,15781,15782,15783,15786,15787,15788,15789,15792
;;15793,15819,15820,15821,15822,15823,15824,15825,15826,15828,15829,15832,15833,15834,15835,15836,15837
;;15838,15839,15840,15841,15842,15845,15850,15851,15852,15860,15876,15877,15878,15879,16000,16020,16025
;;16030,16035,16036,17000,17003,17004,17106,17107,17108,17110,17111,17250,17260,17261,17262,17263,17264
;;17266,17270,17271,17272,17273,17274,17276,17280,17281,17282,17283,17284,17286,17311,17312,17313,17314
;;17315,17340,17360,17380,17999,19000,19001,19020,19030,19081,19082,19083,19084,19085,19086,19100,19101
;;19105,19110,19112,19120,19125,19126,19281,19282,19283,19284,19285,19286,19287,19288,19294,2000F,2001F
;;2002F,2004F,2010F,2014F,2015F,2016F,2018F,2019F,20200,20205,20206,2020F,2021F,20220,20225,2022F,20240
;;20245,2024F,20250,20251,2026F,2027F,2028F,2029F,2030F,2031F,2035F,2040F,2044F,20500,20501,2050F,20520
;;20525,20526,20527,20550,20551,20552,20553,20555,20600,20604,20605,20606,2060F,20610,20611,20612,20615
;;20650,20660,20661,20662,20663,20664,20665,20670,20680,20690,20692,20693,20694,20696,20697,20900,20902
;;20910,20912,20920,20922,20924,20926,20939,20950,20974,20975,20979,20982,20983,20985,21010,21011,21012
;;21013,21014,21015,21016,21025,21026,21029,21030,21031,21032,21073,21076,21077,21079,21080,21081,21082
;;21083,21084,21085,21086,21087,21088,21116,21210,21230,21282,21310,21315,21320,21325,21330,21335,21336
;;21337,21338,21339,21340,21345,21400,21401,21421,21431,21440,21450,21451,21452,21453,21480,21485,21497
;;21550,21552,21554,21555,21556,21600,21820,21920,21925,21930,21931,21932,21933,22310,22315,22505,22510
;;22511,22512,22513,22514,22515,22532,22534,22556,22900,22901,22902,22903,23065,23066,23071,23073,23075
;;23076,23100,23330,23333,23350,23500,23505,23520,23525,23540,23545,23570,23575,23600,23605,23620,23625
;;23650,23655,23665,23675,23700,23930,23931,24065,24066,24071,24073,24075,24076,24100,24101,24147,24160
;;24164,24200,24220,24300,24343,24470,24500,24505,24530,24535,24560,24565,24576,24577,24600,24605,24620
;;24640,24650,24655,24670,24675,25000,25028,25031,25065,25066,25071,25073,25075,25076,25085,25100,25101
;;25105,25107,25109,25110,25111,25112,25115,25116,25118,25119,25120,25125,25126,25130,25135,25136,25210
;;25215,25230,25240,25246,25248,25250,25251,25259,25260,25263,25265,25270,25272,25274,25275,25280,25290
;;25295,25300,25301,25310,25312,25315,25316,25320,25332,25335,25337,25350,25355,25360,25365,25370,25375
;;25390,25391,25392,25393,25394,25400,25405,25415,25420,25425,25426,25430,25431,25440,25441,25442,25443
;;25444,25445,25446,25447,25449,25450,25455,25490,25491,25492,25500,25505,25515,25520,25526,25530,25535
;;25545,25560,25565,25574,25575,25600,25605,25606,25607,25608,25609,25622,25624,25628,25630,25635,25645
;;25650,25651,25652,25660,25670,25671,25675,25676,25680,25685,25690,25695,25800,25805,25810,25820,25825
;;25830,25999,26010,26011,26020,26025,26030,26034,26035,26037,26040,26045,26055,26060,26070,26075,26080
;;26100,26105,26110,26111,26113,26115,26116,26117,26118,26121,26123,26125,26130,26135,26140,26145,26160
;;26170,26180,26185,26200,26205,26210,26215,26230,26235,26236,26250,26260,26262,26320,26340,26341,26350
;;26352,26356,26357,26358,26370,26372,26373,26390,26392,26410,26412,26415,26416,26418,26420,26426,26428
;;26432,26433,26434,26437,26440,26442,26445,26449,26450,26455,26460,26471,26474,26476,26477,26478,26479
;;26480,26483,26485,26489,26490,26492,26494,26496,26497,26498,26499,26500,26502,26508,26510,26516,26517
;;26518,26520,26525,26530,26531,26535,26536,26540,26541,26542,26545,26546,26548,26550,26555,26560,26561
;;26562,26565,26567,26568,26580,26587,26590,26591,26593,26596,26600,26605,26607,26608,26615,26641,26645
;;26650,26665,26670,26675,26676,26685,26686,26700,26705,26706,26715,26720,26725,26727,26735,26740,26742
;;26746,26750,26755,26756,26765,26770,26775,26776,26785,26820,26841,26842,26843,26844,26850,26852,26860
;;26861,26862,26863,26910,26951,26952,26989,27003,27040,27041,27043,27045,27047,27048,27050,27052,27093
;;27095,27096,27175,27197,27198,27200,27216,27220,27222,27230,27232,27238,27240,27246,27250,27252,27256
;;27257,27265,27266,27267,27268,27275,27306,27323,27324,27330,27331,27337,27339,27369,27370,27500,27501
;;27502,27503,27508,27510,27516,27517,27520,27530,27532,27538,27550,27552,27560,27562,27570,27613,27614
;;27618,27619,27632,27634,27648,27690,27691,27750,27752,27760,27762,27767,27768,27780,27781,27786,27788
;;27808,27810,27816,27818,27824,27825,27830,27831,27840,27842,27860,27870,27871,27884,28001,28005,28008
;;28010,28011,28020,28022,28024,28035,28039,28041,28043,28045,28046,28050,28052,28054,28055,28060,28062
;;28070,28072,28080,28086,28088,28090,28092,28100,28102,28103,28104,28106,28107,28108,28110,28111,28112
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR195UTL 14474 printed Nov 22, 2024@17:48:18 Page 2
SR195UTL ;BIR/SJA - SR*3*195 UTILITY ROUTINE ;May 21, 2019@08:52:15
+1 ;;3.0;Surgery;**195**;24 Jun 93;Build 8
+2 ;
PRE ; -- pre-install process for SR*3*195
+1 IF '$DATA(^XTMP("PRE 2019-UPDATE BACKUP OF 137"))
Begin DoDot:1
+2 NEW X1,X2,X
+3 SET X1=DT
SET X2=120
DO C^%DTC
+4 SET ^XTMP("PRE 2019-UPDATE BACKUP OF 137",0)=$GET(X)_"^"_$GET(DT)_"^"_"Backup of file 137 before 2019 update is performed by Patch SR*3*195"
+5 DO EN^DDIOL("Backing up the CPT EXCLUSIONS file (#137) to ^XTMP.","","!!?1")
+6 MERGE ^XTMP("PRE 2019-UPDATE BACKUP OF 137",137)=^SRO(137)
+7 DO EN^DDIOL("Backup complete","","!!?1")
End DoDot:1
+8 ;
+9 ; delete data from file #137 prior to updating
DO DATDEL
+10 QUIT
+11 ;
POST ; -- post-install process for SR*3*195
+1 ; -- populate the CPT EXCLUSIONS file (#137)
+2 NEW SRI,SRJ,SRL,SRLIST,SRX,SRY,X
+3 DO MES^XPDUTL(" Populating CPT EXCLUSIONS file (#137)...")
+4 FOR SRJ=0:1
SET SRLIST=$PIECE($TEXT(LIST+SRJ)," ;;",2)
if SRLIST=""
QUIT
FOR SRI=1:1
SET SRX=$PIECE(SRLIST,",",SRI)
if SRX=""
QUIT
IF $DATA(^ICPT("B",SRX))
DO INT
+5 DO EX^SR195UT0
DO EX^SR195UT1
DO EX^SR195UT2
+6 ;
+7 ; -- The following CPT Code ranges are excluded: "00001-0051S", "0051U-0052S", "0052U-0053S", "0053U-0075S",
+8 ; "0075U-0076S", "0076U-0078S", "0078U-0095S", "0095U-0098S", "0098U-0171S", "0171U-0172S", "0172U-0184S"
+9 ; "0184U-01999", "70000-79999", "80000-89999", "90000-93589", "93593-99999"
+10 SET SRX="00001"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0051S"))
QUIT
DO INT
+11 SET SRX="0051U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0052S"))
QUIT
DO INT
+12 SET SRX="0052U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0053S"))
QUIT
DO INT
+13 SET SRX="0053U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0075S"))
QUIT
DO INT
+14 SET SRX="0075U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0076S"))
QUIT
DO INT
+15 SET SRX="0076U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0078S"))
QUIT
DO INT
+16 SET SRX="0078U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0095S"))
QUIT
DO INT
+17 SET SRX="0095U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0098S"))
QUIT
DO INT
+18 SET SRX="0098U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0171S"))
QUIT
DO INT
+19 SET SRX="0171U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0172S"))
QUIT
DO INT
+20 SET SRX="0172U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0184S"))
QUIT
DO INT
+21 SET SRX="0184U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","01999"))
QUIT
DO INT
+22 SET SRX="70000"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","79999"))
QUIT
DO INT
+23 SET SRX="80000"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","89999"))
QUIT
DO INT
+24 SET SRX="90000"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","93589"))
QUIT
DO INT
+25 SET SRX="93593"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","99999"))
QUIT
DO INT
+26 ;
+27 ; -- Exclude all CPT CODES that start with alphabets
+28 SET SRX="A"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=""
QUIT
DO INT
+29 ;
+30 ; -- Honor KIDS "No Delete" setting if called from a KIDS install.
+31 ; -- Delete routines SR195UT0, SR195UT1,& SR195UT2
+32 IF '$$GET^XUPARAM("XPD NO_EPP_DELETE")
Begin DoDot:1
+33 FOR X="SR195UT0","SR195UT1","SR195UT2"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:2
+34 DO MES^XPDUTL(" Deleting routine "_X_"...")
XECUTE ^%ZOSF("DEL")
End DoDot:2
End DoDot:1
+35 KILL DA,DIC,DD,DO,DINUM,X
+36 QUIT
+37 ;
INT SET SRY=0
SET SRY=$ORDER(^ICPT("B",SRX,SRY))
if SRY=""
QUIT
+1 KILL DA,DIC,DD,DO,DINUM
SET (DINUM,X)=SRY
SET DIC="^SRO(137,"
SET DIC(0)="L"
DO FILE^DICN
+2 QUIT
+3 ;
DATDEL ; Delete all data from file #137
+1 NEW SRTXT
+2 SET SRTXT="File #137 hasn't been set up yet, so no data to delete."
+3 IF '$DATA(^SRO(137,0))#2
DO DISP
QUIT
+4 SET SRTXT="File #137 doesn't have any data, so nothing to delete."
+5 IF '$ORDER(^SRO(137,0))
DO DISP
QUIT
+6 SET SRTXT="Deleting data from file #137..."
+7 DO DISP
+8 KILL ^SRO(137)
+9 SET ^SRO(137,0)="CPT EXCLUSIONS^137P^^0"
+10 QUIT
+11 ;
DISP ;display one-line text either interactively or within KIDS installation
+1 IF '$DATA(XPDNM)#2
USE 0
WRITE !!?5,SRTXT
+2 IF '$TEST
DO BMES^XPDUTL(SRTXT)
+3 QUIT
+4 ;
LIST ;;0001F,0001U,0002U,0003U,0004U,0005F,0005U,0006U,0007U,0008U,0009U,00100,00102,00103,00104
+1 ;;0010U,0011U,00120,00124,00126,0012F,0012U,0013U,00140,00142,00144,00145,00147,00148,0014F,0014U
+2 ;;0015F,0015U,00160,00162,00164,0016U,00170,00172,00174,00176,0017U,0018U,00190,00192,0019U,0020U,00210
+3 ;;00211,00212,00214,00215,00216,00218,0021U,00220,00222,0022U,0023U,0024U,0025U,0026U,0027U,0028U,0029U
+4 ;;00300,0030U,0031U,00320,00322,00326,0032U,0033U,0034U,00350,00352,0035U,0036U,0037U,0038U,0039U,00400
+5 ;;00402,00404,00406,0040U,00410,0041U,0042T,0042U,0043U,0044U,00450,00454,0045U,0046U,00470,00472,00474
+6 ;;0047U,0048U,0049U,00500,0050U,0051U,00520,00522,00524,00528,00529,0052U,00530,00532,00534,00537,00539
+7 ;;0053U,00540,00541,00542,00546,00548,0054T,0054U,00550,0055T,0055U,00560,00561,00562,00563,00566,00567
+8 ;;0056U,0057U,00580,0058T,0058U,0059U,00600,00604,0060U,0061U,00620,00625,00626,00630,00632,00635,00640
+9 ;;00670,00700,00702,0071T,0072T,00730,00731,00732,00750,00752,00754,00756,00770,00790,00792,00794,00796
+10 ;;00797,00800,00802,00811,00812,00813,00820,00830,00832,00834,00836,00840,00842,00844,00846,00848,00851
+11 ;;0085T,00860,00862,00864,00865,00866,00868,00870,00872,00873,00880,00882,00902,00904,00906,00908,00910
+12 ;;00912,00914,00916,00918,00920,00921,00922,00924,00926,00928,00930,00932,00934,00936,00938,00940,00942
+13 ;;00944,00948,00950,00952,0100T,0101T,0102T,0106T,0107T,0108T,0109T,0110T,01112,0111T,01120,01130,01140
+14 ;;01150,01160,01170,01173,01200,0001F,01210,01212,01214,01215,01220,01230,01232,01234,01250,01260,0126T
+15 ;;01270,01272,01274,01320,01340,01360,01380,01382,01390,01392,01400,01402,01404,01420,01430,01432,01440
+16 ;;01442,01444,01462,01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,01520,01522,0159T
+17 ;;01610,01620,01622,01630,01634,01636,01638,0163T,0164T,01650,01652,01654,01656,0165T,01670,01680,01710
+18 ;;01712,01714,01716,01730,01732,01740,01742,01744,0174T,01756,01758,0175T,01760,01770,01772,01780,01782
+19 ;;01810,01820,01829,01830,01832,01840,01842,01844,01850,01852,01860,0188T,0189T,0190T,01916,0191T,01920
+20 ;;01922,01924,01925,01926,01930,01931,01932,01933,01935,01936,01951,01952,01953,01958,0195T,01960,01961
+21 ;;01962,01963,01965,01966,01967,01968,01969,0196T,0198T,01990,01991,01992,01996,01999,0200T,0201T,0206T
+22 ;;0207T,0208T,0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T,0217T,0218T,0228T,0229T,0230T,0231T,0232T
+23 ;;0249T,0253T,0263T,0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T,0272T,0273T,0275T,0278T,0290T,0295T
+24 ;;0296T,0297T,0298T,0308T,0312T,0313T,0314T,0315T,0316T,0317T,0329T,0330T,0331T,0332T,0333T,0335T,0337T
+25 ;;0338T,0339T,0341T,0342T,0345T,0346T,0347T,0348T,0349T,0350T,0351T,0352T,0353T,0354T,0355T,0356T,0357T
+26 ;;0358T,0359T,0360T,0361T,0362T,0363T,0364T,0365T,0366T,0367T,0368T,0369T,0370T,0371T,0372T,0373T,0374T
+27 ;;0376T,0377T,0378T,0379T,0380T,0381T,0382T,0383T,0384T,0385T,0386T,0387T,0388T,0389T,0390T,0391T,0394T
+28 ;;0395T,0396T,0397T,0398T,0399T,0400T,0401T,0402T,0403T,0404T,0405T,0406T,0407T,0408T,0409T,0410T,0411T
+29 ;;0412T,0413T,0414T,0415T,0416T,0417T,0418T,0419T,0420T,0422T,0423T,0424T,0425T,0426T,0427T,0428T,0429T
+30 ;;0430T,0431T,0432T,0433T,0434T,0435T,0436T,0437T,0439T,0440T,0441T,0442T,0443T,0444T,0445T,0446T,0447T
+31 ;;0448T,0449T,0450T,0462T,0463T,0464T,0465T,0466T,0467T,0468T,0469T,0470T,0471T,0472T,0473T,0474T,0475T
+32 ;;0476T,0477T,0478T,0479T,0480T,0481T,0482T,0485T,0486T,0487T,0488T,0489T,0490T,0491T,0492T,0493T,0494T
+33 ;;0495T,0496T,0497T,0498T,0499T,0500F,0500T,0501F,0501T,0502F,0502T,0503F,0503T,0504T,0505F,0505T,0506T
+34 ;;0507F,0507T,0508T,0509F,0509T,0510T,0511T,0512T,0513F,0513T,0514F,0514T,0515T,0516F,0516T,0517F,0517T
+35 ;;0518F,0518T,0519F,0519T,0520F,0520T,0521F,0521T,0522T,0523T,0524T,0525F,0525T,0526F,0526T,0527T,0528F
+36 ;;0528T,0529F,0529T,0530T,0531T,0532T,0533T,0534T,0535F,0535T,0536T,0537T,0538T,0539T,0540F,0540T,0541T
+37 ;;0542T,0545F,0550F,0551F,0555F,0556F,0557F,0575F,0580F,0581F,0582F,0583F,0584F,10004,10005,10006,10007
+38 ;;10008,10009,1000F,10010,10011,10012,10021,10022,1002F,10030,10035,10036,1003F,10040,1004F,1005F,10060
+39 ;;10061,1006F,1007F,10080,10081,1008F,1010F,1011F,10120,1012F,1015F,1018F,1019F,1022F,1026F,1030F,1031F
+40 ;;1032F,1033F,1034F,1035F,1036F,1038F,1039F,1040F,1050F,1052F,1055F,1060F,1061F,1065F,1066F,1070F,1071F
+41 ;;1090F,1091F,11000,1100F,1101F,11042,11043,11044,11045,11046,11047,11055,11056,11057,11100,11101,11102
+42 ;;11103,11104,11105,11106,11107,1110F,1111F,1116F,1118F,1119F,11200,11201,1121F,1123F,1124F,1125F,1126F
+43 ;;1127F,1128F,11300,11301,11302,11303,11305,11306,11307,11308,1130F,11310,11311,11312,11313,1134F,1135F
+44 ;;1136F,1137F,11400,11401,11402,11403,11404,11406,11420,11421,11422,11423,11424,11426,11440,11441,11442
+45 ;;11443,11444,11446,11450,11451,11462,11463,11470,11471,1150F,1151F,1152F,1153F,1157F,1158F,1159F,11600
+46 ;;11601,11602,11603,11604,11606,1160F,11620,11621,11622,11623,11624,11626,11640,11641,11642,11643,11644
+47 ;;11646,1170F,11719,11720,11721,11730,11732,11740,11750,11755,1175F,11760,11762,11765,11770,11771,11772
+48 ;;1180F,1181F,1182F,1183F,11900,11901,11920,11921,11922,11950,11951,11952,11954,11960,11970,11971,11976
+49 ;;11980,11981,11982,11983,12001,12002,12004,12005,12006,12007,1200F,12011,12013,12014,12015,12016,12017
+50 ;;12018,12020,12021,12031,12032,12034,12035,12036,12037,12041,12042,12044,12045,12046,12047,12051,12052
+51 ;;12053,12054,12055,12056,12057,1205F,1220F,13100,13101,13102,13120,13121,13122,13131,13132,13133,13151
+52 ;;13152,13153,13160,14000,14001,1400F,14020,14021,14040,14041,14060,14061,14301,14302,14350,1450F,1451F
+53 ;;1460F,1461F,1490F,1491F,1493F,1494F,15002,15003,15004,1500F,1501F,1502F,1503F,1504F,15050,1505F,15100
+54 ;;15101,15110,15111,15115,15116,15120,15121,15130,15131,15135,15136,15150,15151,15152,15155,15156,15157
+55 ;;15200,15201,15220,15221,15240,15241,15260,15261,15271,15272,15273,15274,15275,15276,15277,15278,15570
+56 ;;15572,15574,15576,15730,15733,15775,15776,15777,15780,15781,15782,15783,15786,15787,15788,15789,15792
+57 ;;15793,15819,15820,15821,15822,15823,15824,15825,15826,15828,15829,15832,15833,15834,15835,15836,15837
+58 ;;15838,15839,15840,15841,15842,15845,15850,15851,15852,15860,15876,15877,15878,15879,16000,16020,16025
+59 ;;16030,16035,16036,17000,17003,17004,17106,17107,17108,17110,17111,17250,17260,17261,17262,17263,17264
+60 ;;17266,17270,17271,17272,17273,17274,17276,17280,17281,17282,17283,17284,17286,17311,17312,17313,17314
+61 ;;17315,17340,17360,17380,17999,19000,19001,19020,19030,19081,19082,19083,19084,19085,19086,19100,19101
+62 ;;19105,19110,19112,19120,19125,19126,19281,19282,19283,19284,19285,19286,19287,19288,19294,2000F,2001F
+63 ;;2002F,2004F,2010F,2014F,2015F,2016F,2018F,2019F,20200,20205,20206,2020F,2021F,20220,20225,2022F,20240
+64 ;;20245,2024F,20250,20251,2026F,2027F,2028F,2029F,2030F,2031F,2035F,2040F,2044F,20500,20501,2050F,20520
+65 ;;20525,20526,20527,20550,20551,20552,20553,20555,20600,20604,20605,20606,2060F,20610,20611,20612,20615
+66 ;;20650,20660,20661,20662,20663,20664,20665,20670,20680,20690,20692,20693,20694,20696,20697,20900,20902
+67 ;;20910,20912,20920,20922,20924,20926,20939,20950,20974,20975,20979,20982,20983,20985,21010,21011,21012
+68 ;;21013,21014,21015,21016,21025,21026,21029,21030,21031,21032,21073,21076,21077,21079,21080,21081,21082
+69 ;;21083,21084,21085,21086,21087,21088,21116,21210,21230,21282,21310,21315,21320,21325,21330,21335,21336
+70 ;;21337,21338,21339,21340,21345,21400,21401,21421,21431,21440,21450,21451,21452,21453,21480,21485,21497
+71 ;;21550,21552,21554,21555,21556,21600,21820,21920,21925,21930,21931,21932,21933,22310,22315,22505,22510
+72 ;;22511,22512,22513,22514,22515,22532,22534,22556,22900,22901,22902,22903,23065,23066,23071,23073,23075
+73 ;;23076,23100,23330,23333,23350,23500,23505,23520,23525,23540,23545,23570,23575,23600,23605,23620,23625
+74 ;;23650,23655,23665,23675,23700,23930,23931,24065,24066,24071,24073,24075,24076,24100,24101,24147,24160
+75 ;;24164,24200,24220,24300,24343,24470,24500,24505,24530,24535,24560,24565,24576,24577,24600,24605,24620
+76 ;;24640,24650,24655,24670,24675,25000,25028,25031,25065,25066,25071,25073,25075,25076,25085,25100,25101
+77 ;;25105,25107,25109,25110,25111,25112,25115,25116,25118,25119,25120,25125,25126,25130,25135,25136,25210
+78 ;;25215,25230,25240,25246,25248,25250,25251,25259,25260,25263,25265,25270,25272,25274,25275,25280,25290
+79 ;;25295,25300,25301,25310,25312,25315,25316,25320,25332,25335,25337,25350,25355,25360,25365,25370,25375
+80 ;;25390,25391,25392,25393,25394,25400,25405,25415,25420,25425,25426,25430,25431,25440,25441,25442,25443
+81 ;;25444,25445,25446,25447,25449,25450,25455,25490,25491,25492,25500,25505,25515,25520,25526,25530,25535
+82 ;;25545,25560,25565,25574,25575,25600,25605,25606,25607,25608,25609,25622,25624,25628,25630,25635,25645
+83 ;;25650,25651,25652,25660,25670,25671,25675,25676,25680,25685,25690,25695,25800,25805,25810,25820,25825
+84 ;;25830,25999,26010,26011,26020,26025,26030,26034,26035,26037,26040,26045,26055,26060,26070,26075,26080
+85 ;;26100,26105,26110,26111,26113,26115,26116,26117,26118,26121,26123,26125,26130,26135,26140,26145,26160
+86 ;;26170,26180,26185,26200,26205,26210,26215,26230,26235,26236,26250,26260,26262,26320,26340,26341,26350
+87 ;;26352,26356,26357,26358,26370,26372,26373,26390,26392,26410,26412,26415,26416,26418,26420,26426,26428
+88 ;;26432,26433,26434,26437,26440,26442,26445,26449,26450,26455,26460,26471,26474,26476,26477,26478,26479
+89 ;;26480,26483,26485,26489,26490,26492,26494,26496,26497,26498,26499,26500,26502,26508,26510,26516,26517
+90 ;;26518,26520,26525,26530,26531,26535,26536,26540,26541,26542,26545,26546,26548,26550,26555,26560,26561
+91 ;;26562,26565,26567,26568,26580,26587,26590,26591,26593,26596,26600,26605,26607,26608,26615,26641,26645
+92 ;;26650,26665,26670,26675,26676,26685,26686,26700,26705,26706,26715,26720,26725,26727,26735,26740,26742
+93 ;;26746,26750,26755,26756,26765,26770,26775,26776,26785,26820,26841,26842,26843,26844,26850,26852,26860
+94 ;;26861,26862,26863,26910,26951,26952,26989,27003,27040,27041,27043,27045,27047,27048,27050,27052,27093
+95 ;;27095,27096,27175,27197,27198,27200,27216,27220,27222,27230,27232,27238,27240,27246,27250,27252,27256
+96 ;;27257,27265,27266,27267,27268,27275,27306,27323,27324,27330,27331,27337,27339,27369,27370,27500,27501
+97 ;;27502,27503,27508,27510,27516,27517,27520,27530,27532,27538,27550,27552,27560,27562,27570,27613,27614
+98 ;;27618,27619,27632,27634,27648,27690,27691,27750,27752,27760,27762,27767,27768,27780,27781,27786,27788
+99 ;;27808,27810,27816,27818,27824,27825,27830,27831,27840,27842,27860,27870,27871,27884,28001,28005,28008
+100 ;;28010,28011,28020,28022,28024,28035,28039,28041,28043,28045,28046,28050,28052,28054,28055,28060,28062
+101 ;;28070,28072,28080,28086,28088,28090,28092,28100,28102,28103,28104,28106,28107,28108,28110,28111,28112
