Routine: HLEVSRV0

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

MPRE ; Run M code before load of data...

 ; XTMP -- req

 D MRUN("BEFORE")

MPST ; Run M code after load of data...

 ; XTMP -- req

 D MRUN("AFTER")

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

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")

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

ADDMTXT(TXT) ;

 N NO

 S NO=$O(^XTMP(XTMP,"MTEXT",":"),-1)+1

 S ^XTMP(XTMP,"MTEXT",+NO)=TXT

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

ADD(TXT) ;

 N NO

 S NO=$O(^TMP($J,"HLMCOND",":"),-1)+1

 S ^TMP($J,"HLMCOND",+NO)=TXT

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..."

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..."

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)=""

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=""

ADDMAIL(TXT) D ADDMAIL^HLEVSRV(TXT)

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)

EOR ;HLEVSRV0 - Event Monitor SERVER ;5/16/03 14:42

HLEVSRV0.m