source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMXSEC1.m@ 895

Last change on this file since 895 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 9.1 KB
Line 
1XMXSEC1 ;ISC-SF/GMB-Message security and restrictions (cont.) ;05/17/2002 13:26
2 ;;8.0;MailMan;;Jun 28, 2002
3 ; All entry points covered by DBIA 2732.
4GETRESTR(XMDUZ,XMZ,XMZREC,XMINSTR,XMRESTR) ;
5 ; If a message is closed, it may not be forwarded to SHARED,MAIL, even by the sender
6 I $G(XMZREC)="" S XMZREC=$G(^XMB(3.9,XMZ,0))
7 I "^Y^y^"[(U_$P(XMZREC,U,9)_U) D
8 . S:$G(XMRESTR("FLAGS"))'["X" XMRESTR("FLAGS")=$G(XMRESTR("FLAGS"))_"X"
9 E I $G(XMRESTR("FLAGS"))["X" S XMRESTR("FLAGS")=$TR(XMRESTR("FLAGS"),"X")
10 ; If a message is confidential, it may not be forwarded to SHARED,MAIL
11 I "^Y^y^"[(U_$P(XMZREC,U,11)_U) D
12 . S:$G(XMRESTR("FLAGS"))'["C" XMRESTR("FLAGS")=$G(XMRESTR("FLAGS"))_"C"
13 E I $G(XMRESTR("FLAGS"))["C" S XMRESTR("FLAGS")=$TR(XMRESTR("FLAGS"),"C")
14 Q:$G(XMINSTR("ADDR FLAGS"))["R"
15 ; If a message is priority, it may not be forwarded to groups unless
16 ; the site has chosen to allow it, or if
17 ; the user is the originator or possesses the proper security key,
18 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")=""
19 E K:$D(XMRESTR("NOFPG")) XMRESTR("NOFPG")
20 ; If a message has responses, it may not be broadcast. Users w/auto-
21 ; forward addresses would not see the responses.
22 I $O(^XMB(3.9,XMZ,3,0)) S XMRESTR("NOBCAST")=""
23 ; If a message is more lines than the limit,
24 ; then it may not be sent/forwarded to a remote site.
25 D CHKLINES(XMDUZ,XMZ,.XMRESTR)
26 Q
27CHKLINES(XMDUZ,XMZ,XMRESTR) ; Replaces NO^XMA21A
28 N XMLIMIT
29 Q:$D(^XUSEC("XMMGR",XMDUZ))
30 S XMLIMIT=$P($G(^XMB(1,1,"NETWORK-LIMIT")),U)
31 I XMLIMIT,$P($G(^XMB(3.9,XMZ,2,0)),U,4)>XMLIMIT S XMRESTR("NONET")=XMLIMIT Q
32 K:$D(XMRESTR("NONET")) XMRESTR("NONET")
33 Q
34CHKMSG(XMDUZ,XMK,XMKZ,XMZ,XMZREC) ; Is the message where the calling routine says it is,
35 ; and is the user authorized to access it?
36 I $G(XMK) D Q
37 . S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,""))
38 . I 'XMZ D Q
39 . . N XMPARM
40 . . S XMPARM(1)=XMKZ,XMPARM(2)=XMK
41 . . D ERRSET^XMXUTIL(34351,.XMPARM) ; Message _XMKZ_ in basket _XMK_ does not exist.
42 . S XMZREC=$G(^XMB(3.9,XMZ,0))
43 . I XMZREC'="" D:XMDUZ'=DUZ Q
44 . . N X
45 . . S X=$$SURRACC^XMXSEC(XMDUZ,"",XMZ,XMZREC)
46 . N XMPARM
47 . S XMPARM(1)=XMZ,XMPARM(2)=XMKZ,XMPARM(3)=XMK
48 . D ERRSET^XMXUTIL(34352,.XMPARM) ; Message _XMZ_ (message _XMKZ_ in basket _XMK_) does not exist.
49 S XMZ=XMKZ
50 S XMZREC=$G(^XMB(3.9,XMZ,0))
51 I XMZREC="" D ERRSET^XMXUTIL(34354,XMZ) Q ; Message _XMZ_ does not exist.
52 Q:'$$ACCESS^XMXSEC(XMDUZ,XMZ,XMZREC)
53 S XMK=+$O(^XMB(3.7,"M",XMZ,XMDUZ,""))
54 Q:'XMK
55 S XMKZ=$P($G(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)),U,2)
56 I 'XMKZ D ADDITM^XMUT4A(XMDUZ,XMK,XMZ,.XMKZ)
57 Q
58PAKMAN(XMZ,XMZREC) ; Returns 1 if this is a packman msg; 0 if not.
59 ; Unfortunately, there isn't always an "X" in piece 7 of the zero node,
60 ; so we must go check out the first line of text.
61 N XMTYPE
62 I $G(XMZREC)="" S XMZREC=$G(^XMB(3.9,XMZ,0))
63 S XMTYPE=$P(XMZREC,U,7)
64 I "P"[XMTYPE D Q XMTYPE ; "P" means priority, and it exists along with
65 . ; message type in piece 7 in all MailMan versions thru 7.*
66 . N XMREC,XMI
67 . S XMTYPE=0
68 . S XMI=$O(^XMB(3.9,XMZ,2,.999999)) I 'XMI Q
69 . S XMREC=^XMB(3.9,XMZ,2,XMI,0)
70 . Q:$E(XMREC,1)'="$"
71 . I XMREC?1"$TXT Created by".E1" at ".E1" on ".E S XMTYPE=1 Q ; Unsecured PackMan
72 . I XMREC?1"$TXT PACKMAN BACKUP".E S XMTYPE=1 Q ; PackMan Backup
73 . I XMREC?1"$TXT ^Created by".E1" at ".E1" on ".E S XMTYPE=1 Q ; Secured PackMan
74 Q:XMTYPE="K"!(XMTYPE="X") 1 ; PackMan message (KIDS or regular)
75 Q 0
76OPTGRP(XMDUZ,XMK,XMOPT,XMOX,XMQDNUM) ; What may the user do at the basket/message group level?
77 I XMK D
78 . I XMDUZ=.5,XMK>999 D OPTPOST(.XMOPT,.XMOX) Q
79 . D OPTUSER1(XMDUZ,.XMOPT,.XMOX)
80 . D OPTUSER2(XMK,.XMOPT,.XMOX)
81 E D
82 . I XMK="!" D OPTSS(XMDUZ,.XMOPT,.XMOX) Q
83 . D OPTUSER1(XMDUZ,.XMOPT,.XMOX)
84 Q
85SET(XMCD,XMDN,XMOPT,XMOX) ;
86 N XMDREC
87 S XMDREC=$$EZBLD^DIALOG(XMDN)
88 S XMOPT(XMCD)=$P(XMDREC,":",2,99)
89 S XMOX("O",XMCD)=$P(XMDREC,":",1) ; "O"=original english to foreign
90 S XMOX("X",$P(XMDREC,":",1))=XMCD ; "X"=translate foreign to english
91 Q
92Q(XMCD,XMDN) ;
93 I $G(XMQDNUM) S XMOPT(XMCD,"?")=XMDN Q
94 S XMOPT(XMCD,"?")=$$EZBLD^DIALOG(XMDN)
95 Q
96OPTUSER1(XMDUZ,XMOPT,XMOX) ;
97 D SET("D",37202,.XMOPT,.XMOX) ; Delete messages
98 D SET("F",37203,.XMOPT,.XMOX) ; Forward messages
99 D SET("FI",37204,.XMOPT,.XMOX) ; Filter messages
100 D SET("H",37205,.XMOPT,.XMOX) ; Headerless Print messages
101 D SET("L",37206,.XMOPT,.XMOX) ; Later messages
102 D SET("NT",37208,.XMOPT,.XMOX) ; New Toggle messages
103 D SET("P",37209,.XMOPT,.XMOX) ; Print messages
104 D SET("S",37213,.XMOPT,.XMOX) ; Save messages to another basket
105 D SET("T",37214,.XMOPT,.XMOX) ; Terminate messages
106 I '$D(^XMB(3.7,XMDUZ,15,"AF")) D
107 . I XMDUZ=DUZ D Q("FI",37204.1) Q ; You have no message filters defined.
108 . S XMOPT("FI","?")=$$EZBLD^DIALOG(37204.2,XMV("NAME")) ; |1| has no message filters defined.
109 D SET("V",37216,.XMOPT,.XMOX) ; Vaporize date set messages
110 Q:XMDUZ'=.6
111 D Q("L",37462) ; You may not do this in SHARED,MAIL.
112 S XMOPT("NT","?")=XMOPT("L","?")
113 Q:$$ZPOSTPRV^XMXSEC()
114 ; You must hold the XMMGR key or be a POSTMASTER surrogate to do this in SHARED,MAIL.
115 I $G(XMQDNUM) D Q
116 . F I="D","F","FI","S","T","V" S XMOPT(I,"?")=37261
117 N DIR
118 D BLD^DIALOG(37261,"","","DIR(""?"")")
119 F I="D","F","FI","S","T","V" M XMOPT(I,"?")=DIR("?")
120 Q
121OPTUSER2(XMK,XMOPT,XMOX) ;
122 D SET("C",37201,.XMOPT,.XMOX) ; Change the name of this basket
123 D SET("N",37207,.XMOPT,.XMOX) ; New message list
124 D SET("Q",37211,.XMOPT,.XMOX) ; Query (search for) messages in this basket
125 D SET("R",37212,.XMOPT,.XMOX) ; Resequence messages
126 I XMK'>1 D Q("C",37201.1) ; The name of this basket may not be changed.
127 ;"The name of "_$S(XMK=1:"the IN",XMK=.5:"the WASTE",1:"this")_" basket may not be changed."
128 Q:XMDUZ'=.6!$$ZPOSTPRV^XMXSEC()
129 ; You must hold the XMMGR key or be a POSTMASTER surrogate to do this in SHARED,MAIL.
130 I $G(XMQDNUM) S XMOPT("C","?")=37261 Q
131 N DIR
132 D BLD^DIALOG(37261,"","","DIR(""?"")")
133 M XMOPT("C","?")=DIR("?")
134 Q
135OPTPOST(XMOPT,XMOX) ;
136 D SET("D",37202,.XMOPT,.XMOX) ; Delete messages
137 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.)
138 D SET("Q",37211,.XMOPT,.XMOX) ; Query (search for) messages in this basket
139 D SET("R",37212,.XMOPT,.XMOX) ; Resequence messages
140 D SET("X",37219,.XMOPT,.XMOX) ; Xmit Priority toggle
141 Q
142OPTSS(XMDUZ,XMOPT,XMOX) ; Super Search
143 D SET("H",37205,.XMOPT,.XMOX) ; Headerless Print messages
144 D SET("P",37209,.XMOPT,.XMOX) ; Print messages
145 Q
146COPYAMT(XMZ,XMWHICH) ; Checks total number of lines to be copied and total number of responses to be copied.
147 ; Function returns 1 if OK; 0 if not OK.
148 ; XMWHICH string of which responses to copy (0=original msg).
149 ; Default = original msg and all responses.
150 N XMLIMIT,XMRESPS,XMABORT
151 S XMABORT=0
152 S XMLIMIT=$$COPYLIMS
153 S XMRESPS=+$P($G(^XMB(3.9,XMZ,3,0)),U,4)
154 I XMRESPS=0 D TOOMANY(+$P($G(^XMB(3.9,XMZ,2,0)),U,4),$P(XMLIMIT,U,3),37470,.XMABORT) Q 'XMABORT
155 N I,J,XMRANGE,XMLINES
156 S:'$D(XMWHICH) XMWHICH="0-"_XMRESPS
157 S (XMRESPS,XMLINES)=0
158 F I=1:1:$L(XMWHICH,",")-1 D
159 . S XMRANGE=$P(XMWHICH,",",I)
160 . F J=$P(XMRANGE,"-",1):1:$S(XMRANGE["-":$P(XMRANGE,"-",2),1:XMRANGE) D
161 . . S XMRESPS=XMRESPS+1
162 . . I J=0 S XMLINES=XMLINES+$P($G(^XMB(3.9,XMZ,2,0)),U,4) Q
163 . . S XMLINES=XMLINES+$P($G(^XMB(3.9,+$G(^XMB(3.9,XMZ,3,J,0)),2,0)),U,4)
164 D TOOMANY(XMLINES,$P(XMLIMIT,U,3),37470,.XMABORT) Q:XMABORT 0
165 D TOOMANY(XMRESPS,$P(XMLIMIT,U,2),37471,.XMABORT) Q:XMABORT 0
166 Q 1
167TOOMANY(HOWMANY,XMLIMIT,XMDIALOG,XMABORT) ;
168 Q:HOWMANY'>XMLIMIT
169 S XMABORT=1
170 D ERRSET^XMXUTIL(XMDIALOG,XMLIMIT) ; You may not copy more than the site limit of _XMLIMIT_ lines / responses.
171 Q
172COPYLIMS() ; Function returns copy limits string.
173 ; limits: # recipients^# responses^# lines
174 N I
175 S XMLIMIT=$G(^XMB(1,1,.11))
176 F I=1:1:3 I '$P(XMLIMIT,U,I) S $P(XMLIMIT,U,I)=$P("2999^99^3999",U,I)
177 Q XMLIMIT
178COPYRECP(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.
179 ; Function returns 1 if OK; 0 if not OK.
180 N XMLIMIT
181 S XMLIMIT=$$COPYLIMS
182 Q:$P($G(^XMB(3.9,XMZ,1,0)),U,4)'>$P(XMLIMIT,U,1) 1
183 D ERRSET^XMXUTIL(37472,$P(XMLIMIT,U,1))
184 ;Because this message has more than the site limit of _X_ recipients,
185 ;we will neither list them in the text of the copy,
186 ;nor will we deliver the copy to them.
187 Q 0
188SSPRIV() ; Is the user authorized to conduct a super search?
189 Q:$$ZSSPRIV 1
190 D ERRSET^XMXUTIL(34413.5)
191 Q 0
192ZSSPRIV() ; Is the user authorized to conduct a super search?
193 I DUZ'<1,$D(^XUSEC("XM SUPER SEARCH",DUZ)) Q 1
194 Q 0
195ACCESS2(XMDUZ,XMZ,XMZREC) ; The user (XMDUZ) is not a recipient
196 N XMOK ; of the message, but did he send it?
197 I XMDUZ=$P(XMZREC,U,2)!(XMDUZ=$P(XMZREC,U,4)) D Q XMOK
198 . I XMDUZ='DUZ,'$$SURRACC^XMXSEC(XMDUZ,"",XMZ,XMZREC) S XMOK=0 Q
199 . ; The user sent the message, so add him to it.
200 . D ADDRECP^XMTDL(XMZ,$P(XMZREC,U,7)["P",XMDUZ)
201 . S XMOK=1
202 I XMDUZ'=DUZ D Q 0
203 . Q:'$$ACCESS^XMXSEC(DUZ,XMZ,XMZREC)
204 . D ERRSET^XMXUTIL(37103,XMV("NAME"),XMZ)
205 . ; You may not access this message as |1| unless you
206 . ; or someone else on the message forwards it to |1|.
207 D ERRSET^XMXUTIL(37102,"",XMZ)
208 ; You are neither a sender nor a recipient of this message.
209 ; If you need to see it, ask someone to forward it to you.
210 Q 0
Note: See TracBrowser for help on using the repository browser.