HLEVSRV0.m

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---HLEVSRV0   8868     printed  Feb 18, 2025@23:24:18                                                                                                                                                                                                    Page 2

HLEVSRV0  ;O-OIFO/LJA - Event Monitor SERVER ;02/04/2004 14:42

 +1       ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995

 +2       ;

M(TXT)    ; Called when M code data requested in...

 +1       ; MXEC,XTMP -- req

 +2        NEW MCODE,NO,MTAG,WHEN

 +3       ;

 +4       ; Sets...

 +5        SET WHEN=$PIECE(TXT,U)

 +6       ;

 +7       ; Has license been sent?

 +8       ;->

           IF WHEN="LICENSE"

               Begin DoDot:1

 +9       ;->

                   if $PIECE(MXEC,U,4)]""

                       QUIT 

 +10               SET MCODE=$PIECE(TXT,U,2)

 +11      ;->

                   IF '$$OKCODE^HLEVSRV1(MCODE)

                       SET $PIECE(MXEC,U,4)=0

                       QUIT 

 +12      ; Force DOWN...

                   SET $PIECE(MXEC,U,4)=1

               End DoDot:1

               QUIT 

 +13      ;

 +14      ;->

           if WHEN'="BEFORE"&(WHEN'="AFTER")

               QUIT 

 +15      ;->

           SET MTAG=$PIECE(TXT,U,2)

           if MTAG']""

               QUIT 

 +16      ;->

           SET MCODE=$PIECE(TXT,U,3,999)

           if MCODE']""

               QUIT 

 +17      ;

 +18      ; Is it valid M code?

 +19      ;->

           SET X=MCODE

           DO ^DIM

           if '$DATA(X)

               QUIT 

 +20      ;

 +21       SET NO=$ORDER(^XTMP(XTMP,"M",WHEN,MTAG,":"),-1)+1

 +22       SET ^XTMP(XTMP,"M",WHEN,MTAG,+NO)=MCODE

 +23      ;

 +24       QUIT 

 +25      ;

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

 +1       ; XTMP -- req

 +2        DO MRUN("BEFORE")

 +3        QUIT 

 +4       ;

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

 +1       ; XTMP -- req

 +2        DO MRUN("AFTER")

 +3        QUIT 

 +4       ;

