XMXADDR3 ;ISC-SF/GMB-XMXADDR (cont.) ;04/15/2003 13:16
;;8.0;MailMan;**18**;Jun 28, 2002
SERVER(XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
N XMG
S XMADDR=$P(XMADDR,".",2,99)
I $G(XMIA) D
. N DIC,X
. S X=XMADDR
. S DIC="^DIC(19,"
. S DIC(0)="FEZ"_$S($D(XMGCIRCL):"O",1:"")
. D ^DIC
. I Y<0 D SETERR^XMXADDR4(1,"!",39060) Q ;Invalid server name
. S XMG=+Y
E D
. S XMG=$$FIND1^DIC(19,"","O",XMADDR) I 'XMG D SETERR^XMXADDR4(0,"",$S($D(DIERR):39061,1:39062)) ; Server ambiguous / Server not found.
Q:$D(XMERROR)
S XMFULL="S."_$P(^DIC(19,XMG,0),U,1)
D SETEXP^XMXADDR(XMFULL,XMG,XMSTRIKE,XMPREFIX,XMLATER)
Q
DEVICE(XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
N XMG
S XMADDR1=$$UP^XLFSTR($E(XMADDR,1))
S XMADDR=$P(XMADDR,".",2,99)
I $G(XMIA) D
. N DIC,X
. S X=XMADDR
. S DIC="^%ZIS(1," ; file 3.5
. S DIC(0)="EF"_$S($D(XMGCIRCL):"O",1:"")
. D ^DIC
. I Y<0 D SETERR^XMXADDR4(1,"!",39063) Q ;Invalid device name
. S XMG=+Y
. S XMADDR=$P(Y,U,2)
E D
. 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.
. S XMADDR=$P(^%ZIS(1,XMG,0),U,1)
Q:$D(XMERROR)
I XMADDR["P-MESSAGE" D Q ;You may not use P-MESSAGE in an address.
. D SETERR^XMXADDR4($G(XMIA),"!",39066)
S XMFULL=XMADDR1_"."_XMADDR
D SETEXP^XMXADDR(XMFULL,XMG,XMSTRIKE,XMPREFIX,XMLATER)
Q
REMOTE(XMDUZ,XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
; XMVIA IEN of domain in ^DIC(4.2 via which the msg will be sent
; XMVIAN Name of domain via which the msg will be sent
; XMDOMAIN Domain of the addressee
; XMNAME Name of the addressee
N XMVIA,XMVIAN,XMDOMAIN,XMNAME
S:XMADDR["<"!(XMADDR[" ") XMADDR=$$REMADDR(XMADDR)
S XMNAME=$P(XMADDR,"@",1)
I XMNAME="" D Q
. D SETERR^XMXADDR4($G(XMIA),"!",39010) ;Null addressee
S XMDOMAIN=$P(XMADDR,"@",2,99)
I XMDOMAIN="" D Q
. ; You must specify a reachable uunet host / Null domain
. D SETERR^XMXADDR4($G(XMIA),"!",$S(XMNAME["!":39067,1:39068))
; find out the full domain name, and
; whether the domain is valid, and if so, via which entry in DIC(4.2
D DNS^XMXADDRD(XMDUZ,.XMDOMAIN,.XMVIA,.XMVIAN) Q:$D(XMERROR)
I XMDOMAIN=^XMB("NETNAME") D ; the full domain name = the local domain
. N XMQUOTED
. I XMNAME?1""""1.E1"""" S XMNAME=$E(XMNAME,2,$L(XMNAME)-1),XMQUOTED=1
. I $E(XMNAME,1)=" "!($E(XMNAME,$L(XMNAME))=" ") S XMNAME=$$STRIP^XMXUTIL1(XMNAME)
. D LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
. Q:'$D(XMERROR)
. Q:$G(XMQUOTED)
. N XMSAVE
. S XMSAVE=XMNAME
. I ".G.g.D.d.H.h.S.s."[("."_$E(XMNAME,1,2)) S XMNAME=$E(XMNAME,1,2)_$TR($E(XMNAME,3,99),"._+",", .")
. E S XMNAME=$TR(XMNAME,"._+",", .")
. I XMSAVE'=XMNAME D Q:'$D(XMERROR)
. . K XMERROR
. . I $G(XMIA) D EN^DDIOL($$EZBLD^DIALOG(39069,XMNAME)) ;Checking: |1|
. . D LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
. Q:'$G(XMRESTR("NET RECEIVE"))
. Q:"^39062^39065^39132^"'[(U_XMERROR_U)
. ; Server, Device, or Group not found. Try lower case.
. ; (We do not need to try local user again.)
. S XMSAVE=XMNAME,XMNAME=$$LOW^XLFSTR(XMNAME) Q:XMSAVE=XMNAME
. K XMERROR
. D LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
E D
. I $D(XMRESTR("NONET")) D Q
. . ;Messages longer than |1| lines may not be sent across the network.
. . D SETERR^XMXADDR4($G(XMIA),"!",39001,XMRESTR("NONET"))
. I $D(XMFWDADD),+$G(^XMB(1,1,3)) D Q:$D(XMERROR)
. . ; This is an auto-forward address, and we are limiting it.
. . Q:$$FWDOK(3.1,XMDOMAIN) ; Approved auto-forward site?
. . I '$D(^XUSEC("XM AUTO-FORWARD WAIVER",+XMFWDADD)) D Q
. . . ;You can't have your mail forwarded to a non-VA site. Waivers can
. . . ;be requested through your site Information Security Officer (ISO)
. . . D SETERR^XMXADDR4($G(XMIA),"P",38130.1)
. . Q:$$FWDOK(3.2,XMDOMAIN) ; Waiver auto-forward site?
. . ;You have been granted a waiver to have your mail forwarded to a
. . ;non-VA site, but this site is not one of the sites for which a
. . ;waiver has been granted. Please contact your site Information
. . ;Security Officer (ISO) for further information.
. . D SETERR^XMXADDR4($G(XMIA),"P",38130.2)
. ; I XMDOMAIN?.E1".DOMAIN.EXT" D
. ;. ; Check the address before the @ to find any obvious errors
. ; Now transform spaces, commas, and periods in XMNAME
. S XMFULL=XMNAME_"@"_XMDOMAIN
. I XMSTRIKE D REMINUS(.XMFULL,XMNAME,XMDOMAIN) Q:$D(XMERROR)
. I XMLATER="?" D QLATER^XMXADDR(XMFULL,.XMLATER) Q:$D(XMERROR)
. D SETEXP^XMXADDR(XMFULL,XMVIA,XMSTRIKE,XMPREFIX,XMLATER)
Q
FWDOK(XMNODE,XMDOMAIN) ; Is the auto-forward domain OK?
N I,XMOK
S I="",XMOK=0
F S I=$O(^XMB(1,1,XMNODE,"B",I)) Q:I=""!(I=$E(XMDOMAIN,$L(XMDOMAIN)-$L(I)+1,99))
Q I'=""
REMINUS(XMFULL,XMNAME,XMDOMAIN) ;
Q:$D(^TMP("XMY",$J,XMFULL))
I $O(^TMP("XMY",$J,":"))="" Q:'$G(XMIA) D Q
. D SETERR^XMXADDR4($G(XMIA),"!",39015.1) ;Not a current recipient.
N XMTRY,XMTO
S XMTRY=$$LOW^XLFSTR(XMNAME)_"@"_XMDOMAIN
I $D(^TMP("XMY",$J,XMTRY)) S XMFULL=XMTRY Q
S XMTRY=$$UP^XLFSTR(XMNAME)_"@"_XMDOMAIN
I $D(^TMP("XMY",$J,XMTRY)) S XMFULL=XMTRY Q
S XMTO=":"
F S XMTO=$O(^TMP("XMY",$J,XMTO)) Q:XMTO="" Q:$$UP^XLFSTR(XMTO)=XMTRY
I XMTO="" Q:'$G(XMIA) D SETERR^XMXADDR4($G(XMIA),"!",39015.1) Q ;Not a current recipient.
S XMFULL=XMTO
Q
REMADDR(XMADDR) ;
I XMADDR["<" Q $TR($P($P(XMADDR,">",1),"<",2,99),"<") ; handles <addr> and <<addr>>
Q:XMADDR'[" " XMADDR
I $E(XMADDR,1)=" "!($E(XMADDR,$L(XMADDR))=" ") S XMADDR=$$STRIP^XMXUTIL1(XMADDR)
I XMADDR'["""",XMADDR'["(" Q XMADDR
I XMADDR["""@" D Q XMADDR
. ; "first last"@domain
. N I,J,XMDOM
. S I=$F(XMADDR,"""@")
. S XMDOM=$E(XMADDR,I,999)
. S XMDOM=$P(XMDOM," ",1)
. S J=$F(XMADDR,"""")
. S XMADDR=$E(XMADDR,J-1,I-J)_"@"_XMDOM
; last.first@domain (first last)
N I
F I=1:1:$L(XMADDR," ") Q:$P(XMADDR," ",I)["@"
S XMADDR=$P(XMADDR," ",1,I)
Q XMADDR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMXADDR3 5995 printed Dec 13, 2024@02:13:57 Page 2
XMXADDR3 ;ISC-SF/GMB-XMXADDR (cont.) ;04/15/2003 13:16
+1 ;;8.0;MailMan;**18**;Jun 28, 2002
SERVER(XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
+1 NEW XMG
+2 SET XMADDR=$PIECE(XMADDR,".",2,99)
+3 IF $GET(XMIA)
Begin DoDot:1
+4 NEW DIC,X
+5 SET X=XMADDR
+6 SET DIC="^DIC(19,"
+7 SET DIC(0)="FEZ"_$SELECT($DATA(XMGCIRCL):"O",1:"")
+8 DO ^DIC
+9 ;Invalid server name
IF Y<0
DO SETERR^XMXADDR4(1,"!",39060)
QUIT
+10 SET XMG=+Y
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 ; Server ambiguous / Server not found.
SET XMG=$$FIND1^DIC(19,"","O",XMADDR)
IF 'XMG
DO SETERR^XMXADDR4(0,"",$SELECT($DATA(DIERR):39061,1:39062))
End DoDot:1
+13 if $DATA(XMERROR)
QUIT
+14 SET XMFULL="S."_$PIECE(^DIC(19,XMG,0),U,1)
+15 DO SETEXP^XMXADDR(XMFULL,XMG,XMSTRIKE,XMPREFIX,XMLATER)
+16 QUIT
DEVICE(XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
+1 NEW XMG
+2 SET XMADDR1=$$UP^XLFSTR($EXTRACT(XMADDR,1))
+3 SET XMADDR=$PIECE(XMADDR,".",2,99)
+4 IF $GET(XMIA)
Begin DoDot:1
+5 NEW DIC,X
+6 SET X=XMADDR
+7 ; file 3.5
SET DIC="^%ZIS(1,"
+8 SET DIC(0)="EF"_$SELECT($DATA(XMGCIRCL):"O",1:"")
+9 DO ^DIC
+10 ;Invalid device name
IF Y<0
DO SETERR^XMXADDR4(1,"!",39063)
QUIT
+11 SET XMG=+Y
+12 SET XMADDR=$PIECE(Y,U,2)
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 ; Device ambiguous. / Device not found.
SET XMG=$$FIND1^DIC(3.5,"","O",XMADDR)
IF 'XMG
DO SETERR^XMXADDR4(0,"",$SELECT($DATA(DIERR):39064,1:39065))
QUIT
+15 SET XMADDR=$PIECE(^%ZIS(1,XMG,0),U,1)
End DoDot:1
+16 if $DATA(XMERROR)
QUIT
+17 ;You may not use P-MESSAGE in an address.
IF XMADDR["P-MESSAGE"
Begin DoDot:1
+18 DO SETERR^XMXADDR4($GET(XMIA),"!",39066)
End DoDot:1
QUIT
+19 SET XMFULL=XMADDR1_"."_XMADDR
+20 DO SETEXP^XMXADDR(XMFULL,XMG,XMSTRIKE,XMPREFIX,XMLATER)
+21 QUIT
REMOTE(XMDUZ,XMADDR,XMSTRIKE,XMPREFIX,XMLATER,XMFULL) ;
+1 ; XMVIA IEN of domain in ^DIC(4.2 via which the msg will be sent
+2 ; XMVIAN Name of domain via which the msg will be sent
+3 ; XMDOMAIN Domain of the addressee
+4 ; XMNAME Name of the addressee
+5 NEW XMVIA,XMVIAN,XMDOMAIN,XMNAME
+6 if XMADDR["<"!(XMADDR[" ")
SET XMADDR=$$REMADDR(XMADDR)
+7 SET XMNAME=$PIECE(XMADDR,"@",1)
+8 IF XMNAME=""
Begin DoDot:1
+9 ;Null addressee
DO SETERR^XMXADDR4($GET(XMIA),"!",39010)
End DoDot:1
QUIT
+10 SET XMDOMAIN=$PIECE(XMADDR,"@",2,99)
+11 IF XMDOMAIN=""
Begin DoDot:1
+12 ; You must specify a reachable uunet host / Null domain
+13 DO SETERR^XMXADDR4($GET(XMIA),"!",$SELECT(XMNAME["!":39067,1:39068))
End DoDot:1
QUIT
+14 ; find out the full domain name, and
+15 ; whether the domain is valid, and if so, via which entry in DIC(4.2
+16 DO DNS^XMXADDRD(XMDUZ,.XMDOMAIN,.XMVIA,.XMVIAN)
if $DATA(XMERROR)
QUIT
+17 ; the full domain name = the local domain
IF XMDOMAIN=^XMB("NETNAME")
Begin DoDot:1
+18 NEW XMQUOTED
+19 IF XMNAME?1""""1.E1""""
SET XMNAME=$EXTRACT(XMNAME,2,$LENGTH(XMNAME)-1)
SET XMQUOTED=1
+20 IF $EXTRACT(XMNAME,1)=" "!($EXTRACT(XMNAME,$LENGTH(XMNAME))=" ")
SET XMNAME=$$STRIP^XMXUTIL1(XMNAME)
+21 DO LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
+22 if '$DATA(XMERROR)
QUIT
+23 if $GET(XMQUOTED)
QUIT
+24 NEW XMSAVE
+25 SET XMSAVE=XMNAME
+26 IF ".G.g.D.d.H.h.S.s."[("."_$EXTRACT(XMNAME,1,2))
SET XMNAME=$EXTRACT(XMNAME,1,2)_$TRANSLATE($EXTRACT(XMNAME,3,99),"._+",", .")
+27 IF '$TEST
SET XMNAME=$TRANSLATE(XMNAME,"._+",", .")
+28 IF XMSAVE'=XMNAME
Begin DoDot:2
+29 KILL XMERROR
+30 ;Checking: |1|
IF $GET(XMIA)
DO EN^DDIOL($$EZBLD^DIALOG(39069,XMNAME))
+31 DO LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
End DoDot:2
if '$DATA(XMERROR)
QUIT
+32 if '$GET(XMRESTR("NET RECEIVE"))
QUIT
+33 if "^39062^39065^39132^"'[(U_XMERROR_U)
QUIT
+34 ; Server, Device, or Group not found. Try lower case.
+35 ; (We do not need to try local user again.)
+36 SET XMSAVE=XMNAME
SET XMNAME=$$LOW^XLFSTR(XMNAME)
if XMSAVE=XMNAME
QUIT
+37 KILL XMERROR
+38 DO LOCAL^XMXADDR(XMDUZ,XMNAME,XMSTRIKE,XMPREFIX,.XMLATER,.XMFULL)
End DoDot:1
+39 IF '$TEST
Begin DoDot:1
+40 IF $DATA(XMRESTR("NONET"))
Begin DoDot:2
+41 ;Messages longer than |1| lines may not be sent across the network.
+42 DO SETERR^XMXADDR4($GET(XMIA),"!",39001,XMRESTR("NONET"))
End DoDot:2
QUIT
+43 IF $DATA(XMFWDADD)
IF +$GET(^XMB(1,1,3))
Begin DoDot:2
+44 ; This is an auto-forward address, and we are limiting it.
+45 ; Approved auto-forward site?
if $$FWDOK(3.1,XMDOMAIN)
QUIT
+46 IF '$DATA(^XUSEC("XM AUTO-FORWARD WAIVER",+XMFWDADD))
Begin DoDot:3
+47 ;You can't have your mail forwarded to a non-VA site. Waivers can
+48 ;be requested through your site Information Security Officer (ISO)
+49 DO SETERR^XMXADDR4($GET(XMIA),"P",38130.1)
End DoDot:3
QUIT
+50 ; Waiver auto-forward site?
if $$FWDOK(3.2,XMDOMAIN)
QUIT
+51 ;You have been granted a waiver to have your mail forwarded to a
+52 ;non-VA site, but this site is not one of the sites for which a
+53 ;waiver has been granted. Please contact your site Information
+54 ;Security Officer (ISO) for further information.
+55 DO SETERR^XMXADDR4($GET(XMIA),"P",38130.2)
End DoDot:2
if $DATA(XMERROR)
QUIT
+56 ; I XMDOMAIN?.E1".DOMAIN.EXT" D
+57 ;. ; Check the address before the @ to find any obvious errors
+58 ; Now transform spaces, commas, and periods in XMNAME
+59 SET XMFULL=XMNAME_"@"_XMDOMAIN
+60 IF XMSTRIKE
DO REMINUS(.XMFULL,XMNAME,XMDOMAIN)
if $DATA(XMERROR)
QUIT
+61 IF XMLATER="?"
DO QLATER^XMXADDR(XMFULL,.XMLATER)
if $DATA(XMERROR)
QUIT
+62 DO SETEXP^XMXADDR(XMFULL,XMVIA,XMSTRIKE,XMPREFIX,XMLATER)
End DoDot:1
+63 QUIT
FWDOK(XMNODE,XMDOMAIN) ; Is the auto-forward domain OK?
+1 NEW I,XMOK
+2 SET I=""
SET XMOK=0
+3 FOR
SET I=$ORDER(^XMB(1,1,XMNODE,"B",I))
if I=""!(I=$EXTRACT(XMDOMAIN,$LENGTH(XMDOMAIN)-$LENGTH(I)+1,99))
QUIT
+4 QUIT I'=""
REMINUS(XMFULL,XMNAME,XMDOMAIN) ;
+1 if $DATA(^TMP("XMY",$JOB,XMFULL))
QUIT
+2 IF $ORDER(^TMP("XMY",$JOB,":"))=""
if '$GET(XMIA)
QUIT
Begin DoDot:1
+3 ;Not a current recipient.
DO SETERR^XMXADDR4($GET(XMIA),"!",39015.1)
End DoDot:1
QUIT
+4 NEW XMTRY,XMTO
+5 SET XMTRY=$$LOW^XLFSTR(XMNAME)_"@"_XMDOMAIN
+6 IF $DATA(^TMP("XMY",$JOB,XMTRY))
SET XMFULL=XMTRY
QUIT
+7 SET XMTRY=$$UP^XLFSTR(XMNAME)_"@"_XMDOMAIN
+8 IF $DATA(^TMP("XMY",$JOB,XMTRY))
SET XMFULL=XMTRY
QUIT
+9 SET XMTO=":"
+10 FOR
SET XMTO=$ORDER(^TMP("XMY",$JOB,XMTO))
if XMTO=""
QUIT
if $$UP^XLFSTR(XMTO)=XMTRY
QUIT
+11 ;Not a current recipient.
IF XMTO=""
if '$GET(XMIA)
QUIT
DO SETERR^XMXADDR4($GET(XMIA),"!",39015.1)
QUIT
+12 SET XMFULL=XMTO
+13 QUIT
REMADDR(XMADDR) ;
+1 ; handles <addr> and <<addr>>
IF XMADDR["<"
QUIT $TRANSLATE($PIECE($PIECE(XMADDR,">",1),"<",2,99),"<")
+2 if XMADDR'[" "
QUIT XMADDR
+3 IF $EXTRACT(XMADDR,1)=" "!($EXTRACT(XMADDR,$LENGTH(XMADDR))=" ")
SET XMADDR=$$STRIP^XMXUTIL1(XMADDR)
+4 IF XMADDR'[""""
IF XMADDR'["("
QUIT XMADDR
+5 IF XMADDR["""@"
Begin DoDot:1
+6 ; "first last"@domain
+7 NEW I,J,XMDOM
+8 SET I=$FIND(XMADDR,"""@")
+9 SET XMDOM=$EXTRACT(XMADDR,I,999)
+10 SET XMDOM=$PIECE(XMDOM," ",1)
+11 SET J=$FIND(XMADDR,"""")
+12 SET XMADDR=$EXTRACT(XMADDR,J-1,I-J)_"@"_XMDOM
End DoDot:1
QUIT XMADDR
+13 ; last.first@domain (first last)
+14 NEW I
+15 FOR I=1:1:$LENGTH(XMADDR," ")
if $PIECE(XMADDR," ",I)["@"
QUIT
+16 SET XMADDR=$PIECE(XMADDR," ",1,I)
+17 QUIT XMADDR
