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

HLMA4   ;OIFO-O/RJH-DON'T PING VIE ;03/29/2007  16:21
        ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
        ;Per VHA Directive 2004-038, this routine should not be modified.
        ;
        Q
DONTPING(PAR)   ;
        ; check the data stored in file #869.3 related multiples to
        ; to see if ping is allowed for the Ping option, PING^HLMA
        ; return 1: don't ping this link.
        ; return 0: ok to ping the link.
        ;
        N ONE,LINE,PINGOK
        S HLQUIET=$G(HLQUIET)
        ;
        ; the only one entry in file #869.3
        S ONE=$O(^HLCS(869.3,0))
        ;
        D PINGIP
        Q:PINGOK 0
        ;
        D DONTPORT
        Q:'PINGOK 1
        ;
        D DONTDOMN
        Q:'PINGOK 1
        ;
        D DONTNAME
        Q:'PINGOK 1
        ;
        D DONTIP
        Q:'PINGOK 1
        ;
        D PINGDOMN
        Q:PINGOK 0
        ;
        I 'HLQUIET S HLCS="This link is not allowed to ping"
        Q 1
        ;
PINGIP  ;
        ; retrieve the "Ping IP" multiple, which are ok to ping
        S PINGOK=0
        S LINE=0
        F  S LINE=$O(^HLCS(869.3,ONE,7,LINE)) Q:'LINE  D  Q:PINGOK
        . N DATAS,COUNT,DATA
        . S DATAS=$G(^HLCS(869.3,ONE,7,LINE,0))
        . S COUNT=$L(DATAS,",")
        . F I=1:1:COUNT D  Q:PINGOK
        .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
        .. I DATA=HLTCPADD S PINGOK=1
        Q
        ;
DONTPORT        ;
        ; retrieve the "Don't Ping Port" multiple, which are not
        ; allowed to ping
        S PINGOK=1
        S LINE=0
        F  S LINE=$O(^HLCS(869.3,ONE,9,LINE)) Q:'LINE  D  Q:'PINGOK
        . N DATAS,COUNT,DATA
        . S DATAS=$G(^HLCS(869.3,ONE,9,LINE,0))
        . S COUNT=$L(DATAS,",")
        . F I=1:1:COUNT D  Q:'PINGOK
        .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
        .. I DATA=HLTCPORT D
        ... S PINGOK=0
        ... I 'HLQUIET D
        .... S HLCS="This link with 'PORT' as '"_HLTCPORT
        .... S HLCS=HLCS_"' is not allowed to ping"
        Q
        ;
DONTDOMN        ;
        ; retrieve the "Don't Ping Domain (Full)" multiple,
        ; which are not allowed to ping
        ;
        N HLDOM
        S PINGOK=1
        S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
        S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
        I 'HLDOM,($L(HLDOM("DNS"),".")<3) Q
        ;
        I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
        ;
        S LINE=0
        F  S LINE=$O(^HLCS(869.3,ONE,12,LINE)) Q:'LINE  D  Q:'PINGOK
        . N DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
        . S DATAS=$G(^HLCS(869.3,ONE,12,LINE,0))
        . S COUNT=$L(DATAS,",")
        . F I=1:1:COUNT D  Q:'PINGOK
        .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
        .. ; set PINGOK to 0 if domain is not allowed to ping
        .. I ($L(HLDOM("DNS"),".")>2),HLDOM("DNS")=DATA D  Q
        ... D SETHLCS(HLDOM("DNS"),"DNS DOMAIN")
        .. I $L(HLDOM)>5,HLDOM=DATA D
        ... D SETHLCS(HLDOM,"MAILMAN DOMAIN")
        Q
        ;
SETHLCS(DATA,TYPE)      ;
        ; to be called from sub-routine DONTDOMN
        S PINGOK=0
        I 'HLQUIET D
        . S HLCS="This link with '"_TYPE_"' as '"_DATA
        . S HLCS=HLCS_"' is not allowed to ping"
        Q
        ;
DONTNAME        ;
        ; retrieve the "Don't Ping Link Name (Partial)" multiple,
        ; which are not allowed to ping
        ;
        N LINKNAME
        S PINGOK=1
        ;
        S LINKNAME=$P(^HLCS(870,HLDP,0),U,1)
        ;
        S LINE=0
        F  S LINE=$O(^HLCS(869.3,ONE,10,LINE)) Q:'LINE  D  Q:'PINGOK
        . N DATAS,COUNT,DATA
        . S DATAS=$G(^HLCS(869.3,ONE,10,LINE,0))
        . S COUNT=$L(DATAS,",")
        . F I=1:1:COUNT D  Q:'PINGOK
        .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
        .. I LINKNAME[DATA D
        ... S PINGOK=0
        ... I 'HLQUIET D
        .... S HLCS="This link 'NAME' containing name-stub"
        .... S HLCS=HLCS_" '"_DATA_"' is not allowed to ping"
        Q
        ;
DONTIP  ;
        ; retrieve the "Don't Ping IP" multiple, which are not 
        ; allowed to ping
        ;
        S PINGOK=1
        ;
        S LINE=0
        F  S LINE=$O(^HLCS(869.3,ONE,11,LINE)) Q:'LINE  D  Q:'PINGOK
        . N DATAS,COUNT,DATA
        . S DATAS=$G(^HLCS(869.3,ONE,11,LINE,0))
        . S COUNT=$L(DATAS,",")
        . F I=1:1:COUNT D  Q:'PINGOK
        .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
        .. I DATA=HLTCPADD D
        ... S PINGOK=0
        ... I 'HLQUIET D
        .... S HLCS="This link with 'IP' as '"_HLTCPADD
        .... S HLCS=HLCS_"' is not allowed to ping"
        Q
        ;
PINGDOMN        ;
        ; retrieve the "Ping Domain (Partial)" multiple,
        ; which is ok to ping, data could be partial domain.
        ;
        N HLDOM
        S PINGOK=0
        ;
        S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
        S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
        I 'HLDOM,($L(HLDOM("DNS"),".")<3) Q
        ;
        I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
        ;
        S LINE=0
        F  S LINE=$O(^HLCS(869.3,ONE,8,LINE)) Q:'LINE  D  Q:PINGOK
        . N DATAS,COUNT,DATA,DNSDOMN,MAILDOMN
        . S DATAS=$G(^HLCS(869.3,ONE,8,LINE,0))
        . S COUNT=$L(DATAS,",")
        . F I=1:1:COUNT D  Q:PINGOK
        .. S DATA=$P(DATAS,",",I),DATA=$TR(DATA," ","")
        .. ; set PINGOK to 1 if domain is allowed to ping
        .. I ($L(HLDOM("DNS"),".")>2),HLDOM("DNS")[DATA S PINGOK=1 Q
        .. I $L(HLDOM)>5,HLDOM[DATA S PINGOK=1
        Q
        ;