source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOO1.m@ 1071

Last change on this file since 1071 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 7.9 KB
Line 
1XQOO1 ;SEA/Luke - Out-of-order set calls ;01/28/97 15:00
2 ;;8.0;KERNEL;**10,21,39,41,58**;Jul 10, 1995
3 ;
4OFF(XQSET) ;Mark options and protocols Out Of Order
5 N %,DA,XQMESS,XQN,XQKD
6 I '$D(^XTMP("XQOO",XQSET,0))#2 S XQSET="^" Q
7 S XQMESS=$P(^XTMP("XQOO",XQSET,0),U),XQKD=" is being installed by KIDS"
8 ;
9 S XQN=0
10 F S XQN=$O(^XTMP("XQOO",XQSET,19,XQN)) Q:XQN="" D
11 .Q:'$D(^DIC(19,XQN,0))#2 S %=$P(^(0),U,3)
12 .;quit if KIDS and option already out by nonKIDS user
13 .Q:$D(XPDSET)&(%]"")&(%'[XQKD) S %=$P(%,XQKD)
14 .;if KIDS save off current OOO message
15 .I $D(XPDSET),%]"",%'=XQSET,$D(^XTMP("XQOO",%)) S $P(^XTMP("XQOO",XQSET,19,XQN),U,3)=%_XQKD
16 .S $P(^DIC(19,XQN,0),U,3)=XQMESS,DA=XQN D REDO^XQ7
17 .Q
18 ;
19 S XQN=0
20 F S XQN=$O(^XTMP("XQOO",XQSET,101,XQN)) Q:XQN="" D
21 .Q:'$D(^ORD(101,XQN,0))#2 S %=$P(^(0),U,3)
22 .Q:$D(XPDSET)&(%]"")&(%'[XQKD) S %=$P(%,XQKD)
23 .I $D(XPDSET),%]"",%'=XQSET,$D(^XTMP("XQOO",%)) S $P(^XTMP("XQOO",XQSET,101,XQN),U,3)=%
24 .S $P(^ORD(101,XQN,0),U,3)=XQMESS
25 .Q
26 D OUT
27 D KICK^XQ7
28 Q
29 ;
30ON(XQSET) ;Remove Out Of Order messages from the set XQSET
31 N %,%1,DA,XQN,XQKD
32 I '$D(^XTMP("XQOO",XQSET,0))#2 S XQSET="^" Q
33 ;
34 S XQN=0,XQKD=" is being installed by KIDS"
35 F S XQN=$O(^XTMP("XQOO",XQSET,19,XQN)) Q:XQN="" S XQMESS=$P(^(XQN),U,3) D
36 .Q:'$D(^DIC(19,XQN,0))#2 S %=$P(^(0),U,3),%1=$S($D(XPDSET):$P(XQMESS,XQKD),1:"")
37 .;quit if OOO message is set by nonKIDS
38 .Q:$D(XPDSET)&(%'[XQKD) S %=$P(%,XQKD)
39 .I $D(XPDSET),%'=XQSET,%]"",$D(^XTMP("XQOO",%)) Q ;another set has this option
40 .;if we have another message to restore, check that set still exist
41 .I XQMESS]"" S XQMESS=$S(%1="":"",'$D(^XTMP("XQOO",%1)):"",1:XQMESS)
42 .S $P(^DIC(19,XQN,0),U,3)=XQMESS,DA=XQN D REDO^XQ7
43 .Q
44 ;
45 S XQN=0
46 F S XQN=$O(^XTMP("XQOO",XQSET,101,XQN)) Q:XQN="" S XQMESS=$P(^(XQN),U,3) D
47 .Q:'$D(^ORD(101,XQN,0))#2 S %=$P(^(0),U,3),%1=$S($D(XPDSET):$P(XQMESS,XQKD),1:"")
48 .Q:$D(XPDSET)&(%'[XQKD) S %=$P(%,XQKD)
49 .I $D(XPDSET),%'=XQSET,%]"",$D(^XTMP("XQOO",%)) Q
50 .I XQMESS]"" S XQMESS=$S(%1="":"",'$D(^XTMP("XQOO",%1)):"",1:XQMESS)
51 .S $P(^ORD(101,XQN,0),U,3)=XQMESS
52 .Q
53 ;
54 I '$D(XPDSET) D
55 .S DIR(0)="Y",DIR("B")="Y"
56 .S DIR("A")="Should I remove the option set "_XQSET_" from ^XTMP?"
57 .S DIR("?")=XQSET_" is the list of options and/or protocols you just turned on."
58 .D ^DIR
59 .I Y K ^XTMP("XQOO",XQSET)
60 .K DIR,Y
61 .Q
62 D OUT
63 D KICK^XQ7
64 Q
65 ;
66ADD(XQSET,XQFIL,XQN) ;New option/protocol - add to set and mark it OOO
67 ;Called by KIDS during a build
68 I '$D(^XTMP("XQOO",XQSET,0)) S XQSET="^" D OUT Q
69 S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
70 S XQGL=$S(XQFIL=19:"^DIC(",1:"^ORD(")
71 S %=@(XQGL_XQFIL_","_XQN_",0)"),^XTMP("XQOO",XQSET,XQFIL,XQN)=$P(%,U)_"^"_$P(%,U,2)
72 S %=XQGL_XQFIL_","_XQN_",0)",$P(@%,U,3)=XQMESS
73 D OUT
74 Q
75 ;
76KIDS(XQSET,XQFIL,XQNAME,XQFLAG) ;Turn on/off an option or protocol
77 ;Called only from KIDS during an install so OERR would work
78 ;XQFLAG is set to 0 to put an option or protocol out of order,
79 ;1 to turn it on, and I return it as -1 if the request
80 ;fails.
81 ;
82 N XQGL,XQMESS,XQMES2,XQN
83 I '$D(^XTMP("XQOO",XQSET)) S XQFLAG=-1 Q
84 S XQGL=$S(XQFIL=19:"^DIC(19)",XQFIL=101:"^ORD(101)",1:"")
85 I XQGL="" S XQFLAG=-1 Q
86 I XQNAME=+XQNAME S XQN=XQNAME
87 E D I XQFLAG<0 Q
88 .S XQN=$O(@XQGL@("B",XQNAME,0)) I XQN'>0 S XQFLAG=-1
89 .Q
90 S %=@XQGL@(XQN,0) S XQMES2=$P(%,U,3)
91 S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
92 I XQMESS=XQMES2 S XQMES2=""
93 I '$D(^XTMP("XQOO",XQSET,XQFIL,XQN)) S ^XTMP("XQOO",XQSET,XQFIL,XQN)=$P(@XQGL@(XQN,0),U)_U_$P(^(0),U,2)
94 ;
95 I 'XQFLAG D
96 .I XQMES2]"" S $P(^XTMP("XQOO",XQSET,XQFIL,XQN),U,3)=XQMES2
97 .S $P(@XQGL@(XQN,0),U,3)=XQMESS
98 .Q
99 I XQFLAG D
100 .S $P(@XQGL@(XQN,0),U,3)=""
101 .Q
102 ;
103OUT ;Exit point
104 K %,XQFIL,XQGL,XQMESS,XQN,XQS
105 Q
106 ;
107OFFOP ;Option entry for turning off options
108 W !
109 S XQSET=""
110 D GETSET(.XQSET)
111 I XQSET]"" D
112 .S DIR(0)="Y",DIR("B")="N"
113 .S DIR("A")="Mark the options in "_XQSET_" Out-Of Order now"
114 .S DIR("?")="If you answer ""Yes"" you will mark all the options in the set "_XQSET_" Out Of Order."
115 .D ^DIR
116 .I Y D OFF(XQSET)
117 .K DIR,X,Y
118 .Q
119 Q
120 ;
121 ;
122ONOP ;Option entry for turning on options
123 S XQSET=""
124 D GETSET(.XQSET)
125 I XQSET]"" D
126 .S DIR(0)="Y",DIR("B")="Y"
127 .S DIR("A")="Return options in "_XQSET_" to general use"
128 .S DIR("?")="If you answer ""Yes"" you will remove the Out-Of-Order message from the options in the set "_XQSET
129 .D ^DIR
130 .I Y D ON(XQSET)
131 .K DIR,X,Y
132 .Q
133 D KICK^XQ7
134 Q
135 ;
136GETSET(XQSET) ;Get the name of the option set in question
137 I '$D(^XTMP("XQOO")) W !!,"There are currently no option sets definded in ^XTMP." Q
138 S XQI=0
139 D SETS^XQOO2(.XQI)
140 I XQI=1 S XQSET=0,XQSET=$O(^XTMP("XQOO",XQSET)) Q
141 I XQI>1 D
142 .S DIR(0)="NO^1:"_XQI,DIR("B")=XQI
143 .S DIR("A")=" Please enter the number of the option set you want"
144 .S DIR("?")=" Which option set do you want to work with? 1, "_XQI_" etc."
145 .W !
146 .D ^DIR
147 .S XQSET=0 F XQI=1:1:+Y S XQSET=$O(^XTMP("XQOO",XQSET))
148 .Q
149 K XQI
150 Q
151 ;
152 ;
153REBLD ;Rebuild a "lost" set of options and protocols
154 N XQ,XQMESS,XQOP,XQPROT,XQSET
155 S (XQOP,XQPROT)=0
156 ;
157 S DIR(0)="F^3:30"
158 S DIR("A")=" Please enter the exact Out-Of-Order message"
159 S DIR("?")=" All options/protocols with this message are reclaimed into a set in ^XTMP"
160 D ^DIR G:$D(DIRUT) OUTRE
161 S XQMESS=X K DIR
162 ;
163RE1 S DIR(0)="F^1:20"
164 S DIR("A")=" What do you want to name the recovered set? "
165 S DIR("?")=" Enter any name of up to 20 characters"
166 D ^DIR G:$D(DIRUT) OUTRE
167 S XQSET=X K DIR
168 I $D(^XTMP("XQOO",XQSET,0)) D G RE1
169 .W !,"Sorry, that set already exists. Use the Create/Modify option to"
170 .W !?3,"modify it, or choose another name."
171 .Q
172 ;
173REFIND ;Find options and protocols with the message XQMESS
174 S XQ=0 F S XQ=$O(^DIC(19,XQ)) Q:XQ'=+XQ!(XQ="") D
175 .Q:$P(^DIC(19,XQ,0),U,3)'=XQMESS
176 .S ^XTMP("XQOO",XQSET,19,XQ)=$P(^DIC(19,XQ,0),U)_U_$P(^(0),U,2)
177 .S XQOP=XQOP+1
178 .Q
179 ;
180 S XQ=0 F S XQ=$O(^ORD(101,XQ)) Q:XQ'=+XQ!(XQ="") D
181 .Q:$P(^ORD(101,XQ,0),U,3)'=XQMESS
182 .S ^XTMP("XQOO",XQSET,101,XQ)=$P(^ORD(101,XQ,0),U)_U_$P(^(0),U,2)
183 .S XQPROT=XQPROT+1
184 .Q
185 ;
186 I XQOP>0!(XQPROT>0) D G OUTRE
187 .D ^XQDATE
188 .S %=$P(^VA(200,DUZ,0),U),%=$P(%,",")
189 .S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_%
190 .S ^XTMP("XQOO",0)=DT+7
191 .W !!,"Set named ",XQSET," recovered with ",XQOP," options and ",XQPROT," protocols."
192 .Q
193 E W !!,"No options or protocols with the message ",XQMESS," were found." G OUTRE
194 Q
195 ;
196OUTRE ;Exit point for REBLD
197 K %,%Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XQ,XQMESS,XQOP,XQPROT,XQSET,Y
198 Q
199 ;
200TOG ;Toggle options and protocols on and off. (XQOOTOG option)
201 N XQ
202 D T1,OUTT,T2,KICK^XQ7
203 ;
204OUTT ;Exit for XQOOTOG
205 K DIC,DTOUT,DUOUT,X,Y
206 Q
207 ;
208T1 ;Toggle options
209 S DIC=19,DIC(0)="AEMQZ",DIC("A")="Enter the name or menu text of an option: "
210 F W ! D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y<0) D
211 .S XQ=+Y,XQ0=Y(0)
212 .I $P(XQ0,U,3)]"" D
213 ..S XQMESS=$P(XQ0,U,3)
214 ..W !!,"Option ",$P(Y(0),U)," is out with the message '",XQMESS,"'",!
215 ..S DIR(0)="Y",DIR("A")="Put it in service",DIR("B")="YES"
216 ..S DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
217 ..D ^DIR
218 ..I Y S $P(^DIC(19,XQ,0),U,3)="",DA=XQ D REDO^XQ7
219 ..K DIR,X,Y
220 ..Q
221 .E W ! D
222 ..S DIR(0)="FA^3:50",DIR("A")="Enter a message to put this option out of order: "
223 ..S DIR("?")="This option is in service. Enter a string to remove it from use."
224 ..K DIRUT D ^DIR
225 ..I '$D(DIRUT) S $P(^DIC(19,XQ,0),U,3)=Y,DA=XQ D REDO^XQ7
226 ..K DIR,DIRUT,X,Y
227 ..Q
228 .Q
229 Q
230 ;
231T2 ;Toggle protocols
232 S DIC=101,DIC(0)="AEMQZ",DIC("A")="Enter the name or menu text of a protocol: "
233 F W ! D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y<0) D
234 .S XQ=+Y,XQ0=Y(0)
235 .I $P(XQ0,U,3)]"" D
236 ..S XQMESS=$P(XQ0,U,3)
237 ..W !!,"Protocol ",$P(Y(0),U)," is out with the message '",XQMESS,"'",!
238 ..S DIR(0)="Y",DIR("A")="Put it in service",DIR("B")="YES"
239 ..S DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
240 ..D ^DIR
241 ..I Y S $P(^ORD(101,XQ,0),U,3)=""
242 ..K DA,DIR,X,Y
243 ..Q
244 .E W ! D
245 ..S DIR(0)="FA^3:50",DIR("A")="Enter a message to put this protocol out of order: "
246 ..S DIR("?")="This protocol is in service. Enter a string to remove it from use."
247 ..K DIRUT D ^DIR
248 ..I '$D(DIRUT) S $P(^ORD(101,XQ,0),U,3)=Y
249 ..K DIR,DIRUT,X,Y
250 ..Q
251 .Q
252 Q
Note: See TracBrowser for help on using the repository browser.