- XMXSEC1 ;ISC-SF/GMB - Message security and restrictions (cont.) ;05/17/2002 13:26
- ;;8.0;MailMan;**47**;Jun 28, 2002;Build 6
- ; 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
- ; **Patch XM*8*47 modifies the FOR loop to work when XMWHICH does not contain a ",". Added a conditional so that response(XMRESPS) lines are counted correctly.**
- F I=1:1:$L(XMWHICH,",") D
- . S XMRANGE=$P(XMWHICH,",",I)
- . F J=$P(XMRANGE,"-",1):1:$S(XMRANGE["-":$P(XMRANGE,"-",2),1:XMRANGE) D
- . . I J=0 S XMLINES=XMLINES+$P($G(^XMB(3.9,XMZ,2,0)),U,4)
- . . I J'=0 S XMRESPS=XMRESPS+1,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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMXSEC1 9731 printed Feb 18, 2025@23:40:34 Page 2
- XMXSEC1 ;ISC-SF/GMB - Message security and restrictions (cont.) ;05/17/2002 13:26
- +1 ;;8.0;MailMan;**47**;Jun 28, 2002;Build 6
- +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 ; **Patch XM*8*47 modifies the FOR loop to work when XMWHICH does not contain a ",". Added a conditional so that response(XMRESPS) lines are counted correctly.**
- +13 FOR I=1:1:$LENGTH(XMWHICH,",")
- Begin DoDot:1
- +14 SET XMRANGE=$PIECE(XMWHICH,",",I)
- +15 FOR J=$PIECE(XMRANGE,"-",1):1:$SELECT(XMRANGE["-":$PIECE(XMRANGE,"-",2),1:XMRANGE)
- Begin DoDot:2
- +16 IF J=0
- SET XMLINES=XMLINES+$PIECE($GET(^XMB(3.9,XMZ,2,0)),U,4)
- +17 IF J'=0
- SET XMRESPS=XMRESPS+1
- 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