Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m
r613 r623 1 HLMA ;AISC/SAW-Message Administration Module ;05/02/2008 10:27 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122,140**;Oct 13, 1995;Build 5 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ; 5 ;Entry point to generate a deferred message 6 ; 7 ;This is a subroutine call with parameter passing. It returns a 8 ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows 9 ;as follows: 1st message ID^error code^error description 10 ;If no error occurs, only the first piece is returned equal to a unique 11 ;ID for the 1st message. If message was sent to more than 1 subscriber 12 ;than the other message IDs will be in the array HLRESLT(n)=ID 13 ;Otherwise, three pieces are returned with the 14 ;first piece equal to the message ID, if one was assigned, otherwise 0 15 ; 16 ;Required Input Parameters 17 ; HLEID = Name or IEN of event driver protocol in the Protocol file 18 ; HLARYTYP = Array type. One of the following codes: 19 ; LM = local array containing a single message 20 ; LB = local array containig a batch of messages 21 ; GM = global array containing a single message 22 ; GB = global array containing a batch of messages 23 ; HLFORMAT = Format of array, 1 for pre-formatted in HL7 format, 24 ; otherwise 0 25 ;NOTE: The parameter HLRESLT must be passed by reference 26 ; HLRESLT = The variable that will be returned to the calling 27 ; application as descibed above 28 ;Optional Parameters 29 ; HLMTIEN = IEN of entry in Message Text file where the message 30 ; being generated is to be stored. This parameter is 31 ; only passed for a batch type message 32 ;NOTE: The parameter HLP used for the following parameters must be 33 ; passed by reference 34 ; HLP("SECURITY") = A 1 to 40 character string 35 ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string 36 ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91 37 ; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or 38 ; <subscriber protocol name> - A list of protocols to dynamically 39 ; drop from the event protocol's subscriber multiple. 40 ; 41 ;can't have link open when generating new message 42 N HLTCP,HLTCPO,HLPRIO,HLMIDAR 43 S HLPRIO="D" 44 S HLRESLT="" 45 ;Check for required parameters 46 CONT ; 47 I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D G EXIT 48 . S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" 49 I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT 50 N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)="" 51 I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT 52 I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT 53 I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT 54 I $D(HLL("LINKS")) D G:$G(HLRESLT)]"" EXIT 55 . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN 56 . S I=0 57 . F S I=$O(HLL("LINKS",I)) Q:'I D Q:$G(HLRESLT)]"" 58 . . S HLPNAM=$P(HLL("LINKS",I),U) 59 . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0)) 60 . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q 61 . . S HLLNAM=$P(HLL("LINKS",I),U,2) 62 . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0)) 63 . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q 64 ;Extract data from Protocol file 65 D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN) 66 S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)) 67 S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT 68 ;Create message ID and Message Text IEN if Message Text IEN not 69 ;previously created ('$G(HLMTIEN)) 70 I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) 71 ;Get message ID if Message Text IEN already created 72 I '$G(HLMID) D 73 .S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT 74 .S HLDT1=$$HLDATE^HLFNC(HLDT) 75 S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1 76 ;Execute entry action for event driver protocol 77 I HLENROU]"" X HLENROU 78 ;Invoke transaction processor 79 K HLDT,HLDT1,HLENROU 80 D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP) 81 ;HLMIDAR is array of message IDs, only set for broadcast messages 82 I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR 83 S HLRESLT=HLRESLT_"^"_HLRESLT1 84 ; 85 ; patch HL*1.6*122 86 S HLRESLT("HLMID")=$G(HLMIDAR("HLMID")) 87 S HLRESLT("IEN773")=$G(HLMIDAR("IEN773")) 88 ; 89 ;Execute exit action for event driver protocol 90 I HLEXROU]"" X HLEXROU 91 EXIT ;Update status if Message Text file entry has been created 92 K HLTCP 93 I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:"")) 94 K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU 95 Q 96 DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ; 97 ;Entry point to generate an immediate message, must be TCP Logical Link 98 ;Input: 99 ; The same as GENERATE,with one additional subscript to the HLP input 100 ; array: 101 ; 102 ; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between 103 ; 1 and 120 that specifies how many seconds the DIRECT CONNECT should 104 ; try to open a connection before failing. It is killed upon 105 ; completion. 106 ; 107 N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT 108 ; patch HL*1.6*140- to protect application who call this entry 109 N IO,IOF,ION,IOT,IOST,POP 110 S HLRESLT="" 111 ;HLMTIENO=ien passed in, batch message 112 S HLMTIEN=$G(HLMTIENO) 113 I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER" 114 I $G(HLP("OPEN TIMEOUT")) D 115 .S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT") 116 .K HLP("OPEN TIMEOUT") 117 K HL,HLMTIENO 118 D INIT^HLFNC2(HLEID,.HL) 119 I $G(HL) S HLRESLT="0^"_HL Q 120 S HLPRIO="I" D CONT 121 ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2 122 S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR) 123 ;Set special HL variables 124 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" 125 Q 126 ; 127 CLOSE(LOGLINK) ;close connection that was open in tag DIRECT 128 Q 129 PING ;ping another VAMC to test Link 130 ;set HLQUIET =1 to skip writes 131 ;look for HLTPUT to get turnaround time over network. 132 N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM 133 N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2 134 S HLQUIET=$G(HLQUIET) 135 S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT" 136 S DIC="^HLCS(870,",DIC(0)="QEAMZ" 137 D ^DIC Q:Y<0 138 S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2) 139 ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q 140 D SETUP^HLCSAC G:HLCS PINGQ 141 ; patch HL*1.6*122 142 G:$$DONTPING^HLMA4 PINGQ 143 ;PING header=MSH^PING^domain^PING^logical link^datetime 144 S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H) 145 D OPEN^HLCSAC 146 I HLCS D DNS G:HLCS PINGQ 147 D 148 . N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA" 149 . ;non-standard HL7 header; start block,header,end block 150 . S HLX1=$H 151 . ; 152 . ; HL*1.6*122 start 153 . ; replace flush character '!' with @IOF (! or #) 154 . ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char 155 . ; patch HL*1.6*140, flush character- HLTCPLNK("IOF") 156 . ; W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF 157 . W $C(11)_INPUT(1)_$C(28)_$C(13),@HLTCPLNK("IOF") 158 . ; HL*1.6*122 end 159 . ; 160 . ;read response 161 . R X:HLDREAD 162 . S HLX2=$H 163 . S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response") 164 . ;Get roundtrip time 165 . K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2) 166 D CLOSE^%ZISTCP 167 PINGQ ;write back status and quit 168 I 'HLQUIET W !,HLCS,! 169 Q 170 PINGERR ;process errors from PING 171 S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error" 172 ;I $ZE["READ" S HLCS="-1^Error during read" 173 ;I $ZE["WRITE" S HLCS="-1^Error during write" 174 ; HL*1.6*115, SACC compliance 175 I $$EC^%ZOSV["READ" S HLCS="-1^Error during read" 176 I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write" 177 G UNWIND^%ZTER 178 DNS ; 179 ;openfail-try DNS lookup-Link must contain point to Domain Name 180 S POP=$G(POP) 181 S HLQUIET=$G(HLQUIET) 182 I 'HLQUIET W !,"Calling DNS" 183 N HLDOM,HLIP S HLCS="" 184 S HLDOM=$P(^HLCS(870,HLDP,0),U,7) 185 ; patch HL*1.6*122 start 186 S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8) 187 ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q 188 I 'HLDOM,($L(HLDOM("DNS"),".")<3) D Q 189 . I 'HLQUIET W !,"Domain Unknown" 190 . S HLCS="-1^Connection Fail" 191 ; patch HL*1.6*122 end 192 I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U) 193 ; patch HL*1.6*122 194 ; I HLDOM]"" D Q:'POP 195 I HLDOM]""!($L(HLDOM("DNS"),".")>2) D Q:'POP 196 . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" 197 . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM 198 . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM 199 . ; patch HL*1.6*122 200 . I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS") 201 . I 'HLQUIET W !,"Domain, "_HLDOM 202 . I 'HLQUIET W !,"Port: ",HLTCPORT 203 . S HLIP=$$ADDRESS^XLFNSLK(HLDOM) 204 . I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP 205 . I HLIP]"" D 206 . . ;If more than one IP returned, try each, cache successful open 207 . . N HLI,HLJ,HLIP1 208 . . F HLJ=1:1:$L(HLIP,",") D Q:'POP 209 . . . S HLIP1=$P(HLIP,",",HLJ) 210 . . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP 211 . . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1 212 . . . U IO 213 I POP S HLCS="-1^DNS Lookup Failed" 1 HLMA ;AISC/SAW-Message Administration Module ;10/25/2006 2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132**;Oct 13, 1995;Build 6 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ; 5 ;Entry point to generate a deferred message 6 ; 7 ;This is a subroutine call with parameter passing. It returns a 8 ;value in the variable HLRESLT with 1 to 3 pieces separated by uparrows 9 ;as follows: 1st message ID^error code^error description 10 ;If no error occurs, only the first piece is returned equal to a unique 11 ;ID for the 1st message. If message was sent to more than 1 subscriber 12 ;than the other message IDs will be in the array HLRESLT(n)=ID 13 ;Otherwise, three pieces are returned with the 14 ;first piece equal to the message ID, if one was assigned, otherwise 0 15 ; 16 ;Required Input Parameters 17 ; HLEID = Name or IEN of event driver protocol in the Protocol file 18 ; HLARYTYP = Array type. One of the following codes: 19 ; LM = local array containing a single message 20 ; LB = local array containig a batch of messages 21 ; GM = global array containing a single message 22 ; GB = global array containing a batch of messages 23 ; HLFORMAT = Format of array, 1 for pre-formatted in HL7 format, 24 ; otherwise 0 25 ;NOTE: The parameter HLRESLT must be passed by reference 26 ; HLRESLT = The variable that will be returned to the calling 27 ; application as descibed above 28 ;Optional Parameters 29 ; HLMTIEN = IEN of entry in Message Text file where the message 30 ; being generated is to be stored. This parameter is 31 ; only passed for a batch type message 32 ;NOTE: The parameter HLP used for the following parameters must be 33 ; passed by reference 34 ; HLP("SECURITY") = A 1 to 40 character string 35 ; HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string 36 ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91 37 ; HLP("EXLCLUDE SUBSCRIBER",<n=1,2,3...>)=<subsciber protocol ien> - A list of protocols to dynamically drop from the event protocol's subscriber multiple. 38 ; 39 ;can't have link open when generating new message 40 N HLTCP,HLTCPO,HLPRIO,HLMIDAR 41 S HLPRIO="D" 42 S HLRESLT="" 43 ;Check for required parameters 44 CONT I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" G EXIT 45 I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT 46 N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)="" 47 I "GL"'[$E(HLARYTYP) S HLRESLT="0^4^"_$G(^HL(771.7,4,0)) G EXIT 48 I $L($G(HLP("SECURITY")))>40 S HLRESLT="0^6^"_$G(^HL(771.7,6,0)) G EXIT 49 I $L($G(HLP("CONTPTR")))>180 S HLRESLT="0^11^"_$G(^HL(771.7,11,0)) G EXIT 50 I $D(HLL("LINKS")) D G:$G(HLRESLT)]"" EXIT 51 . N I,HLPNAM,HLPIEN,HLLNAM,HLLIEN 52 . S I=0 53 . F S I=$O(HLL("LINKS",I)) Q:'I D Q:$G(HLRESLT)]"" 54 . . S HLPNAM=$P(HLL("LINKS",I),U) 55 . . S HLPIEN=+$O(^ORD(101,"B",HLPNAM,0)) 56 . . I $P($G(^ORD(101,HLPIEN,0)),U,4)'="S" S HLRESLT="0^15^Invalid Subscriber Protocol in HLL('LINKS'): "_HLL("LINKS",I) Q 57 . . S HLLNAM=$P(HLL("LINKS",I),U,2) 58 . . S HLLIEN=+$O(^HLCS(870,"B",HLLNAM,0)) 59 . . I '$D(^HLCS(870,HLLIEN,0)) S HLRESLT="0^15^Invalid HL Node in HLL('LINKS'): "_HLL("LINKS",I) Q 60 ;Extract data from Protocol file 61 D EVENT^HLUTIL1(HLEID,"15,20,771",.HLN) 62 S HLENROU=$G(HLN(20)),HLEXROU=$G(HLN(15)) 63 S HLP("GROUTINE")=$G(HLN(771)) K HLN I HLP("GROUTINE")']"",'HLFORMAT S HLRESLT="0^3^"_$G(^HL(771.7,3,0)) G EXIT 64 ;Create message ID and Message Text IEN if Message Text IEN not 65 ;previously created ('$G(HLMTIEN)) 66 I '$G(HLMTIEN) D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) 67 ;Get message ID if Message Text IEN already created 68 I '$G(HLMID) D 69 .S HLDT=$G(^HL(772,HLMTIEN,0)),HLMID=$P(HLDT,"^",6),HLDT=+HLDT 70 .S HLDT1=$$HLDATE^HLFNC(HLDT) 71 S HLMIDAR=0,HLRESLT=HLMID,HLP("DT")=HLDT,HLP("DTM")=HLDT1 72 ;Execute entry action for event driver protocol 73 I HLENROU]"" X HLENROU 74 ;Invoke transaction processor 75 K HLDT,HLDT1,HLENROU 76 D GENERATE^HLTP(HLMID,HLMTIEN,HLEID,HLARYTYP,HLFORMAT,.HLRESLT1,.HLP) 77 ;HLMIDAR is array of message IDs, only set for broadcast messages 78 I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR 79 S HLRESLT=HLRESLT_"^"_HLRESLT1 80 ;Execute exit action for event driver protocol 81 I HLEXROU]"" X HLEXROU 82 EXIT ;Update status if Message Text file entry has been created 83 K HLTCP 84 I $D(HLMTIEN) D STATUS^HLTF0(HLMTIEN,$S($P(HLRESLT,"^",2):4,1:3),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",2),1:""),$S($P(HLRESLT,"^",2):$P(HLRESLT,"^",3),1:"")) 85 K HLDT,HLDT1,HLMID,HLRESLT1,HLENROU,HLEXROU 86 Q 87 DIRECT(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIENO,HLP) ; 88 ;Entry point to generate an immediate message, must be TCP Logical Link 89 ;Input: 90 ; The same as GENERATE,with one additional subscript to the HLP input array: 91 ; 92 ; HLP("OPEN TIMEOUT") (optional, pass by reference) a number between 93 ; 1 and 120 that specifies how many seconds the DIRECT CONNECT should 94 ; try to open a connection before failing. It is killed upon completion. 95 ; 96 N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT 97 S HLRESLT="" 98 ;HLMTIENO=ien passed in, batch message 99 S HLMTIEN=$G(HLMTIENO) 100 I $G(HLP("OPEN TIMEOUT")),((HLP("OPEN TIMEOUT")\1)'=+HLP("OPEN TIMEOUT"))!HLP("OPEN TIMEOUT")>120 Q "0^4^INVALID OPEN TIMEOUT PARAMETER" 101 I $G(HLP("OPEN TIMEOUT")) D 102 .S HLDIRECT("OPEN TIMEOUT")=HLP("OPEN TIMEOUT") 103 .K HLP("OPEN TIMEOUT") 104 K HL,HLMTIENO 105 D INIT^HLFNC2(HLEID,.HL) 106 I $G(HL) S HLRESLT="0^"_HL Q 107 S HLPRIO="I" D CONT 108 ;HLMTIENO=original msg. ien in file 772, HLMTIENR=response ien set in HLMA2 109 S HLMTIENO=HLMTIEN,HLMTIEN=$G(HLMTIENR) 110 ;Set special HL variables 111 S HLQUIT=0,HLNODE="",HLNEXT="D HLNEXT^HLCSUTL" 112 Q 113 ; 114 CLOSE(LOGLINK) ;close connection that was open in tag DIRECT 115 Q 116 PING ;ping another VAMC to test Link 117 ;set HLQUIET =1 to skip writes 118 ;look for HLTPUT to get turnaround time over network. 119 N DA,DIC,HLDP,HLDPNM,HLDPDM,HLCSOUT,HLDBSIZE,HLDREAD,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL,HLPARAM 120 N HCS,HCSCMD,HLCS,HCSDAT,HCSER,HCSEXIT,HCSTRACE,HLDT1,HLDRETR,HLRETRA,HLDBACK,HLDWAIT,HLTCPCS,INPUT,OUTPUT,POP,X,Y,HLX1,HLX2 121 S HLQUIET=$G(HLQUIET) 122 S HLCS="",HCSTRACE="C: ",POP=1,INPUT="INPUT",OUTPUT="OUTPUT" 123 S DIC="^HLCS(870,",DIC(0)="QEAMZ" 124 D ^DIC Q:Y<0 125 S HLDP=+Y,HLDPNM=Y(0,0),HLDPDM=$P($$PARAM^HLCS2,U,2) 126 ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q 127 D SETUP^HLCSAC G:HLCS PINGQ 128 ;PING header=MSH^PING^domain^PING^logical link^datetime 129 S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H) 130 D OPEN^HLCSAC 131 I HLCS D DNS G:HLCS PINGQ 132 D 133 . N $ETRAP,$ESTACK S $ETRAP="D PINGERR^HLMA" 134 . ;non-standard HL7 header; start block,header,end block 135 . S HLX1=$H 136 . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char 137 . ;read response 138 . R X:HLDREAD 139 . S HLX2=$H 140 . S X=$P(X,$C(28)),HLCS=$S(X=INPUT(1):"PING worked",X="":"No response",1:"Incorrect response") 141 . ;Get roundtrip time 142 . K HLTPUT I X]"" S HLTPUT=$$HDIFF^XLFDT(HLX2,HLX1,2) 143 D CLOSE^%ZISTCP 144 PINGQ ;write back status and quit 145 I 'HLQUIET W !,HLCS,! 146 Q 147 PINGERR ;process errors from PING 148 S $ETRAP="G UNWIND^%ZTER",HLCS="-1^Error" 149 ;I $ZE["READ" S HLCS="-1^Error during read" 150 ;I $ZE["WRITE" S HLCS="-1^Error during write" 151 ; HL*1.6*115, SACC compliance 152 I $$EC^%ZOSV["READ" S HLCS="-1^Error during read" 153 I $$EC^%ZOSV["WRITE" S HLCS="-1^Error during write" 154 G UNWIND^%ZTER 155 DNS ; 156 ;openfail-try DNS lookup-Link must contain point to Domain Name 157 S POP=$G(POP) 158 S HLQUIET=$G(HLQUIET) 159 I 'HLQUIET W !,"Calling DNS" 160 N HLDOM,HLIP S HLCS="" 161 S HLDOM=$P(^HLCS(870,HLDP,0),U,7) 162 I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q 163 I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U) 164 I HLDOM]"" D Q:'POP 165 . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV" 166 . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM 167 . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM 168 . I 'HLQUIET W !,"Domain, "_HLDOM 169 . I 'HLQUIET W !,"Port: ",HLTCPORT 170 . S HLIP=$$ADDRESS^XLFNSLK(HLDOM) 171 . I HLIP]"",'HLQUIET W !,"DNS Returned: ",HLIP 172 . I HLIP]"" D 173 . . ;If more than one IP returned, try each, cache successful open 174 . . N HLI,HLJ,HLIP1 175 . . F HLJ=1:1:$L(HLIP,",") D Q:'POP 176 . . . S HLIP1=$P(HLIP,",",HLJ) 177 . . . F HLI=1:1:HLDRETR W:'HLQUIET !,"Trying ",HLIP1 D CALL^%ZISTCP(HLIP1,HLTCPORT,1) Q:'POP 178 . . . I 'POP S $P(^HLCS(870,HLDP,400),U)=HLIP1 179 . . . U IO 180 I POP S HLCS="-1^DNS Lookup Failed"
Note:
See TracChangeset
for help on using the changeset viewer.
