- 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 Jan 18, 2025@03:14:59 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