source: FOIAVistA/trunk/r/MAILMAN-XM/XMXADDR3.m@ 1540

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1XMXADDR3 ;ISC-SF/GMB-XMXADDR (cont.) ;04/15/2003 13:16
2 ;;8.0;MailMan;**18**;Jun 28, 2002
3SERVER(XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
4 N XMG
5 S XMADDR=$P(XMADDR,".",2,99)
6 I $G(XMIA) D
7 . N DIC,X
8 . S X=XMADDR
9 . S DIC="^DIC(19,"
10 . S DIC(0)="FEZ"_$S($D(XMGCIRCL):"O",1:"")
11 . D ^DIC
12 . I Y<0 D SETERR^XMXADDR4(1,"!",39060) Q ;Invalid server name
13 . S XMG=+Y
14 E D
15 . S XMG=$$FIND1^DIC(19,"","O",XMADDR) I 'XMG D SETERR^XMXADDR4(0,"",$S($D(DIERR):39061,1:39062)) ; Server ambiguous / Server not found.
16 Q:$D(XMERROR)
17 S XMFULL="S."_$P(^DIC(19,XMG,0),U,1)
18 D SETEXP^XMXADDR(XMFULL,XMG,XMSTRIKE,XMPREFIX,XMLATER)
19 Q
20DEVICE(XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
21 N XMG
22 S XMADDR1=$$UP^XLFSTR($E(XMADDR,1))
23 S XMADDR=$P(XMADDR,".",2,99)
24 I $G(XMIA) D
25 . N DIC,X
26 . S X=XMADDR
27 . S DIC="^%ZIS(1," ; file 3.5
28 . S DIC(0)="EF"_$S($D(XMGCIRCL):"O",1:"")
29 . D ^DIC
30 . I Y<0 D SETERR^XMXADDR4(1,"!",39063) Q ;Invalid device name
31 . S XMG=+Y
32 . S XMADDR=$P(Y,U,2)
33 E D
34 . S XMG=$$FIND1^DIC(3.5,"","O",XMADDR) I 'XMG D SETERR^XMXADDR4(0,"",$S($D(DIERR):39064,1:39065)) Q ; Device ambiguous. / Device not found.
35 . S XMADDR=$P(^%ZIS(1,XMG,0),U,1)
36 Q:$D(XMERROR)
37 I XMADDR["P-MESSAGE" D Q ;You may not use P-MESSAGE in an address.
38 . D SETERR^XMXADDR4($G(XMIA),"!",39066)
39 S XMFULL=XMADDR1_"."_XMADDR
40 D SETEXP^XMXADDR(XMFULL,XMG,XMSTRIKE,XMPREFIX,XMLATER)
41 Q
42REMOTE(XMDUZ,XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
43 ; XMVIA IEN of domain in ^DIC(4.2 via which the msg will be sent
44 ; XMVIAN Name of domain via which the msg will be sent
45 ; XMDOMAIN Domain of the addressee
46 ; XMNAME Name of the addressee
47 N XMVIA,XMVIAN,XMDOMAIN,XMNAME
48 S:XMADDR["<"!(XMADDR[" ") XMADDR=$$REMADDR(XMADDR)
49 S XMNAME=$P(XMADDR,"@",1)
50 I XMNAME="" D Q
51 . D SETERR^XMXADDR4($G(XMIA),"!",39010) ;Null addressee
52 S XMDOMAIN=$P(XMADDR,"@",2,99)
53 I XMDOMAIN="" D Q
54 . ; You must specify a reachable uunet host / Null domain
55 . D SETERR^XMXADDR4($G(XMIA),"!",$S(XMNAME["!":39067,1:39068))
56 ; find out the full domain name, and
57 ; whether the domain is valid, and if so, via which entry in DIC(4.2
58 D DNS^XMXADDRD(XMDUZ,.XMDOMAIN,.XMVIA,.XMVIAN) Q:$D(XMERROR)
59 I XMDOMAIN=^XMB("NETNAME") D ; the full domain name = the local domain
60 . N XMQUOTED
61 . I XMNAME?1""""1.E1"""" S XMNAME=$E(XMNAME,2,$L(XMNAME)-1),XMQUOTED=1
62 . I $E(XMNAME,1)=" "!($E(XMNAME,$L(XMNAME))=" ") S XMNAME=$$STRIP^XMXUTIL1(XMNAME)
63 . D LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
64 . Q:'$D(XMERROR)
65 . Q:$G(XMQUOTED)
66 . N XMSAVE
67 . S XMSAVE=XMNAME
68 . I ".G.g.D.d.H.h.S.s."[("."_$E(XMNAME,1,2)) S XMNAME=$E(XMNAME,1,2)_$TR($E(XMNAME,3,99),"._+",", .")
69 . E S XMNAME=$TR(XMNAME,"._+",", .")
70 . I XMSAVE'=XMNAME D Q:'$D(XMERROR)
71 . . K XMERROR
72 . . I $G(XMIA) D EN^DDIOL($$EZBLD^DIALOG(39069,XMNAME)) ;Checking: |1|
73 . . D LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
74 . Q:'$G(XMRESTR("NET RECEIVE"))
75 . Q:"^39062^39065^39132^"'[(U_XMERROR_U)
76 . ; Server, Device, or Group not found. Try lower case.
77 . ; (We do not need to try local user again.)
78 . S XMSAVE=XMNAME,XMNAME=$$LOW^XLFSTR(XMNAME) Q:XMSAVE=XMNAME
79 . K XMERROR
80 . D LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
81 E D
82 . I $D(XMRESTR("NONET")) D Q
83 . . ;Messages longer than |1| lines may not be sent across the network.
84 . . D SETERR^XMXADDR4($G(XMIA),"!",39001,XMRESTR("NONET"))
85 . I $D(XMFWDADD),+$G(^XMB(1,1,3)) D Q:$D(XMERROR)
86 . . ; This is an auto-forward address, and we are limiting it.
87 . . Q:$$FWDOK(3.1,XMDOMAIN) ; Approved auto-forward site?
88 . . I '$D(^XUSEC("XM AUTO-FORWARD WAIVER",+XMFWDADD)) D Q
89 . . . ;You can't have your mail forwarded to a non-VA site. Waivers can
90 . . . ;be requested through your site Information Security Officer (ISO)
91 . . . D SETERR^XMXADDR4($G(XMIA),"P",38130.1)
92 . . Q:$$FWDOK(3.2,XMDOMAIN) ; Waiver auto-forward site?
93 . . ;You have been granted a waiver to have your mail forwarded to a
94 . . ;non-VA site, but this site is not one of the sites for which a
95 . . ;waiver has been granted. Please contact your site Information
96 . . ;Security Officer (ISO) for further information.
97 . . D SETERR^XMXADDR4($G(XMIA),"P",38130.2)
98 . ; I XMDOMAIN?.E1".VA.GOV" D
99 . ;. ; Check the address before the @ to find any obvious errors
100 . ; Now transform spaces, commas, and periods in XMNAME
101 . S XMFULL=XMNAME_"@"_XMDOMAIN
102 . I XMSTRIKE D REMINUS(.XMFULL,XMNAME,XMDOMAIN) Q:$D(XMERROR)
103 . I XMLATER="?" D QLATER^XMXADDR(XMFULL,.XMLATER) Q:$D(XMERROR)
104 . D SETEXP^XMXADDR(XMFULL,XMVIA,XMSTRIKE,XMPREFIX,XMLATER)
105 Q
106FWDOK(XMNODE,XMDOMAIN) ; Is the auto-forward domain OK?
107 N I,XMOK
108 S I="",XMOK=0
109 F S I=$O(^XMB(1,1,XMNODE,"B",I)) Q:I=""!(I=$E(XMDOMAIN,$L(XMDOMAIN)-$L(I)+1,99))
110 Q I'=""
111REMINUS(XMFULL,XMNAME,XMDOMAIN) ;
112 Q:$D(^TMP("XMY",$J,XMFULL))
113 I $O(^TMP("XMY",$J,":"))="" Q:'$G(XMIA) D Q
114 . D SETERR^XMXADDR4($G(XMIA),"!",39015.1) ;Not a current recipient.
115 N XMTRY,XMTO
116 S XMTRY=$$LOW^XLFSTR(XMNAME)_"@"_XMDOMAIN
117 I $D(^TMP("XMY",$J,XMTRY)) S XMFULL=XMTRY Q
118 S XMTRY=$$UP^XLFSTR(XMNAME)_"@"_XMDOMAIN
119 I $D(^TMP("XMY",$J,XMTRY)) S XMFULL=XMTRY Q
120 S XMTO=":"
121 F S XMTO=$O(^TMP("XMY",$J,XMTO)) Q:XMTO="" Q:$$UP^XLFSTR(XMTO)=XMTRY
122 I XMTO="" Q:'$G(XMIA) D SETERR^XMXADDR4($G(XMIA),"!",39015.1) Q ;Not a current recipient.
123 S XMFULL=XMTO
124 Q
125REMADDR(XMADDR) ;
126 I XMADDR["<" Q $TR($P($P(XMADDR,">",1),"<",2,99),"<") ; handles <addr> and <<addr>>
127 Q:XMADDR'[" " XMADDR
128 I $E(XMADDR,1)=" "!($E(XMADDR,$L(XMADDR))=" ") S XMADDR=$$STRIP^XMXUTIL1(XMADDR)
129 I XMADDR'["""",XMADDR'["(" Q XMADDR
130 I XMADDR["""@" D Q XMADDR
131 . ; "first last"@domain
132 . N I,J,XMDOM
133 . S I=$F(XMADDR,"""@")
134 . S XMDOM=$E(XMADDR,I,999)
135 . S XMDOM=$P(XMDOM," ",1)
136 . S J=$F(XMADDR,"""")
137 . S XMADDR=$E(XMADDR,J-1,I-J)_"@"_XMDOM
138 ; last.first@domain (first last)
139 N I
140 F I=1:1:$L(XMADDR," ") Q:$P(XMADDR," ",I)["@"
141 S XMADDR=$P(XMADDR," ",1,I)
142 Q XMADDR
Note: See TracBrowser for help on using the repository browser.