source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLEVSRV0.m@ 1231

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1HLEVSRV0 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
3 ;
4M(TXT) ; Called when M code data requested in...
5 ; MXEC,XTMP -- req
6 N MCODE,NO,MTAG,WHEN
7 ;
8 ; Sets...
9 S WHEN=$P(TXT,U)
10 ;
11 ; Has license been sent?
12 I WHEN="LICENSE" D QUIT ;->
13 . QUIT:$P(MXEC,U,4)]"" ;->
14 . S MCODE=$P(TXT,U,2)
15 . I '$$OKCODE^HLEVSRV1(MCODE) S $P(MXEC,U,4)=0 QUIT ;->
16 . S $P(MXEC,U,4)=1 ; Force DOWN...
17 ;
18 QUIT:WHEN'="BEFORE"&(WHEN'="AFTER") ;->
19 S MTAG=$P(TXT,U,2) QUIT:MTAG']"" ;->
20 S MCODE=$P(TXT,U,3,999) Q:MCODE']"" ;->
21 ;
22 ; Is it valid M code?
23 S X=MCODE D ^DIM QUIT:'$D(X) ;->
24 ;
25 S NO=$O(^XTMP(XTMP,"M",WHEN,MTAG,":"),-1)+1
26 S ^XTMP(XTMP,"M",WHEN,MTAG,+NO)=MCODE
27 ;
28 Q
29 ;
30MPRE ; Run M code before load of data...
31 ; XTMP -- req
32 D MRUN("BEFORE")
33 Q
34 ;
35MPST ; Run M code after load of data...
36 ; XTMP -- req
37 D MRUN("AFTER")
38 Q
39 ;
40MRUN(WHEN) ; Run M code's INIT...
41 ; XTMP -- req
42 N ZZADD,ZZCALL,ZZMCODE,ZZMLNO,ZZMTAG,ZZNEXT,ZZNO,ZZREC
43 ;
44 ; Get starting M code...
45 QUIT:$G(^XTMP(XTMP,"M",WHEN,"INIT",1))']"" ;->
46 ;
47 ; Values set up as a service for the developer sending in M code...
48 ;
49 ; NEXT LINE - Executable code to execute next line in "subroutine"...
50 S ZZNEXT="S ZZMLNO=ZZMLNO+1,ZZMCODE=$G(^XTMP(XTMP,""M"",WHEN,ZZMTAG,ZZMLNO)) QUIT:ZZMCODE']"""" X ZZMCODE,ZZREC"
51 S ZZREC="S ZZCALL=$G(ZZCALL)+1,^XTMP(XTMP,""M"",""REC"",WHEN,ZZCALL)=ZZMLNO_U_ZZMTAG"
52 S ZZADD="D ADDMTXT^HLEVSRV0($G(ZZTXT))"
53 ;
54 ; Set up every "subroutine" in an executable call "tag"
55 S ZZMCODE=""
56 F S ZZMCODE=$O(^XTMP(XTMP,"M",WHEN,ZZMCODE)) Q:ZZMCODE']"" D
57 . S @ZZMCODE="S ZZMTAG="""_ZZMCODE_""",ZZMLNO=0 X ZZNEXT"
58 ;
59 S ZZCALL=0
60 ;
61 ; Start...
62 X INIT
63 ;
64 Q
65 ;
66MCOND ; Condense M call data...
67 N DATA,TAG,TAGL,TAGN,TXT,WHEN,ZZCALL
68 ;
69 QUIT:'$D(^XTMP(XTMP,"M","REC")) ;->
70 ;
71 KILL ^TMP($J,"HLMCOND")
72 ;
73 F WHEN="BEFORE","AFTER" D
74 . S ZZCALL=0,TXT=WHEN_": ",POSX=$L(TXT),TAGL="",TAGN=0
75 . F S ZZCALL=$O(^XTMP(XTMP,"M","REC",WHEN,ZZCALL)) Q:ZZCALL'>0 D
76 . . S DATA=^XTMP(XTMP,"M","REC",WHEN,ZZCALL),TAG=$P(DATA,U,2) QUIT:TAG']"" ;->
77 . . I $L(TXT)>55 D
78 . . . D ADD(TXT)
79 . . . S TXT=$$REPEAT^XLFSTR(" ",POSX)
80 . . I TAGL'=TAG D
81 . . . I TAGL]"",TAGN>0 S TXT=TXT_"(#"_TAGN_")",TAGN=0
82 . . . S TXT=TXT_$S($L(TXT)>POSX:"-",1:"")_TAG,TAGN=1
83 . . I TAGL=TAG S TAGN=TAGN+1
84 . . S TAGL=TAG
85 . I TAGN>0,$L(TXT)>POSX S TXT=TXT_"(#"_TAGN_")",TAGN=0
86 . I $L(TXT)>POSX D ADD(TXT)
87 ;
88 QUIT:'$D(^TMP($J,"HLMCOND")) ;->
89 ;
90 KILL ^XTMP(XTMP,"M","REC")
91 MERGE ^XTMP(XTMP,"M","REC")=^TMP($J,"HLMCOND")
92 ;
93 Q
94 ;
95MCALLREC ; Store MCOND data in mail message..
96 N NO
97 ;
98 QUIT:'$D(^XTMP(XTMP,"M","REC")) ;->
99 ;
100 D ADDMAIL^HLEVSRV(""),ADDMAIL^HLEVSRV("M Call Record")
101 D ADDMAIL^HLEVSRV($$REPEAT^XLFSTR("-",74))
102 ;
103 S NO=0
104 F S NO=$O(^XTMP(XTMP,"M","REC",NO)) Q:NO'>0 D
105 . D ADDMAIL^HLEVSRV(^XTMP(XTMP,"M","REC",NO))
106 ;
107 Q
108 ;
109ADDMTXT(TXT) ;
110 N NO
111 S NO=$O(^XTMP(XTMP,"MTEXT",":"),-1)+1
112 S ^XTMP(XTMP,"MTEXT",+NO)=TXT
113 Q
114 ;
115MTEXT ; Add text to Mailman message created by M code...
116 N NO
117 ;
118 I $G(^XTMP(XTMP,"MTEXT")) D
119 . D ADDMAIL("")
120 . D ADDMAIL($$CJ^XLFSTR(" M-Created Text ",74,"-"))
121 ;
122 S NO=0
123 F S NO=$O(^XTMP(XTMP,"MTEXT",NO)) Q:NO'>0 D
124 . D ADDMAIL(^XTMP(XTMP,"MTEXT",NO))
125 ;
126 Q
127 ;
128ADD(TXT) ;
129 N NO
130 S NO=$O(^TMP($J,"HLMCOND",":"),-1)+1
131 S ^TMP($J,"HLMCOND",+NO)=TXT
132 Q
133 ;
134MTEST ; Test M code embedded in a Mailman message...
135 N IOINHI,IOINORM,MIEN,X,XTMP
136 ;
137 S X="IOINHI;IOINORM" D ENDR^%ZISS
138 ;
139 W @IOF,$$CJ^XLFSTR("M Code Test",IOM)
140 W !,$$REPEAT^XLFSTR("=",IOM)
141 W !!,"This utility will execute the code in the BEFORE and AFTER sections of the"
142 W !,"M code embedded in a Mailman message. The message must be in the format"
143 W !,"used by the [HLEV-INFORMATION-SERVER] menu option."
144 ;
145MT1 W !
146 F R !,"Message IEN: ",MIEN:60 Q:MIEN'>0 D QUIT:$G(^XMB(3.9,+MIEN,0))]""
147 . I $G(^XMB(3.9,+MIEN,0))']"" D QUIT ;->
148 . . W " no message found..."
149 . W " ",$P(^XMB(3.9,+MIEN,0),U),"..."
150 ;
151 QUIT:$G(^XMB(3.9,+MIEN,0))']"" ;->
152 ;
153 S XTMP="HLEV SERVER 9999999",NOW=$$NOW^XLFDT
154 KILL ^XTMP(XTMP)
155 S ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,1)_U_NOW_U_"TEST"
156 ;
157 W !!,"Loading M code..."
158 S LNO=0
159 F S LNO=$O(^XMB(3.9,+MIEN,2,LNO)) Q:LNO'>0 D
160 . S TXT=$G(^XMB(3.9,+MIEN,2,+LNO,0)) QUIT:$E(TXT,1,2)'="M^" ;->
161 . S TXT=$P(TXT,U,2,999) QUIT:TXT']"" ;->
162 . W "."
163 . D M(TXT)
164 ;
165 I '$D(^XTMP(XTMP,"M")) D G MT1 ;->
166 . W !!,"No M code embedded in this Mailman message..."
167 ;
168 W !
169 S LP=$NA(^XTMP(XTMP,"M")),ST="^XTMP("""_XTMP_""",""M"","
170 F S LP=$Q(@LP) Q:LP'[ST D
171 . W !,IOINHI,"...",$P(LP,",""M"",",2,99),IOINORM," = "
172 . S POSX=$X,DATA=@LP
173 . F QUIT:DATA']"" D
174 . . W $E(DATA,1,IOM-POSX)
175 . . S DATA=$E(DATA,IOM-POSX+1,999)
176 ;
177 W !!,"You can execute the BEFORE load M code, or the AFTER load M code. The BEFORE"
178 W !,"load M code requires a BEFORE^INIT... node(s). The AFTER load M code"
179 W !,"requires an AFTER^INIT... node(s)."
180 ;
181 I '$D(^XTMP(XTMP,"M","BEFORE"))&('$D(^XTMP(XTMP,"M","AFTER"))) D G MT1 ;->
182 . W !!,"You must add a BEFORE and/or AFTER section to the M code embedded in the"
183 . W !,"Mailman message before you can use this utility to test."
184 ;
185 D MEX("BEFORE")
186 D MEX("AFTER")
187 ;
188 KILL ^XTMP(XTMP)
189 ;
190 W !!,"Done..."
191 ;
192 Q
193 ;
194MEX(WHEN) ; Called by MTEST to execute ^XTMP(XTMP,"M") code...
195 N X
196 QUIT:'$D(^XTMP(XTMP,"M",WHEN)) ;->
197 W !!,"Press RETURN to execute the ",IOINHI,WHEN,IOINORM
198 W " code, or '^' to skip... "
199 R X:60 I '$T!(X[U) W " no action taken..." QUIT ;->
200 W !,"Executing the ",WHEN," code..."
201 I WHEN="BEFORE" D MPRE
202 I WHEN="AFTER" D MPST
203 W " M code finished..."
204 Q
205 ;
206UNIT(TXT) ; Load IEN list found by MSG ID... (TXT=MsgID)
207 ; XTMP -- req
208 ;
209 ; Data request line must equal UNIT^#^TYPE (#^TYPE passed in here)
210 ;
211 ; TYPE = "IEN772", "IEN773", or "MSGID"
212 ; # = IEN772, IEN773 or MSGID
213 ;
214 ; The # used to find any IEN772 in the unit.
215 ; All messages in unit found using $$LOAD772S^HLUCM009, and
216 ; formatted by LOADUNIT and returned in email to user.
217 ;
218 N CT,HL772,HLID,HLTYPE,IEN772,IEN773,IEN773,NO772S
219 ;
220 ; Initial sets...
221 S HLID=$P($G(TXT),U) QUIT:HLID']"" ;->
222 S HLTYPE=$P(TXT,U,2) ; IEN772, IEN773, or MSGID
223 S IEN772=""
224 ;
225 ; Try to get IEN772 from MSGID...
226 I HLTYPE="MSGID" D QUIT:'IEN772 ;->
227 . S IEN772=$O(^HL(772,"C",HLID,":"),-1)
228 . I IEN772 D QUIT:IEN772'>0 ;->
229 . . S IEN773=$O(^HLMA("C",HLID,0)) QUIT:IEN773'>0 ;->
230 . . S IEN772=+$G(^HLMA(+IEN773,0))
231 . S IEN773=$O(^HLMA("C",HLID,":"),-1) QUIT:'IEN773 ;->
232 . S IEN772=+$G(^HLMA(+IEN773,0))
233 ;
234 ; If passed IEN772...
235 I HLTYPE="IEN772" D QUIT:IEN772'>0 ;->
236 . QUIT:$G(^HL(772,+HLID,0))']"" ;->
237 . S IEN772=+HLID
238 ;
239 ; If passed IEN773...
240 I HLTYPE="IEN773" D QUIT:IEN772'>0 ;->
241 . S IEN772=+$G(^HLMA(+HLID,0))
242 . QUIT:$G(^HL(772,+IEN772,0))]"" ;-> It's OK
243 . S IEN772=""
244 ;
245 QUIT:$G(^HL(772,+$G(IEN772),0))']"" ;->
246 ;
247 ; Load associated entries...
248 S NO772S=$$LOAD772S^HLUCM009(+IEN772,.HL772) QUIT:NO772S'>0 ;->
249 ;
250 ; Load data...
251 S IEN772=0
252 F S IEN772=$O(HL772("HLPARENT",IEN772)) Q:IEN772'>0 D
253 . S IEN772C=0
254 . F S IEN772C=$O(HL772("HLPARENT",IEN772,IEN772C)) Q:IEN772C'>0 D
255 . . S ^XTMP(XTMP,"HLUNIT",IEN772,IEN772C)=""
256 ;
257 Q
258 ;
259LOADUNIT ; Load data found by UNIT above...
260 N IEN772C,IEN772P,POSX,TXT
261 ;
262 QUIT:'$D(^XTMP(XTMP,"HLUNIT")) ;->
263 ;
264 D ADDMAIL(""),ADDMAIL($$CJ^XLFSTR(" Msg ID-requested Message Units ",74,"-"))
265 ;
266 S IEN772P=0
267 F S IEN772P=$O(^XTMP(XTMP,"HLUNIT",IEN772P)) Q:IEN772P'>0 D
268 . S TXT=IEN772P_": ",POSX=$L(TXT)
269 . S IEN772C=0
270 . F S IEN772C=$O(^XTMP(XTMP,"HLUNIT",IEN772P,IEN772C)) Q:IEN772C'>0 D
271 . . I ($L(TXT)+$L(IEN772C)+2)>74 D
272 . . . D ADDMAIL(TXT)
273 . . . S TXT=$$REPEAT^XLFSTR(" ",POSX)
274 . . S TXT=TXT_$S($L(TXT)>POSX:",",1:"")_IEN772C
275 . I TXT]"" D ADDMAIL(TXT) S TXT=""
276 ;
277 Q
278 ;
279ADDMAIL(TXT) D ADDMAIL^HLEVSRV(TXT)
280 Q
281 ;
282QUITQ(LPVAL,STOP,NOLINE,CT) ; Should looping stop?
283 QUIT:LPVAL']"" 1 ;->
284 QUIT:LPVAL'[STOP 1 ;->
285 QUIT:(CT+1)>NOLINE 1 ;->
286 Q ""
287 ;
288QUITS(LPVAL,SCREEN) ; Should this be included?
289 N DATA,DIV,MAXNO,OK,PCE,VAL,X
290 S DIV=""
291 S MAXNO=$L(LPVAL,",") I $L(SCREEN,",")'=MAXNO QUIT 1 ;->
292 F PCE=1:1:MAXNO D QUIT:'OK
293 . S OK=0
294 . S X=$P(SCREEN,"#",PCE),DIV=$S(DIV]"":",",1:$E(X,$L(X)))
295 . S DATA(1)=$P(LPVAL,DIV,+PCE) QUIT:DATA(1)']"" ;->
296 . S DATA(2)=$P(SCREEN,DIV,+PCE) QUIT:DATA(2)']"" ;->
297 . I DATA(2)="#" QUIT:DATA(1)'?1.N ;->
298 . I DATA(2)'="#" QUIT:DATA(1)'=DATA(2) ;->
299 . S OK=1
300 S OK='OK ; Because this is a QUIT IF extrinsic function
301 Q OK
302 ;
303ADDLINE(TXT) D ADDLINE^HLEVSRV(TXT)
304 Q
305 ;
306EOR ;HLEVSRV0 - Event Monitor SERVER ;5/16/03 14:42
Note: See TracBrowser for help on using the repository browser.