- 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 Feb 18, 2025@23:40:10 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