source: IHS-VA_UTILITIES-XB/trunk/ZIBGCHAR.m@ 1423

Last change on this file since 1423 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.

File size: 5.6 KB
Line 
1ZIBGCHAR ; IHS/ADC/GTH - NONINTERACTIVE MODIFICATIONS OF GLOBAL CHARACTERISTICS ; [ 08/26/2004 12:01 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
4 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
5 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
6 ; XB*3*10 IHS/ITSC/DMJ 8/19/2004 Bad global name.
7 ;
8 ; Not all capabilities of the implementation-specific global
9 ; characteristics routines are reflected in this routine.
10 ;
11 ; The argument for each entry point is the unsubscripted
12 ; name of the global whose characteristics you want to
13 ; change, with NO leading circumflex.
14 ;
15 ; If the call is successful, 0 is returned.
16 ;
17 ; If the call is not successful, a positive integer is
18 ; returned, and the cause can be retrieved at the ERR()
19 ; entry point.
20 ;
21 ; E.g's:
22 ; S %=$$NOJOURN^ZIBGCHAR("AUTTSITE")
23 ; I % W !,$$ERR^ZIBGCHAR(%)
24 ;
25 Q
26 ;
27 ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
28KILL(ZIBGLOB) ;PEP - Kill global or global referenced at the top level
29 NEW QF,X
30 I '$L($G(ZIBGLOB)) Q 1
31 I ZIBGLOB'["," D Q QF ; just one global to kill
32 . S QF=$$PROCESS("D","N")
33 . I QF Q
34 . KILL @("^"_ZIBGLOB)
35 . I $$VERSION^%ZOSV(1)["Cache" S X=$ZU(68,28,1) ;disallow kill again
36 .Q
37 ;multiple globals to kill, comma delimited string like "gbl1,gbl2,gbl3"
38 F X=1:1:$L(ZIBGLOB,",") S ZIBGLOB(X)=$P(ZIBGLOB,",",X)
39 F X=1:1:$L(ZIBGLOB,",") D Q:QF
40 . S QF=$$KILLOK(ZIBGLOB(X))
41 . I QF Q
42 . KILL @("^"_ZIBGLOB(X)),ZIBGLOB(X)
43 .Q
44 I $$VERSION^%ZOSV(1)["Cache" S X=$ZU(68,28,1) ;disallow kill again
45 Q QF
46 ;
47 ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
48KILLOK(ZIBGLOB) ;PEP - Allow kill of global.
49 Q $$PROCESS("D","N")
50 ;
51KILLNO(ZIBGLOB) ;PEP - Prevent kill'ing of global.
52 Q $$PROCESS("D","Y")
53 ;
54JOURN(ZIBGLOB) ;PEP - Set Journaling to ALWAYS.
55 Q $$PROCESS("J","A")
56 ;
57NOJOURN(ZIBGLOB) ;PEP - Set Journaling for global to NEVER.
58 Q $$PROCESS("J","N")
59 ;
60UCIJOURN(ZIBGLOB) ;PEP - Journal when UCI is Journaled.
61 Q $$PROCESS("J","U")
62 ;
63PROCESS(ZIBFLAG,ZIBVAL) ;
64 I '$L($G(ZIBGLOB)) Q 1
65 ;I '(ZIBGLOB?1.8U) Q 5;IHS/SET/GTH XB*3*9 10/29/2002
66 ;I '(ZIBGLOB?1.8U!(ZIBGLOB?1"%"1.7U)) Q 5 ;Cache needs to SET % globals;IHS/SET/GTH XB*3*9 10/29/2002 XB*3*10 next line will do the job
67 I '$D(@("^"_ZIBGLOB)) Q 2
68 ; NEW O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
69 ; S O=$P(^%ZOSF("OS"),"-",1) ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
70 ; I '$L($T(@O)) Q 3 ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
71 ; G @O ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
72 ; I $P(^%ZOSF("OS"),"^",1)["MSM" G MSM ; XB*3*4 IHS/ADC/GTH 05-22-97 Prevent <INDER> err.
73 I $$VERSION^%ZOSV(1)["Cache" Q $$CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;IHS/SET/GTH XB*3*9 10/29/2002
74 I $P(^%ZOSF("OS"),"^",1)'["MSM" Q 3 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
75 D MSM
76 I '$D(ZTQUEUED) D HOME^%ZIS U IO(0) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
77 Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
78 ; 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.
79 ;
80 ;Begin New Code;IHS/SET/GTH XB*3*9 10/29/2002
81CACHE(ZIBFLAG,ZIBGLOB,ZIBVAL) ;PEP - allow/prevent kill or enable/disable journaling on Cache
82 ;TASSC/MFD added subroutine to mimic portions of %GCH that Cache can do
83 ; -Patterned after CALL subroutine of MSM's %GCH but an extrinsic
84 ; -Less options than MSM- journaling is either on or off for a global
85 ; as there is no Journal entire UCI option
86 ; -Allowing top-level kill is by process not by global specification
87 ; -If the call is successful, 0 is returned.
88 ;
89 ; ZIBGLOB = global reference, no leading ^
90 ; ZIBFLAG can be "J" or "D"- J is for journaling on or off, D is for
91 ; allowing top kill or not
92 ; ZIBVAL = for Journaling- E, A or U for enable, D, N or null for disable
93 ; for Prev kill- Y to prevent kill, N to allow kill
94 ;
95 I '(ZIBGLOB?1.8AN!(ZIBGLOB?1"%"1.7AN)) Q 5 ; XB*3*10 allow lower case
96 I '$D(@("^"_ZIBGLOB)) Q 2
97 I ZIBFLAG="D",ZIBVAL="N" NEW X S X=$ZU(68,28,0) Q 0 ;don't prevent top-level kill for the process
98 I ZIBFLAG="D",ZIBVAL="Y" NEW X S X=$ZU(68,28,1) Q 0 ;prevent top-level kill for the process
99 I ZIBFLAG="J" NEW ZIBRC D
100 .S ZIBVAL=$S(ZIBVAL="E":4,ZIBVAL="A":4,ZIBVAL="U":4,ZIBVAL="N":0,ZIBVAL="D":0,ZIBVAL="":0,1:1)
101 .I ZIBVAL'=1 S ZIBRC=$$SetJournalType^%DM("",ZIBGLOB,ZIBVAL)
102 .Q
103 I ZIBRC=1 Q 0 ;Cache returns a 1 if successful
104 Q 1 ; any other condition is bad so quit 1
105 ;
106 ;End New Code;IHS/SET/GTH XB*3*9 10/29/2002
107MSM ; Micronetics Standard MUMPS.
108 I '$L($T(CALL^%GCH)) Q 4
109 S:$D(ZTQUEUED) CALL="" ; Tell ^%GCH not to talk if errors.
110 KILL O
111 NEW (ZIBFLAG,ZIBGLOB,ZIBVAL) ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
112 D CALL^%GCH(ZIBFLAG,ZIBGLOB,ZIBVAL)
113 KILL CALL
114 ; Q 0 ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
115 Q ; XB*3*5 IHS/ADC/GTH 10-31-97 Prevent errors in return from ^%GCH.
116 ;
117ERR(Z) ;PEP - Return cause of error.
118 Q $P($T(@Z),";;",2)
1191 ;;NO GLOBAL SPECIFIED IN PARAMETER
1202 ;;GLOBAL DOES NOT EXIST
1213 ;;OPERATING SYSTEM NOT SUPPORTED
1224 ;;WRONG VERSION OF MSM'S ^%GCH
1235 ;;BAD GLOBAL NAME
124 ;
125 ;
126TEST ;
127 NEW AZHB,AZHB1
128 F AZHBCTR=1:1 S AZHB=$P($T(DATA+AZHBCTR),";",3) Q:AZHB="###" D T1(AZHB),T2(AZHB)
129 Q
130 ;
131T1(AZHB) ;
132 W !,"No Journaling For '",AZHB,"'"
133 S AZHB1=$$NOJOURN(AZHB)
134 W ?28," : ",AZHB1
135 I AZHB1 W " : ",$$ERR(AZHB1)
136 E W " : <kool>"
137 Q
138 ;
139T2(AZHB) ;
140 W !,"No Killing For '",AZHB,"'"
141 S AZHB1=$$KILLNO(AZHB)
142 W ?28," : ",AZHB1
143 I AZHB1 W " : ",$$ERR(AZHB1)
144 E W " : <kool>"
145 Q
146 ;
147DATA ;
148 ;;
149 ;;FREDDATA
150 ;;ACHSDATA
151 ;;AUTTSITE
152 ;;^AUTTLOC
153 ;;jen
154 ;;44
155 ;;DIC(4,
156 ;;###
Note: See TracBrowser for help on using the repository browser.