XMXSEC1 ;ISC-SF/GMB-Message security and restrictions (cont.) ;05/17/2002 13:26
;;8.0;MailMan;;Jun 28, 2002
; All entry points covered by DBIA 2732.
GETRESTR(XMDUZ,XMZ,XMZREC,XMINSTR,XMRESTR) ;
; If a message is closed, it may not be forwarded to SHARED,MAIL, even by the sender
I $G(XMZREC)="" S XMZREC=$G(^XMB(3.9,XMZ,0))
I "^Y^y^"[(U_$P(XMZREC,U,9)_U) D
. S:$G(XMRESTR("FLAGS"))'["X" XMRESTR("FLAGS")=$G(XMRESTR("FLAGS"))_"X"
E I $G(XMRESTR("FLAGS"))["X" S XMRESTR("FLAGS")=$TR(XMRESTR("FLAGS"),"X")
; If a message is confidential, it may not be forwarded to SHARED,MAIL
I "^Y^y^"[(U_$P(XMZREC,U,11)_U) D
. S:$G(XMRESTR("FLAGS"))'["C" XMRESTR("FLAGS")=$G(XMRESTR("FLAGS"))_"C"
E I $G(XMRESTR("FLAGS"))["C" S XMRESTR("FLAGS")=$TR(XMRESTR("FLAGS"),"C")
Q:$G(XMINSTR("ADDR FLAGS"))["R"
; If a message is priority, it may not be forwarded to groups unless
; the site has chosen to allow it, or if
; the user is the originator or possesses the proper security key,
I $P(XMZREC,U,7)["P",'$P($G(^XMB(1,1,2)),U,1),'$$ORIGIN8R^XMXSEC(XMDUZ,XMZREC),'$D(^XUSEC("XM GROUP PRIORITY",XMDUZ)) S XMRESTR("NOFPG")=""
E K:$D(XMRESTR("NOFPG")) XMRESTR("NOFPG")
; If a message has responses, it may not be broadcast. Users w/auto-
; forward addresses would not see the responses.
I $O(^XMB(3.9,XMZ,3,0)) S XMRESTR("NOBCAST")=""
; If a message is more lines than the limit,
; then it may not be sent/forwarded to a remote site.
D CHKLINES(XMDUZ,XMZ,.XMRESTR)
Q
CHKLINES(XMDUZ,XMZ,XMRESTR) ; Replaces NO^XMA21A
N XMLIMIT
Q:$D(^XUSEC("XMMGR",XMDUZ))
S XMLIMIT=$P($G(^XMB(1,1,"NETWORK-LIMIT")),U)
I XMLIMIT,$P($G(^XMB(3.9,XMZ,2,0)),U,4)>XMLIMIT S XMRESTR("NONET")=XMLIMIT Q
K:$D(XMRESTR("NONET")) XMRESTR("NONET")
Q
CHKMSG(XMDUZ,XMK,XMKZ,XMZ,XMZREC) ; Is the message where the calling routine says it is,
; and is the user authorized to access it?
I $G(XMK) D Q
. S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,""))
. I 'XMZ D Q
. . N XMPARM
. . S XMPARM(1)=XMKZ,XMPARM(2)=XMK
. . D ERRSET^XMXUTIL(34351,.XMPARM) ; Message _XMKZ_ in basket _XMK_ does not exist.
. S XMZREC=$G(^XMB(3.9,XMZ,0))
. I XMZREC'="" D:XMDUZ'=DUZ Q
. . N X
. . S X=$$SURRACC^XMXSEC(XMDUZ,"",XMZ,XMZREC)
. N XMPARM
. S XMPARM(1)=XMZ,XMPARM(2)=XMKZ,XMPARM(3)=XMK
. D ERRSET^XMXUTIL(34352,.XMPARM) ; Message _XMZ_ (message _XMKZ_ in basket _XMK_) does not exist.
S XMZ=XMKZ
S XMZREC=$G(^XMB(3.9,XMZ,0))
I XMZREC="" D ERRSET^XMXUTIL(34354,XMZ) Q ; Message _XMZ_ does not exist.
Q:'$$ACCESS^XMXSEC(XMDUZ,XMZ,XMZREC)
S XMK=+$O(^XMB(3.7,"M",XMZ,XMDUZ,""))
Q:'XMK
S XMKZ=$P($G(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,2)
I 'XMKZ D ADDITM^XMUT4A(XMDUZ,XMK,XMZ,.XMKZ)
Q
PAKMAN(XMZ,XMZREC) ; Returns 1 if this is a packman msg; 0 if not.
; Unfortunately, there isn't always an "X" in piece 7 of the zero node,
; so we must go check out the first line of text.
N XMTYPE
I $G(XMZREC)="" S XMZREC=$G(^XMB(3.9,XMZ,0))
S XMTYPE=$P(XMZREC,U,7)
I "P"[XMTYPE D Q XMTYPE ; "P" means priority, and it exists along with
. ; message type in piece 7 in all MailMan versions thru 7.*
. N XMREC,XMI
. S XMTYPE=0
. S XMI=$O(^XMB(3.9,XMZ,2,.999999)) I 'XMI Q
. S XMREC=^XMB(3.9,XMZ,2,XMI,0)
. Q:$E(XMREC,1)'="$"
. I XMREC?1"$TXT Created by".E1" at ".E1" on ".E S XMTYPE=1 Q ; Unsecured PackMan
. I XMREC?1"$TXT PACKMAN BACKUP".E S XMTYPE=1 Q ; PackMan Backup
. I XMREC?1"$TXT ^Created by".E1" at ".E1" on ".E S XMTYPE=1 Q ; Secured PackMan
Q:XMTYPE="K"!(XMTYPE="X") 1 ; PackMan message (KIDS or regular)
Q 0
OPTGRP(XMDUZ,XMK,XMOPT,XMOX,XMQDNUM) ; What may the user do at the basket/message group level?
I XMK D
. I XMDUZ=.5,XMK>999 D OPTPOST(.XMOPT,.XMOX) Q
. D OPTUSER1(XMDUZ,.XMOPT,.XMOX)
. D OPTUSER2(XMK,.XMOPT,.XMOX)
E D
. I XMK="!" D OPTSS(XMDUZ,.XMOPT,.XMOX) Q
. D OPTUSER1(XMDUZ,.XMOPT,.XMOX)
Q
SET(XMCD,XMDN,XMOPT,XMOX) ;
N XMDREC
S XMDREC=$$EZBLD^DIALOG(XMDN)
S XMOPT(XMCD)=$P(XMDREC,":",2,99)
S XMOX("O",XMCD)=$P(XMDREC,":",1) ; "O"=original english to foreign
S XMOX("X",$P(XMDREC,":",1))=XMCD ; "X"=translate foreign to english
Q
Q(XMCD,XMDN) ;
I $G(XMQDNUM) S XMOPT(XMCD,"?")=XMDN Q
S XMOPT(XMCD,"?")=$$EZBLD^DIALOG(XMDN)
Q
OPTUSER1(XMDUZ,XMOPT,XMOX) ;
D SET("D",37202,.XMOPT,.XMOX) ; Delete messages
D SET("F",37203,.XMOPT,.XMOX) ; Forward messages
D SET("FI",37204,.XMOPT,.XMOX) ; Filter messages
D SET("H",37205,.XMOPT,.XMOX) ; Headerless Print messages
D SET("L",37206,.XMOPT,.XMOX) ; Later messages
D SET("NT",37208,.XMOPT,.XMOX) ; New Toggle messages
D SET("P",37209,.XMOPT,.XMOX) ; Print messages
D SET("S",37213,.XMOPT,.XMOX) ; Save messages to another basket
D SET("T",37214,.XMOPT,.XMOX) ; Terminate messages
I '$D(^XMB(3.7,XMDUZ,15,"AF")) D
. I XMDUZ=DUZ D Q("FI",37204.1) Q ; You have no message filters defined.
. S XMOPT("FI","?")=$$EZBLD^DIALOG(37204.2,XMV("NAME")) ; |1| has no message filters defined.
D SET("V",37216,.XMOPT,.XMOX) ; Vaporize date set messages
Q:XMDUZ'=.6
D Q("L",37462) ; You may not do this in SHARED,MAIL.
S XMOPT("NT","?")=XMOPT("L","?")
Q:$$ZPOSTPRV^XMXSEC()
; You must hold the XMMGR key or be a POSTMASTER surrogate to do this in SHARED,MAIL.
I $G(XMQDNUM) D Q
. F I="D","F","FI","S","T","V" S XMOPT(I,"?")=37261
N DIR
D BLD^DIALOG(37261,"","","DIR(""?"")")
F I="D","F","FI","S","T","V" M XMOPT(I,"?")=DIR("?")
Q
OPTUSER2(XMK,XMOPT,XMOX) ;
D SET("C",37201,.XMOPT,.XMOX) ; Change the name of this basket
D SET("N",37207,.XMOPT,.XMOX) ; New message list
D SET("Q",37211,.XMOPT,.XMOX) ; Query (search for) messages in this basket
D SET("R",37212,.XMOPT,.XMOX) ; Resequence messages
I XMK'>1 D Q("C",37201.1) ; The name of this basket may not be changed.
;"The name of "_$S(XMK=1:"the IN",XMK=.5:"the WASTE",1:"this")_" basket may not be changed."
Q:XMDUZ'=.6!$$ZPOSTPRV^XMXSEC()
; You must hold the XMMGR key or be a POSTMASTER surrogate to do this in SHARED,MAIL.
I $G(XMQDNUM) S XMOPT("C","?")=37261 Q
N DIR
D BLD^DIALOG(37261,"","","DIR(""?"")")
M XMOPT("C","?")=DIR("?")
Q
OPTPOST(XMOPT,XMOX) ;
D SET("D",37202,.XMOPT,.XMOX) ; Delete messages
D SET("F",37203,.XMOPT,.XMOX) ; Forward messages (Added so that postmaster could reroute messages which for some reason were addressed to the wrong domain.)
D SET("Q",37211,.XMOPT,.XMOX) ; Query (search for) messages in this basket
D SET("R",37212,.XMOPT,.XMOX) ; Resequence messages
D SET("X",37219,.XMOPT,.XMOX) ; Xmit Priority toggle
Q
OPTSS(XMDUZ,XMOPT,XMOX) ; Super Search
D SET("H",37205,.XMOPT,.XMOX) ; Headerless Print messages
D SET("P",37209,.XMOPT,.XMOX) ; Print messages
Q
COPYAMT(XMZ,XMWHICH) ; Checks total number of lines to be copied and total number of responses to be copied.
; Function returns 1 if OK; 0 if not OK.
; XMWHICH string of which responses to copy (0=original msg).
; Default = original msg and all responses.
N XMLIMIT,XMRESPS,XMABORT
S XMABORT=0
S XMLIMIT=$$COPYLIMS
S XMRESPS=+$P($G(^XMB(3.9,XMZ,3,0)),U,4)
I XMRESPS=0 D TOOMANY(+$P($G(^XMB(3.9,XMZ,2,0)),U,4),$P(XMLIMIT,U,3),37470,.XMABORT) Q 'XMABORT
N I,J,XMRANGE,XMLINES
S:'$D(XMWHICH) XMWHICH="0-"_XMRESPS
S (XMRESPS,XMLINES)=0
F I=1:1:$L(XMWHICH,",")-1 D
. S XMRANGE=$P(XMWHICH,",",I)
. F J=$P(XMRANGE,"-",1):1:$S(XMRANGE["-":$P(XMRANGE,"-",2),1:XMRANGE) D
. . S XMRESPS=XMRESPS+1
. . I J=0 S XMLINES=XMLINES+$P($G(^XMB(3.9,XMZ,2,0)),U,4) Q
. . S XMLINES=XMLINES+$P($G(^XMB(3.9,+$G(^XMB(3.9,XMZ,3,J,0)),2,0)),U,4)
D TOOMANY(XMLINES,$P(XMLIMIT,U,3),37470,.XMABORT) Q:XMABORT 0
D TOOMANY(XMRESPS,$P(XMLIMIT,U,2),37471,.XMABORT) Q:XMABORT 0
Q 1
TOOMANY(HOWMANY,XMLIMIT,XMDIALOG,XMABORT) ;
Q:HOWMANY'>XMLIMIT
S XMABORT=1
D ERRSET^XMXUTIL(XMDIALOG,XMLIMIT) ; You may not copy more than the site limit of _XMLIMIT_ lines / responses.
Q
COPYLIMS() ; Function returns copy limits string.
; limits: # recipients^# responses^# lines
N I
S XMLIMIT=$G(^XMB(1,1,.11))
F I=1:1:3 I '$P(XMLIMIT,U,I) S $P(XMLIMIT,U,I)=$P("2999^99^3999",U,I)
Q XMLIMIT
COPYRECP(XMZ) ; Checks total number of recipients to see if it's OK to list them in the copy text and send the copy to them, too.
; Function returns 1 if OK; 0 if not OK.
N XMLIMIT
S XMLIMIT=$$COPYLIMS
Q:$P($G(^XMB(3.9,XMZ,1,0)),U,4)'>$P(XMLIMIT,U,1) 1
D ERRSET^XMXUTIL(37472,$P(XMLIMIT,U,1))
;Because this message has more than the site limit of _X_ recipients,
;we will neither list them in the text of the copy,
;nor will we deliver the copy to them.
Q 0
SSPRIV() ; Is the user authorized to conduct a super search?
Q:$$ZSSPRIV 1
D ERRSET^XMXUTIL(34413.5)
Q 0
ZSSPRIV() ; Is the user authorized to conduct a super search?
I DUZ'<1,$D(^XUSEC("XM SUPER SEARCH",DUZ)) Q 1
Q 0
ACCESS2(XMDUZ,XMZ,XMZREC) ; The user (XMDUZ) is not a recipient
N XMOK ; of the message, but did he send it?
I XMDUZ=$P(XMZREC,U,2)!(XMDUZ=$P(XMZREC,U,4)) D Q XMOK
. I XMDUZ='DUZ,'$$SURRACC^XMXSEC(XMDUZ,"",XMZ,XMZREC) S XMOK=0 Q
. ; The user sent the message, so add him to it.
. D ADDRECP^XMTDL(XMZ,$P(XMZREC,U,7)["P",XMDUZ)
. S XMOK=1
I XMDUZ'=DUZ D Q 0
. Q:'$$ACCESS^XMXSEC(DUZ,XMZ,XMZREC)
. D ERRSET^XMXUTIL(37103,XMV("NAME"),XMZ)
. ; You may not access this message as |1| unless you
. ; or someone else on the message forwards it to |1|.
D ERRSET^XMXUTIL(37102,"",XMZ)
; You are neither a sender nor a recipient of this message.
; If you need to see it, ask someone to forward it to you.
Q 0
XMXSEC1 ;ISC-SF/GMB-Message security and restrictions (cont.) ;05/17/2002 13:26
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; All entry points covered by DBIA 2732.
GETRESTR(XMDUZ,XMZ,XMZREC,XMINSTR,XMRESTR) ;
+1 ; If a message is closed, it may not be forwarded to SHARED,MAIL, even by the sender
+2 IF $GET(XMZREC)=""
SET XMZREC=$GET(^XMB(3.9,XMZ,0))
+3 IF "^Y^y^"[(U_$PIECE(XMZREC,U,9)_U)
Begin DoDot:1
+4 IF $GET(XMRESTR("FLAGS"))'["X"
SET XMRESTR("FLAGS")=$GET(XMRESTR("FLAGS"))_"X"
End DoDot:1
+5 IF '$TEST
IF $GET(XMRESTR("FLAGS"))["X"
SET XMRESTR("FLAGS")=$TRANSLATE(XMRESTR("FLAGS"),"X")
+6 ; If a message is confidential, it may not be forwarded to SHARED,MAIL
+7 IF "^Y^y^"[(U_$PIECE(XMZREC,U,11)_U)
Begin DoDot:1
+8 IF $GET(XMRESTR("FLAGS"))'["C"
SET XMRESTR("FLAGS")=$GET(XMRESTR("FLAGS"))_"C"
End DoDot:1
+9 IF '$TEST
IF $GET(XMRESTR("FLAGS"))["C"
SET XMRESTR("FLAGS")=$TRANSLATE(XMRESTR("FLAGS"),"C")
+10 IF $GET(XMINSTR("ADDR FLAGS"))["R"
QUIT
+11 ; If a message is priority, it may not be forwarded to groups unless
+12 ; the site has chosen to allow it, or if
+13 ; the user is the originator or possesses the proper security key,
+14 IF $PIECE(XMZREC,U,7)["P"
IF '$PIECE($GET(^XMB(1,1,2)),U,1)
IF '$$ORIGIN8R^XMXSEC(XMDUZ,XMZREC)
IF '$DATA(^XUSEC("XM GROUP PRIORITY",XMDUZ))
SET XMRESTR("NOFPG")=""
+15 IF '$TEST
IF $DATA(XMRESTR("NOFPG"))
KILL XMRESTR("NOFPG")
+16 ; If a message has responses, it may not be broadcast. Users w/auto-
+17 ; forward addresses would not see the responses.
+18 IF $ORDER(^XMB(3.9,XMZ,3,0))
SET XMRESTR("NOBCAST")=""
+19 ; If a message is more lines than the limit,
+20 ; then it may not be sent/forwarded to a remote site.
+21 DO CHKLINES(XMDUZ,XMZ,.XMRESTR)
+22 QUIT
CHKLINES(XMDUZ,XMZ,XMRESTR) ; Replaces NO^XMA21A
+1 NEW XMLIMIT
+2 IF $DATA(^XUSEC("XMMGR",XMDUZ))
QUIT
+3 SET XMLIMIT=$PIECE($GET(^XMB(1,1,"NETWORK-LIMIT")),U)
+4 IF XMLIMIT
IF $PIECE($GET(^XMB(3.9,XMZ,2,0)),U,4)>XMLIMIT
SET XMRESTR("NONET")=XMLIMIT
QUIT
+5 IF $DATA(XMRESTR("NONET"))
KILL XMRESTR("NONET")
+6 QUIT
CHKMSG(XMDUZ,XMK,XMKZ,XMZ,XMZREC) ; Is the message where the calling routine says it is,
+1 ; and is the user authorized to access it?
+2 IF $GET(XMK)
Begin DoDot:1
+3 SET XMZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,""))
+4 IF 'XMZ
Begin DoDot:2
+5 NEW XMPARM
+6 SET XMPARM(1)=XMKZ
SET XMPARM(2)=XMK
+7 ; Message _XMKZ_ in basket _XMK_ does not exist.
DO ERRSET^XMXUTIL(34351,.XMPARM)
End DoDot:2
QUIT
+8 SET XMZREC=$GET(^XMB(3.9,XMZ,0))
+9 IF XMZREC'=""
IF XMDUZ'=DUZ
Begin DoDot:2
+10 NEW X
+11 SET X=$$SURRACC^XMXSEC(XMDUZ,"",XMZ,XMZREC)
End DoDot:2
QUIT
+12 NEW XMPARM
+13 SET XMPARM(1)=XMZ
SET XMPARM(2)=XMKZ
SET XMPARM(3)=XMK
+14 ; Message _XMZ_ (message _XMKZ_ in basket _XMK_) does not exist.
DO ERRSET^XMXUTIL(34352,.XMPARM)
End DoDot:1
QUIT
+15 SET XMZ=XMKZ
+16 SET XMZREC=$GET(^XMB(3.9,XMZ,0))
+17 ; Message _XMZ_ does not exist.
IF XMZREC=""
DO ERRSET^XMXUTIL(34354,XMZ)
QUIT
+18 IF '$$ACCESS^XMXSEC(XMDUZ,XMZ,XMZREC)
QUIT
+19 SET XMK=+$ORDER(^XMB(3.7,"M",XMZ,XMDUZ,""))
+20 IF 'XMK
QUIT
+21 SET XMKZ=$PIECE($GET(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,2)
+22 IF 'XMKZ
DO ADDITM^XMUT4A(XMDUZ,XMK,XMZ,.XMKZ)
+23 QUIT
PAKMAN(XMZ,XMZREC) ; Returns 1 if this is a packman msg; 0 if not.
+1 ; Unfortunately, there isn't always an "X" in piece 7 of the zero node,
+2 ; so we must go check out the first line of text.
+3 NEW XMTYPE
+4 IF $GET(XMZREC)=""
SET XMZREC=$GET(^XMB(3.9,XMZ,0))
+5 SET XMTYPE=$PIECE(XMZREC,U,7)
+6 ; "P" means priority, and it exists along with
IF "P"[XMTYPE
Begin DoDot:1
+7 ; message type in piece 7 in all MailMan versions thru 7.*
+8 NEW XMREC,XMI
+9 SET XMTYPE=0
+10 SET XMI=$ORDER(^XMB(3.9,XMZ,2,.999999))
IF 'XMI
QUIT
+11 SET XMREC=^XMB(3.9,XMZ,2,XMI,0)
+12 IF $EXTRACT(XMREC,1)'="$"
QUIT
+13 ; Unsecured PackMan
IF XMREC?1"$TXT Created by".E1" at ".E1" on ".E
SET XMTYPE=1
QUIT
+14 ; PackMan Backup
IF XMREC?1"$TXT PACKMAN BACKUP".E
SET XMTYPE=1
QUIT
+15 ; Secured PackMan
IF XMREC?1"$TXT ^Created by".E1" at ".E1" on ".E
SET XMTYPE=1
QUIT
End DoDot:1
QUIT XMTYPE
+16 ; PackMan message (KIDS or regular)
IF XMTYPE="K"!(XMTYPE="X")
QUIT 1
+17 QUIT 0
OPTGRP(XMDUZ,XMK,XMOPT,XMOX,XMQDNUM) ; What may the user do at the basket/message group level?
+1 IF XMK
Begin DoDot:1
+2 IF XMDUZ=.5
IF XMK>999
DO OPTPOST(.XMOPT,.XMOX)
QUIT
+3 DO OPTUSER1(XMDUZ,.XMOPT,.XMOX)
+4 DO OPTUSER2(XMK,.XMOPT,.XMOX)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 IF XMK="!"
DO OPTSS(XMDUZ,.XMOPT,.XMOX)
QUIT
+7 DO OPTUSER1(XMDUZ,.XMOPT,.XMOX)
End DoDot:1
+8 QUIT
SET(XMCD,XMDN,XMOPT,XMOX) ;
+1 NEW XMDREC
+2 SET XMDREC=$$EZBLD^DIALOG(XMDN)
+3 SET XMOPT(XMCD)=$PIECE(XMDREC,":",2,99)
+4 ; "O"=original english to foreign
SET XMOX("O",XMCD)=$PIECE(XMDREC,":",1)
+5 ; "X"=translate foreign to english
SET XMOX("X",$PIECE(XMDREC,":",1))=XMCD
+6 QUIT
Q(XMCD,XMDN) ;
+1 IF $GET(XMQDNUM)
SET XMOPT(XMCD,"?")=XMDN
QUIT
+2 SET XMOPT(XMCD,"?")=$$EZBLD^DIALOG(XMDN)
+3 QUIT
OPTUSER1(XMDUZ,XMOPT,XMOX) ;
+1 ; Delete messages
DO SET("D",37202,.XMOPT,.XMOX)
+2 ; Forward messages
DO SET("F",37203,.XMOPT,.XMOX)
+3 ; Filter messages
DO SET("FI",37204,.XMOPT,.XMOX)
+4 ; Headerless Print messages
DO SET("H",37205,.XMOPT,.XMOX)
+5 ; Later messages
DO SET("L",37206,.XMOPT,.XMOX)
+6 ; New Toggle messages
DO SET("NT",37208,.XMOPT,.XMOX)
+7 ; Print messages
DO SET("P",37209,.XMOPT,.XMOX)
+8 ; Save messages to another basket
DO SET("S",37213,.XMOPT,.XMOX)
+9 ; Terminate messages
DO SET("T",37214,.XMOPT,.XMOX)
+10 IF '$DATA(^XMB(3.7,XMDUZ,15,"AF"))
Begin DoDot:1
+11 ; You have no message filters defined.
IF XMDUZ=DUZ
DO Q("FI",37204.1)
QUIT
+12 ; |1| has no message filters defined.
SET XMOPT("FI","?")=$$EZBLD^DIALOG(37204.2,XMV("NAME"))
End DoDot:1
+13 ; Vaporize date set messages
DO SET("V",37216,.XMOPT,.XMOX)
+14 IF XMDUZ'=.6
QUIT
+15 ; You may not do this in SHARED,MAIL.
DO Q("L",37462)
+16 SET XMOPT("NT","?")=XMOPT("L","?")
+17 IF $$ZPOSTPRV^XMXSEC()
QUIT
+18 ; You must hold the XMMGR key or be a POSTMASTER surrogate to do this in SHARED,MAIL.
+19 IF $GET(XMQDNUM)
Begin DoDot:1
+20 FOR I="D","F","FI","S","T","V"
SET XMOPT(I,"?")=37261
End DoDot:1
QUIT
+21 NEW DIR
+22 DO BLD^DIALOG(37261,"","","DIR(""?"")")
+23 FOR I="D","F","FI","S","T","V"
MERGE XMOPT(I,"?")=DIR("?")
+24 QUIT
OPTUSER2(XMK,XMOPT,XMOX) ;
+1 ; Change the name of this basket
DO SET("C",37201,.XMOPT,.XMOX)
+2 ; New message list
DO SET("N",37207,.XMOPT,.XMOX)
+3 ; Query (search for) messages in this basket
DO SET("Q",37211,.XMOPT,.XMOX)
+4 ; Resequence messages
DO SET("R",37212,.XMOPT,.XMOX)
+5 ; The name of this basket may not be changed.
IF XMK'>1
DO Q("C",37201.1)
+6 ;"The name of "_$S(XMK=1:"the IN",XMK=.5:"the WASTE",1:"this")_" basket may not be changed."
+7 IF XMDUZ'=.6!$$ZPOSTPRV^XMXSEC()
QUIT
+8 ; You must hold the XMMGR key or be a POSTMASTER surrogate to do this in SHARED,MAIL.
+9 IF $GET(XMQDNUM)
SET XMOPT("C","?")=37261
QUIT
+10 NEW DIR
+11 DO BLD^DIALOG(37261,"","","DIR(""?"")")
+12 MERGE XMOPT("C","?")=DIR("?")
+13 QUIT
OPTPOST(XMOPT,XMOX) ;
+1 ; Delete messages
DO SET("D",37202,.XMOPT,.XMOX)
+2 ; Forward messages (Added so that postmaster could reroute messages which for some reason were addressed to the wrong domain.)
DO SET("F",37203,.XMOPT,.XMOX)
+3 ; Query (search for) messages in this basket
DO SET("Q",37211,.XMOPT,.XMOX)
+4 ; Resequence messages
DO SET("R",37212,.XMOPT,.XMOX)
+5 ; Xmit Priority toggle
DO SET("X",37219,.XMOPT,.XMOX)
+6 QUIT
OPTSS(XMDUZ,XMOPT,XMOX) ; Super Search
+1 ; Headerless Print messages
DO SET("H",37205,.XMOPT,.XMOX)
+2 ; Print messages
DO SET("P",37209,.XMOPT,.XMOX)
+3 QUIT
COPYAMT(XMZ,XMWHICH) ; Checks total number of lines to be copied and total number of responses to be copied.
+1 ; Function returns 1 if OK; 0 if not OK.
+2 ; XMWHICH string of which responses to copy (0=original msg).
+3 ; Default = original msg and all responses.
+4 NEW XMLIMIT,XMRESPS,XMABORT
+5 SET XMABORT=0
+6 SET XMLIMIT=$$COPYLIMS
+7 SET XMRESPS=+$PIECE($GET(^XMB(3.9,XMZ,3,0)),U,4)
+8 IF XMRESPS=0
DO TOOMANY(+$PIECE($GET(^XMB(3.9,XMZ,2,0)),U,4),$PIECE(XMLIMIT,U,3),37470,.XMABORT)
QUIT 'XMABORT
+9 NEW I,J,XMRANGE,XMLINES
+10 IF '$DATA(XMWHICH)
SET XMWHICH="0-"_XMRESPS
+11 SET (XMRESPS,XMLINES)=0
+12 FOR I=1:1:$LENGTH(XMWHICH,",")-1
Begin DoDot:1
+13 SET XMRANGE=$PIECE(XMWHICH,",",I)
+14 FOR J=$PIECE(XMRANGE,"-",1):1:$SELECT(XMRANGE["-":$PIECE(XMRANGE,"-",2),1:XMRANGE)
Begin DoDot:2
+15 SET XMRESPS=XMRESPS+1
+16 IF J=0
SET XMLINES=XMLINES+$PIECE($GET(^XMB(3.9,XMZ,2,0)),U,4)
QUIT
+17 SET XMLINES=XMLINES+$PIECE($GET(^XMB(3.9,+$GET(^XMB(3.9,XMZ,3,J,0)),2,0)),U,4)
End DoDot:2
End DoDot:1
+18 DO TOOMANY(XMLINES,$PIECE(XMLIMIT,U,3),37470,.XMABORT)
IF XMABORT
QUIT 0
+19 DO TOOMANY(XMRESPS,$PIECE(XMLIMIT,U,2),37471,.XMABORT)
IF XMABORT
QUIT 0
+20 QUIT 1
TOOMANY(HOWMANY,XMLIMIT,XMDIALOG,XMABORT) ;
+1 IF HOWMANY'>XMLIMIT
QUIT
+2 SET XMABORT=1
+3 ; You may not copy more than the site limit of _XMLIMIT_ lines / responses.
DO ERRSET^XMXUTIL(XMDIALOG,XMLIMIT)
+4 QUIT
COPYLIMS() ; Function returns copy limits string.
+1 ; limits: # recipients^# responses^# lines
+2 NEW I
+3 SET XMLIMIT=$GET(^XMB(1,1,.11))
+4 FOR I=1:1:3
IF '$PIECE(XMLIMIT,U,I)
SET $PIECE(XMLIMIT,U,I)=$PIECE("2999^99^3999",U,I)
+5 QUIT XMLIMIT
COPYRECP(XMZ) ; Checks total number of recipients to see if it's OK to list them in the copy text and send the copy to them, too.
+1 ; Function returns 1 if OK; 0 if not OK.
+2 NEW XMLIMIT
+3 SET XMLIMIT=$$COPYLIMS
+4 IF $PIECE($GET(^XMB(3.9,XMZ,1,0)),U,4)'>$PIECE(XMLIMIT,U,1)
QUIT 1
+5 DO ERRSET^XMXUTIL(37472,$PIECE(XMLIMIT,U,1))
+6 ;Because this message has more than the site limit of _X_ recipients,
+7 ;we will neither list them in the text of the copy,
+8 ;nor will we deliver the copy to them.
+9 QUIT 0
SSPRIV() ; Is the user authorized to conduct a super search?
+1 IF $$ZSSPRIV
QUIT 1
+2 DO ERRSET^XMXUTIL(34413.5)
+3 QUIT 0
ZSSPRIV() ; Is the user authorized to conduct a super search?
+1 IF DUZ'<1
IF $DATA(^XUSEC("XM SUPER SEARCH",DUZ))
QUIT 1
+2 QUIT 0
ACCESS2(XMDUZ,XMZ,XMZREC) ; The user (XMDUZ) is not a recipient
+1 ; of the message, but did he send it?
NEW XMOK
+2 IF XMDUZ=$PIECE(XMZREC,U,2)!(XMDUZ=$PIECE(XMZREC,U,4))
Begin DoDot:1
+3 IF XMDUZ='DUZ
IF '$$SURRACC^XMXSEC(XMDUZ,"",XMZ,XMZREC)
SET XMOK=0
QUIT
+4 ; The user sent the message, so add him to it.
+5 DO ADDRECP^XMTDL(XMZ,$PIECE(XMZREC,U,7)["P",XMDUZ)
+6 SET XMOK=1
End DoDot:1
QUIT XMOK
+7 IF XMDUZ'=DUZ
Begin DoDot:1
+8 IF '$$ACCESS^XMXSEC(DUZ,XMZ,XMZREC)
QUIT
+9 DO ERRSET^XMXUTIL(37103,XMV("NAME"),XMZ)
+10 ; You may not access this message as |1| unless you
+11 ; or someone else on the message forwards it to |1|.
End DoDot:1
QUIT 0
+12 DO ERRSET^XMXUTIL(37102,"",XMZ)
+13 ; You are neither a sender nor a recipient of this message.
+14 ; If you need to see it, ask someone to forward it to you.
+15 QUIT 0
