| [636] | 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
|
|---|
| [628] | 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
|
|---|
| [636] | 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.
|
|---|
| [628] | 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
|
|---|
| [636] | 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
|
|---|
| [628] | 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:
|
|---|
| [636] | 90 | ; The same as GENERATE,with one additional subscript to the HLP input array:
|
|---|
| [628] | 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
|
|---|
| [636] | 94 | ; try to open a connection before failing. It is killed upon completion.
|
|---|
| [628] | 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
|
|---|
| [636] | 136 | . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
|
|---|
| [628] | 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)
|
|---|
| [636] | 162 | I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
|
|---|
| [628] | 163 | I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
|
|---|
| [636] | 164 | I HLDOM]"" D Q:'POP
|
|---|
| [628] | 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"
|
|---|
