XMXADDRD ;ISC-SF/GMB-Lookup Domain Name ;04/24/2002 10:36
;;8.0;MailMan;;Jun 28, 2002
; Replaces PSP^XMA210,^XMA21A,^XMA21B (ISC-WASH/CAP)
DNS(XMDUZ,XMDOMAIN,XMVIA,XMVIAN) ;
; XMDOMAIN - (in/out) Domain name. May be mixed case. Must already be
; in xxx.xxx.xxx format.
; XMVIA - (out) IEN of (relay) domain (in ^DIC(4.2))
; XMVIAN - (out) Name of (relay) domain
N XMVIAREC,XMNETNAM
S XMNETNAM=^XMB("NETNAME")
S XMDOMAIN=$$UP^XLFSTR(XMDOMAIN)
I XMDOMAIN=XMNETNAM D Q
. S XMVIA=^XMB("NUM")
. S XMVIAN=XMNETNAM
D FINDDOMN
Q:$D(XMERROR)
I XMVIAN="DOMAIN.EXT",$$FORUM D Q
. D SETERR^XMXADDR4($G(XMIA),"!",39100,XMDOMAIN) ;Domain not found: |1|
I $G(XMIA) D
. W:XMDOMAIN'=XMVIAN $$EZBLD^DIALOG(39101,XMVIAN) ;via |1|
. I XMVIAN'=XMNETNAM,$P(XMVIAREC,U,2)'["S" W $$EZBLD^DIALOG(39102) ; queued
Q
FORUM() ; Is this FORUM or GATEWAY?
Q $S($G(XMNETNAM,^XMB("NETNAME"))'["FORUM.":0,1:1)
FINDDOMN ; Look up domain
N XMSUBDOM,XMFLAGS,DIC,X,Y,XMDCIRCL
S XMSUBDOM="",X=XMDOMAIN
;S XMFLAGS="ZMF"_$S('$G(XMIA):"O",$G(XMINSTR("EXACT")):"OE",$D(XMGCIRCL):"OE",1:"E")
S XMFLAGS="ZMF"_$S($G(XMINSTR("EXACT")):"X",'$G(XMIA):"O",$D(XMGCIRCL):"O",1:"")_$S($G(XMIA):"E",1:"")
S DIC="^DIC(4.2,",DIC(0)=XMFLAGS
F S D="B^C" D MIX^DIC1 Q:Y>0!(X'[".")!$D(DUOUT)!$D(DTOUT) D Q:X=XMNETNAM
. S XMSUBDOM=XMSUBDOM_$P(X,".")_"."
. S X=$P(X,".",2,999)
I Y'>0,X'[".",'$G(XMIA),$L(X)<4 S DIC(0)="ZFX",D="C" D IX^DIC ; Look for COM,MIL,NET,etc. as synonym for one of the domains.
I Y>0 D Q ; Domain successfully found
. I XMSUBDOM'="" D Q:$D(XMERROR)
. . D CHKDOM($E(XMSUBDOM,1,$L(XMSUBDOM)-1)) Q:$D(XMERROR)
. . Q:Y(0,0)'=XMNETNAM
. . D SETERR^XMXADDR4($G(XMIA),"!",39103,$E(XMSUBDOM,1,$L(XMSUBDOM)-1),X) ; Sub-domain '|1|' not found for domain '|2|'
. I XMSUBDOM="",X'[".",$L(X)<4,$$FIND1^DIC(4.2996,"","QX",X) D NEEDSUB(X) Q
. S XMDOMAIN=$S(XMSUBDOM="":Y(0,0),1:XMSUBDOM_X) ; MailMan's klugey way
. ;S XMDOMAIN=XMSUBDOM_X ; Proper way? Nope.
. S XMVIA=+Y
. S XMVIAREC=Y(0)
. D VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
I '$G(XMIA),X'=XMNETNAM D Q:$D(XMERROR)
. N Y,X
. S X=XMDOMAIN
. F S Y=$$FIND1^DIC(4.2,"","MOQ",X,"B^C") Q:Y>0!$D(DIERR)!(X'[".") D
. . S X=$P(X,".",2,999)
. Q:Y!'$D(DIERR) ; (Y should never be >0, because we didn't find it before.)
. I X'[".",$$FIND1^DIC(4.2996,"","QX",X) Q
. D SETERR^XMXADDR4(0,"",39106,X) ;Domain ambiguous: |1|
I $D(DTOUT)!$D(DUOUT) D Q
. ;up-arrow out. / time out.
. D SETERR^XMXADDR4(1,"!",$S($D(DUOUT):37000,1:37001))
I X'["." D Q ; Domain not found, look in internet suffix file
. D LOOKSFX Q:$D(XMERROR)
. I X=XMDOMAIN D NEEDSUB(X) Q
. D CHKDOM($E(XMSUBDOM,1,$L(XMSUBDOM)-1))
I X=XMNETNAM D Q ;Sub-domain '|1|' not found for domain '|2|'
. D SETERR^XMXADDR4($G(XMIA),"!",39103,$E(XMSUBDOM,1,$L(XMSUBDOM)-1),X)
Q
NEEDSUB(X) ;
D SETERR^XMXADDR4(0,"",39104,X) ;Valid domain, but need subdomain: |1|
Q:'$G(XMIA)
;Domain |1| is a valid Internet domain,
;but you must specify at least one sub-domain.
N XMTEXT
D BLD^DIALOG(39105,X,"","XMTEXT","F")
D MSG^DIALOG("WE","","","","XMTEXT")
Q
VIA(XMVIA,XMVIAREC,XMVIAN,XMDCIRCL) ;
S XMVIAN=$P(XMVIAREC,U,1)
Q:XMVIAN=XMNETNAM
D CHKPRMIT(XMDUZ,XMVIAREC) Q:$D(XMERROR)
I $D(XMDCIRCL(XMVIA)) D Q
. I $G(XMIA) D EN^DDIOL($$EZBLD^DIALOG(39088)) ;Error:
. ;Circular relay domain: |1|
. D SETERR^XMXADDR4($G(XMIA),"",39107,XMVIAN)
I $P(XMVIAREC,U,3) D Q ; If there's a relay domain, follow it.
. S XMDCIRCL(XMVIA)=""
. S XMVIA=$P(XMVIAREC,U,3),XMVIAREC=$G(^DIC(4.2,XMVIA,0))
. D VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
Q:$P(XMVIAREC,U,2)'["S"
Q:$O(^DIC(4.2,XMVIA,1,0)) ; Domain has script(s).
Q:$L(XMVIAN)+1=$F(XMVIAN,XMNETNAM) ; Subdomain of this domain.
N Y
I $L(XMVIAN,".")>3 D I Y,$P(^DIC(4.2,+Y,0),U,1)=XMNETNAM Q ; Subdomain of this domain.
. N X
. S X=$P(XMVIAN,".",2,999)
. F S Y=$$FIND1^DIC(4.2,"","QX",X,"C") Q:Y!($L(X,".")<3) D
. . S X=$P(X,".",2,999)
; No script, so send to parent domain, if there is one,
; and if the parent isn't the same as this domain.
Q:'$G(^XMB("PARENT"))
Q:'$G(^XMB("NUM"))
Q:^XMB("PARENT")=^XMB("NUM")
Q:'$D(^DIC(4.2,^XMB("PARENT"),0))
S XMVIA=^XMB("PARENT")
S XMVIAREC=^DIC(4.2,XMVIA,0)
S XMVIAN=$P(XMVIAREC,U,1)
Q
CHKDOM(XMDOM,XMMAXDOM,XMMAXDOT) ;
N I,XMSUBDOM
I $TR(XMDOM,".-","")'?.AN D Q
. ;Domain may not contain punctuation other than '.' or '-'.
. D SETERR^XMXADDR4($G(XMIA),"!",39108)
I '$D(XMMAXDOM) S XMMAXDOM=255
I $L(XMDOM)>XMMAXDOM D Q
. ;Domain must be from 1 to |1| characters.
. D SETERR^XMXADDR4($G(XMIA),"!",39109,XMMAXDOM)
I '$D(XMMAXDOT) S XMMAXDOT=63
F I=1:1:$L(XMDOM,".") D Q:$D(XMERROR)
. S XMSUBDOM=$P(XMDOM,".",I)
. I XMSUBDOM?1AN.E,$L(XMSUBDOM)'>XMMAXDOT Q
. ; 39110 - Domain dot pieces must be from 1 to |1| characters.
. ; 39111 - Domain dot pieces must begin with a letter or number.
. D SETERR^XMXADDR4($G(XMIA),"!",$S($L(XMSUBDOM,I)>XMMAXDOT:39110,1:39111),XMMAXDOT)
. Q:'$G(XMIA)
. D EN^DDIOL($$EZBLD^DIALOG(39112,XMSUBDOM)) ;|1| is not valid.
Q
LOOKSFX ; Look for top level domain in internet suffix file
; Instead of looking in the file, we could call the COTS DNS, if it exists.
N DIC,Y
I $G(XMIA) D
. D EN^DDIOL($$EZBLD^DIALOG(39113)) ;Looking in Internet Suffix file...
. S DIC(0)=$TR(XMFLAGS,"O")_"X"
E S DIC(0)="X"
S DIC="^DIC(4.2996,"
S:$G(XMIA) DIC("W")="W "" "",$P(^(0),U,2)" ; high-level domain purpose/country
D ^DIC
I Y>0 D Q:XMVIA
. S XMVIA=$G(^XMB("PARENT"))
. I 'XMVIA S XMVIA=$$FIND1^DIC(4.2,"","MQX",$S($$FORUM:"GK.DOMAIN.EXT",1:"DOMAIN.EXT"),"B^C") Q:'XMVIA
. S XMVIAREC=^DIC(4.2,XMVIA,0)
. S XMVIAN=$P(XMVIAREC,U)
D SETERR^XMXADDR4($G(XMIA),"!",39100,X) ;Domain not found: |1|
Q
CHKPRMIT(XMDUZ,XMVIAREC) ;
I $G(XMINSTR("ADDR FLAGS"))["R",'$D(XMRESTR("NET RECEIVE")) Q
I $P(XMVIAREC,U,2)["C",$P(XMVIAREC,U,2)'["S" D Q ;Domain closed: |1|
. D SETERR^XMXADDR4($G(XMIA),"!",39114,$P(XMVIAREC,U,1))
Q:$G(XMINSTR("ADDR FLAGS"))["R"
I $P(XMVIAREC,U,11)'="",'$D(^XUSEC($P(XMVIAREC,U,11),XMDUZ)) D Q
. ;You don't hold key to domain '|1|'.
. D SETERR^XMXADDR4($G(XMIA),"!",39115,$P(XMVIAREC,U,1))
; Maybe the following belongs in XMFWD^XMVVITAE:
;I $P(XMVIAREC,U,2)["N" D Q
;. D SETERR^XMXADDR4($G(XMIA),"!",XXXXX,$P(XMVIAREC,U,1)) ; No forwarding to domain '|1|'.
Q
CHKNAME ; Input transform for .01 field of DOMAIN file 4.2
N XMIA,XMERROR,I
S XMIA=0
S X=$$UP^XLFSTR(X)
D CHKDOM(X,64,20)
I $D(XMERROR) D Q
. D WRIERR^XMXADDR4("!,$C(7)")
. K X
Q:$D(DIFROM)
F I=1:1:$L(X,".")-1 D Q:'$D(X)
. Q:'$D(^DIC(4.2996,"B",$P(X,".",I),0))
. D EN^DDIOL($$EZBLD^DIALOG(39116),"","!,$C(7)")
. K X ;Domain dot pieces must not match Internet reserved domain names.
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMXADDRD 6850 printed Dec 13, 2024@02:13:59 Page 2
XMXADDRD ;ISC-SF/GMB-Lookup Domain Name ;04/24/2002 10:36
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Replaces PSP^XMA210,^XMA21A,^XMA21B (ISC-WASH/CAP)
DNS(XMDUZ,XMDOMAIN,XMVIA,XMVIAN) ;
+1 ; XMDOMAIN - (in/out) Domain name. May be mixed case. Must already be
+2 ; in xxx.xxx.xxx format.
+3 ; XMVIA - (out) IEN of (relay) domain (in ^DIC(4.2))
+4 ; XMVIAN - (out) Name of (relay) domain
+5 NEW XMVIAREC,XMNETNAM
+6 SET XMNETNAM=^XMB("NETNAME")
+7 SET XMDOMAIN=$$UP^XLFSTR(XMDOMAIN)
+8 IF XMDOMAIN=XMNETNAM
Begin DoDot:1
+9 SET XMVIA=^XMB("NUM")
+10 SET XMVIAN=XMNETNAM
End DoDot:1
QUIT
+11 DO FINDDOMN
+12 if $DATA(XMERROR)
QUIT
+13 IF XMVIAN="DOMAIN.EXT"
IF $$FORUM
Begin DoDot:1
+14 ;Domain not found: |1|
DO SETERR^XMXADDR4($GET(XMIA),"!",39100,XMDOMAIN)
End DoDot:1
QUIT
+15 IF $GET(XMIA)
Begin DoDot:1
+16 ;via |1|
if XMDOMAIN'=XMVIAN
WRITE $$EZBLD^DIALOG(39101,XMVIAN)
+17 ; queued
IF XMVIAN'=XMNETNAM
IF $PIECE(XMVIAREC,U,2)'["S"
WRITE $$EZBLD^DIALOG(39102)
End DoDot:1
+18 QUIT
FORUM() ; Is this FORUM or GATEWAY?
+1 QUIT $SELECT($GET(XMNETNAM,^XMB("NETNAME"))'["FORUM.":0,1:1)
FINDDOMN ; Look up domain
+1 NEW XMSUBDOM,XMFLAGS,DIC,X,Y,XMDCIRCL
+2 SET XMSUBDOM=""
SET X=XMDOMAIN
+3 ;S XMFLAGS="ZMF"_$S('$G(XMIA):"O",$G(XMINSTR("EXACT")):"OE",$D(XMGCIRCL):"OE",1:"E")
+4 SET XMFLAGS="ZMF"_$SELECT($GET(XMINSTR("EXACT")):"X",'$GET(XMIA):"O",$DATA(XMGCIRCL):"O",1:"")_$SELECT($GET(XMIA):"E",1:"")
+5 SET DIC="^DIC(4.2,"
SET DIC(0)=XMFLAGS
+6 FOR
SET D="B^C"
DO MIX^DIC1
if Y>0!(X'[".")!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
Begin DoDot:1
+7 SET XMSUBDOM=XMSUBDOM_$PIECE(X,".")_"."
+8 SET X=$PIECE(X,".",2,999)
End DoDot:1
if X=XMNETNAM
QUIT
+9 ; Look for COM,MIL,NET,etc. as synonym for one of the domains.
IF Y'>0
IF X'["."
IF '$GET(XMIA)
IF $LENGTH(X)<4
SET DIC(0)="ZFX"
SET D="C"
DO IX^DIC
+10 ; Domain successfully found
IF Y>0
Begin DoDot:1
+11 IF XMSUBDOM'=""
Begin DoDot:2
+12 DO CHKDOM($EXTRACT(XMSUBDOM,1,$LENGTH(XMSUBDOM)-1))
if $DATA(XMERROR)
QUIT
+13 if Y(0,0)'=XMNETNAM
QUIT
+14 ; Sub-domain '|1|' not found for domain '|2|'
DO SETERR^XMXADDR4($GET(XMIA),"!",39103,$EXTRACT(XMSUBDOM,1,$LENGTH(XMSUBDOM)-1),X)
End DoDot:2
if $DATA(XMERROR)
QUIT
+15 IF XMSUBDOM=""
IF X'["."
IF $LENGTH(X)<4
IF $$FIND1^DIC(4.2996,"","QX",X)
DO NEEDSUB(X)
QUIT
+16 ; MailMan's klugey way
SET XMDOMAIN=$SELECT(XMSUBDOM="":Y(0,0),1:XMSUBDOM_X)
+17 ;S XMDOMAIN=XMSUBDOM_X ; Proper way? Nope.
+18 SET XMVIA=+Y
+19 SET XMVIAREC=Y(0)
+20 DO VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
End DoDot:1
QUIT
+21 IF '$GET(XMIA)
IF X'=XMNETNAM
Begin DoDot:1
+22 NEW Y,X
+23 SET X=XMDOMAIN
+24 FOR
SET Y=$$FIND1^DIC(4.2,"","MOQ",X,"B^C")
if Y>0!$DATA(DIERR)!(X'[".")
QUIT
Begin DoDot:2
+25 SET X=$PIECE(X,".",2,999)
End DoDot:2
+26 ; (Y should never be >0, because we didn't find it before.)
if Y!'$DATA(DIERR)
QUIT
+27 IF X'["."
IF $$FIND1^DIC(4.2996,"","QX",X)
QUIT
+28 ;Domain ambiguous: |1|
DO SETERR^XMXADDR4(0,"",39106,X)
End DoDot:1
if $DATA(XMERROR)
QUIT
+29 IF $DATA(DTOUT)!$DATA(DUOUT)
Begin DoDot:1
+30 ;up-arrow out. / time out.
+31 DO SETERR^XMXADDR4(1,"!",$SELECT($DATA(DUOUT):37000,1:37001))
End DoDot:1
QUIT
+32 ; Domain not found, look in internet suffix file
IF X'["."
Begin DoDot:1
+33 DO LOOKSFX
if $DATA(XMERROR)
QUIT
+34 IF X=XMDOMAIN
DO NEEDSUB(X)
QUIT
+35 DO CHKDOM($EXTRACT(XMSUBDOM,1,$LENGTH(XMSUBDOM)-1))
End DoDot:1
QUIT
+36 ;Sub-domain '|1|' not found for domain '|2|'
IF X=XMNETNAM
Begin DoDot:1
+37 DO SETERR^XMXADDR4($GET(XMIA),"!",39103,$EXTRACT(XMSUBDOM,1,$LENGTH(XMSUBDOM)-1),X)
End DoDot:1
QUIT
+38 QUIT
NEEDSUB(X) ;
+1 ;Valid domain, but need subdomain: |1|
DO SETERR^XMXADDR4(0,"",39104,X)
+2 if '$GET(XMIA)
QUIT
+3 ;Domain |1| is a valid Internet domain,
+4 ;but you must specify at least one sub-domain.
+5 NEW XMTEXT
+6 DO BLD^DIALOG(39105,X,"","XMTEXT","F")
+7 DO MSG^DIALOG("WE","","","","XMTEXT")
+8 QUIT
VIA(XMVIA,XMVIAREC,XMVIAN,XMDCIRCL) ;
+1 SET XMVIAN=$PIECE(XMVIAREC,U,1)
+2 if XMVIAN=XMNETNAM
QUIT
+3 DO CHKPRMIT(XMDUZ,XMVIAREC)
if $DATA(XMERROR)
QUIT
+4 IF $DATA(XMDCIRCL(XMVIA))
Begin DoDot:1
+5 ;Error:
IF $GET(XMIA)
DO EN^DDIOL($$EZBLD^DIALOG(39088))
+6 ;Circular relay domain: |1|
+7 DO SETERR^XMXADDR4($GET(XMIA),"",39107,XMVIAN)
End DoDot:1
QUIT
+8 ; If there's a relay domain, follow it.
IF $PIECE(XMVIAREC,U,3)
Begin DoDot:1
+9 SET XMDCIRCL(XMVIA)=""
+10 SET XMVIA=$PIECE(XMVIAREC,U,3)
SET XMVIAREC=$GET(^DIC(4.2,XMVIA,0))
+11 DO VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
End DoDot:1
QUIT
+12 if $PIECE(XMVIAREC,U,2)'["S"
QUIT
+13 ; Domain has script(s).
if $ORDER(^DIC(4.2,XMVIA,1,0))
QUIT
+14 ; Subdomain of this domain.
if $LENGTH(XMVIAN)+1=$FIND(XMVIAN,XMNETNAM)
QUIT
+15 NEW Y
+16 ; Subdomain of this domain.
IF $LENGTH(XMVIAN,".")>3
Begin DoDot:1
+17 NEW X
+18 SET X=$PIECE(XMVIAN,".",2,999)
+19 FOR
SET Y=$$FIND1^DIC(4.2,"","QX",X,"C")
if Y!($LENGTH(X,".")<3)
QUIT
Begin DoDot:2
+20 SET X=$PIECE(X,".",2,999)
End DoDot:2
End DoDot:1
IF Y
IF $PIECE(^DIC(4.2,+Y,0),U,1)=XMNETNAM
QUIT
+21 ; No script, so send to parent domain, if there is one,
+22 ; and if the parent isn't the same as this domain.
+23 if '$GET(^XMB("PARENT"))
QUIT
+24 if '$GET(^XMB("NUM"))
QUIT
+25 if ^XMB("PARENT")=^XMB("NUM")
QUIT
+26 if '$DATA(^DIC(4.2,^XMB("PARENT"),0))
QUIT
+27 SET XMVIA=^XMB("PARENT")
+28 SET XMVIAREC=^DIC(4.2,XMVIA,0)
+29 SET XMVIAN=$PIECE(XMVIAREC,U,1)
+30 QUIT
CHKDOM(XMDOM,XMMAXDOM,XMMAXDOT) ;
+1 NEW I,XMSUBDOM
+2 IF $TRANSLATE(XMDOM,".-","")'?.AN
Begin DoDot:1
+3 ;Domain may not contain punctuation other than '.' or '-'.
+4 DO SETERR^XMXADDR4($GET(XMIA),"!",39108)
End DoDot:1
QUIT
+5 IF '$DATA(XMMAXDOM)
SET XMMAXDOM=255
+6 IF $LENGTH(XMDOM)>XMMAXDOM
Begin DoDot:1
+7 ;Domain must be from 1 to |1| characters.
+8 DO SETERR^XMXADDR4($GET(XMIA),"!",39109,XMMAXDOM)
End DoDot:1
QUIT
+9 IF '$DATA(XMMAXDOT)
SET XMMAXDOT=63
+10 FOR I=1:1:$LENGTH(XMDOM,".")
Begin DoDot:1
+11 SET XMSUBDOM=$PIECE(XMDOM,".",I)
+12 IF XMSUBDOM?1AN.E
IF $LENGTH(XMSUBDOM)'>XMMAXDOT
QUIT
+13 ; 39110 - Domain dot pieces must be from 1 to |1| characters.
+14 ; 39111 - Domain dot pieces must begin with a letter or number.
+15 DO SETERR^XMXADDR4($GET(XMIA),"!",$SELECT($LENGTH(XMSUBDOM,I)>XMMAXDOT:39110,1:39111),XMMAXDOT)
+16 if '$GET(XMIA)
QUIT
+17 ;|1| is not valid.
DO EN^DDIOL($$EZBLD^DIALOG(39112,XMSUBDOM))
End DoDot:1
if $DATA(XMERROR)
QUIT
+18 QUIT
LOOKSFX ; Look for top level domain in internet suffix file
+1 ; Instead of looking in the file, we could call the COTS DNS, if it exists.
+2 NEW DIC,Y
+3 IF $GET(XMIA)
Begin DoDot:1
+4 ;Looking in Internet Suffix file...
DO EN^DDIOL($$EZBLD^DIALOG(39113))
+5 SET DIC(0)=$TRANSLATE(XMFLAGS,"O")_"X"
End DoDot:1
+6 IF '$TEST
SET DIC(0)="X"
+7 SET DIC="^DIC(4.2996,"
+8 ; high-level domain purpose/country
if $GET(XMIA)
SET DIC("W")="W "" "",$P(^(0),U,2)"
+9 DO ^DIC
+10 IF Y>0
Begin DoDot:1
+11 SET XMVIA=$GET(^XMB("PARENT"))
+12 IF 'XMVIA
SET XMVIA=$$FIND1^DIC(4.2,"","MQX",$SELECT($$FORUM:"GK.DOMAIN.EXT",1:"DOMAIN.EXT"),"B^C")
if 'XMVIA
QUIT
+13 SET XMVIAREC=^DIC(4.2,XMVIA,0)
+14 SET XMVIAN=$PIECE(XMVIAREC,U)
End DoDot:1
if XMVIA
QUIT
+15 ;Domain not found: |1|
DO SETERR^XMXADDR4($GET(XMIA),"!",39100,X)
+16 QUIT
CHKPRMIT(XMDUZ,XMVIAREC) ;
+1 IF $GET(XMINSTR("ADDR FLAGS"))["R"
IF '$DATA(XMRESTR("NET RECEIVE"))
QUIT
+2 ;Domain closed: |1|
IF $PIECE(XMVIAREC,U,2)["C"
IF $PIECE(XMVIAREC,U,2)'["S"
Begin DoDot:1
+3 DO SETERR^XMXADDR4($GET(XMIA),"!",39114,$PIECE(XMVIAREC,U,1))
End DoDot:1
QUIT
+4 if $GET(XMINSTR("ADDR FLAGS"))["R"
QUIT
+5 IF $PIECE(XMVIAREC,U,11)'=""
IF '$DATA(^XUSEC($PIECE(XMVIAREC,U,11),XMDUZ))
Begin DoDot:1
+6 ;You don't hold key to domain '|1|'.
+7 DO SETERR^XMXADDR4($GET(XMIA),"!",39115,$PIECE(XMVIAREC,U,1))
End DoDot:1
QUIT
+8 ; Maybe the following belongs in XMFWD^XMVVITAE:
+9 ;I $P(XMVIAREC,U,2)["N" D Q
+10 ;. D SETERR^XMXADDR4($G(XMIA),"!",XXXXX,$P(XMVIAREC,U,1)) ; No forwarding to domain '|1|'.
+11 QUIT
CHKNAME ; Input transform for .01 field of DOMAIN file 4.2
+1 NEW XMIA,XMERROR,I
+2 SET XMIA=0
+3 SET X=$$UP^XLFSTR(X)
+4 DO CHKDOM(X,64,20)
+5 IF $DATA(XMERROR)
Begin DoDot:1
+6 DO WRIERR^XMXADDR4("!,$C(7)")
+7 KILL X
End DoDot:1
QUIT
+8 if $DATA(DIFROM)
QUIT
+9 FOR I=1:1:$LENGTH(X,".")-1
Begin DoDot:1
+10 if '$DATA(^DIC(4.2996,"B",$PIECE(X,".",I),0))
QUIT
+11 DO EN^DDIOL($$EZBLD^DIALOG(39116),"","!,$C(7)")
+12 ;Domain dot pieces must not match Internet reserved domain names.
KILL X
End DoDot:1
if '$DATA(X)
QUIT
+13 QUIT
