ZIBGCHAR ; IHS/ADC/GTH - NONINTERACTIVE MODIFICATIONS OF GLOBAL CHARACTERISTICS ; [ 07/23/2002 10:35 AM ]
;;3.0;IHS/VA UTILITIES;**4,5,9**;FEB 07, 1997
; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
; XB*3*9 IHS/SET/GTH XB*3*9 07/23/2002 Cache' mods.
;
; Not all capabilities of the implementation-specific global
; characteristics routines are reflected in this routine.
;
; The argument for each entry point is the unsubscripted
; name of the global whose characteristics you want to
; change, with NO leading circumflex.
;
; If the call is successful, 0 is returned.
;
; If the call is not successful, a positive integer is
; returned, and the cause can be retrieved at the ERR()
; entry point.
;
; E.g's:
; S %=$$NOJOURN^ZIBGCHAR("AUTTSITE")
; I % W !,$$ERR^ZIBGCHAR(%)
;
Q
;
;Begin New Code;IHS/SET/GTH XB*3*9 07/23/2002
KILL(ZIBGLOB) ;PEP - Kill global or global referenced at the top level
NEW QF,X
I '$L($G(ZIBGLOB)) Q 1
I ZIBGLOB'["," D Q QF ; just one global to kill
. S QF=$$PROCESS("D","N")
. I QF Q
. KILL @("^"_ZIBGLOB)
. I $$VERSION^%ZOSV(1)["Cache" S X=$ZU(68,28,1) ;disallow kill again
.Q
;multiple globals to kill, comma delimited string like "gbl1,gbl2,gbl3"
F X=1:1:$L(ZIBGLOB,",") S ZIBGLOB(X)=$P(ZIBGLOB,",",X)
F X=1:1:$L(ZIBGLOB,",") D Q:QF
. S QF=$$KILLOK(ZIBGLOB(X))
. I QF Q
. KILL @("^"_ZIBGLOB(X)),ZIBGLOB(X)
.Q
I $$VERSION^%ZOSV(1)["Cache" S X=$ZU(68,28,1) ;disallow kill again
Q QF
;
;End New Code;IHS/SET/GTH XB*3*9 07/23/2002
KILLOK(ZIBGLOB) ;PEP - Allow kill of global.
Q $$PROCESS("D","N")
;
KILLNO(ZIBGLOB) ;PEP - Prevent kill'ing of global.
Q $$PROCESS("D","Y")
;
JOURN(ZIBGLOB) ;PEP - Set Journaling to ALWAYS.
Q $$PROCESS("J","A")
;
NOJOURN(ZIBGLOB) ;PEP - Set Journaling for global to NEVER.
Q $$PROCESS("J","N")
;
UCIJOURN(ZIBGLOB) ;PEP - Journal when UCI is Journaled.
Q $$PROCESS("J","U")
;
PROCESS(ZIBFLAG,ZIBVAL) ;
I '$L($G(ZIBGLOB)) Q 1
;I '(ZIBGLOB?1.8U) Q 5;IHS/SET/GTH XB*3*9 07/23/2002
I '(ZIBGLOB?1.8U!(ZIBGLOB?1"%"1.7U)) Q 5 ;Cache needs to SET % globals;IHS/SET/GTH XB*3*9 07/23/2002
I '$D(@("^"_ZIBGLOB)) Q 2
; NEW O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
; I '$L($T(@O)) Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
; G @O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
; I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
I $$VERSION^%ZOSV(1)["Cache" Q $$CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;IHS/SET/GTH XB*3*9 07/23/2002
I $P(^%ZOSF("OS"),"^",1)'["MSM" Q 3 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
D MSM
I '$D(ZTQUEUED) D HOME^%ZIS U IO(0) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
; Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err. ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
;
;Begin New Code;IHS/SET/GTH XB*3*9 07/23/2002
CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;PEP - allow/prevent kill or enable/disable journaling on Cache
;TASSC/MFD added subroutine to mimic portions of %GCH that Cache can do
; -Patterned after CALL subroutine of MSM's %GCH but an extrinsic
; -Less options than MSM- journaling is either on or off for a global
; as there is no Journal entire UCI option
; -Allowing top-level kill is by process not by global specification
; -If the call is successful, 0 is returned.
;
; ZIBGLOB = global reference, no leading ^
; ZIBFLAG can be "J" or "D"- J is for journaling on or off, D is for
; allowing top kill or not
; ZIBVAL = for Journaling- E, A or U for enable, D, N or null for disable
; for Prev kill- Y to prevent kill, N to allow kill
;
I '(ZIBGLOB?1.8U!(ZIBGLOB?1"%"1.7UL)) Q 5 ;TASSC/MFD added L to 1.7U for %zmu
I '$D(@("^"_ZIBGLOB)) Q 2
I ZIBFLAG="D",ZIBVAL="N" NEW X S X=$ZU(68,28,0) Q 0 ;don't prevent top-level kill for the process
I ZIBFLAG="D",ZIBVAL="Y" NEW X S X=$ZU(68,28,1) Q 0 ;prevent top-level kill for the process
I ZIBFLAG="J" NEW ZIBRC D
.S ZIBVAL=$S(ZIBVAL="E":4,ZIBVAL="A":4,ZIBVAL="U":4,ZIBVAL="N":0,ZIBVAL="D":0,ZIBVAL="":0,1:1)
.I ZIBVAL'=1 S ZIBRC=$$SetJournalType^%DM("",ZIBGLOB,ZIBVAL)
.Q
I ZIBRC=1 Q 0 ;Cache returns a 1 if successful
Q 1 ; any other condition is bad so quit 1
;
;End New Code;IHS/SET/GTH XB*3*9 07/23/2002
MSM ; Micronetics Standard MUMPS.
I '$L($T(CALL^%GCH)) Q 4
S:$D(ZTQUEUED) CALL="" ; Tell ^%GCH not to talk if errors.
KILL O
NEW (ZIBFLAG,ZIBGLOB,ZIBVAL) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
D CALL^%GCH(ZIBFLAG,ZIBGLOB,ZIBVAL)
KILL CALL
; Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
;
ERR(Z) ;PEP - Return cause of error.
Q $P($T(@Z),";;",2)
1 ;;NO GLOBAL SPECIFIED IN PARAMETER
2 ;;GLOBAL DOES NOT EXIST
3 ;;OPERATING SYSTEM NOT SUPPORTED
4 ;;WRONG VERSION OF MSM'S ^%GCH
5 ;;BAD GLOBAL NAME
;
;
TEST ;
NEW AZHB,AZHB1
F AZHBCTR=1:1 S AZHB=$P($T(DATA+AZHBCTR),";",3) Q:AZHB="###" D T1(AZHB),T2(AZHB)
Q
;
T1(AZHB) ;
W !,"No Journaling For '",AZHB,"'"
S AZHB1=$$NOJOURN(AZHB)
W ?28," : ",AZHB1
I AZHB1 W " : ",$$ERR(AZHB1)
E W " : <kool>"
Q
;
T2(AZHB) ;
W !,"No Killing For '",AZHB,"'"
S AZHB1=$$KILLNO(AZHB)
W ?28," : ",AZHB1
I AZHB1 W " : ",$$ERR(AZHB1)
E W " : <kool>"
Q
;
DATA ;
;;
;;FREDDATA
;;ACHSDATA
;;AUTTSITE
;;^AUTTLOC
;;jen
;;44
;;DIC(4,
;;###
ZIBGCHAR ; IHS/ADC/GTH - NONINTERACTIVE MODIFICATIONS OF GLOBAL CHARACTERISTICS ; [ 07/23/2002 10:35 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**4,5,9**;FEB 07, 1997
+2 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
+3 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
+4 ; XB*3*9 IHS/SET/GTH XB*3*9 07/23/2002 Cache' mods.
+5 ;
+6 ; Not all capabilities of the implementation-specific global
+7 ; characteristics routines are reflected in this routine.
+8 ;
+9 ; The argument for each entry point is the unsubscripted
+10 ; name of the global whose characteristics you want to
+11 ; change, with NO leading circumflex.
+12 ;
+13 ; If the call is successful, 0 is returned.
+14 ;
+15 ; If the call is not successful, a positive integer is
+16 ; returned, and the cause can be retrieved at the ERR()
+17 ; entry point.
+18 ;
+19 ; E.g's:
+20 ; S %=$$NOJOURN^ZIBGCHAR("AUTTSITE")
+21 ; I % W !,$$ERR^ZIBGCHAR(%)
+22 ;
+23 QUIT
+24 ;
+25 ;Begin New Code;IHS/SET/GTH XB*3*9 07/23/2002
KILL(ZIBGLOB) ;PEP - Kill global or global referenced at the top level
+1 NEW QF,X
+2 IF '$LENGTH($GET(ZIBGLOB))
QUIT 1
+3 ; just one global to kill
IF ZIBGLOB'[","
Begin DoDot:1
+4 SET QF=$$PROCESS("D","N")
+5 IF QF
QUIT
+6 KILL @("^"_ZIBGLOB)
+7 ;disallow kill again
IF $$VERSION^%ZOSV(1)["Cache"
SET X=$ZU(68,28,1)
+8 QUIT
End DoDot:1
QUIT QF
+9 ;multiple globals to kill, comma delimited string like "gbl1,gbl2,gbl3"
+10 FOR X=1:1:$LENGTH(ZIBGLOB,",")
SET ZIBGLOB(X)=$PIECE(ZIBGLOB,",",X)
+11 FOR X=1:1:$LENGTH(ZIBGLOB,",")
Begin DoDot:1
+12 SET QF=$$KILLOK(ZIBGLOB(X))
+13 IF QF
QUIT
+14 KILL @("^"_ZIBGLOB(X)),ZIBGLOB(X)
+15 QUIT
End DoDot:1
IF QF
QUIT
+16 ;disallow kill again
IF $$VERSION^%ZOSV(1)["Cache"
SET X=$ZU(68,28,1)
+17 QUIT QF
+18 ;
+19 ;End New Code;IHS/SET/GTH XB*3*9 07/23/2002
KILLOK(ZIBGLOB) ;PEP - Allow kill of global.
+1 QUIT $$PROCESS("D","N")
+2 ;
KILLNO(ZIBGLOB) ;PEP - Prevent kill'ing of global.
+1 QUIT $$PROCESS("D","Y")
+2 ;
JOURN(ZIBGLOB) ;PEP - Set Journaling to ALWAYS.
+1 QUIT $$PROCESS("J","A")
+2 ;
NOJOURN(ZIBGLOB) ;PEP - Set Journaling for global to NEVER.
+1 QUIT $$PROCESS("J","N")
+2 ;
UCIJOURN(ZIBGLOB) ;PEP - Journal when UCI is Journaled.
+1 QUIT $$PROCESS("J","U")
+2 ;
PROCESS(ZIBFLAG,ZIBVAL) ;
+1 IF '$LENGTH($GET(ZIBGLOB))
QUIT 1
+2 ;I '(ZIBGLOB?1.8U) Q 5;IHS/SET/GTH XB*3*9 07/23/2002
+3 ;Cache needs to SET % globals;IHS/SET/GTH XB*3*9 07/23/2002
IF '(ZIBGLOB?1.8U!(ZIBGLOB?1"%"1.7U))
QUIT 5
+4 IF '$DATA(@("^"_ZIBGLOB))
QUIT 2
+5 ; NEW O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
+6 ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
+7 ; I '$L($T(@O)) Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
+8 ; G @O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
+9 ; I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
+10 ;IHS/SET/GTH XB*3*9 07/23/2002
IF $$VERSION^%ZOSV(1)["Cache"
QUIT $$CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL)
+11 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
IF $PIECE(^%ZOSF("OS"),"^",1)'["MSM"
QUIT 3
+12 DO MSM
+13 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
IF '$DATA(ZTQUEUED)
DO HOME^%ZIS
USE IO(0)
+14 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
QUIT 0
+15 ; Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err. ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
+16 ;
+17 ;Begin New Code;IHS/SET/GTH XB*3*9 07/23/2002
CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;PEP - allow/prevent kill or enable/disable journaling on Cache
+1 ;TASSC/MFD added subroutine to mimic portions of %GCH that Cache can do
+2 ; -Patterned after CALL subroutine of MSM's %GCH but an extrinsic
+3 ; -Less options than MSM- journaling is either on or off for a global
+4 ; as there is no Journal entire UCI option
+5 ; -Allowing top-level kill is by process not by global specification
+6 ; -If the call is successful, 0 is returned.
+7 ;
+8 ; ZIBGLOB = global reference, no leading ^
+9 ; ZIBFLAG can be "J" or "D"- J is for journaling on or off, D is for
+10 ; allowing top kill or not
+11 ; ZIBVAL = for Journaling- E, A or U for enable, D, N or null for disable
+12 ; for Prev kill- Y to prevent kill, N to allow kill
+13 ;
+14 ;TASSC/MFD added L to 1.7U for %zmu
IF '(ZIBGLOB?1.8U!(ZIBGLOB?1"%"1.7UL))
QUIT 5
+15 IF '$DATA(@("^"_ZIBGLOB))
QUIT 2
+16 ;don't prevent top-level kill for the process
IF ZIBFLAG="D"
IF ZIBVAL="N"
NEW X
SET X=$ZU(68,28,0)
QUIT 0
+17 ;prevent top-level kill for the process
IF ZIBFLAG="D"
IF ZIBVAL="Y"
NEW X
SET X=$ZU(68,28,1)
QUIT 0
+18 IF ZIBFLAG="J"
NEW ZIBRC
Begin DoDot:1
+19 SET ZIBVAL=$SELECT(ZIBVAL="E":4,ZIBVAL="A":4,ZIBVAL="U":4,ZIBVAL="N":0,ZIBVAL="D":0,ZIBVAL="":0,1:1)
+20 IF ZIBVAL'=1
SET ZIBRC=$$SetJournalType^%DM("",ZIBGLOB,ZIBVAL)
+21 QUIT
End DoDot:1
+22 ;Cache returns a 1 if successful
IF ZIBRC=1
QUIT 0
+23 ; any other condition is bad so quit 1
QUIT 1
+24 ;
+25 ;End New Code;IHS/SET/GTH XB*3*9 07/23/2002
MSM ; Micronetics Standard MUMPS.
+1 IF '$LENGTH($TEXT(CALL^%GCH))
QUIT 4
+2 ; Tell ^%GCH not to talk if errors.
IF $DATA(ZTQUEUED)
SET CALL=""
+3 KILL O
+4 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
NEW (ZIBFLAG,ZIBGLOB,ZIBVAL)
+5 DO CALL^%GCH(ZIBFLAG,ZIBGLOB,ZIBVAL)
+6 KILL CALL
+7 ; Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
+8 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
QUIT
+9 ;
ERR(Z) ;PEP - Return cause of error.
+1 QUIT $PIECE($TEXT(@Z),";;",2)
1 ;;NO GLOBAL SPECIFIED IN PARAMETER
2 ;;GLOBAL DOES NOT EXIST
3 ;;OPERATING SYSTEM NOT SUPPORTED
4 ;;WRONG VERSION OF MSM'S ^%GCH
5 ;;BAD GLOBAL NAME
+1 ;
+2 ;
TEST ;
+1 NEW AZHB,AZHB1
+2 FOR AZHBCTR=1:1
SET AZHB=$PIECE($TEXT(DATA+AZHBCTR),";",3)
IF AZHB="###"
QUIT
DO T1(AZHB)
DO T2(AZHB)
+3 QUIT
+4 ;
T1(AZHB) ;
+1 WRITE !,"No Journaling For '",AZHB,"'"
+2 SET AZHB1=$$NOJOURN(AZHB)
+3 WRITE ?28," : ",AZHB1
+4 IF AZHB1
WRITE " : ",$$ERR(AZHB1)
+5 IF '$TEST
WRITE " : <kool>"
+6 QUIT
+7 ;
T2(AZHB) ;
+1 WRITE !,"No Killing For '",AZHB,"'"
+2 SET AZHB1=$$KILLNO(AZHB)
+3 WRITE ?28," : ",AZHB1
+4 IF AZHB1
WRITE " : ",$$ERR(AZHB1)
+5 IF '$TEST
WRITE " : <kool>"
+6 QUIT
+7 ;
DATA ;
+1 ;;
+2 ;;FREDDATA
+3 ;;ACHSDATA
+4 ;;AUTTSITE
+5 ;;^AUTTLOC
+6 ;;jen
+7 ;;44
+8 ;;DIC(4,
+9 ;;###
