source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m@ 701

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

revised back to 6/30/08 version

File size: 8.2 KB
Line 
1HLMA ;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.
4GENERATE(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
44CONT 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
82EXIT ;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
87DIRECT(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 ;
114CLOSE(LOGLINK) ;close connection that was open in tag DIRECT
115 Q
116PING ;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
144PINGQ ;write back status and quit
145 I 'HLQUIET W !,HLCS,!
146 Q
147PINGERR ;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
155DNS ;
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 TracBrowser for help on using the repository browser.