source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLEVSRV1.m@ 1211

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

initial load of WorldVistAEHR
File size: 8.7 KB
Line 
1HLEVSRV1 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
3 ;
4OPENM ; Open/close access to M code...
5 D OFFBEF
6 D HDM,EXM,STM,SWM
7 Q
8 ;
9OKCODE(CODE) ; Check if license available and if so, mark used...
10 N XTMP
11 D OFFBEF
12 S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1) QUIT:XTMP']"" "" ;->
13 QUIT:'$D(^XTMP(XTMP,"LIC",CODE)) "" ;->
14 QUIT:$G(^XTMP(XTMP,"LIC",CODE))]"" "" ;->
15 S ^XTMP(XTMP,"LIC",CODE)=$$NOW^XLFDT_U_.5_U_$G(XMZ)_U_$G(ZTSK)
16 Q 1
17 ;
18OFFBEF ; Turn off all but last M code entry...
19 N XTMP
20 S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1) QUIT:XTMP']"" ;->
21 F S XTMP=$O(^XTMP(XTMP),-1) Q:XTMP']"" D
22 . D SETOFF(XTMP)
23 Q
24 ;
25SWM ; Switch state...
26 N STAT
27 S STAT=$$MST
28 I +STAT=0 D UPM
29 I +STAT=1 D DOWNM
30 W !
31 S X=$$BTE^HLCSMON("Press RETURN to exit... ")
32 Q
33 ;
34DOWNM ; Turn off M code execution...
35 ; STAT -- req
36 N END,START,XTMP
37 S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1)
38 I XTMP']"" D QUIT ;->
39 . W !!,"M code execution is OFF already..."
40 W !
41 I '$$YN^HLCSRPT4("Turn off M code execution") D QUIT ;->
42 . W " nothing changed..."
43 D SETOFF(XTMP)
44 W " M code execution disallowed..."
45 Q
46 ;
47UPM ; Turn on M code execution...
48 ; STAT -- req
49 N CODES,END,IOBOFF,IOBON,NOC,START,X,XTMP
50 ;
51 S X="IOBOFF;IOBON" D ENDR^%ZISS
52 S XTMP="HLEV SERVER M "_$$NOW^XLFDT
53 ;
54 W !
55 I '$$YN^HLCSRPT4("Turn on M code execution","No") D QUIT ;->
56 . W " nothing changed..."
57 ;
58 W !!,"Before M code execution can be turned on, you must answer a few questions..."
59 W !!,"Please include ",IOBON,"time",IOBOFF
60 W " when entering the start and end date/times..."
61 ;
62 W !
63 S START=$$ASKDATE^HLEVAPI2("Enter START TIME","","NOW")
64 I START'?7N1"."1.N D QUIT ;->
65 . W " exiting..."
66 ;
67 W !!,"Prompting START+24 hours..."
68 W !
69 S END=$$ASKDATE^HLEVAPI2("Enter END TIME","",$$FMTE^XLFDT($$FMADD^XLFDT(START,1)))
70 I END'?7N1"."1.N D QUIT ;->
71 . W " exiting..."
72 ;
73 W !
74 S NOC=$$ASKCODES(.CODES) I 'NOC D QUIT ;->
75 . W " exiting..."
76 W !!,$S(NOC=1:"The '"_$O(CODES(""))_"' license",1:"These licenses")
77 W " will be installed if you turn on M code execution now:"
78 ;
79 I NOC>1 D
80 . W !!,?5
81 . S CODES=""
82 . F S CODES=$O(CODES(CODES)) Q:CODES']"" D
83 . . W:($X+$L(CODES))>IOM !,?5
84 . . W $E(CODES_" ",1,10)
85 ;
86 W !
87 I '$$YN^HLCSRPT4("OK to turn on M code execution") D QUIT ;->
88 . W " nothing changed..."
89 ;
90 D SETON(XTMP,START,END)
91 W " M code execution allowed..."
92 ;
93 W !!,"Be sure to pass on ",$S(NOC>1:"these licenses",1:"the license")
94 W " to the VistA HL7 team..."
95 D LICENSE(XTMP,.CODES)
96 ;
97 W !
98 S X=$$BTE^HLCSMON("Press RETURN to exit...")
99 ;
100 Q
101 ;
102LICENSE(XTMP,CODES) ; Install licenses
103 N CODE
104 W !!,"Codes: "
105 ;
106 S CODE=""
107 F S CODE=$O(CODES(CODE)) Q:CODE']"" D
108 . S ^XTMP(XTMP,"LIC",CODE)="" ; Mailman server uses stored on this node
109 . S X=$E(CODE_" ",1,20) W:($X+$L(X))>IOM !,?10 W X
110 ;
111 Q
112 ;
113ASKCODES(CODES) ; Ask user for codes...
114 N CODE,NOC
115 ;
116 W !!,"You must now give the VistA HL7 team ""licences"" for M code execution. One"
117 W !,"license is used for every Mailman server request containing executable M "
118 W !,"code."
119 W !
120 ;
121 S NOC=0
122 F D QUIT:CODE']""
123 . S CODE=$$CODE QUIT:CODE']"" ;->
124 . S ANS=$$YN^HLCSRPT4("Install the license# ["_CODE_"]","Yes")
125 . I ANS'=1 S CODE="" W " not intalled..." QUIT ;->
126 . S NOC=NOC+1,CODES(CODE)=""
127 ;
128 Q NOC
129 ;
130SETON(XTMP,START,END) ; Allow M code execution
131 S ^XTMP(XTMP,0)=$$FMADD^XLFDT($$NOW^XLFDT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Mailman Server M Control"
132 S ^XTMP(XTMP,"STATUS")=START_U_END_U_$G(DUZ)
133 Q
134 ;
135SETOFF(XTMP) ; Disallow M code execution...
136 S $P(^XTMP(XTMP,"STATUS"),U,4,5)=$$NOW^XLFDT_U_$G(DUZ)
137 Q
138 ;
139STM ; What is the status of M code execution?
140 W !!,$$CJ^XLFSTR("------ M Code Execution Status: "_$P($$MST,U,3)_" ------",IOM)
141 Q
142 ;
143MST() ; Status?
144 ; Piece 1 = 0 -> DOWN UP OR DOWN
145 ; = 1 -> UP
146 ; Piece 2 = 1 -> No XTMP data exists... DOWN REASONS
147 ; = 2 -> Invalid START/ENDs
148 ; = 3 -> Before cutoff time
149 ; = 4 -> After cutoff time
150 ; = 5 -> Inactive date (p4) found
151 ; = 0 -> Not DOWN!!!
152 ; Piece 3 = Status text information
153 ;
154 ; NOW -- req
155 N NOW,END,IDATE,START,STAT,XTMP
156 S NOW=$$NOW^XLFDT
157 S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1) QUIT:XTMP']"" "0^1^DOWN" ;->
158 S STAT=$G(^XTMP(XTMP,"STATUS")),START=+STAT,END=$P(STAT,U,2),IDATE=$P(STAT,U,4)
159 I IDATE?7N1"."1.N QUIT "0^5^DOWN" ;->
160 I START'?7N1"."1.N!(END'?7N1"."1.N) QUIT "0^2^DOWN" ;->
161 I START>NOW QUIT "0^3^DOWN - (Too early ("_$$SDT^HLEVX001(+START)_")" ;->
162 I END<NOW QUIT "0^4^DOWN - (Too late ("_$$SDT^HLEVX001(+END)_")" ;->
163 ;
164 Q "1^0^UP"
165 ;
166HDM W @IOF,$$CJ^XLFSTR("Open Access to Mailman Server M Code",IOM)
167 W !,$$REPEAT^XLFSTR("=",IOM)
168 QUIT
169 ;
170EXM N I,T F I=1:1 S T=$T(EXM+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
171 ;;Mailman server requests can be sent to your site requesting HL7 data be
172 ;;returned to the VistA HL7 team. (These requests are only sent to the VistA
173 ;;HL7 team, and under no circumstances are sent to any other mail groups or
174 ;;individuals.) Under very rare circumstances, in order to debug problems on
175 ;;your site, or to collect diagnostic information, it might be desired to run
176 ;;some M code embedded in the Mailman server requests.
177 ;;
178 ;;In order to provide a high level of security, no M code will ever be run by
179 ;;the Mailman server option unless you explicity allow M code execution. This
180 ;;option allows you to allow, or disallow, M code execution.
181 QUIT
182 ;
183CODE() ; Return license code...
184 N CODE,EX,NOP,TYPE
185 F EX=39,44,95,96 S EX(EX)=""
186 S CODE="",NOP=0
187 F EX=1:1:6 D
188 . S TYPE=$P("A^P",U,$R(2)+1)
189 . I EX=6,NOP=0 S TYPE="P" ; Must be at least one punctuation
190 . I TYPE="P" S NOP=NOP+1
191 . S:NOP>1 TYPE="A"
192 . S CODE=CODE_$$RNO(TYPE)
193 . I EX=3 S CODE=CODE_"-"
194 Q CODE
195 ;
196RNO(TYPE) ; Return random number between 33 and 122 (w/exceptions)
197 ; NOP -- req
198 N NO,OK
199 F S NO=$R(89)+33 D Q:OK
200 . S OK=0
201 . I $D(EX(NO)) QUIT ;-> Is it in exclusion list?
202 . I TYPE="A" D QUIT ;-> Is it an alpha character
203 . . I $$ALPHA(NO) S OK=1
204 . I '$$ALPHA(NO) S OK=1 ; Need punctuation...
205 Q $C(NO)
206 ;
207ALPHA(NO) ; Is it ALPHA character?
208 N X
209 S X=$A($$UP^XLFSTR($C(NO))) QUIT:X>64&(X<91) 1 ;->
210 Q ""
211 ;
212GBLTOXM ; Place global data in Mailman message global...
213 N DATA,FILE,GBL,IEN,LP,REF,ST,TXT
214 ;
215 ; Add data found...
216 S GBL=$NA(^XTMP(XTMP,"DATA"))
217 ;
218 S FILE=0
219 F S FILE=$O(@GBL@(FILE)) Q:FILE'>0 D
220 . D ADDMAIL^HLEVSRV("")
221 . D ADDMAIL^HLEVSRV($$CJ^XLFSTR(" "_$P($G(^HLEV(+FILE,0)),U)_" [#"_FILE_"] ",74,"-"))
222 . S IEN=0
223 . F S IEN=$O(@GBL@(FILE,IEN)) Q:IEN'>0 D
224 . . S TXT="#"_IEN
225 . . S LP="^XTMP("""_XTMP_""",""DATA"","_FILE_","_IEN,ST=LP_","
226 . . S LP=LP_")"
227 . . F S LP=$Q(@LP) Q:LP'[ST D
228 . . . S REF="#"_IEN_","_$P(LP,ST,2)_"=",POSX=$L(REF)
229 . . . S DATA=@LP
230 . . . F D QUIT:$TR(REF," ","")']""&(DATA']"") ;->
231 . . . . S TXT=REF_$E(DATA,1,74-$L(REF))
232 . . . . D ADDMAIL^HLEVSRV(TXT)
233 . . . . S DATA=$E(DATA,74-$L(REF)+1,999)
234 . . . . S REF=$$REPEAT^XLFSTR(" ",POSX)
235 ;
236 Q
237 ;
238TEST ; Test server...
239 N CT,HLEVQUIT,LASTXTMP,XTMP,XMREC,XMZ
240 ;
241 W !!,"The current time is ",$$NOW^XLFDT,"..."
242 ;
243 W !!,"Displaying all existing ^XTMP(""HLEV SERVER ..."") entries..."
244 ;
245 ; Find last 6 entries to show...
246 S XTMP="HLEV SERVER 9999999",CT=0
247 F S XTMP=$O(^XTMP(XTMP),-1) Q:XTMP'?1"HLEV SERVER "7N1"."1.N!(CT>6) D
248 . S CT=CT+1
249 ;
250 S CT=0
251 S XTMP=$S(XTMP?1"HLEV SERVER "7N1"."1.N:XTMP,1:"HLEV SERVER 0000000")
252 F S XTMP=$O(^XTMP(XTMP)) Q:XTMP'?1"HLEV SERVER "7N1"."1.N D
253 . W:'CT !!
254 . W $E("^XTMP("""_XTMP_""""_$$REPEAT^XLFSTR(" ",40),1,40)
255 . S CT=CT+1
256 ;
257 I 'CT W !!,"No XTMP server data exists..." QUIT ;->
258 ;
259 S LASTXTMP=$O(^XTMP("HLEV SERVER 9999999"),-1)
260 D SHOWXTMP("Last XTMP entry",LASTXTMP)
261 ;
262T1 W !!,"Enter XTMP to rerun: ",LASTXTMP,"// "
263 R XTMP:999 QUIT:XTMP[U ;->
264 S:XTMP']"" XTMP=LASTXTMP
265 I '$D(^XTMP(XTMP)) D G T1 ;->
266 . W " entry not found..."
267 ;
268 S XMZ=$P($G(^XTMP(XTMP,"MAIL")),U)
269 I $G(^XMB(3.9,+XMZ,0))']"" D QUIT ;->
270 . W !!,"There is no Mailman message recorded..."
271 ;
272 S XMREC="D REC^XMS3"
273 ;
274 W !!,"Calling SERVER^HLEVSRV with XTMP=",XTMP,"..."
275 ;
276 D SERVER^HLEVSRV
277 ;
278 D SHOWXTMP("Last (and newly created) XTMP entry",$O(^XTMP("HLEV SERVER 9999999"),-1))
279 ;
280 W !!,"The last 776 IEN = ",$O(^HLEV(776,":"),-1),"..."
281 W !
282 ;
283 D ^%G
284 ;
285 Q
286 ;
287SHOWXTMP(TXT,XTMP) ; Show the XTMP data...
288 N DATA,LP,POSX,ST
289 ;
290 I '$D(^XTMP(XTMP)) QUIT ;->
291 ;
292 W !!,$$CJ^XLFSTR(" "_TXT_" ",IOM,"=")
293 ;
294 S LP=$NA(^XTMP(XTMP)),ST=$E(LP,1,$L(LP)-1)_","
295 F S LP=$Q(@LP) Q:LP'[ST D
296 . W !,LP," = "
297 . S POSX=$X,DATA=@LP
298 . F Q:DATA']"" D
299 . . W:$X>POSX ! W:$X<POSX ?POSX
300 . . W $E(DATA,1,IOM-POSX-1)
301 . . S DATA=$E(DATA,IOM-POSX,999)
302 ;
303 W !,$$REPEAT^XLFSTR("=",IOM)
304 ;
305 Q
306 ;
307EOR ;HLEVSRV1 - Event Monitor SERVER ;5/16/03 14:42
Note: See TracBrowser for help on using the repository browser.