SR176UTL ;BIR/SJA - SR*3*176 UTILITY ROUTINE ;01/17/2012
;;3.0;Surgery;**176**;24 Jun 93;Build 8
Q
PRE ; pre-install process for SR*3*176
; delete data from file 136.5 and re-initialize file
K ^SRO(136.5) S ^SRO(136.5,0)="PERIOPERATIVE OCCURRENCE CATEGORY^136.5I^^"
; set LATEST 30-READMISSION REPORT field (#8) in file #133 to null
N SRI S SRI=0 F S SRI=$O(^SRO(133,SRI)) Q:'SRI S $P(^SRO(133,SRI,0),"^",9)=""
; delete DD for modified field #240
S DA=240,DIK="^DD(130,",DA(1)=130 D ^DIK K DA,DIK
Q
POST ; post-install process for SR*3*176
; populate file 137
N SRI,SRJ,SRL,SRLIST,SRX,SRY,X
D MES^XPDUTL(" Populating CPT EXCLUSIONS file...")
K ^SRO(137) S ^SRO(137,0)="CPT EXCLUSIONS^137P^^"
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 PEX^SR176UT0,PEX^SR176UT1,PEX^SR176UT2
S SRX="A" F S SRX=$O(^ICPT("B",SRX)) Q:SRX="" D INT
DEL ; delete routines SR176UT0, SR176UT1 and SR176UT2
F X="SR176UT0","SR176UT1","SR176UT2" 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
LIST ;;0001F,0005F,00100,00102,00103,00104,00120,00124,00126,0012F,00140,00142
;;00144,00145,00147,00148,0014F,0015F,00160,00162,00164,00170,00172,00174,00176,00190,00192,0019T,00210,00211,00212,00214
;;00215,00216,00218,00220,00222,00300,0030T,00320,00322,00326,00350,00352,00400,00402,00404,00406,00410,0042T,00450,00452
;;00454,00470,00472,00474,0048T,00500,0050T,0051T,00520,00522,00524,00528,00529,0052T,00530,00532,00534,00537,00539,0053T
;;00540,00541,00542,00546,00548,0054T,00550,0055T,00560,00561,00562,00563,00566,00567,00580,0058T,0059T,00600,00604,00620
;;00622,00625,00626,00630,00632,00634,00635,00640,00670,00700,00702,0071T,0072T,00730,0073T,00740,00750,00752,00754,00756
;;0075T,0076T,00770,0078T,00790,00792,00794,00796,00797,0079T,00800,00802,0080T,00810,0081T,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,0092T,00930,00932,00934,00936,00938,00940
;;00942,00944,00948,00950,00952,0095T,0098T,0099T,0100T,0101T,0102T,0103T,0106T,0107T,0108T,0109T,0110T,01112,0111T,01120
;;01130,01140,01150,01160,01170,01173,01180,01190,01200,01202,01210,01212,01214,01215,01220,01230,01232,01234,0123T,0124T
;;01250,01260,0126T,01270,01272,01274,01320,01340,01360,01380,01382,01390,01392,01400,01402,01404,0141T,01420,0142T,01430
;;01432,0143T,01440,01442,01444,01462,01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,01520,01522,0155T
;;0156T,0157T,0158T,0159T,01610,01620,01622,01630,01634,01636,01638,0163T,0164T,01650,01652,01654,01656,0165T,0166T,01670
;;0167T,01680,01682,0168T,0169T,01710,01712,01714,01716,0171T,0172T,01730,01732,0173T,01740,01742,01744,0174T,01756,01758
;;0175T,01760,01770,01772,01780,01782,0178T,0179T,0180T,01810,0181T,01820,01829,0182T,01830,01832,0183T,01840,01842,01844
;;01850,01852,0185T,01860,0186T,0188T,0189T,0190T,01916,0191T,01920,01922,01924,01925,01926,0192T,01930,01931,01932,01933
;;01935,01936,01951,01952,01953,01958,0195T,01960,01961,01962,01963,01965,01966,01967,01968,01969,0196T,0197T,0198T,01990
;;01991,01992,01996,01999,0199T,0200T,0201T,0202T,0206T,0207T,0208T,0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T,0217T
;;0218T,0223T,0224T,0225T,0226T,0227T,0228T,0229T,0230T,0231T,0232T,0233T,0234T,0235T,0236T,0237T,0238T,0239T,0240T,0241T
;;0242T,0243T,0244T,0249T,0251T,0252T,0253T,0260T,0261T,0263T,0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T,0272T,0273T
;;0274T,0275T,0276T,0277T,0278T,0279T,0280T,0281T,0283T,0284T,0285T,0286T,0287T,0288T,0289T,0290T,0500F,0501F,0502F,0503F
;;0505F,0507F,0509F,0513F,0514F,0516F,0517F,0518F,0519F,0520F,0521F,0525F,0526F,0528F,0529F,0535F,0540F,0545F,0550F,0551F
;;0555F,0556F,0557F,0575F,1000F,10021,10022,1002F,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,1055F
;;1060F,1061F,1065F,1066F,1070F,1071F,1090F,1091F,11000,1100F,11010,11011,11012,1101F,11042,11043,11044,11055,11056,11057
;;11100,11101,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,11752,11755,1175F,11760,11762,11765,11770,11771,11772
;;1180F,1181F,1182F,1183F,11900,11901,11920,11921,11922,11950,11951,11952,11954,11970,11971,11975,11976,11977,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,13150,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,15050,15100,15101,15110
;;15111,15115,15116,15120,15121,15130,15131,15135,15136,15150,15151,15152,15155,15156,15157,15170,15171,15175,15176,15200
;;15201,15220,15221,15240,15241,15260,15261,15271,15272,15273,15274,15275,15276,15277,15278,15300,15301,15320,15321,15330
;;15331,15335,15336,15340,15341,15360,15361,15365,15366,15400,15401,15420,15421,15430,15431,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,15850,15851,15852,15860,16000,16020,16025,16030,16035,16036,17000,17003,17004,17106
;;17110,17250,17260,17261,17262,17263,17264,17266,17270,17271,17272,17273,17274,17276,17280,17281,17282,17283,17284,17286
;;17340,17360,17380,17999,19000,19001,19030,19100,19101,19102,19103,19112,19290,19291,19295,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
;;20605,2060F,20610,20612,20615,20650,20660,20661,20662,20663,20664,20665,20670,20680,20690,20692,20693,20694,20696,20697
;;20912,20924,20950,20974,20979,20982,20985,21011,21012,21013,21014,21016,21030,21031,21032,21073,21076,21077,21079,21080
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR176UTL 7081 printed Apr 09, 2024@21:49:38 Page 2
SR176UTL ;BIR/SJA - SR*3*176 UTILITY ROUTINE ;01/17/2012
+1 ;;3.0;Surgery;**176**;24 Jun 93;Build 8
+2 QUIT
PRE ; pre-install process for SR*3*176
+1 ; delete data from file 136.5 and re-initialize file
+2 KILL ^SRO(136.5)
SET ^SRO(136.5,0)="PERIOPERATIVE OCCURRENCE CATEGORY^136.5I^^"
+3 ; set LATEST 30-READMISSION REPORT field (#8) in file #133 to null
+4 NEW SRI
SET SRI=0
FOR
SET SRI=$ORDER(^SRO(133,SRI))
if 'SRI
QUIT
SET $PIECE(^SRO(133,SRI,0),"^",9)=""
+5 ; delete DD for modified field #240
+6 SET DA=240
SET DIK="^DD(130,"
SET DA(1)=130
DO ^DIK
KILL DA,DIK
+7 QUIT
POST ; post-install process for SR*3*176
+1 ; populate file 137
+2 NEW SRI,SRJ,SRL,SRLIST,SRX,SRY,X
+3 DO MES^XPDUTL(" Populating CPT EXCLUSIONS file...")
+4 KILL ^SRO(137)
SET ^SRO(137,0)="CPT EXCLUSIONS^137P^^"
+5 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
+6 DO PEX^SR176UT0
DO PEX^SR176UT1
DO PEX^SR176UT2
+7 SET SRX="A"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=""
QUIT
DO INT
DEL ; delete routines SR176UT0, SR176UT1 and SR176UT2
+1 FOR X="SR176UT0","SR176UT1","SR176UT2"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+2 DO MES^XPDUTL(" Deleting routine "_X_"...")
+3 XECUTE ^%ZOSF("DEL")
End DoDot:1
+4 KILL DA,DIC,DD,DO,DINUM,X
+5 QUIT
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
LIST ;;0001F,0005F,00100,00102,00103,00104,00120,00124,00126,0012F,00140,00142
+1 ;;00144,00145,00147,00148,0014F,0015F,00160,00162,00164,00170,00172,00174,00176,00190,00192,0019T,00210,00211,00212,00214
+2 ;;00215,00216,00218,00220,00222,00300,0030T,00320,00322,00326,00350,00352,00400,00402,00404,00406,00410,0042T,00450,00452
+3 ;;00454,00470,00472,00474,0048T,00500,0050T,0051T,00520,00522,00524,00528,00529,0052T,00530,00532,00534,00537,00539,0053T
+4 ;;00540,00541,00542,00546,00548,0054T,00550,0055T,00560,00561,00562,00563,00566,00567,00580,0058T,0059T,00600,00604,00620
+5 ;;00622,00625,00626,00630,00632,00634,00635,00640,00670,00700,00702,0071T,0072T,00730,0073T,00740,00750,00752,00754,00756
+6 ;;0075T,0076T,00770,0078T,00790,00792,00794,00796,00797,0079T,00800,00802,0080T,00810,0081T,00820,00830,00832,00834,00836
+7 ;;00840,00842,00844,00846,00848,00851,0085T,00860,00862,00864,00865,00866,00868,00870,00872,00873,00880,00882,00902,00904
+8 ;;00906,00908,00910,00912,00914,00916,00918,00920,00921,00922,00924,00926,00928,0092T,00930,00932,00934,00936,00938,00940
+9 ;;00942,00944,00948,00950,00952,0095T,0098T,0099T,0100T,0101T,0102T,0103T,0106T,0107T,0108T,0109T,0110T,01112,0111T,01120
+10 ;;01130,01140,01150,01160,01170,01173,01180,01190,01200,01202,01210,01212,01214,01215,01220,01230,01232,01234,0123T,0124T
+11 ;;01250,01260,0126T,01270,01272,01274,01320,01340,01360,01380,01382,01390,01392,01400,01402,01404,0141T,01420,0142T,01430
+12 ;;01432,0143T,01440,01442,01444,01462,01464,01470,01472,01474,01480,01482,01484,01486,01490,01500,01502,01520,01522,0155T
+13 ;;0156T,0157T,0158T,0159T,01610,01620,01622,01630,01634,01636,01638,0163T,0164T,01650,01652,01654,01656,0165T,0166T,01670
+14 ;;0167T,01680,01682,0168T,0169T,01710,01712,01714,01716,0171T,0172T,01730,01732,0173T,01740,01742,01744,0174T,01756,01758
+15 ;;0175T,01760,01770,01772,01780,01782,0178T,0179T,0180T,01810,0181T,01820,01829,0182T,01830,01832,0183T,01840,01842,01844
+16 ;;01850,01852,0185T,01860,0186T,0188T,0189T,0190T,01916,0191T,01920,01922,01924,01925,01926,0192T,01930,01931,01932,01933
+17 ;;01935,01936,01951,01952,01953,01958,0195T,01960,01961,01962,01963,01965,01966,01967,01968,01969,0196T,0197T,0198T,01990
+18 ;;01991,01992,01996,01999,0199T,0200T,0201T,0202T,0206T,0207T,0208T,0209T,0210T,0211T,0212T,0213T,0214T,0215T,0216T,0217T
+19 ;;0218T,0223T,0224T,0225T,0226T,0227T,0228T,0229T,0230T,0231T,0232T,0233T,0234T,0235T,0236T,0237T,0238T,0239T,0240T,0241T
+20 ;;0242T,0243T,0244T,0249T,0251T,0252T,0253T,0260T,0261T,0263T,0264T,0265T,0266T,0267T,0268T,0269T,0270T,0271T,0272T,0273T
+21 ;;0274T,0275T,0276T,0277T,0278T,0279T,0280T,0281T,0283T,0284T,0285T,0286T,0287T,0288T,0289T,0290T,0500F,0501F,0502F,0503F
+22 ;;0505F,0507F,0509F,0513F,0514F,0516F,0517F,0518F,0519F,0520F,0521F,0525F,0526F,0528F,0529F,0535F,0540F,0545F,0550F,0551F
+23 ;;0555F,0556F,0557F,0575F,1000F,10021,10022,1002F,1003F,10040,1004F,1005F,10060,10061,1006F,1007F,10080,10081,1008F,1010F
+24 ;;1011F,10120,1012F,1015F,1018F,1019F,1022F,1026F,1030F,1031F,1032F,1033F,1034F,1035F,1036F,1038F,1039F,1040F,1050F,1055F
+25 ;;1060F,1061F,1065F,1066F,1070F,1071F,1090F,1091F,11000,1100F,11010,11011,11012,1101F,11042,11043,11044,11055,11056,11057
+26 ;;11100,11101,1110F,1111F,1116F,1118F,1119F,11200,11201,1121F,1123F,1124F,1125F,1126F,1127F,1128F,11300,11301,11302,11303
+27 ;;11305,11306,11307,11308,1130F,11310,11311,11312,11313,1134F,1135F,1136F,1137F,11400,11401,11402,11403,11404,11406,11420
+28 ;;11421,11422,11423,11424,11426,11440,11441,11442,11443,11444,11446,11450,11451,11462,11463,11470,11471,1150F,1151F,1152F
+29 ;;1153F,1157F,1158F,1159F,11600,11601,11602,11603,11604,11606,1160F,11620,11621,11622,11623,11624,11626,11640,11641,11642
+30 ;;11643,11644,11646,1170F,11719,11720,11721,11730,11732,11740,11750,11752,11755,1175F,11760,11762,11765,11770,11771,11772
+31 ;;1180F,1181F,1182F,1183F,11900,11901,11920,11921,11922,11950,11951,11952,11954,11970,11971,11975,11976,11977,11980,11981
+32 ;;11982,11983,12001,12002,12004,12005,12006,12007,1200F,12011,12013,12014,12015,12016,12017,12018,12020,12021,12031,12032
+33 ;;12034,12035,12036,12037,12041,12042,12044,12045,12046,12047,12051,12052,12053,12054,12055,12056,12057,1205F,1220F,13100
+34 ;;13101,13102,13120,13121,13122,13131,13132,13133,13150,13151,13152,13153,13160,14000,14001,1400F,14020,14021,14040,14041
+35 ;;14060,14061,14301,14302,14350,1450F,1451F,1460F,1461F,1490F,1491F,1493F,1494F,15002,15003,15004,15050,15100,15101,15110
+36 ;;15111,15115,15116,15120,15121,15130,15131,15135,15136,15150,15151,15152,15155,15156,15157,15170,15171,15175,15176,15200
+37 ;;15201,15220,15221,15240,15241,15260,15261,15271,15272,15273,15274,15275,15276,15277,15278,15300,15301,15320,15321,15330
+38 ;;15331,15335,15336,15340,15341,15360,15361,15365,15366,15400,15401,15420,15421,15430,15431,15775,15776,15777,15780,15781
+39 ;;15782,15783,15786,15787,15788,15789,15792,15793,15819,15820,15821,15822,15823,15824,15825,15826,15828,15829,15832,15833
+40 ;;15834,15835,15836,15837,15838,15839,15850,15851,15852,15860,16000,16020,16025,16030,16035,16036,17000,17003,17004,17106
+41 ;;17110,17250,17260,17261,17262,17263,17264,17266,17270,17271,17272,17273,17274,17276,17280,17281,17282,17283,17284,17286
+42 ;;17340,17360,17380,17999,19000,19001,19030,19100,19101,19102,19103,19112,19290,19291,19295,2000F,2001F,2002F,2004F,2010F
+43 ;;2014F,2015F,2016F,2018F,2019F,20200,20205,20206,2020F,2021F,20220,20225,2022F,20240,20245,2024F,20250,20251,2026F,2027F
+44 ;;2028F,2029F,2030F,2031F,2035F,2040F,2044F,20500,20501,2050F,20520,20525,20526,20527,20550,20551,20552,20553,20555,20600
+45 ;;20605,2060F,20610,20612,20615,20650,20660,20661,20662,20663,20664,20665,20670,20680,20690,20692,20693,20694,20696,20697
+46 ;;20912,20924,20950,20974,20979,20982,20985,21011,21012,21013,21014,21016,21030,21031,21032,21073,21076,21077,21079,21080
