source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMXADDRD.m@ 1739

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

initial load of WorldVistAEHR
File size: 6.5 KB
Line 
1XMXADDRD ;ISC-SF/GMB-Lookup Domain Name ;04/24/2002 10:36
2 ;;8.0;MailMan;;Jun 28, 2002
3 ; Replaces PSP^XMA210,^XMA21A,^XMA21B (ISC-WASH/CAP)
4DNS(XMDUZ,XMDOMAIN,XMVIA,XMVIAN) ;
5 ; XMDOMAIN - (in/out) Domain name. May be mixed case. Must already be
6 ; in xxx.xxx.xxx format.
7 ; XMVIA - (out) IEN of (relay) domain (in ^DIC(4.2))
8 ; XMVIAN - (out) Name of (relay) domain
9 N XMVIAREC,XMNETNAM
10 S XMNETNAM=^XMB("NETNAME")
11 S XMDOMAIN=$$UP^XLFSTR(XMDOMAIN)
12 I XMDOMAIN=XMNETNAM D Q
13 . S XMVIA=^XMB("NUM")
14 . S XMVIAN=XMNETNAM
15 D FINDDOMN
16 Q:$D(XMERROR)
17 I XMVIAN="VA.GOV",$$FORUM D Q
18 . D SETERR^XMXADDR4($G(XMIA),"!",39100,XMDOMAIN) ;Domain not found: |1|
19 I $G(XMIA) D
20 . W:XMDOMAIN'=XMVIAN $$EZBLD^DIALOG(39101,XMVIAN) ;via |1|
21 . I XMVIAN'=XMNETNAM,$P(XMVIAREC,U,2)'["S" W $$EZBLD^DIALOG(39102) ; queued
22 Q
23FORUM() ; Is this FORUM or GATEWAY?
24 Q $S($G(XMNETNAM,^XMB("NETNAME"))'["FORUM.":0,1:1)
25FINDDOMN ; Look up domain
26 N XMSUBDOM,XMFLAGS,DIC,X,Y,XMDCIRCL
27 S XMSUBDOM="",X=XMDOMAIN
28 ;S XMFLAGS="ZMF"_$S('$G(XMIA):"O",$G(XMINSTR("EXACT")):"OE",$D(XMGCIRCL):"OE",1:"E")
29 S XMFLAGS="ZMF"_$S($G(XMINSTR("EXACT")):"X",'$G(XMIA):"O",$D(XMGCIRCL):"O",1:"")_$S($G(XMIA):"E",1:"")
30 S DIC="^DIC(4.2,",DIC(0)=XMFLAGS
31 F S D="B^C" D MIX^DIC1 Q:Y>0!(X'[".")!$D(DUOUT)!$D(DTOUT) D Q:X=XMNETNAM
32 . S XMSUBDOM=XMSUBDOM_$P(X,".")_"."
33 . S X=$P(X,".",2,999)
34 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.
35 I Y>0 D Q ; Domain successfully found
36 . I XMSUBDOM'="" D Q:$D(XMERROR)
37 . . D CHKDOM($E(XMSUBDOM,1,$L(XMSUBDOM)-1)) Q:$D(XMERROR)
38 . . Q:Y(0,0)'=XMNETNAM
39 . . D SETERR^XMXADDR4($G(XMIA),"!",39103,$E(XMSUBDOM,1,$L(XMSUBDOM)-1),X) ; Sub-domain '|1|' not found for domain '|2|'
40 . I XMSUBDOM="",X'[".",$L(X)<4,$$FIND1^DIC(4.2996,"","QX",X) D NEEDSUB(X) Q
41 . S XMDOMAIN=$S(XMSUBDOM="":Y(0,0),1:XMSUBDOM_X) ; MailMan's klugey way
42 . ;S XMDOMAIN=XMSUBDOM_X ; Proper way? Nope.
43 . S XMVIA=+Y
44 . S XMVIAREC=Y(0)
45 . D VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
46 I '$G(XMIA),X'=XMNETNAM D Q:$D(XMERROR)
47 . N Y,X
48 . S X=XMDOMAIN
49 . F S Y=$$FIND1^DIC(4.2,"","MOQ",X,"B^C") Q:Y>0!$D(DIERR)!(X'[".") D
50 . . S X=$P(X,".",2,999)
51 . Q:Y!'$D(DIERR) ; (Y should never be >0, because we didn't find it before.)
52 . I X'[".",$$FIND1^DIC(4.2996,"","QX",X) Q
53 . D SETERR^XMXADDR4(0,"",39106,X) ;Domain ambiguous: |1|
54 I $D(DTOUT)!$D(DUOUT) D Q
55 . ;up-arrow out. / time out.
56 . D SETERR^XMXADDR4(1,"!",$S($D(DUOUT):37000,1:37001))
57 I X'["." D Q ; Domain not found, look in internet suffix file
58 . D LOOKSFX Q:$D(XMERROR)
59 . I X=XMDOMAIN D NEEDSUB(X) Q
60 . D CHKDOM($E(XMSUBDOM,1,$L(XMSUBDOM)-1))
61 I X=XMNETNAM D Q ;Sub-domain '|1|' not found for domain '|2|'
62 . D SETERR^XMXADDR4($G(XMIA),"!",39103,$E(XMSUBDOM,1,$L(XMSUBDOM)-1),X)
63 Q
64NEEDSUB(X) ;
65 D SETERR^XMXADDR4(0,"",39104,X) ;Valid domain, but need subdomain: |1|
66 Q:'$G(XMIA)
67 ;Domain |1| is a valid Internet domain,
68 ;but you must specify at least one sub-domain.
69 N XMTEXT
70 D BLD^DIALOG(39105,X,"","XMTEXT","F")
71 D MSG^DIALOG("WE","","","","XMTEXT")
72 Q
73VIA(XMVIA,XMVIAREC,XMVIAN,XMDCIRCL) ;
74 S XMVIAN=$P(XMVIAREC,U,1)
75 Q:XMVIAN=XMNETNAM
76 D CHKPRMIT(XMDUZ,XMVIAREC) Q:$D(XMERROR)
77 I $D(XMDCIRCL(XMVIA)) D Q
78 . I $G(XMIA) D EN^DDIOL($$EZBLD^DIALOG(39088)) ;Error:
79 . ;Circular relay domain: |1|
80 . D SETERR^XMXADDR4($G(XMIA),"",39107,XMVIAN)
81 I $P(XMVIAREC,U,3) D Q ; If there's a relay domain, follow it.
82 . S XMDCIRCL(XMVIA)=""
83 . S XMVIA=$P(XMVIAREC,U,3),XMVIAREC=$G(^DIC(4.2,XMVIA,0))
84 . D VIA(.XMVIA,.XMVIAREC,.XMVIAN,.XMDCIRCL)
85 Q:$P(XMVIAREC,U,2)'["S"
86 Q:$O(^DIC(4.2,XMVIA,1,0)) ; Domain has script(s).
87 Q:$L(XMVIAN)+1=$F(XMVIAN,XMNETNAM) ; Subdomain of this domain.
88 N Y
89 I $L(XMVIAN,".")>3 D I Y,$P(^DIC(4.2,+Y,0),U,1)=XMNETNAM Q ; Subdomain of this domain.
90 . N X
91 . S X=$P(XMVIAN,".",2,999)
92 . F S Y=$$FIND1^DIC(4.2,"","QX",X,"C") Q:Y!($L(X,".")<3) D
93 . . S X=$P(X,".",2,999)
94 ; No script, so send to parent domain, if there is one,
95 ; and if the parent isn't the same as this domain.
96 Q:'$G(^XMB("PARENT"))
97 Q:'$G(^XMB("NUM"))
98 Q:^XMB("PARENT")=^XMB("NUM")
99 Q:'$D(^DIC(4.2,^XMB("PARENT"),0))
100 S XMVIA=^XMB("PARENT")
101 S XMVIAREC=^DIC(4.2,XMVIA,0)
102 S XMVIAN=$P(XMVIAREC,U,1)
103 Q
104CHKDOM(XMDOM,XMMAXDOM,XMMAXDOT) ;
105 N I,XMSUBDOM
106 I $TR(XMDOM,".-","")'?.AN D Q
107 . ;Domain may not contain punctuation other than '.' or '-'.
108 . D SETERR^XMXADDR4($G(XMIA),"!",39108)
109 I '$D(XMMAXDOM) S XMMAXDOM=255
110 I $L(XMDOM)>XMMAXDOM D Q
111 . ;Domain must be from 1 to |1| characters.
112 . D SETERR^XMXADDR4($G(XMIA),"!",39109,XMMAXDOM)
113 I '$D(XMMAXDOT) S XMMAXDOT=63
114 F I=1:1:$L(XMDOM,".") D Q:$D(XMERROR)
115 . S XMSUBDOM=$P(XMDOM,".",I)
116 . I XMSUBDOM?1AN.E,$L(XMSUBDOM)'>XMMAXDOT Q
117 . ; 39110 - Domain dot pieces must be from 1 to |1| characters.
118 . ; 39111 - Domain dot pieces must begin with a letter or number.
119 . D SETERR^XMXADDR4($G(XMIA),"!",$S($L(XMSUBDOM,I)>XMMAXDOT:39110,1:39111),XMMAXDOT)
120 . Q:'$G(XMIA)
121 . D EN^DDIOL($$EZBLD^DIALOG(39112,XMSUBDOM)) ;|1| is not valid.
122 Q
123LOOKSFX ; Look for top level domain in internet suffix file
124 ; Instead of looking in the file, we could call the COTS DNS, if it exists.
125 N DIC,Y
126 I $G(XMIA) D
127 . D EN^DDIOL($$EZBLD^DIALOG(39113)) ;Looking in Internet Suffix file...
128 . S DIC(0)=$TR(XMFLAGS,"O")_"X"
129 E S DIC(0)="X"
130 S DIC="^DIC(4.2996,"
131 S:$G(XMIA) DIC("W")="W "" "",$P(^(0),U,2)" ; high-level domain purpose/country
132 D ^DIC
133 I Y>0 D Q:XMVIA
134 . S XMVIA=$G(^XMB("PARENT"))
135 . I 'XMVIA S XMVIA=$$FIND1^DIC(4.2,"","MQX",$S($$FORUM:"GK.VA.GOV",1:"FORUM.VA.GOV"),"B^C") Q:'XMVIA
136 . S XMVIAREC=^DIC(4.2,XMVIA,0)
137 . S XMVIAN=$P(XMVIAREC,U)
138 D SETERR^XMXADDR4($G(XMIA),"!",39100,X) ;Domain not found: |1|
139 Q
140CHKPRMIT(XMDUZ,XMVIAREC) ;
141 I $G(XMINSTR("ADDR FLAGS"))["R",'$D(XMRESTR("NET RECEIVE")) Q
142 I $P(XMVIAREC,U,2)["C",$P(XMVIAREC,U,2)'["S" D Q ;Domain closed: |1|
143 . D SETERR^XMXADDR4($G(XMIA),"!",39114,$P(XMVIAREC,U,1))
144 Q:$G(XMINSTR("ADDR FLAGS"))["R"
145 I $P(XMVIAREC,U,11)'="",'$D(^XUSEC($P(XMVIAREC,U,11),XMDUZ)) D Q
146 . ;You don't hold key to domain '|1|'.
147 . D SETERR^XMXADDR4($G(XMIA),"!",39115,$P(XMVIAREC,U,1))
148 ; Maybe the following belongs in XMFWD^XMVVITAE:
149 ;I $P(XMVIAREC,U,2)["N" D Q
150 ;. D SETERR^XMXADDR4($G(XMIA),"!",XXXXX,$P(XMVIAREC,U,1)) ; No forwarding to domain '|1|'.
151 Q
152CHKNAME ; Input transform for .01 field of DOMAIN file 4.2
153 N XMIA,XMERROR,I
154 S XMIA=0
155 S X=$$UP^XLFSTR(X)
156 D CHKDOM(X,64,20)
157 I $D(XMERROR) D Q
158 . D WRIERR^XMXADDR4("!,$C(7)")
159 . K X
160 Q:$D(DIFROM)
161 F I=1:1:$L(X,".")-1 D Q:'$D(X)
162 . Q:'$D(^DIC(4.2996,"B",$P(X,".",I),0))
163 . D EN^DDIOL($$EZBLD^DIALOG(39116),"","!,$C(7)")
164 . K X ;Domain dot pieces must not match Internet reserved domain names.
165 Q
Note: See TracBrowser for help on using the repository browser.