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 ; 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