MRUN(WHEN) ; Run M code's INIT...

 +1       ; XTMP -- req

 +2        NEW ZZADD,ZZCALL,ZZMCODE,ZZMLNO,ZZMTAG,ZZNEXT,ZZNO,ZZREC

 +3       ;

 +4       ; Get starting M code...

 +5       ;->

           if $GET(^XTMP(XTMP,"M",WHEN,"INIT",1))']""

               QUIT 

 +6       ;

 +7       ; Values set up as a service for the developer sending in M code...

 +8       ;

 +9       ; NEXT LINE - Executable code to execute next line in "subroutine"...

 +10       SET ZZNEXT="S ZZMLNO=ZZMLNO+1,ZZMCODE=$G(^XTMP(XTMP,""M"",WHEN,ZZMTAG,ZZMLNO)) QUIT:ZZMCODE']""""  X ZZMCODE,ZZREC"

 +11       SET ZZREC="S ZZCALL=$G(ZZCALL)+1,^XTMP(XTMP,""M"",""REC"",WHEN,ZZCALL)=ZZMLNO_U_ZZMTAG"

 +12       SET ZZADD="D ADDMTXT^HLEVSRV0($G(ZZTXT))"

 +13      ;

 +14      ; Set up every "subroutine" in an executable call "tag"

 +15       SET ZZMCODE=""

 +16       FOR 

               SET ZZMCODE=$ORDER(^XTMP(XTMP,"M",WHEN,ZZMCODE))

               if ZZMCODE']""

                   QUIT 

               Begin DoDot:1

 +17               SET @ZZMCODE="S ZZMTAG="""_ZZMCODE_""",ZZMLNO=0 X ZZNEXT"

               End DoDot:1

 +18      ;

 +19       SET ZZCALL=0

 +20      ;

 +21      ; Start...

 +22       XECUTE INIT

 +23      ;

 +24       QUIT 

 +25      ;

MCOND     ; Condense M call data...

 +1        NEW DATA,TAG,TAGL,TAGN,TXT,WHEN,ZZCALL

 +2       ;

 +3       ;->

           if '$DATA(^XTMP(XTMP,"M","REC"))

               QUIT 

 +4       ;

 +5        KILL ^TMP($JOB,"HLMCOND")

 +6       ;

 +7        FOR WHEN="BEFORE","AFTER"

               Begin DoDot:1

 +8                SET ZZCALL=0

                   SET TXT=WHEN_": "

                   SET POSX=$LENGTH(TXT)

                   SET TAGL=""

                   SET TAGN=0

 +9                FOR 

                       SET ZZCALL=$ORDER(^XTMP(XTMP,"M","REC",WHEN,ZZCALL))

                       if ZZCALL'>0

                           QUIT 

                       Begin DoDot:2

 +10      ;->

                           SET DATA=^XTMP(XTMP,"M","REC",WHEN,ZZCALL)

                           SET TAG=$PIECE(DATA,U,2)

                           if TAG']""

                               QUIT 

 +11                       IF $LENGTH(TXT)>55

                               Begin DoDot:3

 +12                               DO ADD(TXT)

 +13                               SET TXT=$$REPEAT^XLFSTR(" ",POSX)

                               End DoDot:3

 +14                       IF TAGL'=TAG

                               Begin DoDot:3

 +15                               IF TAGL]""

                                       IF TAGN>0

                                           SET TXT=TXT_"(#"_TAGN_")"

                                           SET TAGN=0

 +16                               SET TXT=TXT_$SELECT($LENGTH(TXT)>POSX:"-",1:"")_TAG

                                   SET TAGN=1

                               End DoDot:3

 +17                       IF TAGL=TAG

                               SET TAGN=TAGN+1

 +18                       SET TAGL=TAG

                       End DoDot:2

 +19               IF TAGN>0

                       IF $LENGTH(TXT)>POSX

                           SET TXT=TXT_"(#"_TAGN_")"

                           SET TAGN=0

 +20               IF $LENGTH(TXT)>POSX

                       DO ADD(TXT)

               End DoDot:1

 +21      ;

 +22      ;->

           if '$DATA(^TMP($JOB,"HLMCOND"))

               QUIT 

 +23      ;

 +24       KILL ^XTMP(XTMP,"M","REC")

 +25       MERGE ^XTMP(XTMP,"M","REC")=^TMP($JOB,"HLMCOND")

 +26      ;

 +27       QUIT 

 +28      ;

MCALLREC  ; Store MCOND data in mail message..

 +1        NEW NO

 +2       ;

 +3       ;->

           if '$DATA(^XTMP(XTMP,"M","REC"))

               QUIT 

 +4       ;

 +5        DO ADDMAIL^HLEVSRV("")

           DO ADDMAIL^HLEVSRV("M Call Record")

 +6        DO ADDMAIL^HLEVSRV($$REPEAT^XLFSTR("-",74))

 +7       ;

 +8        SET NO=0

 +9        FOR 

               SET NO=$ORDER(^XTMP(XTMP,"M","REC",NO))

               if NO'>0

                   QUIT 

               Begin DoDot:1

 +10               DO ADDMAIL^HLEVSRV(^XTMP(XTMP,"M","REC",NO))

               End DoDot:1

 +11      ;

 +12       QUIT 

 +13      ;

ADDMTXT(TXT) ;

 +1        NEW NO

 +2        SET NO=$ORDER(^XTMP(XTMP,"MTEXT",":"),-1)+1

 +3        SET ^XTMP(XTMP,"MTEXT",+NO)=TXT

 +4        QUIT 

 +5       ;

MTEXT     ; Add text to Mailman message created by M code...

 +1        NEW NO

 +2       ;

 +3        IF $GET(^XTMP(XTMP,"MTEXT"))

               Begin DoDot:1

 +4                DO ADDMAIL("")

 +5                DO ADDMAIL($$CJ^XLFSTR(" M-Created Text ",74,"-"))

               End DoDot:1

 +6       ;

 +7        SET NO=0

 +8        FOR 

               SET NO=$ORDER(^XTMP(XTMP,"MTEXT",NO))

               if NO'>0

                   QUIT 

               Begin DoDot:1

 +9                DO ADDMAIL(^XTMP(XTMP,"MTEXT",NO))

               End DoDot:1

 +10      ;

 +11       QUIT 

 +12      ;

ADD(TXT)  ;

 +1        NEW NO

 +2        SET NO=$ORDER(^TMP($JOB,"HLMCOND",":"),-1)+1

 +3        SET ^TMP($JOB,"HLMCOND",+NO)=TXT

 +4        QUIT 

 +5       ;

MTEST     ; Test M code embedded in a Mailman message...

 +1        NEW IOINHI,IOINORM,MIEN,X,XTMP

 +2       ;

 +3        SET X="IOINHI;IOINORM"

           DO ENDR^%ZISS

 +4       ;

 +5        WRITE @IOF,$$CJ^XLFSTR("M Code Test",IOM)

 +6        WRITE !,$$REPEAT^XLFSTR("=",IOM)

 +7        WRITE !!,"This utility will execute the code in the BEFORE and AFTER sections of the"

 +8        WRITE !,"M code embedded in a Mailman message.  The message must be in the format"

 +9        WRITE !,"used by the [HLEV-INFORMATION-SERVER] menu option."

 +10      ;

MT1        WRITE !

 +1        FOR 

               READ !,"Message IEN: ",MIEN:60

               if MIEN'>0

                   QUIT 

               Begin DoDot:1

 +2       ;->

                   IF $GET(^XMB(3.9,+MIEN,0))']""

                       Begin DoDot:2

 +3                        WRITE "   no message found..."

                       End DoDot:2

                       QUIT 

 +4                WRITE "   ",$PIECE(^XMB(3.9,+MIEN,0),U),"..."

               End DoDot:1

               if $GET(^XMB(3.9,+MIEN,0))]""

                   QUIT 

 +5       ;

 +6       ;->

           if $GET(^XMB(3.9,+MIEN,0))']""

               QUIT 

 +7       ;

 +8        SET XTMP="HLEV SERVER 9999999"

           SET NOW=$$NOW^XLFDT

 +9        KILL ^XTMP(XTMP)

 +10       SET ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,0,1)_U_NOW_U_"TEST"

 +11      ;

 +12       WRITE !!,"Loading M code..."

 +13       SET LNO=0

 +14       FOR 

               SET LNO=$ORDER(^XMB(3.9,+MIEN,2,LNO))

               if LNO'>0

                   QUIT 

               Begin DoDot:1

 +15      ;->

                   SET TXT=$GET(^XMB(3.9,+MIEN,2,+LNO,0))

                   if $EXTRACT(TXT,1,2)'="M^"

                       QUIT 

 +16      ;->

                   SET TXT=$PIECE(TXT,U,2,999)

                   if TXT']""

                       QUIT 

 +17               WRITE "."

 +18               DO M(TXT)

               End DoDot:1

 +19      ;

 +20      ;->

           IF '$DATA(^XTMP(XTMP,"M"))

               Begin DoDot:1

 +21               WRITE !!,"No M code embedded in this Mailman message..."

               End DoDot:1

               GOTO MT1

 +22      ;

 +23       WRITE !

 +24       SET LP=$NAME(^XTMP(XTMP,"M"))

           SET ST="^XTMP("""_XTMP_""",""M"","

 +25       FOR 

               SET LP=$QUERY(@LP)

               if LP'[ST

                   QUIT 

               Begin DoDot:1

 +26               WRITE !,IOINHI,"...",$PIECE(LP,",""M"",",2,99),IOINORM," = "

 +27               SET POSX=$X

                   SET DATA=@LP

 +28               FOR 

                       if DATA']""

                           QUIT 

                       Begin DoDot:2

 +29                       WRITE $EXTRACT(DATA,1,IOM-POSX)

 +30                       SET DATA=$EXTRACT(DATA,IOM-POSX+1,999)

                       End DoDot:2

               End DoDot:1

 +31      ;

 +32       WRITE !!,"You can execute the BEFORE load M code, or the AFTER load M code.  The BEFORE"

 +33       WRITE !,"load M code requires a BEFORE^INIT... node(s).  The AFTER load M code"

 +34       WRITE !,"requires an AFTER^INIT... node(s)."

 +35      ;

 +36      ;->

           IF '$DATA(^XTMP(XTMP,"M","BEFORE"))&('$DATA(^XTMP(XTMP,"M","AFTER")))

               Begin DoDot:1

 +37               WRITE !!,"You must add a BEFORE and/or AFTER section to the M code embedded in the"

 +38               WRITE !,"Mailman message before you can use this utility to test."

               End DoDot:1

               GOTO MT1

 +39      ;

 +40       DO MEX("BEFORE")

 +41       DO MEX("AFTER")

 +42      ;

 +43       KILL ^XTMP(XTMP)

 +44      ;

 +45       WRITE !!,"Done..."

 +46      ;

 +47       QUIT 

 +48      ;

MEX(WHEN) ; Called by MTEST to execute ^XTMP(XTMP,"M") code...

 +1        NEW X

 +2       ;->

           if '$DATA(^XTMP(XTMP,"M",WHEN))

               QUIT 

 +3        WRITE !!,"Press RETURN to execute the ",IOINHI,WHEN,IOINORM

 +4        WRITE " code, or '^' to skip... "

 +5       ;->

           READ X:60

           IF '$TEST!(X[U)

               WRITE "  no action taken..."

               QUIT 

 +6        WRITE !,"Executing the ",WHEN," code..."

 +7        IF WHEN="BEFORE"

               DO MPRE

 +8        IF WHEN="AFTER"

               DO MPST

 +9        WRITE "  M code finished..."

 +10       QUIT 

 +11      ;

UNIT(TXT) ; Load IEN list found by MSG ID... (TXT=MsgID)

 +1       ; XTMP -- req

 +2       ;

 +3       ; Data request line must equal UNIT^#^TYPE  (#^TYPE passed in here)

 +4       ;

 +5       ; TYPE = "IEN772", "IEN773", or "MSGID"

 +6       ;    # = IEN772, IEN773 or MSGID

 +7       ;

 +8       ; The # used to find any IEN772 in the unit.

 +9       ; All messages in unit found using $$LOAD772S^HLUCM009, and

 +10      ; formatted by LOADUNIT and returned in email to user.

 +11      ;

 +12       NEW CT,HL772,HLID,HLTYPE,IEN772,IEN773,IEN773,NO772S

 +13      ;

 +14      ; Initial sets...

 +15      ;->

           SET HLID=$PIECE($GET(TXT),U)

           if HLID']""

               QUIT 

 +16      ; IEN772, IEN773, or MSGID

           SET HLTYPE=$PIECE(TXT,U,2)

 +17       SET IEN772=""

 +18      ;

 +19      ; Try to get IEN772 from MSGID...

 +20      ;->

           IF HLTYPE="MSGID"

               Begin DoDot:1

 +21               SET IEN772=$ORDER(^HL(772,"C",HLID,":"),-1)

 +22      ;->

                   IF IEN772

                       Begin DoDot:2

 +23      ;->

                           SET IEN773=$ORDER(^HLMA("C",HLID,0))

                           if IEN773'>0

                               QUIT 

 +24                       SET IEN772=+$GET(^HLMA(+IEN773,0))

                       End DoDot:2

                       if IEN772'>0

                           QUIT 

 +25      ;->

                   SET IEN773=$ORDER(^HLMA("C",HLID,":"),-1)

                   if 'IEN773

                       QUIT 

 +26               SET IEN772=+$GET(^HLMA(+IEN773,0))

               End DoDot:1

               if 'IEN772

                   QUIT 

 +27      ;

 +28      ; If passed IEN772...

 +29      ;->

           IF HLTYPE="IEN772"

               Begin DoDot:1

 +30      ;->

                   if $GET(^HL(772,+HLID,0))']""

                       QUIT 

 +31               SET IEN772=+HLID

               End DoDot:1

               if IEN772'>0

                   QUIT 

 +32      ;

 +33      ; If passed IEN773...

 +34      ;->

           IF HLTYPE="IEN773"

               Begin DoDot:1

 +35               SET IEN772=+$GET(^HLMA(+HLID,0))

 +36      ;-> It's OK

                   if $GET(^HL(772,+IEN772,0))]""

                       QUIT 

 +37               SET IEN772=""

               End DoDot:1

               if IEN772'>0

                   QUIT 

 +38      ;

 +39      ;->

           if $GET(^HL(772,+$GET(IEN772),0))']""

               QUIT 

 +40      ;

 +41      ; Load associated entries...

 +42      ;->

           SET NO772S=$$LOAD772S^HLUCM009(+IEN772,.HL772)

           if NO772S'>0

               QUIT 

 +43      ;

 +44      ; Load data...

 +45       SET IEN772=0

 +46       FOR 

               SET IEN772=$ORDER(HL772("HLPARENT",IEN772))

               if IEN772'>0

                   QUIT 

               Begin DoDot:1

 +47               SET IEN772C=0

 +48               FOR 

                       SET IEN772C=$ORDER(HL772("HLPARENT",IEN772,IEN772C))

                       if IEN772C'>0

                           QUIT 

                       Begin DoDot:2

 +49                       SET ^XTMP(XTMP,"HLUNIT",IEN772,IEN772C)=""

                       End DoDot:2

               End DoDot:1

 +50      ;

 +51       QUIT 

 +52      ;

LOADUNIT  ; Load data found by UNIT above...

 +1        NEW IEN772C,IEN772P,POSX,TXT

 +2       ;

 +3       ;->

           if '$DATA(^XTMP(XTMP,"HLUNIT"))

               QUIT 

 +4       ;

 +5        DO ADDMAIL("")

           DO ADDMAIL($$CJ^XLFSTR(" Msg ID-requested Message Units ",74,"-"))

 +6       ;

 +7        SET IEN772P=0

 +8        FOR 

               SET IEN772P=$ORDER(^XTMP(XTMP,"HLUNIT",IEN772P))

               if IEN772P'>0

                   QUIT 

               Begin DoDot:1

 +9                SET TXT=IEN772P_": "

                   SET POSX=$LENGTH(TXT)

 +10               SET IEN772C=0

 +11               FOR 

                       SET IEN772C=$ORDER(^XTMP(XTMP,"HLUNIT",IEN772P,IEN772C))

                       if IEN772C'>0

                           QUIT 

                       Begin DoDot:2

 +12                       IF ($LENGTH(TXT)+$LENGTH(IEN772C)+2)>74

                               Begin DoDot:3

 +13                               DO ADDMAIL(TXT)