HLEVSRV1 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
;
OPENM ; Open/close access to M code...
D OFFBEF
D HDM,EXM,STM,SWM
Q
;
OKCODE(CODE) ; Check if license available and if so, mark used...
N XTMP
D OFFBEF
S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1) QUIT:XTMP']"" "" ;->
QUIT:'$D(^XTMP(XTMP,"LIC",CODE)) "" ;->
QUIT:$G(^XTMP(XTMP,"LIC",CODE))]"" "" ;->
S ^XTMP(XTMP,"LIC",CODE)=$$NOW^XLFDT_U_.5_U_$G(XMZ)_U_$G(ZTSK)
Q 1
;
OFFBEF ; Turn off all but last M code entry...
N XTMP
S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1) QUIT:XTMP']"" ;->
F S XTMP=$O(^XTMP(XTMP),-1) Q:XTMP']"" D
. D SETOFF(XTMP)
Q
;
SWM ; Switch state...
N STAT
S STAT=$$MST
I +STAT=0 D UPM
I +STAT=1 D DOWNM
W !
S X=$$BTE^HLCSMON("Press RETURN to exit... ")
Q
;
DOWNM ; Turn off M code execution...
; STAT -- req
N END,START,XTMP
S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1)
I XTMP']"" D QUIT ;->
. W !!,"M code execution is OFF already..."
W !
I '$$YN^HLCSRPT4("Turn off M code execution") D QUIT ;->
. W " nothing changed..."
D SETOFF(XTMP)
W " M code execution disallowed..."
Q
;
UPM ; Turn on M code execution...
; STAT -- req
N CODES,END,IOBOFF,IOBON,NOC,START,X,XTMP
;
S X="IOBOFF;IOBON" D ENDR^%ZISS
S XTMP="HLEV SERVER M "_$$NOW^XLFDT
;
W !
I '$$YN^HLCSRPT4("Turn on M code execution","No") D QUIT ;->
. W " nothing changed..."
;
W !!,"Before M code execution can be turned on, you must answer a few questions..."
W !!,"Please include ",IOBON,"time",IOBOFF
W " when entering the start and end date/times..."
;
W !
S START=$$ASKDATE^HLEVAPI2("Enter START TIME","","NOW")
I START'?7N1"."1.N D QUIT ;->
. W " exiting..."
;
W !!,"Prompting START+24 hours..."
W !
S END=$$ASKDATE^HLEVAPI2("Enter END TIME","",$$FMTE^XLFDT($$FMADD^XLFDT(START,1)))
I END'?7N1"."1.N D QUIT ;->
. W " exiting..."
;
W !
S NOC=$$ASKCODES(.CODES) I 'NOC D QUIT ;->
. W " exiting..."
W !!,$S(NOC=1:"The '"_$O(CODES(""))_"' license",1:"These licenses")
W " will be installed if you turn on M code execution now:"
;
I NOC>1 D
. W !!,?5
. S CODES=""
. F S CODES=$O(CODES(CODES)) Q:CODES']"" D
. . W:($X+$L(CODES))>IOM !,?5
. . W $E(CODES_" ",1,10)
;
W !
I '$$YN^HLCSRPT4("OK to turn on M code execution") D QUIT ;->
. W " nothing changed..."
;
D SETON(XTMP,START,END)
W " M code execution allowed..."
;
W !!,"Be sure to pass on ",$S(NOC>1:"these licenses",1:"the license")
W " to the VistA HL7 team..."
D LICENSE(XTMP,.CODES)
;
W !
S X=$$BTE^HLCSMON("Press RETURN to exit...")
;
Q
;
LICENSE(XTMP,CODES) ; Install licenses
N CODE
W !!,"Codes: "
;
S CODE=""
F S CODE=$O(CODES(CODE)) Q:CODE']"" D
. S ^XTMP(XTMP,"LIC",CODE)="" ; Mailman server uses stored on this node
. S X=$E(CODE_" ",1,20) W:($X+$L(X))>IOM !,?10 W X
;
Q
;
ASKCODES(CODES) ; Ask user for codes...
N CODE,NOC
;
W !!,"You must now give the VistA HL7 team ""licences"" for M code execution. One"
W !,"license is used for every Mailman server request containing executable M "
W !,"code."
W !
;
S NOC=0
F D QUIT:CODE']""
. S CODE=$$CODE QUIT:CODE']"" ;->
. S ANS=$$YN^HLCSRPT4("Install the license# ["_CODE_"]","Yes")
. I ANS'=1 S CODE="" W " not intalled..." QUIT ;->
. S NOC=NOC+1,CODES(CODE)=""
;
Q NOC
;
SETON(XTMP,START,END) ; Allow M code execution
S ^XTMP(XTMP,0)=$$FMADD^XLFDT($$NOW^XLFDT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Mailman Server M Control"
S ^XTMP(XTMP,"STATUS")=START_U_END_U_$G(DUZ)
Q
;
SETOFF(XTMP) ; Disallow M code execution...
S $P(^XTMP(XTMP,"STATUS"),U,4,5)=$$NOW^XLFDT_U_$G(DUZ)
Q
;
STM ; What is the status of M code execution?
W !!,$$CJ^XLFSTR("------ M Code Execution Status: "_$P($$MST,U,3)_" ------",IOM)
Q
;
MST() ; Status?
; Piece 1 = 0 -> DOWN UP OR DOWN
; = 1 -> UP
; Piece 2 = 1 -> No XTMP data exists... DOWN REASONS
; = 2 -> Invalid START/ENDs
; = 3 -> Before cutoff time
; = 4 -> After cutoff time
; = 5 -> Inactive date (p4) found
; = 0 -> Not DOWN!!!
; Piece 3 = Status text information
;
; NOW -- req
N NOW,END,IDATE,START,STAT,XTMP
S NOW=$$NOW^XLFDT
S XTMP=$O(^XTMP("HLEV SERVER M 9999999"),-1) QUIT:XTMP']"" "0^1^DOWN" ;->
S STAT=$G(^XTMP(XTMP,"STATUS")),START=+STAT,END=$P(STAT,U,2),IDATE=$P(STAT,U,4)
I IDATE?7N1"."1.N QUIT "0^5^DOWN" ;->
I START'?7N1"."1.N!(END'?7N1"."1.N) QUIT "0^2^DOWN" ;->
I START>NOW QUIT "0^3^DOWN - (Too early ("_$$SDT^HLEVX001(+START)_")" ;->
I END<NOW QUIT "0^4^DOWN - (Too late ("_$$SDT^HLEVX001(+END)_")" ;->
;
Q "1^0^UP"
;
HDM W @IOF,$$CJ^XLFSTR("Open Access to Mailman Server M Code",IOM)
W !,$$REPEAT^XLFSTR("=",IOM)
QUIT
;
EXM N I,T F I=1:1 S T=$T(EXM+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
;;Mailman server requests can be sent to your site requesting HL7 data be
;;returned to the VistA HL7 team. (These requests are only sent to the VistA
;;HL7 team, and under no circumstances are sent to any other mail groups or
;;individuals.) Under very rare circumstances, in order to debug problems on
;;your site, or to collect diagnostic information, it might be desired to run
;;some M code embedded in the Mailman server requests.
;;
;;In order to provide a high level of security, no M code will ever be run by
;;the Mailman server option unless you explicity allow M code execution. This
;;option allows you to allow, or disallow, M code execution.
QUIT
;
CODE() ; Return license code...
N CODE,EX,NOP,TYPE
F EX=39,44,95,96 S EX(EX)=""
S CODE="",NOP=0
F EX=1:1:6 D
. S TYPE=$P("A^P",U,$R(2)+1)
. I EX=6,NOP=0 S TYPE="P" ; Must be at least one punctuation
. I TYPE="P" S NOP=NOP+1
. S:NOP>1 TYPE="A"
. S CODE=CODE_$$RNO(TYPE)
. I EX=3 S CODE=CODE_"-"
Q CODE
;
RNO(TYPE) ; Return random number between 33 and 122 (w/exceptions)
; NOP -- req
N NO,OK
F S NO=$R(89)+33 D Q:OK
. S OK=0
. I $D(EX(NO)) QUIT ;-> Is it in exclusion list?
. I TYPE="A" D QUIT ;-> Is it an alpha character
. . I $$ALPHA(NO) S OK=1
. I '$$ALPHA(NO) S OK=1 ; Need punctuation...
Q $C(NO)
;
ALPHA(NO) ; Is it ALPHA character?
N X
S X=$A($$UP^XLFSTR($C(NO))) QUIT:X>64&(X<91) 1 ;->
Q ""
;
GBLTOXM ; Place global data in Mailman message global...
N DATA,FILE,GBL,IEN,LP,REF,ST,TXT
;
; Add data found...
S GBL=$NA(^XTMP(XTMP,"DATA"))
;
S FILE=0
F S FILE=$O(@GBL@(FILE)) Q:FILE'>0 D
. D ADDMAIL^HLEVSRV("")
. D ADDMAIL^HLEVSRV($$CJ^XLFSTR(" "_$P($G(^HLEV(+FILE,0)),U)_" [#"_FILE_"] ",74,"-"))
. S IEN=0
. F S IEN=$O(@GBL@(FILE,IEN)) Q:IEN'>0 D
. . S TXT="#"_IEN
. . S LP="^XTMP("""_XTMP_""",""DATA"","_FILE_","_IEN,ST=LP_","
. . S LP=LP_")"
. . F S LP=$Q(@LP) Q:LP'[ST D
. . . S REF="#"_IEN_","_$P(LP,ST,2)_"=",POSX=$L(REF)
. . . S DATA=@LP
. . . F D QUIT:$TR(REF," ","")']""&(DATA']"") ;->
. . . . S TXT=REF_$E(DATA,1,74-$L(REF))
. . . . D ADDMAIL^HLEVSRV(TXT)
. . . . S DATA=$E(DATA,74-$L(REF)+1,999)
. . . . S REF=$$REPEAT^XLFSTR(" ",POSX)
;
Q
;
TEST ; Test server...
N CT,HLEVQUIT,LASTXTMP,XTMP,XMREC,XMZ
;
W !!,"The current time is ",$$NOW^XLFDT,"..."
;
W !!,"Displaying all existing ^XTMP(""HLEV SERVER ..."") entries..."
;
; Find last 6 entries to show...
S XTMP="HLEV SERVER 9999999",CT=0
F S XTMP=$O(^XTMP(XTMP),-1) Q:XTMP'?1"HLEV SERVER "7N1"."1.N!(CT>6) D
. S CT=CT+1
;
S CT=0
S XTMP=$S(XTMP?1"HLEV SERVER "7N1"."1.N:XTMP,1:"HLEV SERVER 0000000")
F S XTMP=$O(^XTMP(XTMP)) Q:XTMP'?1"HLEV SERVER "7N1"."1.N D
. W:'CT !!
. W $E("^XTMP("""_XTMP_""""_$$REPEAT^XLFSTR(" ",40),1,40)
. S CT=CT+1
;
I 'CT W !!,"No XTMP server data exists..." QUIT ;->
;
S LASTXTMP=$O(^XTMP("HLEV SERVER 9999999"),-1)
D SHOWXTMP("Last XTMP entry",LASTXTMP)
;
T1 W !!,"Enter XTMP to rerun: ",LASTXTMP,"// "
R XTMP:999 QUIT:XTMP[U ;->
S:XTMP']"" XTMP=LASTXTMP
I '$D(^XTMP(XTMP)) D G T1 ;->
. W " entry not found..."
;
S XMZ=$P($G(^XTMP(XTMP,"MAIL")),U)
I $G(^XMB(3.9,+XMZ,0))']"" D QUIT ;->
. W !!,"There is no Mailman message recorded..."
;
S XMREC="D REC^XMS3"
;
W !!,"Calling SERVER^HLEVSRV with XTMP=",XTMP,"..."
;
D SERVER^HLEVSRV
;
D SHOWXTMP("Last (and newly created) XTMP entry",$O(^XTMP("HLEV SERVER 9999999"),-1))
;
W !!,"The last 776 IEN = ",$O(^HLEV(776,":"),-1),"..."
W !
;
D ^%G
;
Q
;
SHOWXTMP(TXT,XTMP) ; Show the XTMP data...
N DATA,LP,POSX,ST
;
I '$D(^XTMP(XTMP)) QUIT ;->
;
W !!,$$CJ^XLFSTR(" "_TXT_" ",IOM,"=")
;
S LP=$NA(^XTMP(XTMP)),ST=$E(LP,1,$L(LP)-1)_","
F S LP=$Q(@LP) Q:LP'[ST D
. W !,LP," = "
. S POSX=$X,DATA=@LP
. F Q:DATA']"" D
. . W:$X>POSX ! W:$X<POSX ?POSX
. . W $E(DATA,1,IOM-POSX-1)
. . S DATA=$E(DATA,IOM-POSX,999)
;
W !,$$REPEAT^XLFSTR("=",IOM)
;
Q
;
EOR ;HLEVSRV1 - Event Monitor SERVER ;5/16/03 14:42
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLEVSRV1 9180 printed Nov 22, 2024@17:08:02 Page 2
HLEVSRV1 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
+1 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+2 ;
OPENM ; Open/close access to M code...
+1 DO OFFBEF
+2 DO HDM
DO EXM
DO STM
DO SWM
+3 QUIT
+4 ;
OKCODE(CODE) ; Check if license available and if so, mark used...
+1 NEW XTMP
+2 DO OFFBEF
+3 ;->
SET XTMP=$ORDER(^XTMP("HLEV SERVER M 9999999"),-1)
if XTMP']""
QUIT ""
+4 ;->
if '$DATA(^XTMP(XTMP,"LIC",CODE))
QUIT ""
+5 ;->
if $GET(^XTMP(XTMP,"LIC",CODE))]""
QUIT ""
+6 SET ^XTMP(XTMP,"LIC",CODE)=$$NOW^XLFDT_U_.5_U_$G(XMZ)_U_$GET(ZTSK)
+7 QUIT 1
+8 ;
OFFBEF ; Turn off all but last M code entry...
+1 NEW XTMP
+2 ;->
SET XTMP=$ORDER(^XTMP("HLEV SERVER M 9999999"),-1)
if XTMP']""
QUIT
+3 FOR
SET XTMP=$ORDER(^XTMP(XTMP),-1)
if XTMP']""
QUIT
Begin DoDot:1
+4 DO SETOFF(XTMP)
End DoDot:1
+5 QUIT
+6 ;
SWM ; Switch state...
+1 NEW STAT
+2 SET STAT=$$MST
+3 IF +STAT=0
DO UPM
+4 IF +STAT=1
DO DOWNM
+5 WRITE !
+6 SET X=$$BTE^HLCSMON("Press RETURN to exit... ")
+7 QUIT
+8 ;
DOWNM ; Turn off M code execution...
+1 ; STAT -- req
+2 NEW END,START,XTMP
+3 SET XTMP=$ORDER(^XTMP("HLEV SERVER M 9999999"),-1)
+4 ;->
IF XTMP']""
Begin DoDot:1
+5 WRITE !!,"M code execution is OFF already..."
End DoDot:1
QUIT
+6 WRITE !
+7 ;->
IF '$$YN^HLCSRPT4("Turn off M code execution")
Begin DoDot:1
+8 WRITE " nothing changed..."
End DoDot:1
QUIT
+9 DO SETOFF(XTMP)
+10 WRITE " M code execution disallowed..."
+11 QUIT
+12 ;
UPM ; Turn on M code execution...
+1 ; STAT -- req
+2 NEW CODES,END,IOBOFF,IOBON,NOC,START,X,XTMP
+3 ;
+4 SET X="IOBOFF;IOBON"
DO ENDR^%ZISS
+5 SET XTMP="HLEV SERVER M "_$$NOW^XLFDT
+6 ;
+7 WRITE !
+8 ;->
IF '$$YN^HLCSRPT4("Turn on M code execution","No")
Begin DoDot:1
+9 WRITE " nothing changed..."
End DoDot:1
QUIT
+10 ;
+11 WRITE !!,"Before M code execution can be turned on, you must answer a few questions..."
+12 WRITE !!,"Please include ",IOBON,"time",IOBOFF
+13 WRITE " when entering the start and end date/times..."
+14 ;
+15 WRITE !
+16 SET START=$$ASKDATE^HLEVAPI2("Enter START TIME","","NOW")
+17 ;->
IF START'?7N1"."1.N
Begin DoDot:1
+18 WRITE " exiting..."
End DoDot:1
QUIT
+19 ;
+20 WRITE !!,"Prompting START+24 hours..."
+21 WRITE !
+22 SET END=$$ASKDATE^HLEVAPI2("Enter END TIME","",$$FMTE^XLFDT($$FMADD^XLFDT(START,1)))
+23 ;->
IF END'?7N1"."1.N
Begin DoDot:1
+24 WRITE " exiting..."
End DoDot:1
QUIT
+25 ;
+26 WRITE !
+27 ;->
SET NOC=$$ASKCODES(.CODES)
IF 'NOC
Begin DoDot:1
+28 WRITE " exiting..."
End DoDot:1
QUIT
+29 WRITE !!,$SELECT(NOC=1:"The '"_$ORDER(CODES(""))_"' license",1:"These licenses")
+30 WRITE " will be installed if you turn on M code execution now:"
+31 ;
+32 IF NOC>1
Begin DoDot:1
+33 WRITE !!,?5
+34 SET CODES=""
+35 FOR
SET CODES=$ORDER(CODES(CODES))
if CODES']""
QUIT
Begin DoDot:2
+36 if ($X+$LENGTH(CODES))>IOM
WRITE !,?5
+37 WRITE $EXTRACT(CODES_" ",1,10)
End DoDot:2
End DoDot:1
+38 ;
+39 WRITE !
+40 ;->
IF '$$YN^HLCSRPT4("OK to turn on M code execution")
Begin DoDot:1
+41 WRITE " nothing changed..."
End DoDot:1
QUIT
+42 ;
+43 DO SETON(XTMP,START,END)
+44 WRITE " M code execution allowed..."
+45 ;
+46 WRITE !!,"Be sure to pass on ",$SELECT(NOC>1:"these licenses",1:"the license")
+47 WRITE " to the VistA HL7 team..."
+48 DO LICENSE(XTMP,.CODES)
+49 ;
+50 WRITE !
+51 SET X=$$BTE^HLCSMON("Press RETURN to exit...")
+52 ;
+53 QUIT
+54 ;
LICENSE(XTMP,CODES) ; Install licenses
+1 NEW CODE
+2 WRITE !!,"Codes: "
+3 ;
+4 SET CODE=""
+5 FOR
SET CODE=$ORDER(CODES(CODE))
if CODE']""
QUIT
Begin DoDot:1
+6 ; Mailman server uses stored on this node
SET ^XTMP(XTMP,"LIC",CODE)=""
+7 SET X=$EXTRACT(CODE_" ",1,20)
if ($X+$LENGTH(X))>IOM
WRITE !,?10
WRITE X
End DoDot:1
+8 ;
+9 QUIT
+10 ;
ASKCODES(CODES) ; Ask user for codes...
+1 NEW CODE,NOC
+2 ;
+3 WRITE !!,"You must now give the VistA HL7 team ""licences"" for M code execution. One"
+4 WRITE !,"license is used for every Mailman server request containing executable M "
+5 WRITE !,"code."
+6 WRITE !
+7 ;
+8 SET NOC=0
+9 FOR
Begin DoDot:1
+10 ;->
SET CODE=$$CODE
if CODE']""
QUIT
+11 SET ANS=$$YN^HLCSRPT4("Install the license# ["_CODE_"]","Yes")
+12 ;->
IF ANS'=1
SET CODE=""
WRITE " not intalled..."
QUIT
+13 SET NOC=NOC+1
SET CODES(CODE)=""
End DoDot:1
if CODE']""
QUIT
+14 ;
+15 QUIT NOC
+16 ;
SETON(XTMP,START,END) ; Allow M code execution
+1 SET ^XTMP(XTMP,0)=$$FMADD^XLFDT($$NOW^XLFDT,7)_U_$$NOW^XLFDT_U_"VistA HL7 Mailman Server M Control"
+2 SET ^XTMP(XTMP,"STATUS")=START_U_END_U_$GET(DUZ)
+3 QUIT
+4 ;
SETOFF(XTMP) ; Disallow M code execution...
+1 SET $PIECE(^XTMP(XTMP,"STATUS"),U,4,5)=$$NOW^XLFDT_U_$G(DUZ)
+2 QUIT
+3 ;
STM ; What is the status of M code execution?
+1 WRITE !!,$$CJ^XLFSTR("------ M Code Execution Status: "_$PIECE($$MST,U,3)_" ------",IOM)
+2 QUIT
+3 ;
MST() ; Status?
+1 ; Piece 1 = 0 -> DOWN UP OR DOWN
+2 ; = 1 -> UP
+3 ; Piece 2 = 1 -> No XTMP data exists... DOWN REASONS
+4 ; = 2 -> Invalid START/ENDs
+5 ; = 3 -> Before cutoff time
+6 ; = 4 -> After cutoff time
+7 ; = 5 -> Inactive date (p4) found
+8 ; = 0 -> Not DOWN!!!
+9 ; Piece 3 = Status text information
+10 ;
+11 ; NOW -- req
+12 NEW NOW,END,IDATE,START,STAT,XTMP
+13 SET NOW=$$NOW^XLFDT
+14 ;->
SET XTMP=$ORDER(^XTMP("HLEV SERVER M 9999999"),-1)
if XTMP']""
QUIT "0^1^DOWN"
+15 SET STAT=$GET(^XTMP(XTMP,"STATUS"))
SET START=+STAT
SET END=$PIECE(STAT,U,2)
SET IDATE=$PIECE(STAT,U,4)
+16 ;->
IF IDATE?7N1"."1.N
QUIT "0^5^DOWN"
+17 ;->
IF START'?7N1"."1.N!(END'?7N1"."1.N)
QUIT "0^2^DOWN"
+18 ;->
IF START>NOW
QUIT "0^3^DOWN - (Too early ("_$$SDT^HLEVX001(+START)_")"
+19 ;->
IF END<NOW
QUIT "0^4^DOWN - (Too late ("_$$SDT^HLEVX001(+END)_")"
+20 ;
+21 QUIT "1^0^UP"
+22 ;
HDM WRITE @IOF,$$CJ^XLFSTR("Open Access to Mailman Server M Code",IOM)
+1 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+2 QUIT
+3 ;
EXM NEW I,T
FOR I=1:1
SET T=$TEXT(EXM+I)
if T'[";;"
QUIT
WRITE !,$PIECE(T,";;",2,99)
+1 ;;Mailman server requests can be sent to your site requesting HL7 data be
+2 ;;returned to the VistA HL7 team. (These requests are only sent to the VistA
+3 ;;HL7 team, and under no circumstances are sent to any other mail groups or
+4 ;;individuals.) Under very rare circumstances, in order to debug problems on
+5 ;;your site, or to collect diagnostic information, it might be desired to run
+6 ;;some M code embedded in the Mailman server requests.
+7 ;;
+8 ;;In order to provide a high level of security, no M code will ever be run by
+9 ;;the Mailman server option unless you explicity allow M code execution. This
+10 ;;option allows you to allow, or disallow, M code execution.
+11 QUIT
+12 ;
CODE() ; Return license code...
+1 NEW CODE,EX,NOP,TYPE
+2 FOR EX=39,44,95,96
SET EX(EX)=""
+3 SET CODE=""
SET NOP=0
+4 FOR EX=1:1:6
Begin DoDot:1
+5 SET TYPE=$PIECE("A^P",U,$RANDOM(2)+1)
+6 ; Must be at least one punctuation
IF EX=6
IF NOP=0
SET TYPE="P"
+7 IF TYPE="P"
SET NOP=NOP+1
+8 if NOP>1
SET TYPE="A"
+9 SET CODE=CODE_$$RNO(TYPE)
+10 IF EX=3
SET CODE=CODE_"-"
End DoDot:1
+11 QUIT CODE
+12 ;
RNO(TYPE) ; Return random number between 33 and 122 (w/exceptions)
+1 ; NOP -- req
+2 NEW NO,OK
+3 FOR
SET NO=$RANDOM(89)+33
Begin DoDot:1
+4 SET OK=0
+5 ;-> Is it in exclusion list?
IF $DATA(EX(NO))
QUIT
+6 ;-> Is it an alpha character
IF TYPE="A"
Begin DoDot:2
+7 IF $$ALPHA(NO)
SET OK=1
End DoDot:2
QUIT
+8 ; Need punctuation...
IF '$$ALPHA(NO)
SET OK=1
End DoDot:1
if OK
QUIT
+9 QUIT $CHAR(NO)
+10 ;
ALPHA(NO) ; Is it ALPHA character?
+1 NEW X
+2 ;->
SET X=$ASCII($$UP^XLFSTR($CHAR(NO)))
if X>64&(X<91)
QUIT 1
+3 QUIT ""
+4 ;
GBLTOXM ; Place global data in Mailman message global...
+1 NEW DATA,FILE,GBL,IEN,LP,REF,ST,TXT
+2 ;
+3 ; Add data found...
+4 SET GBL=$NAME(^XTMP(XTMP,"DATA"))
+5 ;
+6 SET FILE=0
+7 FOR
SET FILE=$ORDER(@GBL@(FILE))
if FILE'>0
QUIT
Begin DoDot:1
+8 DO ADDMAIL^HLEVSRV("")
+9 DO ADDMAIL^HLEVSRV($$CJ^XLFSTR(" "_$PIECE($GET(^HLEV(+FILE,0)),U)_" [#"_FILE_"] ",74,"-"))
+10 SET IEN=0
+11 FOR
SET IEN=$ORDER(@GBL@(FILE,IEN))
if IEN'>0
QUIT
Begin DoDot:2
+12 SET TXT="#"_IEN
+13 SET LP="^XTMP("""_XTMP_""",""DATA"","_FILE_","_IEN
SET ST=LP_","
+14 SET LP=LP_")"
+15 FOR
SET LP=$QUERY(@LP)
if LP'[ST
QUIT
Begin DoDot:3
+16 SET REF="#"_IEN_","_$PIECE(LP,ST,2)_"="
SET POSX=$LENGTH(REF)
+17 SET DATA=@LP
+18 ;->
FOR
Begin DoDot:4
+19 SET TXT=REF_$EXTRACT(DATA,1,74-$LENGTH(REF))
+20 DO ADDMAIL^HLEVSRV(TXT)
+21 SET DATA=$EXTRACT(DATA,74-$LENGTH(REF)+1,999)
+22 SET REF=$$REPEAT^XLFSTR(" ",POSX)
End DoDot:4
if $TRANSLATE(REF," ","")']""&(DATA']"")
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
+25 ;
TEST ; Test server...
+1 NEW CT,HLEVQUIT,LASTXTMP,XTMP,XMREC,XMZ
+2 ;
+3 WRITE !!,"The current time is ",$$NOW^XLFDT,"..."
+4 ;
+5 WRITE !!,"Displaying all existing ^XTMP(""HLEV SERVER ..."") entries..."
+6 ;
+7 ; Find last 6 entries to show...
+8 SET XTMP="HLEV SERVER 9999999"
SET CT=0
+9 FOR
SET XTMP=$ORDER(^XTMP(XTMP),-1)
if XTMP'?1"HLEV SERVER "7N1"."1.N!(CT>6)
QUIT
Begin DoDot:1
+10 SET CT=CT+1
End DoDot:1
+11 ;
+12 SET CT=0
+13 SET XTMP=$SELECT(XTMP?1"HLEV SERVER "7N1"."1.N:XTMP,1:"HLEV SERVER 0000000")
+14 FOR
SET XTMP=$ORDER(^XTMP(XTMP))
if XTMP'?1"HLEV SERVER "7N1"."1.N
QUIT
Begin DoDot:1
+15 if 'CT
WRITE !!
+16 WRITE $EXTRACT("^XTMP("""_XTMP_""""_$$REPEAT^XLFSTR(" ",40),1,40)
+17 SET CT=CT+1
End DoDot:1
+18 ;
+19 ;->
IF 'CT
WRITE !!,"No XTMP server data exists..."
QUIT
+20 ;
+21 SET LASTXTMP=$ORDER(^XTMP("HLEV SERVER 9999999"),-1)
+22 DO SHOWXTMP("Last XTMP entry",LASTXTMP)
+23 ;
T1 WRITE !!,"Enter XTMP to rerun: ",LASTXTMP,"// "
+1 ;->
READ XTMP:999
if XTMP[U
QUIT
+2 if XTMP']""
SET XTMP=LASTXTMP
+3 ;->
IF '$DATA(^XTMP(XTMP))
Begin DoDot:1
+4 WRITE " entry not found..."
End DoDot:1
GOTO T1
+5 ;
+6 SET XMZ=$PIECE($GET(^XTMP(XTMP,"MAIL")),U)
+7 ;->
IF $GET(^XMB(3.9,+XMZ,0))']""
Begin DoDot:1
+8 WRITE !!,"There is no Mailman message recorded..."
End DoDot:1
QUIT
+9 ;
+10 SET XMREC="D REC^XMS3"
+11 ;
+12 WRITE !!,"Calling SERVER^HLEVSRV with XTMP=",XTMP,"..."
+13 ;
+14 DO SERVER^HLEVSRV
+15 ;
+16 DO SHOWXTMP("Last (and newly created) XTMP entry",$ORDER(^XTMP("HLEV SERVER 9999999"),-1))
+17 ;
+18 WRITE !!,"The last 776 IEN = ",$ORDER(^HLEV(776,":"),-1),"..."
+19 WRITE !
+20 ;
+21 DO ^%G
+22 ;
+23 QUIT
+24 ;
SHOWXTMP(TXT,XTMP) ; Show the XTMP data...
+1 NEW DATA,LP,POSX,ST
+2 ;
+3 ;->
IF '$DATA(^XTMP(XTMP))
QUIT
+4 ;
+5 WRITE !!,$$CJ^XLFSTR(" "_TXT_" ",IOM,"=")
+6 ;
+7 SET LP=$NAME(^XTMP(XTMP))
SET ST=$EXTRACT(LP,1,$LENGTH(LP)-1)_","
+8 FOR
SET LP=$QUERY(@LP)
if LP'[ST
QUIT
Begin DoDot:1
+9 WRITE !,LP," = "
+10 SET POSX=$X
SET DATA=@LP
+11 FOR
if DATA']""
QUIT
Begin DoDot:2
+12 if $X>POSX
WRITE !
if $X<POSX
WRITE ?POSX
+13 WRITE $EXTRACT(DATA,1,IOM-POSX-1)
+14 SET DATA=$EXTRACT(DATA,IOM-POSX,999)
End DoDot:2
End DoDot:1
+15 ;
+16 WRITE !,$$REPEAT^XLFSTR("=",IOM)
+17 ;
+18 QUIT
+19 ;
EOR ;HLEVSRV1 - Event Monitor SERVER ;5/16/03 14:42
