307 lines
8.4 KiB
Mathematica
307 lines
8.4 KiB
Mathematica
HLEVSRV0 ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42
|
|
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
|
|
;
|
|
M(TXT) ; Called when M code data requested in...
|
|
; MXEC,XTMP -- req
|
|
N MCODE,NO,MTAG,WHEN
|
|
;
|
|
; Sets...
|
|
S WHEN=$P(TXT,U)
|
|
;
|
|
; Has license been sent?
|
|
I WHEN="LICENSE" D QUIT ;->
|
|
. QUIT:$P(MXEC,U,4)]"" ;->
|
|
. S MCODE=$P(TXT,U,2)
|
|
. I '$$OKCODE^HLEVSRV1(MCODE) S $P(MXEC,U,4)=0 QUIT ;->
|
|
. S $P(MXEC,U,4)=1 ; Force DOWN...
|
|
;
|
|
QUIT:WHEN'="BEFORE"&(WHEN'="AFTER") ;->
|
|
S MTAG=$P(TXT,U,2) QUIT:MTAG']"" ;->
|
|
S MCODE=$P(TXT,U,3,999) Q:MCODE']"" ;->
|
|
;
|
|
; Is it valid M code?
|
|
S X=MCODE D ^DIM QUIT:'$D(X) ;->
|
|
;
|
|
S NO=$O(^XTMP(XTMP,"M",WHEN,MTAG,":"),-1)+1
|
|
S ^XTMP(XTMP,"M",WHEN,MTAG,+NO)=MCODE
|
|
;
|
|
Q
|
|
;
|
|
MPRE ; Run M code before load of data...
|
|
; XTMP -- req
|
|
D MRUN("BEFORE")
|
|
Q
|
|
;
|
|
MPST ; Run M code after load of data...
|
|
; XTMP -- req
|
|
D MRUN("AFTER")
|
|
Q
|
|
;
|
|
MRUN(WHEN) ; Run M code's INIT...
|
|
; XTMP -- req
|
|
N ZZADD,ZZCALL,ZZMCODE,ZZMLNO,ZZMTAG,ZZNEXT,ZZNO,ZZREC
|
|
;
|
|
; Get starting M code...
|
|
QUIT:$G(^XTMP(XTMP,"M",WHEN,"INIT",1))']"" ;->
|
|
;
|
|
; Values set up as a service for the developer sending in M code...
|
|
;
|
|
; NEXT LINE - Executable code to execute next line in "subroutine"...
|
|
S ZZNEXT="S ZZMLNO=ZZMLNO+1,ZZMCODE=$G(^XTMP(XTMP,""M"",WHEN,ZZMTAG,ZZMLNO)) QUIT:ZZMCODE']"""" X ZZMCODE,ZZREC"
|
|
S ZZREC="S ZZCALL=$G(ZZCALL)+1,^XTMP(XTMP,""M"",""REC"",WHEN,ZZCALL)=ZZMLNO_U_ZZMTAG"
|
|
S ZZADD="D ADDMTXT^HLEVSRV0($G(ZZTXT))"
|
|
;
|
|
; Set up every "subroutine" in an executable call "tag"
|
|
S ZZMCODE=""
|
|
F S ZZMCODE=$O(^XTMP(XTMP,"M",WHEN,ZZMCODE)) Q:ZZMCODE']"" D
|
|
. S @ZZMCODE="S ZZMTAG="""_ZZMCODE_""",ZZMLNO=0 X ZZNEXT"
|
|
;
|
|
S ZZCALL=0
|
|
;
|
|
; Start...
|
|
X INIT
|
|
;
|
|
Q
|
|
;
|
|
MCOND ; Condense M call data...
|
|
N DATA,TAG,TAGL,TAGN,TXT,WHEN,ZZCALL
|
|
;
|
|
QUIT:'$D(^XTMP(XTMP,"M","REC")) ;->
|
|
;
|
|
KILL ^TMP($J,"HLMCOND")
|
|
;
|
|
F WHEN="BEFORE","AFTER" D
|
|
. S ZZCALL=0,TXT=WHEN_": ",POSX=$L(TXT),TAGL="",TAGN=0
|
|
. F S ZZCALL=$O(^XTMP(XTMP,"M","REC",WHEN,ZZCALL)) Q:ZZCALL'>0 D
|
|
. . S DATA=^XTMP(XTMP,"M","REC",WHEN,ZZCALL),TAG=$P(DATA,U,2) QUIT:TAG']"" ;->
|
|
. . I $L(TXT)>55 D
|
|
. . . D ADD(TXT)
|
|
. . . S TXT=$$REPEAT^XLFSTR(" ",POSX)
|
|
. . I TAGL'=TAG D
|
|
. . . I TAGL]"",TAGN>0 S TXT=TXT_"(#"_TAGN_")",TAGN=0
|
|
. . . S TXT=TXT_$S($L(TXT)>POSX:"-",1:"")_TAG,TAGN=1
|
|
. . I TAGL=TAG S TAGN=TAGN+1
|
|
. . S TAGL=TAG
|
|
. I TAGN>0,$L(TXT)>POSX S TXT=TXT_"(#"_TAGN_")",TAGN=0
|
|
. I $L(TXT)>POSX D ADD(TXT)
|
|
;
|
|
QUIT:'$D(^TMP($J,"HLMCOND")) ;->
|
|
;
|
|
KILL ^XTMP(XTMP,"M","REC")
|
|
MERGE ^XTMP(XTMP,"M","REC")=^TMP($J,"HLMCOND")
|
|
;
|
|
Q
|
|
;
|
|
MCALLREC ; Store MCOND data in mail message..
|
|
N NO
|
|
;
|
|
QUIT:'$D(^XTMP(XTMP,"M","REC")) ;->
|
|
;
|
|
D ADDMAIL^HLEVSRV(""),ADDMAIL^HLEVSRV("M Call Record")
|
|
D ADDMAIL^HLEVSRV($$REPEAT^XLFSTR("-",74))
|
|
;
|
|
S NO=0
|
|
F S NO=$O(^XTMP(XTMP,"M","REC",NO)) Q:NO'>0 D
|
|
. D ADDMAIL^HLEVSRV(^XTMP(XTMP,"M","REC",NO))
|
|
;
|
|
Q
|
|
;
|
|
ADDMTXT(TXT) ;
|
|
N NO
|
|
S NO=$O(^XTMP(XTMP,"MTEXT",":"),-1)+1
|
|
S ^XTMP(XTMP,"MTEXT",+NO)=TXT
|
|
Q
|
|
;
|
|
MTEXT ; Add text to Mailman message created by M code...
|
|
N NO
|
|
;
|
|
I $G(^XTMP(XTMP,"MTEXT")) D
|
|
. D ADDMAIL("")
|
|
. D ADDMAIL($$CJ^XLFSTR(" M-Created Text ",74,"-"))
|
|
;
|
|
S NO=0
|
|
F S NO=$O(^XTMP(XTMP,"MTEXT",NO)) Q:NO'>0 D
|
|
. D ADDMAIL(^XTMP(XTMP,"MTEXT",NO))
|
|
;
|
|
Q
|
|
;
|
|
ADD(TXT) ;
|
|
N NO
|
|
S NO=$O(^TMP($J,"HLMCOND",":"),-1)+1
|
|
S ^TMP($J,"HLMCOND",+NO)=TXT
|
|
Q
|
|
;
|
|
MTEST ; Test M code embedded in a Mailman message...
|
|
N IOINHI,IOINORM,MIEN,X,XTMP
|
|
;
|
|
S X="IOINHI;IOINORM" D ENDR^%ZISS
|
|
;
|
|
W @IOF,$$CJ^XLFSTR("M Code Test",IOM)
|
|
W !,$$REPEAT^XLFSTR("=",IOM)
|
|
W !!,"This utility will execute the code in the BEFORE and AFTER sections of the"
|
|
W !,"M code embedded in a Mailman message. The message must be in the format"
|
|
W !,"used by the [HLEV-INFORMATION-SERVER] menu option."
|
|
;
|
|
MT1 W !
|
|
F R !,"Message IEN: ",MIEN:60 Q:MIEN'>0 D QUIT:$G(^XMB(3.9,+MIEN,0))]""
|
|
. I $G(^XMB(3.9,+MIEN,0))']"" D QUIT ;->
|
|
. . W " no message found..."
|
|
. W " ",$P(^XMB(3.9,+MIEN,0),U),"..."
|
|
;
|
|
QUIT:$G(^XMB(3.9,+MIEN,0))']"" ;->
|
|
;
|
|
S XTMP="HLEV SERVER 9999999",NOW=$$NOW^XLFDT
|
|
KILL ^XTMP(XTMP)
|
|
S ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,1)_U_NOW_U_"TEST"
|
|
;
|
|
W !!,"Loading M code..."
|
|
S LNO=0
|
|
F S LNO=$O(^XMB(3.9,+MIEN,2,LNO)) Q:LNO'>0 D
|
|
. S TXT=$G(^XMB(3.9,+MIEN,2,+LNO,0)) QUIT:$E(TXT,1,2)'="M^" ;->
|
|
. S TXT=$P(TXT,U,2,999) QUIT:TXT']"" ;->
|
|
. W "."
|
|
. D M(TXT)
|
|
;
|
|
I '$D(^XTMP(XTMP,"M")) D G MT1 ;->
|
|
. W !!,"No M code embedded in this Mailman message..."
|
|
;
|
|
W !
|
|
S LP=$NA(^XTMP(XTMP,"M")),ST="^XTMP("""_XTMP_""",""M"","
|
|
F S LP=$Q(@LP) Q:LP'[ST D
|
|
. W !,IOINHI,"...",$P(LP,",""M"",",2,99),IOINORM," = "
|
|
. S POSX=$X,DATA=@LP
|
|
. F QUIT:DATA']"" D
|
|
. . W $E(DATA,1,IOM-POSX)
|
|
. . S DATA=$E(DATA,IOM-POSX+1,999)
|
|
;
|
|
W !!,"You can execute the BEFORE load M code, or the AFTER load M code. The BEFORE"
|
|
W !,"load M code requires a BEFORE^INIT... node(s). The AFTER load M code"
|
|
W !,"requires an AFTER^INIT... node(s)."
|
|
;
|
|
I '$D(^XTMP(XTMP,"M","BEFORE"))&('$D(^XTMP(XTMP,"M","AFTER"))) D G MT1 ;->
|
|
. W !!,"You must add a BEFORE and/or AFTER section to the M code embedded in the"
|
|
. W !,"Mailman message before you can use this utility to test."
|
|
;
|
|
D MEX("BEFORE")
|
|
D MEX("AFTER")
|
|
;
|
|
KILL ^XTMP(XTMP)
|
|
;
|
|
W !!,"Done..."
|
|
;
|
|
Q
|
|
;
|
|
MEX(WHEN) ; Called by MTEST to execute ^XTMP(XTMP,"M") code...
|
|
N X
|
|
QUIT:'$D(^XTMP(XTMP,"M",WHEN)) ;->
|
|
W !!,"Press RETURN to execute the ",IOINHI,WHEN,IOINORM
|
|
W " code, or '^' to skip... "
|
|
R X:60 I '$T!(X[U) W " no action taken..." QUIT ;->
|
|
W !,"Executing the ",WHEN," code..."
|
|
I WHEN="BEFORE" D MPRE
|
|
I WHEN="AFTER" D MPST
|
|
W " M code finished..."
|
|
Q
|
|
;
|
|
UNIT(TXT) ; Load IEN list found by MSG ID... (TXT=MsgID)
|
|
; XTMP -- req
|
|
;
|
|
; Data request line must equal UNIT^#^TYPE (#^TYPE passed in here)
|
|
;
|
|
; TYPE = "IEN772", "IEN773", or "MSGID"
|
|
; # = IEN772, IEN773 or MSGID
|
|
;
|
|
; The # used to find any IEN772 in the unit.
|
|
; All messages in unit found using $$LOAD772S^HLUCM009, and
|
|
; formatted by LOADUNIT and returned in email to user.
|
|
;
|
|
N CT,HL772,HLID,HLTYPE,IEN772,IEN773,IEN773,NO772S
|
|
;
|
|
; Initial sets...
|
|
S HLID=$P($G(TXT),U) QUIT:HLID']"" ;->
|
|
S HLTYPE=$P(TXT,U,2) ; IEN772, IEN773, or MSGID
|
|
S IEN772=""
|
|
;
|
|
; Try to get IEN772 from MSGID...
|
|
I HLTYPE="MSGID" D QUIT:'IEN772 ;->
|
|
. S IEN772=$O(^HL(772,"C",HLID,":"),-1)
|
|
. I IEN772 D QUIT:IEN772'>0 ;->
|
|
. . S IEN773=$O(^HLMA("C",HLID,0)) QUIT:IEN773'>0 ;->
|
|
. . S IEN772=+$G(^HLMA(+IEN773,0))
|
|
. S IEN773=$O(^HLMA("C",HLID,":"),-1) QUIT:'IEN773 ;->
|
|
. S IEN772=+$G(^HLMA(+IEN773,0))
|
|
;
|
|
; If passed IEN772...
|
|
I HLTYPE="IEN772" D QUIT:IEN772'>0 ;->
|
|
. QUIT:$G(^HL(772,+HLID,0))']"" ;->
|
|
. S IEN772=+HLID
|
|
;
|
|
; If passed IEN773...
|
|
I HLTYPE="IEN773" D QUIT:IEN772'>0 ;->
|
|
. S IEN772=+$G(^HLMA(+HLID,0))
|
|
. QUIT:$G(^HL(772,+IEN772,0))]"" ;-> It's OK
|
|
. S IEN772=""
|
|
;
|
|
QUIT:$G(^HL(772,+$G(IEN772),0))']"" ;->
|
|
;
|
|
; Load associated entries...
|
|
S NO772S=$$LOAD772S^HLUCM009(+IEN772,.HL772) QUIT:NO772S'>0 ;->
|
|
;
|
|
; Load data...
|
|
S IEN772=0
|
|
F S IEN772=$O(HL772("HLPARENT",IEN772)) Q:IEN772'>0 D
|
|
. S IEN772C=0
|
|
. F S IEN772C=$O(HL772("HLPARENT",IEN772,IEN772C)) Q:IEN772C'>0 D
|
|
. . S ^XTMP(XTMP,"HLUNIT",IEN772,IEN772C)=""
|
|
;
|
|
Q
|
|
;
|
|
LOADUNIT ; Load data found by UNIT above...
|
|
N IEN772C,IEN772P,POSX,TXT
|
|
;
|
|
QUIT:'$D(^XTMP(XTMP,"HLUNIT")) ;->
|
|
;
|
|
D ADDMAIL(""),ADDMAIL($$CJ^XLFSTR(" Msg ID-requested Message Units ",74,"-"))
|
|
;
|
|
S IEN772P=0
|
|
F S IEN772P=$O(^XTMP(XTMP,"HLUNIT",IEN772P)) Q:IEN772P'>0 D
|
|
. S TXT=IEN772P_": ",POSX=$L(TXT)
|
|
. S IEN772C=0
|
|
. F S IEN772C=$O(^XTMP(XTMP,"HLUNIT",IEN772P,IEN772C)) Q:IEN772C'>0 D
|
|
. . I ($L(TXT)+$L(IEN772C)+2)>74 D
|
|
. . . D ADDMAIL(TXT)
|
|
. . . S TXT=$$REPEAT^XLFSTR(" ",POSX)
|
|
. . S TXT=TXT_$S($L(TXT)>POSX:",",1:"")_IEN772C
|
|
. I TXT]"" D ADDMAIL(TXT) S TXT=""
|
|
;
|
|
Q
|
|
;
|
|
ADDMAIL(TXT) D ADDMAIL^HLEVSRV(TXT)
|
|
Q
|
|
;
|
|
QUITQ(LPVAL,STOP,NOLINE,CT) ; Should looping stop?
|
|
QUIT:LPVAL']"" 1 ;->
|
|
QUIT:LPVAL'[STOP 1 ;->
|
|
QUIT:(CT+1)>NOLINE 1 ;->
|
|
Q ""
|
|
;
|
|
QUITS(LPVAL,SCREEN) ; Should this be included?
|
|
N DATA,DIV,MAXNO,OK,PCE,VAL,X
|
|
S DIV=""
|
|
S MAXNO=$L(LPVAL,",") I $L(SCREEN,",")'=MAXNO QUIT 1 ;->
|
|
F PCE=1:1:MAXNO D QUIT:'OK
|
|
. S OK=0
|
|
. S X=$P(SCREEN,"#",PCE),DIV=$S(DIV]"":",",1:$E(X,$L(X)))
|
|
. S DATA(1)=$P(LPVAL,DIV,+PCE) QUIT:DATA(1)']"" ;->
|
|
. S DATA(2)=$P(SCREEN,DIV,+PCE) QUIT:DATA(2)']"" ;->
|
|
. I DATA(2)="#" QUIT:DATA(1)'?1.N ;->
|
|
. I DATA(2)'="#" QUIT:DATA(1)'=DATA(2) ;->
|
|
. S OK=1
|
|
S OK='OK ; Because this is a QUIT IF extrinsic function
|
|
Q OK
|
|
;
|
|
ADDLINE(TXT) D ADDLINE^HLEVSRV(TXT)
|
|
Q
|
|
;
|
|
EOR ;HLEVSRV0 - Event Monitor SERVER ;5/16/03 14:42
|