- 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 Jan 18, 2025@02:59:10 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