SR182UTL ;BIR/SJA - SR*3*182 UTILITY ROUTINE ;11/21/2013
;;3.0;Surgery;**182**;24 Jun 93;Build 49
Q
PRE ; pre-install process for SR*3*182
; delete data from file #136.5 and re-initialize file
K ^SRO(136.5) S ^SRO(136.5,0)="PERIOPERATIVE OCCURRENCE CATEGORY^136.5I^^"
; delete DD for modified field #.69
F DA=.69,74 S DIK="^DD(130,",DA(1)=130 D ^DIK K DA,DIK
Q
POST ; post-install process for SR*3*182
N SRI,SRTXT,SRIEN,SRZ,SREF,SRX,SRY,X
D MES^XPDUTL(" Starting post-install of SR*3.0*182")
;
; inactivate existing cancellation reasons and add new ones
S SRZ=0 F S SRZ=$O(^SRO(135,SRZ)) Q:'SRZ!(SRZ>1009) S DIE=135,DA=SRZ,DR="10////1" D ^DIE K DA,DIE,DR
; kill then rebuild "B","C" x-ref:
K ^SRO(135,"B"),^SRO(135,"C")
F SRI=1:1 S SRX=$P($T(TXTCAN+SRI),";;",2) Q:SRX="EOM" S SRTXT=$P(SRX,"^",2) D
.S SRIEN=1009+SRI I '$D(^SRO(135,SRIEN,0)) S ^SRO(135,SRIEN,0)=SRTXT_"^"_SRI
F SREF=".01^B","1^C" S DIK="^SRO(135,",DIK(1)=SREF D ENALL^DIK
D MES^XPDUTL("The Surgery Cancellation Reason file (#135) has been updated")
;
I '$$PATCH^XPDUTL("SR*3.0*182") D ADDIS
;
; CPT EXCLUSIONS file #137
D MES^XPDUTL(" Populating CPT EXCLUSIONS file...")
K ^SRO(137)
S ^SRO(137,0)="CPT EXCLUSIONS^137P^^"
D PEX^SR182UT0,PEX^SR182UT1,PEX^SR182UT2,PEX^SR182UT3
;
DEL ; delete routines SR182UT0, SR182UT1, SR182UT2, and SR182UT3
F X="SR182UT0","SR182UT1","SR182UT2","SR182UT3" 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
ADDIS ; inactivate existing SURGERY DISPOSITION file (#131.6) entries and add new ones
S SRZ=0 F S SRZ=$O(^SRO(131.6,SRZ)) Q:'SRZ S DIE=131.6,DA=SRZ,DR="2////1" D ^DIE K DA,DIE,DR
; kill and then rebuild "B","C","D" x-ref:
K ^SRO(131.6,"B"),^SRO(131.6,"C"),^SRO(131.6,"D")
S SRMAX=$O(^SRO(131.6," "),-1) F SRI=1:1 S SRX=$P($T(TXTDIS+SRI),";;",2) Q:SRX="EOM" D
.S SRIEN=SRMAX+SRI I '$D(^SRO(131.6,SRIEN,0)) S ^SRO(131.6,SRIEN,0)=$P(SRX,"^",2)_"^"_$P(SRX,"^")
F SREF=".01^B","1^C" S DIK="^SRO(131.6,",DIK(1)=SREF D ENALL^DIK
K DIK S ^DD(131.6,.01,7.5)="I $G(DIC(0))[""L"",'$D(XUMF) K X D EN^DDIOL(""File is locked. No new entries or edits are allowed."","""",""!?5,$C(7)"")"
D MES^XPDUTL("The Surgery Disposition file (#131.6) has been updated")
Q
TXTCAN ; new surgery cancellation reasons
;;1^PATIENT RELATED ISSUE
;;2^ENVIRONMENTAL ISSUE
;;3^STAFF ISSUE
;;4^PATIENT HEALTH STATUS
;;5^CLIN URGENT/EMERGENT CASE
;;6^SCHED ISSUES NON EMERGENT CASE
;;7^UNAVAILABLE BED
;;8^UNAVAILABLE EQUIP EXCLUDE RME
;;9^UNAVAILABLE REUSABLE EQUP-RME
;;10^CASE MOVED TO EARLIER DATE
;;EOM
TXTDIS ; new surgery disposition entries
;;O^OUTPATIENT/DISCHARGE
;;I^ICU
;;S^STEPDOWN
;;W^WARD
;;OBS^OBSERVATION UNIT
;;M^MORGUE
;;EOM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSR182UTL 2937 printed Apr 09, 2024@21:44:02 Page 2
SR182UTL ;BIR/SJA - SR*3*182 UTILITY ROUTINE ;11/21/2013
+1 ;;3.0;Surgery;**182**;24 Jun 93;Build 49
+2 QUIT
PRE ; pre-install process for SR*3*182
+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 ; delete DD for modified field #.69
+4 FOR DA=.69,74
SET DIK="^DD(130,"
SET DA(1)=130
DO ^DIK
KILL DA,DIK
+5 QUIT
POST ; post-install process for SR*3*182
+1 NEW SRI,SRTXT,SRIEN,SRZ,SREF,SRX,SRY,X
+2 DO MES^XPDUTL(" Starting post-install of SR*3.0*182")
+3 ;
+4 ; inactivate existing cancellation reasons and add new ones
+5 SET SRZ=0
FOR
SET SRZ=$ORDER(^SRO(135,SRZ))
if 'SRZ!(SRZ>1009)
QUIT
SET DIE=135
SET DA=SRZ
SET DR="10////1"
DO ^DIE
KILL DA,DIE,DR
+6 ; kill then rebuild "B","C" x-ref:
+7 KILL ^SRO(135,"B"),^SRO(135,"C")
+8 FOR SRI=1:1
SET SRX=$PIECE($TEXT(TXTCAN+SRI),";;",2)
if SRX="EOM"
QUIT
SET SRTXT=$PIECE(SRX,"^",2)
Begin DoDot:1
+9 SET SRIEN=1009+SRI
IF '$DATA(^SRO(135,SRIEN,0))
SET ^SRO(135,SRIEN,0)=SRTXT_"^"_SRI
End DoDot:1
+10 FOR SREF=".01^B","1^C"
SET DIK="^SRO(135,"
SET DIK(1)=SREF
DO ENALL^DIK
+11 DO MES^XPDUTL("The Surgery Cancellation Reason file (#135) has been updated")
+12 ;
+13 IF '$$PATCH^XPDUTL("SR*3.0*182")
DO ADDIS
+14 ;
+15 ; CPT EXCLUSIONS file #137
+16 DO MES^XPDUTL(" Populating CPT EXCLUSIONS file...")
+17 KILL ^SRO(137)
+18 SET ^SRO(137,0)="CPT EXCLUSIONS^137P^^"
+19 DO PEX^SR182UT0
DO PEX^SR182UT1
DO PEX^SR182UT2
DO PEX^SR182UT3
+20 ;
DEL ; delete routines SR182UT0, SR182UT1, SR182UT2, and SR182UT3
+1 FOR X="SR182UT0","SR182UT1","SR182UT2","SR182UT3"
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
ADDIS ; inactivate existing SURGERY DISPOSITION file (#131.6) entries and add new ones
+1 SET SRZ=0
FOR
SET SRZ=$ORDER(^SRO(131.6,SRZ))
if 'SRZ
QUIT
SET DIE=131.6
SET DA=SRZ
SET DR="2////1"
DO ^DIE
KILL DA,DIE,DR
+2 ; kill and then rebuild "B","C","D" x-ref:
+3 KILL ^SRO(131.6,"B"),^SRO(131.6,"C"),^SRO(131.6,"D")
+4 SET SRMAX=$ORDER(^SRO(131.6," "),-1)
FOR SRI=1:1
SET SRX=$PIECE($TEXT(TXTDIS+SRI),";;",2)
if SRX="EOM"
QUIT
Begin DoDot:1
+5 SET SRIEN=SRMAX+SRI
IF '$DATA(^SRO(131.6,SRIEN,0))
SET ^SRO(131.6,SRIEN,0)=$PIECE(SRX,"^",2)_"^"_$PIECE(SRX,"^")
End DoDot:1
+6 FOR SREF=".01^B","1^C"
SET DIK="^SRO(131.6,"
SET DIK(1)=SREF
DO ENALL^DIK
+7 KILL DIK
SET ^DD(131.6,.01,7.5)="I $G(DIC(0))[""L"",'$D(XUMF) K X D EN^DDIOL(""File is locked. No new entries or edits are allowed."","""",""!?5,$C(7)"")"
+8 DO MES^XPDUTL("The Surgery Disposition file (#131.6) has been updated")
+9 QUIT
TXTCAN ; new surgery cancellation reasons
+1 ;;1^PATIENT RELATED ISSUE
+2 ;;2^ENVIRONMENTAL ISSUE
+3 ;;3^STAFF ISSUE
+4 ;;4^PATIENT HEALTH STATUS
+5 ;;5^CLIN URGENT/EMERGENT CASE
+6 ;;6^SCHED ISSUES NON EMERGENT CASE
+7 ;;7^UNAVAILABLE BED
+8 ;;8^UNAVAILABLE EQUIP EXCLUDE RME
+9 ;;9^UNAVAILABLE REUSABLE EQUP-RME
+10 ;;10^CASE MOVED TO EARLIER DATE
+11 ;;EOM
TXTDIS ; new surgery disposition entries
+1 ;;O^OUTPATIENT/DISCHARGE
+2 ;;I^ICU
+3 ;;S^STEPDOWN
+4 ;;W^WARD
+5 ;;OBS^OBSERVATION UNIT
+6 ;;M^MORGUE
+7 ;;EOM
