| 1 | HLEVSRV1 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
|
|---|
| 2 | ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | OPENM ; Open/close access to M code...
|
|---|
| 5 | D OFFBEF
|
|---|
| 6 | D HDM,EXM,STM,SWM
|
|---|
| 7 | Q
|
|---|
| 8 | ;
|
|---|
| 9 | OKCODE(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 | ;
|
|---|
| 18 | OFFBEF ; 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 | ;
|
|---|
| 25 | SWM ; 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 | ;
|
|---|
| 34 | DOWNM ; 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 | ;
|
|---|
| 47 | UPM ; 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 | ;
|
|---|
| 102 | LICENSE(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 | ;
|
|---|
| 113 | ASKCODES(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 | ;
|
|---|
| 130 | SETON(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 | ;
|
|---|
| 135 | SETOFF(XTMP) ; Disallow M code execution...
|
|---|
| 136 | S $P(^XTMP(XTMP,"STATUS"),U,4,5)=$$NOW^XLFDT_U_$G(DUZ)
|
|---|
| 137 | Q
|
|---|
| 138 | ;
|
|---|
| 139 | STM ; What is the status of M code execution?
|
|---|
| 140 | W !!,$$CJ^XLFSTR("------ M Code Execution Status: "_$P($$MST,U,3)_" ------",IOM)
|
|---|
| 141 | Q
|
|---|
| 142 | ;
|
|---|
| 143 | MST() ; 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 | ;
|
|---|
| 166 | HDM W @IOF,$$CJ^XLFSTR("Open Access to Mailman Server M Code",IOM)
|
|---|
| 167 | W !,$$REPEAT^XLFSTR("=",IOM)
|
|---|
| 168 | QUIT
|
|---|
| 169 | ;
|
|---|
| 170 | EXM 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 | ;
|
|---|
| 183 | CODE() ; 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 | ;
|
|---|
| 196 | RNO(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 | ;
|
|---|
| 207 | ALPHA(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 | ;
|
|---|
| 212 | GBLTOXM ; 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 | ;
|
|---|
| 238 | TEST ; 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 | ;
|
|---|
| 262 | T1 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 | ;
|
|---|
| 287 | SHOWXTMP(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 | ;
|
|---|
| 307 | EOR ;HLEVSRV1 - Event Monitor SERVER ;5/16/03 14:42
|
|---|
