Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLEVSRV1

HLEVSRV1.m

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