SR184UTL ;BIR/SJA - SR*3*184 UTILITY ROUTINE ;03/11/2015
;;3.0;Surgery;**184**;24 Jun 93;Build 35
Q
PRE ; pre-install process for SR*3*184
; delete data from file 136.5 and re-initialize file
K ^SRO(136.5) S ^SRO(136.5,0)="PERIOPERATIVE OCCURRENCE CATEGORY^136.5I^^"
Q
POST ; post-install process for SR*3*184
; 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^SR184UT0,PEX^SR184UT1,PEX^SR184UT2,PEX^SR184UT3
S SRX="A" F S SRX=$O(^ICPT("B",SRX)) Q:SRX="" D INT
;
; delete routines SR184UT0, SR184UT1,SR184UT2,and SR184UT3
F X="SR184UT0","SR184UT1","SR184UT2","SR184UT3" X ^%ZOSF("TEST") I $T D
. D MES^XPDUTL(" Deleting routine "_X_"...")
. X ^%ZOSF("DEL")
K DA,DIC,DD,DO,DINUM,X
;
; populate the CPT-Sipnal Level file #131.4
F SRJ=0:1 S SRLIST=$P($T(SCPT+SRJ),";;",2) Q:SRLIST="END" F SRI=1:1 S SRX=$P(SRLIST,",",SRI) Q:SRX="" I $D(^ICPT("B",SRX)) D
. S SRY=0,SRY=$O(^ICPT("B",SRX,SRY)) Q:SRY=""
. K DA,DIC,DD,DO,DINUM S (DINUM,X)=SRY,DIC="^SRO(131.4,",DIC(0)="L" D FILE^DICN
;
REMVOP ; Remove options from menu and place out of order
N SRMN,SROP,CHK,SRII
F SRII="SROMENU;SR TRANSPLANT ASSESSMENT","SROA CARDIAC ENTER/EDIT;SROA CARDIAC-OUTCOMES" S SRMN=$P(SRII,";"),SROP=$P(SRII,";",2) D
. S CHK=$$DELETE^XPDMENU(SRMN,SROP)
. D BMES^XPDUTL(">>> "_SROP_" option "_$S(CHK:"has been removed from ",1:"does not exist in ")_SRMN_" <<<")
. D OUT^XPDMENU(SROP,"Not used after patch SR*3*184")
;
; update identifier code for file #135
S ^DD(135,0,"ID",1)="D EN^DDIOL($P(^(0),U,2),"""",""?41"")"
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
SCPT ;;0092T,0095T,0098T,0171T,0172T,0202T,0213T,0214T,0215T,0216T,0217T,0218T,0219T,0220T,0221T
;;0222T,0228T,0229T,0230T,0231T,0274T,0275T,0282T,0283T,0284T,0285T,0309T,0334T,0375T,20664
;;20930,20931,20936,20937,20938,22010,22015,22100,22101,22102,22103,22110,22112,22114,22116
;;22206,22207,22208,22210,22212,22214,22216,22220,22222,22224,22226,22318,22319,22325,22326
;;22327,22328,22510,22511,22512,22513,22514,22515,22520,22521,22523,22524,22525,22526,22527
;;22532,22533,22534,22548,22551,22552,22554,22556,22558,22585,22586,22590,22595,22600,22610
;;22612,22614,22630,22632,22633,22634,22800,22802,22804,22808,22810,22812,22818,22819,22830
;;22840,22841,22842,22843,22844,22845,22846,22847,22848,22849,22850,22851,22852,22855,22856
;;22857,22858,22861,22862,22864,22865,22899,27279,62267,62269,62270,62272,62273,62280,62281
;;62282,62284,62287,62290,62291,62292,62310,62311,62318,62319,62350,62351,62355,62360,62361
;;62362,62365,62367,62368,63001,63003,63005,63011,63012,63015,63016,63017,63020,63030,63035
;;63040,63042,63043,63044,63045,63046,63047,63048,63050,63051,63055,63056,63057,63064,63066
;;63075,63076,63077,63078,63081,63082,63085,63086,63087,63088,63090,63091,63101,63102,63103
;;63170,63172,63173,63180,63182,63185,63190,63191,63194,63195,63196,63197,63198,63199,63200
;;63250,63251,63252,63265,63266,63267,63268,63270,63271,63272,63273,63275,63276,63277,63278
;;63280,63281,63282,63283,63285,63286,63287,63290,63295,63300,63301,63302,63303,63304,63305
;;63306,63307,63308,63600,63610,63615,63650,63655,63661,63662,63663,63664,63685,63688,63700
;;63702,63704,63706,63707,63709,63710,63740,63741,63744,63746,64490,64491,64492,64493,64494,64495
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR184UTL 3642 printed Dec 13, 2024@02:38:16 Page 2
SR184UTL ;BIR/SJA - SR*3*184 UTILITY ROUTINE ;03/11/2015
+1 ;;3.0;Surgery;**184**;24 Jun 93;Build 35
+2 QUIT
PRE ; pre-install process for SR*3*184
+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 QUIT
POST ; post-install process for SR*3*184
+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^SR184UT0
DO PEX^SR184UT1
DO PEX^SR184UT2
DO PEX^SR184UT3
+7 SET SRX="A"
FOR
SET SRX=$ORDER(^ICPT("B",SRX))
if SRX=""
QUIT
DO INT
+8 ;
+9 ; delete routines SR184UT0, SR184UT1,SR184UT2,and SR184UT3
+10 FOR X="SR184UT0","SR184UT1","SR184UT2","SR184UT3"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+11 DO MES^XPDUTL(" Deleting routine "_X_"...")
+12 XECUTE ^%ZOSF("DEL")
End DoDot:1
+13 KILL DA,DIC,DD,DO,DINUM,X
+14 ;
+15 ; populate the CPT-Sipnal Level file #131.4
+16 FOR SRJ=0:1
SET SRLIST=$PIECE($TEXT(SCPT+SRJ),";;",2)
if SRLIST="END"
QUIT
FOR SRI=1:1
SET SRX=$PIECE(SRLIST,",",SRI)
if SRX=""
QUIT
IF $DATA(^ICPT("B",SRX))
Begin DoDot:1
+17 SET SRY=0
SET SRY=$ORDER(^ICPT("B",SRX,SRY))
if SRY=""
QUIT
+18 KILL DA,DIC,DD,DO,DINUM
SET (DINUM,X)=SRY
SET DIC="^SRO(131.4,"
SET DIC(0)="L"
DO FILE^DICN
End DoDot:1
+19 ;
REMVOP ; Remove options from menu and place out of order
+1 NEW SRMN,SROP,CHK,SRII
+2 FOR SRII="SROMENU;SR TRANSPLANT ASSESSMENT","SROA CARDIAC ENTER/EDIT;SROA CARDIAC-OUTCOMES"
SET SRMN=$PIECE(SRII,";")
SET SROP=$PIECE(SRII,";",2)
Begin DoDot:1
+3 SET CHK=$$DELETE^XPDMENU(SRMN,SROP)
+4 DO BMES^XPDUTL(">>> "_SROP_" option "_$SELECT(CHK:"has been removed from ",1:"does not exist in ")_SRMN_" <<<")
+5 DO OUT^XPDMENU(SROP,"Not used after patch SR*3*184")
End DoDot:1
+6 ;
+7 ; update identifier code for file #135
+8 SET ^DD(135,0,"ID",1)="D EN^DDIOL($P(^(0),U,2),"""",""?41"")"
+9 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
SCPT ;;0092T,0095T,0098T,0171T,0172T,0202T,0213T,0214T,0215T,0216T,0217T,0218T,0219T,0220T,0221T
+1 ;;0222T,0228T,0229T,0230T,0231T,0274T,0275T,0282T,0283T,0284T,0285T,0309T,0334T,0375T,20664
+2 ;;20930,20931,20936,20937,20938,22010,22015,22100,22101,22102,22103,22110,22112,22114,22116
+3 ;;22206,22207,22208,22210,22212,22214,22216,22220,22222,22224,22226,22318,22319,22325,22326
+4 ;;22327,22328,22510,22511,22512,22513,22514,22515,22520,22521,22523,22524,22525,22526,22527
+5 ;;22532,22533,22534,22548,22551,22552,22554,22556,22558,22585,22586,22590,22595,22600,22610
+6 ;;22612,22614,22630,22632,22633,22634,22800,22802,22804,22808,22810,22812,22818,22819,22830
+7 ;;22840,22841,22842,22843,22844,22845,22846,22847,22848,22849,22850,22851,22852,22855,22856
+8 ;;22857,22858,22861,22862,22864,22865,22899,27279,62267,62269,62270,62272,62273,62280,62281
+9 ;;62282,62284,62287,62290,62291,62292,62310,62311,62318,62319,62350,62351,62355,62360,62361
+10 ;;62362,62365,62367,62368,63001,63003,63005,63011,63012,63015,63016,63017,63020,63030,63035
+11 ;;63040,63042,63043,63044,63045,63046,63047,63048,63050,63051,63055,63056,63057,63064,63066
+12 ;;63075,63076,63077,63078,63081,63082,63085,63086,63087,63088,63090,63091,63101,63102,63103
+13 ;;63170,63172,63173,63180,63182,63185,63190,63191,63194,63195,63196,63197,63198,63199,63200
+14 ;;63250,63251,63252,63265,63266,63267,63268,63270,63271,63272,63273,63275,63276,63277,63278
+15 ;;63280,63281,63282,63283,63285,63286,63287,63290,63295,63300,63301,63302,63303,63304,63305
+16 ;;63306,63307,63308,63600,63610,63615,63650,63655,63661,63662,63663,63664,63685,63688,63700
+17 ;;63702,63704,63706,63707,63709,63710,63740,63741,63744,63746,64490,64491,64492,64493,64494,64495
+18 ;;END
