XMD ;ISC-SF/GMB-Send/Forward/Add text to a message APIs ;08/27/2003 11:01
;;8.0;MailMan;**21**;Jun 28, 2002
; Was (WASH ISC)/THM/CAP
;
; Entry points (DBIA 10070) are:
; ^XMD Send a message.
; If no recipients defined, prompt for them.
; EN1^XMD Put text in a message.
; If no recipients defined, prompt for them.
; Send the message.
; ENL^XMD Add text to an existing message.
; ENT^XMD Interactive 'send a message'. (Same as menu)
; ENT1^XMD Forward a message.
; ENT2^XMD Forward a message.
; Prompt for recipients, whether or not any are already
; defined.
;
; I/O Variables to the various APIs:
; XMDUZ (in, optional) Sender DUZ or string (default=DUZ)
; For new messages, XMDUZ may be a string, which will be
; put in the 'message from' field.
; For forwarded messages, XMDUZ may be a string, which
; will be put in the 'forwarded by' field.
; XMSUB (in) Message subject
; XMTEXT (in) @location of message. For example, the following are
; among the acceptable:
; XMTEXT="array("
; XMTEXT="array(""node"","
; XMTEXT="^TMP(""namespace"",$J,""array"","
; The array must be in the acceptable FM word processing
; format.
; XMSTRIP (in, optional) Characters that user wants stripped from text
; of message (default=none)
; XMY (in, optional) Array of recipients, XMY(x)="", where
; x is a valid local or internet address.
; XMY(x,0)=basket to deliver to, if x=sender's DUZ or .6
; (Basket may be its number or name. If name, and it
; doesn't exist, it will be created.)
; XMY(x,1)=recipient type, either "I" (info only) or
; "C" (carbon copy)
; XMY(x,"D")=delete date, if x=.6 ("SHARED,MAIL")
; A local address may be a user's name or DUZ, a G.group
; name or S.server name.
; If not supplied and the process is not queued,
; you will be prompted.
; XMMG (in, optional) If XMY is not supplied and the process is not
; queued, XMMG is used as the default for the first
; 'send to:' prompt. It is ignored otherwise.
; (out) Contains error message if error occurs.
; Undefined if no error.
; DIFROM (in, optional) ?
; XMROU (in, optional) Array of routines to be loaded in a PackMan
; message. XMROU(x)="", where x=routine name.
; XMYBLOB (in, optional) Array of images from the imaging system to be
; loaded. XMYBLOB(y)=x, where y and x are ?
;
; Local Variables:
; XMDF Flag that programmer interface is in use.
; Therefore do not check for Security Keys on domains.
;
; Entry point ^XMD
; Needs: DUZ,XMSUB,XMTEXT
; Accepts: XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,
; and, if $D(DIFROM), XMDF
; Ignores: N/A
; Returns: XMZ(if no error),XMMG(if error)
; Kills: XMSUB,XMTEXT,XMY,XMSTRIP,XMMG(if no error),XMYBLOB
N XMV,XMINSTR,XMBLOBER,XMABORT
I '$D(DIFROM) N XMDF S XMDF=1
I '$G(DUZ) N DUZ D DUZ^XUP(.5)
I $G(XMDUZ)=""!($G(XMDUZ)=0) S XMDUZ=DUZ
I XMDUZ'?.N S %=XMDUZ N XMDUZ S XMDUZ=% K %
K XMERR,^TMP("XMERR",$J)
S XMABORT=0
I '$D(XMTEXT) S XMMG="Error = No message text" Q
I '$O(@(XMTEXT_"0)")) S XMMG="Error = No message text" Q
I '$D(XMSUB) S XMMG="Error = No message subject" Q
;I $L(XMSUB)<3!($L(XMSUB)>65) S XMMG="Error = Message subject too long or too short" Q
I $L(XMSUB)<3 S XMSUB=XMSUB_"..."
I $L(XMSUB)>65 S XMSUB=$E(XMSUB,1,65)
I $D(XMY)'<10 K XMMG
I XMDUZ'?.N D SETFROM(.XMDUZ,.XMINSTR) Q:$G(XMMG)["Error =" ; If XMDUZ=.5, becomes POSTMASTER
D INITAPI^XMVVITAE
D INITLATR^XMXADDR
I '$D(XMROU),'$D(DIFROM),'$D(XMYBLOB),$D(XMY) D Q
. D SEND(XMDUZ,XMSUB,XMTEXT,.XMSTRIP,.XMY,.XMINSTR,.XMMG,.XMZ)
. D QUIT
D CLEANUP^XMXADDR
S XMSUB=$$ENCODEUP^XMXUTIL1(XMSUB)
F D CRE8XMZ^XMXSEND(XMSUB,.XMZ) Q:XMZ>0 D
. K XMERR,^TMP("XMERR",$J)
. I $D(ZTQUEUED) H 1 Q
. W !,$C(7),$$EZBLD^DIALOG(34101),! ;Waiting for access to the Message File
. N I F I=1:1:10 H 1 W "."
I $D(XMYBLOB)>9 D Q:XMBLOBER
. ; Add BLOBS to message
. S XMBLOBER=$$MULTI^XMBBLOB(XMZ)
. K XMYBLOB
. Q:'XMBLOBER
. D KILLMSG^XMXUTIL(XMZ)
. K XMZ
D EN1A
Q
SEND(XMDUZ,XMSUBJ,XMBODY,XMSTRIP,XMTO,XMINSTR,XMMG,XMZ) ;
S XMBODY=$$CREF^DILF(XMBODY)
S:$D(XMSTRIP) XMINSTR("STRIP")=XMSTRIP
D CHKBSKT(.XMTO,.XMINSTR)
D SENDMSG^XMXPARM(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR)
I $D(XMERR) D ERR1 Q
S:$D(XMDF) XMINSTR("ADDR FLAGS")="R" ; Ignore addressee restrictions
D SENDMSG^XMXSEND(XMDUZ,XMSUBJ,XMBODY,.XMTO,.XMINSTR,.XMZ)
D:$D(XMERR) ERR1
Q
ERR1 ;
S XMMG="Error = "_^TMP("XMERR",$J,1,"TEXT",1)
K XMERR,^TMP("XMERR",$J)
Q
EN1 ; Enter text in the msg, ask for recipients if there aren't any,
; and send the msg.
; Needs: DUZ,XMZ,XMTEXT
; Accepts: XMDF,XMY,XMMG,XMSTRIP,XMROU,DIFROM
; Ignores: XMDUZ,XMSUB
; Returns: N/A
; Kills: XMTEXT,XMY,XMSTRIP,XMMG
N XMV,XMABORT,XMDUZ,XMFROM,XMINSTR,XMSUB ; (XMSUB is newed so it isn't killed in QUIT)
S XMABORT=0
S XMDUZ=DUZ
D INITAPI^XMVVITAE
D INITLATR^XMXADDR
K XMERR,^TMP("XMERR",$J)
I $D(XMY)'<10 K XMMG
S XMFROM=$P($G(^XMB(3.9,XMZ,0)),U,2)
I XMFROM'="",XMFROM'=XMDUZ S XMINSTR("FROM")=XMFROM
D EN1A
Q
EN1A ;
D EN2A
Q:$D(DIFROM)
D EN3A
D QUIT
Q
EN2A ;
N XMI,XMBODY
S XMI=0
I $D(XMROU)>9,'$O(^XMB(3.9,XMZ,2,0)) D NEW^XMP S XMI=1,^XMB(3.9,XMZ,2,0)="^^1^1"
S XMBODY=$$CREF^DILF(XMTEXT)
D MOVEBODY^XMXSEND(XMZ,XMBODY,"A")
D CHEKBODY^XMXSEND(XMZ,.XMSTRIP,XMI)
S XCNP=+$P($G(^XMB(3.9,XMZ,2,0)),U,3)
Q:$D(DIFROM)
Q:$D(XMROU)'>9
D XMROU^XMPH
K XMROU
D PSECURE^XMPSEC(XMZ,.XMABORT)
Q
EN3 ; called from XPDTP (KIDS)
; XMDUZ must be valid DUZ, if provided. It may not be a string.
N XMV,XMINSTR
I '$G(DUZ) N DUZ D DUZ^XUP(.5)
I '$D(XMDUZ) S XMDUZ=DUZ
D INITAPI^XMVVITAE
D INITLATR^XMXADDR
D EN3A
D QUIT
Q
EN3A ;
N XMABORT
S XMABORT=0
S:$D(XMDF) XMINSTR("ADDR FLAGS")="R" ; Ignore addressee restrictions
I $D(XMY)<10,'$$GOTADDR^XMXADDR,'$D(ZTQUEUED) D
. I $D(XMMG) S XMINSTR("TO PROMPT")=XMMG K XMMG
. D TOWHOM^XMJMT($G(XMDUZ,DUZ),$$EZBLD^DIALOG(34110),.XMINSTR,"",.XMABORT) ;Send
E D
. D CHKBSKT(.XMY,.XMINSTR)
. D CHKADDR^XMXADDR(XMDUZ,.XMY,.XMINSTR) K:$D(XMERR) XMERR,^TMP("XMERR",$J)
Q:XMABORT
I '$$GOTADDR^XMXADDR S:'$D(XMMG) XMMG="Error = No recipients." Q
D BLDNSND^XMXSEND(XMDUZ,XMZ,.XMINSTR)
Q
QUIT ;
K XMSUB,XMTEXT,XMY,XMSTRIP
D CLEANUP^XMXADDR
Q
ENT ; Entry for outside users
; All input variables ignored
I '$G(DUZ) W " User ID needed (DUZ) !!" Q
D EN^XM,SEND^XMJMS
Q
INIT ; From DIFROM
D XMZ^XMA2 Q:XMZ<1 S $P(^XMB(3.9,XMZ,0),U,7)="X" D NEW^XMP
Q
ENT1 ; Forward a msg, do not ask for recipients
; Needs: DUZ,XMZ,XMY
; Accepts: XMDUZ
; Ignores: XMSUB,XMTEXT,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB
; Returns: N/A
; Kills: XMDUZ,XMY
N XMDF
S XMDF=1
D ENT1A(0)
Q
ENT1A(XMASK) ;
N XMV,XMINSTR,XMABORT
K XMERR,^TMP("XMERR",$J)
I '$G(DUZ) N DUZ D DUZ^XUP(.5)
I $G(XMDUZ)=""!($G(XMDUZ)=0) S XMDUZ=DUZ
S XMABORT=0
D:XMDUZ'?.N SETFWD(.XMDUZ,.XMINSTR)
D INITAPI^XMVVITAE
D INIT^XMXADDR
S:$D(XMDF) XMINSTR("ADDR FLAGS")="R" ; Ignore addressee restrictions
I XMASK D TOWHOM^XMJMT(XMDUZ,$$EZBLD^DIALOG(34111),.XMINSTR,"",.XMABORT) Q:XMABORT ;Forward
D CHKBSKT(.XMY,.XMINSTR)
D CHKADDR^XMXADDR(XMDUZ,.XMY,.XMINSTR) K:$D(XMERR) XMERR,^TMP("XMERR",$J)
I $$GOTADDR^XMXADDR D
. D FWD^XMKP(XMDUZ,XMZ,.XMINSTR)
. D CHECK^XMKPL
E S:'$D(XMMG) XMMG="Error = No recipients."
K XMDUZ,XMY
D CLEANUP^XMXADDR
Q
ENT2 ; Forward a msg, ask for (more) recipients
; Needs: DUZ,XMZ
; Accepts: XMDUZ,XMY,XMDF
; Ignores: XMSUB,XMTEXT,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB
; Returns: N/A
; Kills: XMDUZ,XMY
D ENT1A($S($D(ZTQUEUED):0,1:1))
Q
ENX ;FROM MAILMAN
S %=XMDUZ N XMDUZ,XMK S XMDUZ=% D XMD K %
Q
ENL ; Add text to an existing message
; Needs: XMZ,XMTEXT
; Accepts: XMSTRIP
; Ignores: DUZ,XMDUZ,XMSUB,XMMG,XMY,XMROU,DIFROM,XMYBLOB
; Returns: N/A
; Kills: XMSTRIP
N XMI,XMBODY
K XMERR,^TMP("XMERR",$J)
S XMBODY=$$CREF^DILF(XMTEXT)
S XMI=+$P($G(^XMB(3.9,XMZ,2,0)),U,3)
D MOVEBODY^XMXSEND(XMZ,XMBODY,"A")
D CHEKBODY^XMXSEND(XMZ,.XMSTRIP,XMI)
K XMSTRIP
Q
CHKBSKT(XMTO,XMINSTR) ;
I $D(XMTO(XMDUZ,0)) S XMINSTR("SELF BSKT")=XMTO(XMDUZ,0)
I $D(XMTO(.6,0)) S XMINSTR("SHARE BSKT")=XMTO(.6,0)
I $D(XMTO(.6,"D")) S XMINSTR("SHARE DATE")=XMTO(.6,"D")
N XMADDR
S XMADDR=""
F S XMADDR=$O(XMTO(XMADDR)) Q:XMADDR="" I $D(XMTO(XMADDR,1)) D
. S XMTO(XMTO(XMADDR,1)_":"_XMADDR)=""
. K XMTO(XMADDR)
Q
SETFROM(XMDUZ,XMINSTR) ;
Q:XMDUZ=DUZ
N XMPOSTPR
I XMDUZ=.5 D Q:XMPOSTPR
. S XMPOSTPR=+$O(^XMB(3.7,"AB",DUZ,.5,0))
. Q:'XMPOSTPR
. I $P($G(^XMB(3.7,.5,9,XMPOSTPR,0)),U,3)'="y" S XMPOSTPR=0
I XMDUZ'="POSTMASTER",XMDUZ'=.5 D CHKUSER(.XMDUZ) Q:+XMDUZ=XMDUZ
S XMINSTR("FROM")=$$XMFROM^XMXPARM("XMDUZ",XMDUZ)
I $D(XMERR) D ERR1 Q
S XMDUZ=DUZ
Q
SETFWD(XMDUZ,XMINSTR) ;
Q:XMDUZ=DUZ
I XMDUZ=.5,$D(^XMB(3.7,"AB",DUZ,.5)) Q
I XMDUZ=.5,'$D(^XMB(3.7,"AB",DUZ,.5)) S XMDUZ="POSTMASTER"
E D CHKUSER(.XMDUZ) Q:+XMDUZ=XMDUZ
S XMINSTR("FWD BY")=$$XMFROM^XMXPARM("XMDUZ",XMDUZ)
I $D(XMERR) D ERR1 Q
S XMDUZ=DUZ
Q
CHKUSER(XMDUZ) ;
N XMERR
D CHKUSER^XMXPARM1(.XMDUZ)
I $D(XMERR) K ^TMP("XMERR",$J),DIERR,^TMP("DIERR",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMD 9739 printed Oct 16, 2024@18:12:11 Page 2
XMD ;ISC-SF/GMB-Send/Forward/Add text to a message APIs ;08/27/2003 11:01
+1 ;;8.0;MailMan;**21**;Jun 28, 2002
+2 ; Was (WASH ISC)/THM/CAP
+3 ;
+4 ; Entry points (DBIA 10070) are:
+5 ; ^XMD Send a message.
+6 ; If no recipients defined, prompt for them.
+7 ; EN1^XMD Put text in a message.
+8 ; If no recipients defined, prompt for them.
+9 ; Send the message.
+10 ; ENL^XMD Add text to an existing message.
+11 ; ENT^XMD Interactive 'send a message'. (Same as menu)
+12 ; ENT1^XMD Forward a message.
+13 ; ENT2^XMD Forward a message.
+14 ; Prompt for recipients, whether or not any are already
+15 ; defined.
+16 ;
+17 ; I/O Variables to the various APIs:
+18 ; XMDUZ (in, optional) Sender DUZ or string (default=DUZ)
+19 ; For new messages, XMDUZ may be a string, which will be
+20 ; put in the 'message from' field.
+21 ; For forwarded messages, XMDUZ may be a string, which
+22 ; will be put in the 'forwarded by' field.
+23 ; XMSUB (in) Message subject
+24 ; XMTEXT (in) @location of message. For example, the following are
+25 ; among the acceptable:
+26 ; XMTEXT="array("
+27 ; XMTEXT="array(""node"","
+28 ; XMTEXT="^TMP(""namespace"",$J,""array"","
+29 ; The array must be in the acceptable FM word processing
+30 ; format.
+31 ; XMSTRIP (in, optional) Characters that user wants stripped from text
+32 ; of message (default=none)
+33 ; XMY (in, optional) Array of recipients, XMY(x)="", where
+34 ; x is a valid local or internet address.
+35 ; XMY(x,0)=basket to deliver to, if x=sender's DUZ or .6
+36 ; (Basket may be its number or name. If name, and it
+37 ; doesn't exist, it will be created.)
+38 ; XMY(x,1)=recipient type, either "I" (info only) or
+39 ; "C" (carbon copy)
+40 ; XMY(x,"D")=delete date, if x=.6 ("SHARED,MAIL")
+41 ; A local address may be a user's name or DUZ, a G.group
+42 ; name or S.server name.
+43 ; If not supplied and the process is not queued,
+44 ; you will be prompted.
+45 ; XMMG (in, optional) If XMY is not supplied and the process is not
+46 ; queued, XMMG is used as the default for the first
+47 ; 'send to:' prompt. It is ignored otherwise.
+48 ; (out) Contains error message if error occurs.
+49 ; Undefined if no error.
+50 ; DIFROM (in, optional) ?
+51 ; XMROU (in, optional) Array of routines to be loaded in a PackMan
+52 ; message. XMROU(x)="", where x=routine name.
+53 ; XMYBLOB (in, optional) Array of images from the imaging system to be
+54 ; loaded. XMYBLOB(y)=x, where y and x are ?
+55 ;
+56 ; Local Variables:
+57 ; XMDF Flag that programmer interface is in use.
+58 ; Therefore do not check for Security Keys on domains.
+59 ;
+60 ; Entry point ^XMD
+61 ; Needs: DUZ,XMSUB,XMTEXT
+62 ; Accepts: XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,
+63 ; and, if $D(DIFROM), XMDF
+64 ; Ignores: N/A
+65 ; Returns: XMZ(if no error),XMMG(if error)
+66 ; Kills: XMSUB,XMTEXT,XMY,XMSTRIP,XMMG(if no error),XMYBLOB
+67 NEW XMV,XMINSTR,XMBLOBER,XMABORT
+68 IF '$DATA(DIFROM)
NEW XMDF
SET XMDF=1
+69 IF '$GET(DUZ)
NEW DUZ
DO DUZ^XUP(.5)
+70 IF $GET(XMDUZ)=""!($GET(XMDUZ)=0)
SET XMDUZ=DUZ
+71 IF XMDUZ'?.N
SET %=XMDUZ
NEW XMDUZ
SET XMDUZ=%
KILL %
+72 KILL XMERR,^TMP("XMERR",$JOB)
+73 SET XMABORT=0
+74 IF '$DATA(XMTEXT)
SET XMMG="Error = No message text"
QUIT
+75 IF '$ORDER(@(XMTEXT_"0)"))
SET XMMG="Error = No message text"
QUIT
+76 IF '$DATA(XMSUB)
SET XMMG="Error = No message subject"
QUIT
+77 ;I $L(XMSUB)<3!($L(XMSUB)>65) S XMMG="Error = Message subject too long or too short" Q
+78 IF $LENGTH(XMSUB)<3
SET XMSUB=XMSUB_"..."
+79 IF $LENGTH(XMSUB)>65
SET XMSUB=$EXTRACT(XMSUB,1,65)
+80 IF $DATA(XMY)'<10
KILL XMMG
+81 ; If XMDUZ=.5, becomes POSTMASTER
IF XMDUZ'?.N
DO SETFROM(.XMDUZ,.XMINSTR)
if $GET(XMMG)["Error ="
QUIT
+82 DO INITAPI^XMVVITAE
+83 DO INITLATR^XMXADDR
+84 IF '$DATA(XMROU)
IF '$DATA(DIFROM)
IF '$DATA(XMYBLOB)
IF $DATA(XMY)
Begin DoDot:1
+85 DO SEND(XMDUZ,XMSUB,XMTEXT,.XMSTRIP,.XMY,.XMINSTR,.XMMG,.XMZ)
+86 DO QUIT
End DoDot:1
QUIT
+87 DO CLEANUP^XMXADDR
+88 SET XMSUB=$$ENCODEUP^XMXUTIL1(XMSUB)
+89 FOR
DO CRE8XMZ^XMXSEND(XMSUB,.XMZ)
if XMZ>0
QUIT
Begin DoDot:1
+90 KILL XMERR,^TMP("XMERR",$JOB)
+91 IF $DATA(ZTQUEUED)
HANG 1
QUIT
+92 ;Waiting for access to the Message File
WRITE !,$CHAR(7),$$EZBLD^DIALOG(34101),!
+93 NEW I
FOR I=1:1:10
HANG 1
WRITE "."
End DoDot:1
+94 IF $DATA(XMYBLOB)>9
Begin DoDot:1
+95 ; Add BLOBS to message
+96 SET XMBLOBER=$$MULTI^XMBBLOB(XMZ)
+97 KILL XMYBLOB
+98 if 'XMBLOBER
QUIT
+99 DO KILLMSG^XMXUTIL(XMZ)
+100 KILL XMZ
End DoDot:1
if XMBLOBER
QUIT
+101 DO EN1A
+102 QUIT
SEND(XMDUZ,XMSUBJ,XMBODY,XMSTRIP,XMTO,XMINSTR,XMMG,XMZ) ;
+1 SET XMBODY=$$CREF^DILF(XMBODY)
+2 if $DATA(XMSTRIP)
SET XMINSTR("STRIP")=XMSTRIP
+3 DO CHKBSKT(.XMTO,.XMINSTR)
+4 DO SENDMSG^XMXPARM(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR)
+5 IF $DATA(XMERR)
DO ERR1
QUIT
+6 ; Ignore addressee restrictions
if $DATA(XMDF)
SET XMINSTR("ADDR FLAGS")="R"
+7 DO SENDMSG^XMXSEND(XMDUZ,XMSUBJ,XMBODY,.XMTO,.XMINSTR,.XMZ)
+8 if $DATA(XMERR)
DO ERR1
+9 QUIT
ERR1 ;
+1 SET XMMG="Error = "_^TMP("XMERR",$JOB,1,"TEXT",1)
+2 KILL XMERR,^TMP("XMERR",$JOB)
+3 QUIT
EN1 ; Enter text in the msg, ask for recipients if there aren't any,
+1 ; and send the msg.
+2 ; Needs: DUZ,XMZ,XMTEXT
+3 ; Accepts: XMDF,XMY,XMMG,XMSTRIP,XMROU,DIFROM
+4 ; Ignores: XMDUZ,XMSUB
+5 ; Returns: N/A
+6 ; Kills: XMTEXT,XMY,XMSTRIP,XMMG
+7 ; (XMSUB is newed so it isn't killed in QUIT)
NEW XMV,XMABORT,XMDUZ,XMFROM,XMINSTR,XMSUB
+8 SET XMABORT=0
+9 SET XMDUZ=DUZ
+10 DO INITAPI^XMVVITAE
+11 DO INITLATR^XMXADDR
+12 KILL XMERR,^TMP("XMERR",$JOB)
+13 IF $DATA(XMY)'<10
KILL XMMG
+14 SET XMFROM=$PIECE($GET(^XMB(3.9,XMZ,0)),U,2)
+15 IF XMFROM'=""
IF XMFROM'=XMDUZ
SET XMINSTR("FROM")=XMFROM
+16 DO EN1A
+17 QUIT
EN1A ;
+1 DO EN2A
+2 if $DATA(DIFROM)
QUIT
+3 DO EN3A
+4 DO QUIT
+5 QUIT
EN2A ;
+1 NEW XMI,XMBODY
+2 SET XMI=0
+3 IF $DATA(XMROU)>9
IF '$ORDER(^XMB(3.9,XMZ,2,0))
DO NEW^XMP
SET XMI=1
SET ^XMB(3.9,XMZ,2,0)="^^1^1"
+4 SET XMBODY=$$CREF^DILF(XMTEXT)
+5 DO MOVEBODY^XMXSEND(XMZ,XMBODY,"A")
+6 DO CHEKBODY^XMXSEND(XMZ,.XMSTRIP,XMI)
+7 SET XCNP=+$PIECE($GET(^XMB(3.9,XMZ,2,0)),U,3)
+8 if $DATA(DIFROM)
QUIT
+9 if $DATA(XMROU)'>9
QUIT
+10 DO XMROU^XMPH
+11 KILL XMROU
+12 DO PSECURE^XMPSEC(XMZ,.XMABORT)
+13 QUIT
EN3 ; called from XPDTP (KIDS)
+1 ; XMDUZ must be valid DUZ, if provided. It may not be a string.
+2 NEW XMV,XMINSTR
+3 IF '$GET(DUZ)
NEW DUZ
DO DUZ^XUP(.5)
+4 IF '$DATA(XMDUZ)
SET XMDUZ=DUZ
+5 DO INITAPI^XMVVITAE
+6 DO INITLATR^XMXADDR
+7 DO EN3A
+8 DO QUIT
+9 QUIT
EN3A ;
+1 NEW XMABORT
+2 SET XMABORT=0
+3 ; Ignore addressee restrictions
if $DATA(XMDF)
SET XMINSTR("ADDR FLAGS")="R"
+4 IF $DATA(XMY)<10
IF '$$GOTADDR^XMXADDR
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+5 IF $DATA(XMMG)
SET XMINSTR("TO PROMPT")=XMMG
KILL XMMG
+6 ;Send
DO TOWHOM^XMJMT($GET(XMDUZ,DUZ),$$EZBLD^DIALOG(34110),.XMINSTR,"",.XMABORT)
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 DO CHKBSKT(.XMY,.XMINSTR)
+9 DO CHKADDR^XMXADDR(XMDUZ,.XMY,.XMINSTR)
if $DATA(XMERR)
KILL XMERR,^TMP("XMERR",$JOB)
End DoDot:1
+10 if XMABORT
QUIT
+11 IF '$$GOTADDR^XMXADDR
if '$DATA(XMMG)
SET XMMG="Error = No recipients."
QUIT
+12 DO BLDNSND^XMXSEND(XMDUZ,XMZ,.XMINSTR)
+13 QUIT
QUIT ;
+1 KILL XMSUB,XMTEXT,XMY,XMSTRIP
+2 DO CLEANUP^XMXADDR
+3 QUIT
ENT ; Entry for outside users
+1 ; All input variables ignored
+2 IF '$GET(DUZ)
WRITE " User ID needed (DUZ) !!"
QUIT
+3 DO EN^XM
DO SEND^XMJMS
+4 QUIT
INIT ; From DIFROM
+1 DO XMZ^XMA2
if XMZ<1
QUIT
SET $PIECE(^XMB(3.9,XMZ,0),U,7)="X"
DO NEW^XMP
+2 QUIT
ENT1 ; Forward a msg, do not ask for recipients
+1 ; Needs: DUZ,XMZ,XMY
+2 ; Accepts: XMDUZ
+3 ; Ignores: XMSUB,XMTEXT,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB
+4 ; Returns: N/A
+5 ; Kills: XMDUZ,XMY
+6 NEW XMDF
+7 SET XMDF=1
+8 DO ENT1A(0)
+9 QUIT
ENT1A(XMASK) ;
+1 NEW XMV,XMINSTR,XMABORT
+2 KILL XMERR,^TMP("XMERR",$JOB)
+3 IF '$GET(DUZ)
NEW DUZ
DO DUZ^XUP(.5)
+4 IF $GET(XMDUZ)=""!($GET(XMDUZ)=0)
SET XMDUZ=DUZ
+5 SET XMABORT=0
+6 if XMDUZ'?.N
DO SETFWD(.XMDUZ,.XMINSTR)
+7 DO INITAPI^XMVVITAE
+8 DO INIT^XMXADDR
+9 ; Ignore addressee restrictions
if $DATA(XMDF)
SET XMINSTR("ADDR FLAGS")="R"
+10 ;Forward
IF XMASK
DO TOWHOM^XMJMT(XMDUZ,$$EZBLD^DIALOG(34111),.XMINSTR,"",.XMABORT)
if XMABORT
QUIT
+11 DO CHKBSKT(.XMY,.XMINSTR)
+12 DO CHKADDR^XMXADDR(XMDUZ,.XMY,.XMINSTR)
if $DATA(XMERR)
KILL XMERR,^TMP("XMERR",$JOB)
+13 IF $$GOTADDR^XMXADDR
Begin DoDot:1
+14 DO FWD^XMKP(XMDUZ,XMZ,.XMINSTR)
+15 DO CHECK^XMKPL
End DoDot:1
+16 IF '$TEST
if '$DATA(XMMG)
SET XMMG="Error = No recipients."
+17 KILL XMDUZ,XMY
+18 DO CLEANUP^XMXADDR
+19 QUIT
ENT2 ; Forward a msg, ask for (more) recipients
+1 ; Needs: DUZ,XMZ
+2 ; Accepts: XMDUZ,XMY,XMDF
+3 ; Ignores: XMSUB,XMTEXT,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB
+4 ; Returns: N/A
+5 ; Kills: XMDUZ,XMY
+6 DO ENT1A($SELECT($DATA(ZTQUEUED):0,1:1))
+7 QUIT
ENX ;FROM MAILMAN
+1 SET %=XMDUZ
NEW XMDUZ,XMK
SET XMDUZ=%
DO XMD
KILL %
+2 QUIT
ENL ; Add text to an existing message
+1 ; Needs: XMZ,XMTEXT
+2 ; Accepts: XMSTRIP
+3 ; Ignores: DUZ,XMDUZ,XMSUB,XMMG,XMY,XMROU,DIFROM,XMYBLOB
+4 ; Returns: N/A
+5 ; Kills: XMSTRIP
+6 NEW XMI,XMBODY
+7 KILL XMERR,^TMP("XMERR",$JOB)
+8 SET XMBODY=$$CREF^DILF(XMTEXT)
+9 SET XMI=+$PIECE($GET(^XMB(3.9,XMZ,2,0)),U,3)
+10 DO MOVEBODY^XMXSEND(XMZ,XMBODY,"A")
+11 DO CHEKBODY^XMXSEND(XMZ,.XMSTRIP,XMI)
+12 KILL XMSTRIP
+13 QUIT
CHKBSKT(XMTO,XMINSTR) ;
+1 IF $DATA(XMTO(XMDUZ,0))
SET XMINSTR("SELF BSKT")=XMTO(XMDUZ,0)
+2 IF $DATA(XMTO(.6,0))
SET XMINSTR("SHARE BSKT")=XMTO(.6,0)
+3 IF $DATA(XMTO(.6,"D"))
SET XMINSTR("SHARE DATE")=XMTO(.6,"D")
+4 NEW XMADDR
+5 SET XMADDR=""
+6 FOR
SET XMADDR=$ORDER(XMTO(XMADDR))
if XMADDR=""
QUIT
IF $DATA(XMTO(XMADDR,1))
Begin DoDot:1
+7 SET XMTO(XMTO(XMADDR,1)_":"_XMADDR)=""
+8 KILL XMTO(XMADDR)
End DoDot:1
+9 QUIT
SETFROM(XMDUZ,XMINSTR) ;
+1 if XMDUZ=DUZ
QUIT
+2 NEW XMPOSTPR
+3 IF XMDUZ=.5
Begin DoDot:1
+4 SET XMPOSTPR=+$ORDER(^XMB(3.7,"AB",DUZ,.5,0))
+5 if 'XMPOSTPR
QUIT
+6 IF $PIECE($GET(^XMB(3.7,.5,9,XMPOSTPR,0)),U,3)'="y"
SET XMPOSTPR=0
End DoDot:1
if XMPOSTPR
QUIT
+7 IF XMDUZ'="POSTMASTER"
IF XMDUZ'=.5
DO CHKUSER(.XMDUZ)
if +XMDUZ=XMDUZ
QUIT
+8 SET XMINSTR("FROM")=$$XMFROM^XMXPARM("XMDUZ",XMDUZ)
+9 IF $DATA(XMERR)
DO ERR1
QUIT
+10 SET XMDUZ=DUZ
+11 QUIT
SETFWD(XMDUZ,XMINSTR) ;
+1 if XMDUZ=DUZ
QUIT
+2 IF XMDUZ=.5
IF $DATA(^XMB(3.7,"AB",DUZ,.5))
QUIT
+3 IF XMDUZ=.5
IF '$DATA(^XMB(3.7,"AB",DUZ,.5))
SET XMDUZ="POSTMASTER"
+4 IF '$TEST
DO CHKUSER(.XMDUZ)
if +XMDUZ=XMDUZ
QUIT
+5 SET XMINSTR("FWD BY")=$$XMFROM^XMXPARM("XMDUZ",XMDUZ)
+6 IF $DATA(XMERR)
DO ERR1
QUIT
+7 SET XMDUZ=DUZ
+8 QUIT
CHKUSER(XMDUZ) ;
+1 NEW XMERR
+2 DO CHKUSER^XMXPARM1(.XMDUZ)
+3 IF $DATA(XMERR)
KILL ^TMP("XMERR",$JOB),DIERR,^TMP("DIERR",$JOB)
+4 QUIT
