SR215UTL ;HPS/JSG - SR*3*215 UTILITY ROUTINE; Apr 3, 2024@11:40
;;3.0;Surgery;**206,210,215**;24 Jun 93;Build 7
;
PRE ; -- pre-install process for SR*3*215
I $D(^XTMP("PRE 2024-UPDATE BACKUP OF 137")) D Q
. D EN^DDIOL("The PRE 2024-UPDATE BACKUP of #137 already exists.","!")
. D EN^DDIOL("Please resolve before performing the install again.")
. K ^XTMP("PRE 2024-UPDATE BACKUP OF 137",1)
N X1,X2,X
S X1=DT,X2=120 D C^%DTC
S ^XTMP("PRE 2024-UPDATE BACKUP OF 137",0)=$G(X)_"^"_$G(DT)_"^"_"Backup of file 137 before 2024 update is performed by Patch SR*3*215"
D EN^DDIOL("Backing up the CPT EXCLUSIONS file (#137) to ^XTMP.","","!!?1")
M ^XTMP("PRE 2024-UPDATE BACKUP OF 137",137)=^SRO(137) S ^XTMP("PRE 2024-UPDATE BACKUP OF 137",1)=DT
D EN^DDIOL("Backup complete","","!!?1")
;
D DATDEL ; delete data from file #137 prior to updating
Q
;
BACK ; -- rollback PRE 2024-UPDATE BACKUP OF 137 from ^XTMP
I '$D(^XTMP("PRE 2024-UPDATE BACKUP OF 137")) W !,"Backup does not exist." Q
D DATDEL ; delete data from file #137 prior to the roolback
M ^SRO(137)=^XTMP("PRE 2024-UPDATE BACKUP OF 137",137)
K ^XTMP("PRE 2024-UPDATE BACKUP OF 137")
W !!,"Rollback completed."
Q
;
POST ; -- post-install process for SR*3*215
; -- check if already run
I '$D(^XTMP("PRE 2024-UPDATE BACKUP OF 137",1)) D Q
. D EN^DDIOL("The PRE 2024-UPDATE BACKUP of #137 did not complete successfully.","!")
. D EN^DDIOL("Please contact support and consider the rollback option before","!")
. D EN^DDIOL("before performing the install again.")
; -- populate the CPT EXCLUSIONS file (#137)
N SRI,SRJ,SRL,SRLIST,SRX,SRY,X,SRABC,I
D MES^XPDUTL(" Populating CPT EXCLUSIONS file (#137)...")
F SRJ=1: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^SR215UT0,EX^SR215UT1,EX^SR215UT2,EX^SR215UT3
;
; -- 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-96546", "96549-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","96546")) D INT ;new break for 2024
S SRX="96549" F S SRX=$O(^ICPT("B",SRX)) Q:SRX=$O(^ICPT("B","99999")) D INT ;new break for 2024
;
EC ; -- Exclude CODES that start with alphabetic characters:
D AC F SRX="A","B","C","D","E","G","H","J","K","L","M","P","Q","R","S","T","V","W","Z" D
. F S SRX=$O(^ICPT("B",SRX)) Q:SRX="" I '$D(SRABC(SRX)) D INT
;
; -- Honor KIDS "No Delete" setting if called from a KIDS install.
; -- Delete routines SR215UT0, SR215UT1, SR215UT2, & SR215UT3
I '$$GET^XUPARAM("XPD NO_EPP_DELETE") D
. F X="SR215UT0","SR215UT1","SR215UT2","SR215UT3" X ^%ZOSF("TEST") I $T D
. .D MES^XPDUTL(" Deleting routine "_X_"...") X ^%ZOSF("DEL")
K DA,DIC,DD,DO,DINUM,X
Q
;
AC ; -- Add back CODES With alpha characters that are included in 2024:
;;C9754,C9755,C9764,C9765,C9766,C9767,C9772,C9781,C9784,S2068,S2070,S2205,S2207,S2208,S2325
F I=1:1:15 S SRABC($P($P($T(AC+1),";",3),",",I))=1
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
;
LINES ;Create n lines each with 13 codes
N L,LC,NC,I,C
S LC=0,L="",NC=0
F I=1:1:8011 S C=$P(^JSG(I),$C(9)),NC=NC+1 S L=$S(NC<13:L_C_",",1:L_C) I NC=13!(I=8011) D
. S LC=LC+1,^JSGL(LC)=L,NC=0,L=""
Q
;
LIST ;
;;0001A,0001F,0002A,0002M,0003A,0003M,0004A,0004M,0005F,0006M,0007M,00100,00102
;;00103,00104,0011A,0011M,00120,00124,00126,0012A,0012F,0012M,0013A,0013M,00140
;;00142,00144,00145,00147,00148,0014F,0014M,0015F,0015M,00160,00162,00164,0016M
;;00170,00172,00174,00176,0017M,0018M,00190,00192,0019M,00210,00211,00212,00214
;;00215,00216,00218,0021A,00220,00222,0022A,00300,0031A,00320,00322,00326,0034A
;;00350,00352,00400,00402,00404,00406,00410,0041A,0042A,0042T,0044A,00450,00454
;;00470,00472,00474,00500,0051A,00520,00522,00524,00528,00529,0052A,00530,00532
;;00534,00537,00539,0053A,00540,00541,00542,00546,00548,0054A,0054T,00550,0055T
;;00560,00561,00562,00563,00566,00567,00580,00600,00604,00620,00625,00626,00630
;;00632,00635,00640,0064A,00670,00700,00702,0071A,0071T,0072A,0072T,00730,00731
;;00732,0073A,0074A,00750,00752,00754,00756,00770,00790,00792,00794,00796,00797
;;00800,00802,00811,00812,00813,0081A,00820,0082A,00830,00832,00834,00836,0083A
;;00840,00842,00844,00846,00848,00851,00860,00862,00864,00865,00866,00868,00870
;;00872,00873,00880,00882,00902,00904,00906,00908,00910,00912,00914,00916,00918
;;0091A,00920,00921,00922,00924,00926,00928,0092A,00930,00932,00934,00936,00938
;;0093A,00940,00942,00944,00948,0094A,00950,00952,0100T,0101T,0102T,0104A,0106T
;;0107T,0108T,0109T,0110T,01112,0111A,01120,0112A,01130,0113A,01140,01150,01160
;;01170,01173,01200,01202,01210,01212,01214,01215,0121A,01220,01230,01232,01234
;;0124A,01250,01260,01270,01272,01274,01320,01340,0134A,01360,01380,01382,01390
;;01392,01400,01402,01404,0141A,01420,0142A,01430,01432,01440,01442,01444,0144A
;;01462,01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,0151A
;;01520,01522,0154A,01610,01620,01622,01630,01634,01636,01638,0164A,0164T,01650
;;01652,01654,01656,0165T,01670,01680,01710,01712,01714,01716,0171A,0172A,01730
;;01732,0173A,01740,01742,01744,0174A,0174T,01756,01758,0175T,01760,01770,01772
;;01780,01782,01810,01820,01829,01830,01832,01840,01842,01844,01850,01852,01860
;;01916,01920,01922,01924,01925,01926,01930,01931,01932,01933,01937,01938,01939
;;01940,01941,01942,01951,01952,01953,01958,01960,01961,01962,01963,01965,01966
;;01967,01968,01969,0198T,01990,01991,01992,01996,01999,0200T,0201T,0207T,0208T
;;0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T,0217T,0218T,0232T,0253T,0263T
;;0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T,0272T,0273T,0275T,0278T,0308T
;;0329T,0330T,0331T,0332T,0333T,0335T,0338T,0339T,0342T,0345T,0347T,0348T,0349T
;;0350T,0351T,0352T,0353T,0354T,0358T,0362T,0373T,0378T,0379T,0394T,0395T,0397T
;;0398T,0402T,0403T,0404T,0408T,0409T,0410T,0411T,0412T,0413T,0414T,0415T,0416T
;;0417T,0418T,0419T,0420T,0422T,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,0464T,0465T,0469T,0472T,0473T,0474T,0479T,0480T
;;0481T,0485T,0486T,0488T,0489T,0490T,0494T,0495T,0496T,0500F,0500T,0501F,0501T
;;0502F,0502T,0503F,0503T,0504T,0505F,0505T,0506T,0507F,0507T,0508T,0509F,0509T
;;0510T,0511T,0512T,0513F,0513T,0514F,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,0546T,0547T,0550F,0551F,0552T
;;0553T,0554T,0555F,0555T,0556F,0556T,0557F,0557T,0558T,0559T,0560T,0561T,0562T
;;0563T,0564T,0565T,0566T,0567T,0568T,0571T,0572T,0573T,0574T,0575F,0575T,0576T
;;0577T,0578T,0579T,0580F,0580T,0581F,0581T,0582F,0582T,0583F,0583T,0584F,0587T
;;0588T,0589T,0590T,0591T,0592T,0593T,0594T,0596T,0597T,0598T,0599T,0600T,0601T
;;0602T,0603T,0604T,0605T,0606T,0607T,0608T,0609T,0610T,0611T,0612T,0613T,0614T
;;0615T,0616T,0617T,0618T,0619T,0620T,0621T,0622T,0623T,0624T,0625T,0626T,0627T
;;0628T,0629T,0630T,0631T,0632T,0633T,0634T,0635T,0636T,0637T,0638T,0639T,0640T
;;0641T,0642T,0647T,0648T,0649T,0650T,0651T,0652T,0653T,0654T,0655T,0658T,0659T
;;0660T,0661T,0662T,0663T,0664T,0671T,0672T,0673T,0682T,0683T,0684T,0685T,0686T
;;0687T,0688T,0689T,0690T,0691T,0692T,0693T,0694T,0695T,0696T,0697T,0698T,0699T
;;0700T,0701T,0704T,0705T,0706T,0707T,0708T,0709T,0710T,0711T,0712T,0713T,0715T
;;0716T,0717T,0718T,0719T,0720T,0721T,0722T,0723T,0724T,0728T,0729T,0730T,0731T
;;0732T,0733T,0734T,0736T,0738T,0739T,0740T,0741T,0742T,0743T,0745T,0746T,0747T
;;0748T,0749T,0750T,0751T,0752T,0753T,0754T,0755T,0756T,0757T,0758T,0759T,0760T
;;0761T,0762T,0763T,0764T,0765T,0766T,0767T,0768T,0769T,0770T,0771T,0772T,0773T
;;0774T,0775T,0776T,0777T,0778T,0779T,0780T,0781T,0782T,0783T,0784T,0785T,0786T
;;0787T,0788T,0789T,0790T,0791T,0792T,0793T,0794T,0795T,0796T,0797T,0798T,0799T
;;0800T,0801T,0802T,0803T,0804T,0807T,0808T,0810T,0811T,0812T,0813T,0814T,0815T
;;0816T,0817T,0818T,0819T,0820T,0821T,0822T,0823T,0824T,0825T,0826T,0827T,0828T
;;0829T,0830T,0831T,0832T,0833T,0834T,0835T,0836T,0837T,0838T,0839T,0840T,0841T
;;0842T,0843T,0844T,0845T,0846T,0847T,0848T,0849T,0850T,0851T,0852T,0853T,0854T
;;0855T,0856T,0857T,0858T,0859T,0860T,0861T,0862T,0863T,0864T,0865T,0866T,10004
;;10005,10006,10007,10008,10009,1000F,10010,10011,10012,10021,1002F,10030,10035
;;10036,1003F,10040,1004F,1005F,10060,10061,1006F,1007F,10080,10081,1008F,1010F
;;1011F,10120,10121,1012F,10140,1015F,10160,10180,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,11001,1100F,1101F,11042,11043
;;11044,11045,11046,11047,11055,11056,11057,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,15769,15771,15772,15773,15774,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,15851,15852,15853,15854,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,2023F,20240,20245
;;2024F,20250,20251,2025F,2026F,2027F,2028F,2029F,2030F,2031F,2033F,2035F,2040F
;;2044F,20500,20501,2050F,20520,20525,20526,20527,20550,20551,20552,20553,20555
;;20560,20561,20600,20604,20605,20606,2060F,20610,20611,20612,20615,20650,20660
;;20661,20662,20663,20664,20665,20670,20680,20690,20692,20693,20694,20696,20697
;;20700,20701,20702,20703,20704,20705,20900,20902,20910,20912,20920,20922,20924
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR215UTL 13834 printed Nov 22, 2024@17:48:37 Page 2
SR215UTL ;HPS/JSG - SR*3*215 UTILITY ROUTINE; Apr 3, 2024@11:40
+1 ;;3.0;Surgery;**206,210,215**;24 Jun 93;Build 7
+2 ;
PRE ; -- pre-install process for SR*3*215
+1 IF $DATA(^XTMP("PRE 2024-UPDATE BACKUP OF 137"))
Begin DoDot:1
+2 DO EN^DDIOL("The PRE 2024-UPDATE BACKUP of #137 already exists.","!")
+3 DO EN^DDIOL("Please resolve before performing the install again.")
+4 KILL ^XTMP("PRE 2024-UPDATE BACKUP OF 137",1)
End DoDot:1
QUIT
+5 NEW X1,X2,X
+6 SET X1=DT
SET X2=120
DO C^%DTC
+7 SET ^XTMP("PRE 2024-UPDATE BACKUP OF 137",0)=$GET(X)_"^"_$GET(DT)_"^"_"Backup of file 137 before 2024 update is performed by Patch SR*3*215"
+8 DO EN^DDIOL("Backing up the CPT EXCLUSIONS file (#137) to ^XTMP.","","!!?1")
+9 MERGE ^XTMP("PRE 2024-UPDATE BACKUP OF 137",137)=^SRO(137)
SET ^XTMP("PRE 2024-UPDATE BACKUP OF 137",1)=DT
+10 DO EN^DDIOL("Backup complete","","!!?1")
+11 ;
+12 ; delete data from file #137 prior to updating
DO DATDEL
+13 QUIT
+14 ;
BACK ; -- rollback PRE 2024-UPDATE BACKUP OF 137 from ^XTMP
+1 IF '$DATA(^XTMP("PRE 2024-UPDATE BACKUP OF 137"))
WRITE !,"Backup does not exist."
QUIT
+2 ; delete data from file #137 prior to the roolback
DO DATDEL
+3 MERGE ^SRO(137)=^XTMP("PRE 2024-UPDATE BACKUP OF 137",137)
+4 KILL ^XTMP("PRE 2024-UPDATE BACKUP OF 137")
+5 WRITE !!,"Rollback completed."
+6 QUIT
+7 ;
POST ; -- post-install process for SR*3*215
+1 ; -- check if already run
+2 IF '$DATA(^XTMP("PRE 2024-UPDATE BACKUP OF 137",1))
Begin DoDot:1
+3 DO EN^DDIOL("The PRE 2024-UPDATE BACKUP of #137 did not complete successfully.","!")
+4 DO EN^DDIOL("Please contact support and consider the rollback option before","!")
+5 DO EN^DDIOL("before performing the install again.")
End DoDot:1
QUIT
+6 ; -- populate the CPT EXCLUSIONS file (#137)
+7 NEW SRI,SRJ,SRL,SRLIST,SRX,SRY,X,SRABC,I
+8 DO MES^XPDUTL(" Populating CPT EXCLUSIONS file (#137)...")
+9 FOR SRJ=1: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
+10 DO EX^SR215UT0
DO EX^SR215UT1
DO EX^SR215UT2
DO EX^SR215UT3
+11 ;
+12 ; -- The following CPT Code ranges are excluded: "00001-0051S", "0051U-0052S", "0052U-0053S", "0053U-0075S",
+13 ; "0075U-0076S", "0076U-0078S", "0078U-0095S", "0095U-0098S", "0098U-0171S", "0171U-0172S", "0172U-0184S"
+14 ; "0184U-01999", "70000-79999", "80000-89999", "90000-93589", "93593-96546", "96549-99999"
+15 SET SRX="00001"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0051S"))
QUIT
DO INT
+16 SET SRX="0051U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0052S"))
QUIT
DO INT
+17 SET SRX="0052U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0053S"))
QUIT
DO INT
+18 SET SRX="0053U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0075S"))
QUIT
DO INT
+19 SET SRX="0075U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0076S"))
QUIT
DO INT
+20 SET SRX="0076U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0078S"))
QUIT
DO INT
+21 SET SRX="0078U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0095S"))
QUIT
DO INT
+22 SET SRX="0095U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0098S"))
QUIT
DO INT
+23 SET SRX="0098U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0171S"))
QUIT
DO INT
+24 SET SRX="0171U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0172S"))
QUIT
DO INT
+25 SET SRX="0172U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","0184S"))
QUIT
DO INT
+26 SET SRX="0184U"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","01999"))
QUIT
DO INT
+27 SET SRX="70000"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","79999"))
QUIT
DO INT
+28 SET SRX="80000"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","89999"))
QUIT
DO INT
+29 SET SRX="90000"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","93589"))
QUIT
DO INT
+30 ;new break for 2024
SET SRX="93593"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","96546"))
QUIT
DO INT
+31 ;new break for 2024
SET SRX="96549"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=$ORDER(^ICPT("B","99999"))
QUIT
DO INT
+32 ;
EC ; -- Exclude CODES that start with alphabetic characters:
+1 DO AC
FOR SRX="A","B","C","D","E","G","H","J","K","L","M","P","Q","R","S","T","V","W","Z"
Begin DoDot:1
+2 FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=""
QUIT
IF '$DATA(SRABC(SRX))
DO INT
End DoDot:1
+3 ;
+4 ; -- Honor KIDS "No Delete" setting if called from a KIDS install.
+5 ; -- Delete routines SR215UT0, SR215UT1, SR215UT2, & SR215UT3
+6 IF '$$GET^XUPARAM("XPD NO_EPP_DELETE")
Begin DoDot:1
+7 FOR X="SR215UT0","SR215UT1","SR215UT2","SR215UT3"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:2
+8 DO MES^XPDUTL(" Deleting routine "_X_"...")
XECUTE ^%ZOSF("DEL")
End DoDot:2
End DoDot:1
+9 KILL DA,DIC,DD,DO,DINUM,X
+10 QUIT
+11 ;
AC ; -- Add back CODES With alpha characters that are included in 2024:
+1 ;;C9754,C9755,C9764,C9765,C9766,C9767,C9772,C9781,C9784,S2068,S2070,S2205,S2207,S2208,S2325
+2 FOR I=1:1:15
SET SRABC($PIECE($PIECE($TEXT(AC+1),";",3),",",I))=1
+3 QUIT
+4 ;
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 ;
LINES ;Create n lines each with 13 codes
+1 NEW L,LC,NC,I,C
+2 SET LC=0
SET L=""
SET NC=0
+3 FOR I=1:1:8011
SET C=$PIECE(^JSG(I),$CHAR(9))
SET NC=NC+1
SET L=$SELECT(NC<13:L_C_",",1:L_C)
IF NC=13!(I=8011)
Begin DoDot:1
+4 SET LC=LC+1
SET ^JSGL(LC)=L
SET NC=0
SET L=""
End DoDot:1
+5 QUIT
+6 ;
LIST ;
+1 ;;0001A,0001F,0002A,0002M,0003A,0003M,0004A,0004M,0005F,0006M,0007M,00100,00102
+2 ;;00103,00104,0011A,0011M,00120,00124,00126,0012A,0012F,0012M,0013A,0013M,00140
+3 ;;00142,00144,00145,00147,00148,0014F,0014M,0015F,0015M,00160,00162,00164,0016M
+4 ;;00170,00172,00174,00176,0017M,0018M,00190,00192,0019M,00210,00211,00212,00214
+5 ;;00215,00216,00218,0021A,00220,00222,0022A,00300,0031A,00320,00322,00326,0034A
+6 ;;00350,00352,00400,00402,00404,00406,00410,0041A,0042A,0042T,0044A,00450,00454
+7 ;;00470,00472,00474,00500,0051A,00520,00522,00524,00528,00529,0052A,00530,00532
+8 ;;00534,00537,00539,0053A,00540,00541,00542,00546,00548,0054A,0054T,00550,0055T
+9 ;;00560,00561,00562,00563,00566,00567,00580,00600,00604,00620,00625,00626,00630
+10 ;;00632,00635,00640,0064A,00670,00700,00702,0071A,0071T,0072A,0072T,00730,00731
+11 ;;00732,0073A,0074A,00750,00752,00754,00756,00770,00790,00792,00794,00796,00797
+12 ;;00800,00802,00811,00812,00813,0081A,00820,0082A,00830,00832,00834,00836,0083A
+13 ;;00840,00842,00844,00846,00848,00851,00860,00862,00864,00865,00866,00868,00870
+14 ;;00872,00873,00880,00882,00902,00904,00906,00908,00910,00912,00914,00916,00918
+15 ;;0091A,00920,00921,00922,00924,00926,00928,0092A,00930,00932,00934,00936,00938
+16 ;;0093A,00940,00942,00944,00948,0094A,00950,00952,0100T,0101T,0102T,0104A,0106T
+17 ;;0107T,0108T,0109T,0110T,01112,0111A,01120,0112A,01130,0113A,01140,01150,01160
+18 ;;01170,01173,01200,01202,01210,01212,01214,01215,0121A,01220,01230,01232,01234
+19 ;;0124A,01250,01260,01270,01272,01274,01320,01340,0134A,01360,01380,01382,01390
+20 ;;01392,01400,01402,01404,0141A,01420,0142A,01430,01432,01440,01442,01444,0144A
+21 ;;01462,01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,0151A
+22 ;;01520,01522,0154A,01610,01620,01622,01630,01634,01636,01638,0164A,0164T,01650
+23 ;;01652,01654,01656,0165T,01670,01680,01710,01712,01714,01716,0171A,0172A,01730
+24 ;;01732,0173A,01740,01742,01744,0174A,0174T,01756,01758,0175T,01760,01770,01772
+25 ;;01780,01782,01810,01820,01829,01830,01832,01840,01842,01844,01850,01852,01860
+26 ;;01916,01920,01922,01924,01925,01926,01930,01931,01932,01933,01937,01938,01939
+27 ;;01940,01941,01942,01951,01952,01953,01958,01960,01961,01962,01963,01965,01966
+28 ;;01967,01968,01969,0198T,01990,01991,01992,01996,01999,0200T,0201T,0207T,0208T
+29 ;;0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T,0217T,0218T,0232T,0253T,0263T
+30 ;;0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T,0272T,0273T,0275T,0278T,0308T
+31 ;;0329T,0330T,0331T,0332T,0333T,0335T,0338T,0339T,0342T,0345T,0347T,0348T,0349T
+32 ;;0350T,0351T,0352T,0353T,0354T,0358T,0362T,0373T,0378T,0379T,0394T,0395T,0397T
+33 ;;0398T,0402T,0403T,0404T,0408T,0409T,0410T,0411T,0412T,0413T,0414T,0415T,0416T
+34 ;;0417T,0418T,0419T,0420T,0422T,0424T,0425T,0426T,0427T,0428T,0429T,0430T,0431T
+35 ;;0432T,0433T,0434T,0435T,0436T,0437T,0439T,0440T,0441T,0442T,0443T,0444T,0445T
+36 ;;0446T,0447T,0448T,0449T,0450T,0464T,0465T,0469T,0472T,0473T,0474T,0479T,0480T
+37 ;;0481T,0485T,0486T,0488T,0489T,0490T,0494T,0495T,0496T,0500F,0500T,0501F,0501T
+38 ;;0502F,0502T,0503F,0503T,0504T,0505F,0505T,0506T,0507F,0507T,0508T,0509F,0509T
+39 ;;0510T,0511T,0512T,0513F,0513T,0514F,0515T,0516F,0516T,0517F,0517T,0518F,0518T
+40 ;;0519F,0519T,0520F,0520T,0521F,0521T,0522T,0523T,0524T,0525F,0525T,0526F,0526T
+41 ;;0527T,0528F,0528T,0529F,0529T,0530T,0531T,0532T,0533T,0534T,0535F,0535T,0536T
+42 ;;0537T,0538T,0539T,0540F,0540T,0541T,0542T,0545F,0546T,0547T,0550F,0551F,0552T
+43 ;;0553T,0554T,0555F,0555T,0556F,0556T,0557F,0557T,0558T,0559T,0560T,0561T,0562T
+44 ;;0563T,0564T,0565T,0566T,0567T,0568T,0571T,0572T,0573T,0574T,0575F,0575T,0576T
+45 ;;0577T,0578T,0579T,0580F,0580T,0581F,0581T,0582F,0582T,0583F,0583T,0584F,0587T
+46 ;;0588T,0589T,0590T,0591T,0592T,0593T,0594T,0596T,0597T,0598T,0599T,0600T,0601T
+47 ;;0602T,0603T,0604T,0605T,0606T,0607T,0608T,0609T,0610T,0611T,0612T,0613T,0614T
+48 ;;0615T,0616T,0617T,0618T,0619T,0620T,0621T,0622T,0623T,0624T,0625T,0626T,0627T
+49 ;;0628T,0629T,0630T,0631T,0632T,0633T,0634T,0635T,0636T,0637T,0638T,0639T,0640T
+50 ;;0641T,0642T,0647T,0648T,0649T,0650T,0651T,0652T,0653T,0654T,0655T,0658T,0659T
+51 ;;0660T,0661T,0662T,0663T,0664T,0671T,0672T,0673T,0682T,0683T,0684T,0685T,0686T
+52 ;;0687T,0688T,0689T,0690T,0691T,0692T,0693T,0694T,0695T,0696T,0697T,0698T,0699T
+53 ;;0700T,0701T,0704T,0705T,0706T,0707T,0708T,0709T,0710T,0711T,0712T,0713T,0715T
+54 ;;0716T,0717T,0718T,0719T,0720T,0721T,0722T,0723T,0724T,0728T,0729T,0730T,0731T
+55 ;;0732T,0733T,0734T,0736T,0738T,0739T,0740T,0741T,0742T,0743T,0745T,0746T,0747T
+56 ;;0748T,0749T,0750T,0751T,0752T,0753T,0754T,0755T,0756T,0757T,0758T,0759T,0760T
+57 ;;0761T,0762T,0763T,0764T,0765T,0766T,0767T,0768T,0769T,0770T,0771T,0772T,0773T
+58 ;;0774T,0775T,0776T,0777T,0778T,0779T,0780T,0781T,0782T,0783T,0784T,0785T,0786T
+59 ;;0787T,0788T,0789T,0790T,0791T,0792T,0793T,0794T,0795T,0796T,0797T,0798T,0799T
+60 ;;0800T,0801T,0802T,0803T,0804T,0807T,0808T,0810T,0811T,0812T,0813T,0814T,0815T
+61 ;;0816T,0817T,0818T,0819T,0820T,0821T,0822T,0823T,0824T,0825T,0826T,0827T,0828T
+62 ;;0829T,0830T,0831T,0832T,0833T,0834T,0835T,0836T,0837T,0838T,0839T,0840T,0841T
+63 ;;0842T,0843T,0844T,0845T,0846T,0847T,0848T,0849T,0850T,0851T,0852T,0853T,0854T
+64 ;;0855T,0856T,0857T,0858T,0859T,0860T,0861T,0862T,0863T,0864T,0865T,0866T,10004
+65 ;;10005,10006,10007,10008,10009,1000F,10010,10011,10012,10021,1002F,10030,10035
+66 ;;10036,1003F,10040,1004F,1005F,10060,10061,1006F,1007F,10080,10081,1008F,1010F
+67 ;;1011F,10120,10121,1012F,10140,1015F,10160,10180,1018F,1019F,1022F,1026F,1030F
+68 ;;1031F,1032F,1033F,1034F,1035F,1036F,1038F,1039F,1040F,1050F,1052F,1055F,1060F
+69 ;;1061F,1065F,1066F,1070F,1071F,1090F,1091F,11000,11001,1100F,1101F,11042,11043
+70 ;;11044,11045,11046,11047,11055,11056,11057,11102,11103,11104,11105,11106,11107
+71 ;;1110F,1111F,1116F,1118F,1119F,11200,11201,1121F,1123F,1124F,1125F,1126F,1127F
+72 ;;1128F,11300,11301,11302,11303,11305,11306,11307,11308,1130F,11310,11311,11312
+73 ;;11313,1134F,1135F,1136F,1137F,11400,11401,11402,11403,11404,11406,11420,11421
+74 ;;11422,11423,11424,11426,11440,11441,11442,11443,11444,11446,11450,11451,11462
+75 ;;11463,11470,11471,1150F,1151F,1152F,1153F,1157F,1158F,1159F,11600,11601,11602
+76 ;;11603,11604,11606,1160F,11620,11621,11622,11623,11624,11626,11640,11641,11642
+77 ;;11643,11644,11646,1170F,11719,11720,11721,11730,11732,11740,11750,11755,1175F
+78 ;;11760,11762,11765,11770,11771,11772,1180F,1181F,1182F,1183F,11900,11901,11920
+79 ;;11921,11922,11950,11951,11952,11954,11960,11970,11971,11976,11980,11981,11982
+80 ;;11983,12001,12002,12004,12005,12006,12007,1200F,12011,12013,12014,12015,12016
+81 ;;12017,12018,12020,12021,12031,12032,12034,12035,12036,12037,12041,12042,12044
+82 ;;12045,12046,12047,12051,12052,12053,12054,12055,12056,12057,1205F,1220F,13100
+83 ;;13101,13102,13120,13121,13122,13131,13132,13133,13151,13152,13153,13160,14000
+84 ;;14001,1400F,14020,14021,14040,14041,14060,14061,14301,14302,14350,1450F,1451F
+85 ;;1460F,1461F,1490F,1491F,1493F,1494F,15002,15003,15004,1500F,1501F,1502F,1503F
+86 ;;1504F,15050,1505F,15100,15101,15110,15111,15115,15116,15120,15121,15130,15131
+87 ;;15135,15136,15150,15151,15152,15155,15156,15157,15200,15201,15220,15221,15240
+88 ;;15241,15260,15261,15271,15272,15273,15274,15275,15276,15277,15278,15570,15572
+89 ;;15574,15576,15730,15733,15769,15771,15772,15773,15774,15775,15776,15777,15780
+90 ;;15781,15782,15783,15786,15787,15788,15789,15792,15793,15819,15820,15821,15822
+91 ;;15823,15824,15825,15826,15828,15829,15832,15833,15834,15835,15836,15837,15838
+92 ;;15839,15840,15841,15842,15845,15851,15852,15853,15854,15860,15876,15877,15878
+93 ;;15879,16000,16020,16025,16030,16035,16036,17000,17003,17004,17106,17107,17108
+94 ;;17110,17111,17250,17260,17261,17262,17263,17264,17266,17270,17271,17272,17273
+95 ;;17274,17276,17280,17281,17282,17283,17284,17286,17311,17312,17313,17314,17315
+96 ;;17340,17360,17380,17999,19000,19001,19020,19030,19081,19082,19083,19084,19085
+97 ;;19086,19100,19101,19105,19110,19112,19120,19125,19126,19281,19282,19283,19284
+98 ;;19285,19286,19287,19288,19294,2000F,2001F,2002F,2004F,2010F,2014F,2015F,2016F
+99 ;;2018F,2019F,20200,20205,20206,2020F,2021F,20220,20225,2022F,2023F,20240,20245
+100 ;;2024F,20250,20251,2025F,2026F,2027F,2028F,2029F,2030F,2031F,2033F,2035F,2040F
+101 ;;2044F,20500,20501,2050F,20520,20525,20526,20527,20550,20551,20552,20553,20555
+102 ;;20560,20561,20600,20604,20605,20606,2060F,20610,20611,20612,20615,20650,20660
+103 ;;20661,20662,20663,20664,20665,20670,20680,20690,20692,20693,20694,20696,20697
+104 ;;20700,20701,20702,20703,20704,20705,20900,20902,20910,20912,20920,20922,20924
