source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA4.m@ 1073

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

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1HLMA4 ;OIFO-O/RJH-DON'T PING VIE ;03/29/2007 16:21
2 ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 Q
6DONTPING(PAR) ;
7 ; check the data stored in file #869.3 related multiples to
8 ; to see if ping is allowed for the Ping option, PING^HLMA
9 ; return 1: don't ping this link.
10 ; return 0: ok to ping the link.
11 ;
12 N ONE,LINE,PINGOK
13 S HLQUIET=$G(HLQUIET)
14 ;
15 ; the only one entry in file #869.3
16 S ONE=$O(^HLCS(869.3,0))
17 ;
18 D PINGIP
19 Q:PINGOK 0
20 ;
21 D DONTPORT
22 Q:'PINGOK 1
23 ;
24 D DONTDOMN
25 Q:'PINGOK 1
26 ;
27 D DONTNAME
28 Q:'PINGOK 1
29 ;
30 D DONTIP
31 Q:'PINGOK 1
32 ;
33 D PINGDOMN
34 Q:PINGOK 0
35 ;
36 I 'HLQUIET S HLCS="This link is not allowed to ping"
37 Q 1
38 ;
39PINGIP ;
40 ; retrieve the "Ping IP" multiple, which are ok to ping
41 S PINGOK=0
42 S LINE=0
43 F S LINE=$O(^HLCS(869.3,ONE,7,LINE)) Q:'LINE D Q:PINGOK
44 . N DATAS,COUNT,DATA
45 . S DATAS=$G(^HLCS(869.3,ONE,7,LINE,0))
46 . S COUNT=$L(DATAS,",")
47 . F I=1:1:COUNT D Q:PINGOK
48 .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
49 .. I DATA=HLTCPADD S PINGOK=1
50 Q
51 ;
52DONTPORT ;
53 ; retrieve the "Don't Ping Port" multiple, which are not
54 ; allowed to ping
55 S PINGOK=1
56 S LINE=0
57 F S LINE=$O(^HLCS(869.3,ONE,9,LINE)) Q:'LINE D Q:'PINGOK
58 . N DATAS,COUNT,DATA
59 . S DATAS=$G(^HLCS(869.3,ONE,9,LINE,0))
60 . S COUNT=$L(DATAS,",")
61 . F I=1:1:COUNT D Q:'PINGOK
62 .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
63 .. I DATA=HLTCPORT D
64 ... S PINGOK=0
65 ... I 'HLQUIET D
66 .... S HLCS="This link with 'PORT' as '"_HLTCPORT
67 .... S HLCS=HLCS_"' is not allowed to ping"
68 Q
69 ;
70DONTDOMN ;
71 ; retrieve the "Don't Ping Domain (Full)" multiple,
72 ; which are not allowed to ping
73 ;
74 N HLDOM
75 S PINGOK=1
76 S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
77 S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
78 I 'HLDOM,($L(HLDOM("DNS"),".")<3) Q
79 ;
80 I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
81 ;
82 S LINE=0
83 F S LINE=$O(^HLCS(869.3,ONE,12,LINE)) Q:'LINE D Q:'PINGOK
84 . N DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
85 . S DATAS=$G(^HLCS(869.3,ONE,12,LINE,0))
86 . S COUNT=$L(DATAS,",")
87 . F I=1:1:COUNT D Q:'PINGOK
88 .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
89 .. ; set PINGOK to 0 if domain is not allowed to ping
90 .. I ($L(HLDOM("DNS"),".")>2),HLDOM("DNS")=DATA D Q
91 ... D SETHLCS(HLDOM("DNS"),"DNS DOMAIN")
92 .. I $L(HLDOM)>5,HLDOM=DATA D
93 ... D SETHLCS(HLDOM,"MAILMAN DOMAIN")
94 Q
95 ;
96SETHLCS(DATA,TYPE) ;
97 ; to be called from sub-routine DONTDOMN
98 S PINGOK=0
99 I 'HLQUIET D
100 . S HLCS="This link with '"_TYPE_"' as '"_DATA
101 . S HLCS=HLCS_"' is not allowed to ping"
102 Q
103 ;
104DONTNAME ;
105 ; retrieve the "Don't Ping Link Name (Partial)" multiple,
106 ; which are not allowed to ping
107 ;
108 N LINKNAME
109 S PINGOK=1
110 ;
111 S LINKNAME=$P(^HLCS(870,HLDP,0),U,1)
112 ;
113 S LINE=0
114 F S LINE=$O(^HLCS(869.3,ONE,10,LINE)) Q:'LINE D Q:'PINGOK
115 . N DATAS,COUNT,DATA
116 . S DATAS=$G(^HLCS(869.3,ONE,10,LINE,0))
117 . S COUNT=$L(DATAS,",")
118 . F I=1:1:COUNT D Q:'PINGOK
119 .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
120 .. I LINKNAME[DATA D
121 ... S PINGOK=0
122 ... I 'HLQUIET D
123 .... S HLCS="This link 'NAME' containing name-stub"
124 .... S HLCS=HLCS_" '"_DATA_"' is not allowed to ping"
125 Q
126 ;
127DONTIP ;
128 ; retrieve the "Don't Ping IP" multiple, which are not
129 ; allowed to ping
130 ;
131 S PINGOK=1
132 ;
133 S LINE=0
134 F S LINE=$O(^HLCS(869.3,ONE,11,LINE)) Q:'LINE D Q:'PINGOK
135 . N DATAS,COUNT,DATA
136 . S DATAS=$G(^HLCS(869.3,ONE,11,LINE,0))
137 . S COUNT=$L(DATAS,",")
138 . F I=1:1:COUNT D Q:'PINGOK
139 .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
140 .. I DATA=HLTCPADD D
141 ... S PINGOK=0
142 ... I 'HLQUIET D
143 .... S HLCS="This link with 'IP' as '"_HLTCPADD
144 .... S HLCS=HLCS_"' is not allowed to ping"
145 Q
146 ;
147PINGDOMN ;
148 ; retrieve the "Ping Domain (Partial)" multiple,
149 ; which is ok to ping, data could be partial domain.
150 ;
151 N HLDOM
152 S PINGOK=0
153 ;
154 S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
155 S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
156 I 'HLDOM,($L(HLDOM("DNS"),".")<3) Q
157 ;
158 I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
159 ;
160 S LINE=0
161 F S LINE=$O(^HLCS(869.3,ONE,8,LINE)) Q:'LINE D Q:PINGOK
162 . N DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
163 . S DATAS=$G(^HLCS(869.3,ONE,8,LINE,0))
164 . S COUNT=$L(DATAS,",")
165 . F I=1:1:COUNT D Q:PINGOK
166 .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
167 .. ; set PINGOK to 1 if domain is allowed to ping
168 .. I ($L(HLDOM("DNS"),".")>2),HLDOM("DNS")[DATA S PINGOK=1 Q
169 .. I $L(HLDOM)>5,HLDOM[DATA S PINGOK=1
170 Q
171 ;
Note: See TracBrowser for help on using the repository browser.