source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFHLUT.m@ 811

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

initial load of FOIAVistA 6/30/08 version
File size: 7.5 KB
Line 
1DGPFHLUT ;ALB/RPM - PRF HL7 UTILITIES ; 5/31/05 3:45pm
2 ;;5.3;Registration;**425,650**;Aug 13, 1993;Build 3
3 ;This routine contains generic utilities used when building
4 ;or processing received patient record flag HL7 messages.
5 ;
6 Q ;no supported direct entry
7 ;
8INIT(DGPROT,DGHL) ;Kernel HL7 INIT wrapper
9 ;
10 ; Supported DBIA #2161: The supported DBIA is used to access the
11 ; VistA HL7 API to initialize the HL7 environ-
12 ; ment variables.
13 ;
14 ; Input:
15 ; DGPROT - Event protocol name
16 ;
17 ; Output:
18 ; Function value - HLEID on success;0 on failure
19 ; DGHL - HL array from INIT^HLFNC2 Kernel call
20 ;
21 N DGHLEID
22 S DGHLEID=0
23 S DGHLEID=$$HLEID(DGPROT)
24 I DGHLEID D
25 . D INIT^HLFNC2(DGHLEID,.DGHL)
26 . I $O(DGHL(""))="" S DGHLEID=0
27 Q DGHLEID
28 ;
29HLEID(DGPROT) ;return IEN of HL7 protocol
30 ;
31 ; Input:
32 ; DGPROT - Protocol name
33 ;
34 ; Output:
35 ; Function value - IEN of protocol on success, 0 on failure
36 ;
37 I $G(DGPROT)="" Q 0
38 Q +$O(^ORD(101,"B",DGPROT,0))
39 ;
40GETLINK(DGINST) ;retrieve a single link for a given institution
41 ;
42 ; Supported DBIA #2271: The supported DBIA is used to access the
43 ; VistA HL7 API to retrieve logical links
44 ; given a pointer to the INSTITUTION (#4) file.
45 ;
46 ; Input:
47 ; DGINST - IEN of site in INSTITUTION (#4) file
48 ;
49 ; Output:
50 ; Function Value - HL Logical link on success, 0 on failure
51 ;
52 N DGLINKS
53 N DGLNK
54 N DGRSLT
55 ;
56 S DGRSLT=0
57 I $G(DGINST)>0 D
58 . D LINK^HLUTIL3(DGINST,.DGLINKS)
59 . S DGLNK=$O(DGLINKS(0))
60 . S DGRSLT=$S(DGLNK>0:DGLINKS(DGLNK),1:0)
61 Q DGRSLT
62 ;
63BLDTEXT(DGWP,DGHL,DGARR) ;Build HL7 word proc text array
64 ;
65 ; Supported DBIA #10104: The supported DBIA is used to access KERNEL
66 ; string functions.
67 ;
68 ; Input:
69 ; DGWP - Word processing closed root
70 ; DGHL - HL7 environment array
71 ;
72 ; Output:
73 ; Function Value - count of segment array elements on success,
74 ; 0 on failure
75 ; DGARR - array of segment text data
76 ;
77 N DGLIN ;word processing line iterator
78 N DGCNT ;text segment counter
79 N DGTXT ;word processing text
80 N DGBLK ;blank line counter
81 N DGREP ;HL7 repetition character
82 ;
83 S DGLIN=0
84 S DGCNT=0
85 S DGBLK=0
86 S DGREP=$E(DGHL("ECH"),2)
87 ;
88 F S DGLIN=$O(@DGWP@(DGLIN)) Q:'DGLIN D
89 . S DGTXT=$G(@DGWP@(DGLIN,0))
90 . S DGTXT=$$STRIPTS^DGPFHLUT(DGTXT) ;strip trailing spaces
91 . I DGTXT?1.PC!(DGTXT="") S DGBLK=DGBLK+1 Q
92 . S DGCNT=DGCNT+1
93 . I DGBLK D
94 . . S DGARR(DGCNT)=$$REPEAT^XLFSTR(DGREP,DGBLK)_DGTXT
95 . . S DGBLK=0
96 . E S DGARR(DGCNT)=DGTXT
97 Q DGCNT
98 ;
99NXTSEG(DGROOT,DGCURR,DGFS,DGFLD) ;retrieves next sequential segment
100 ; This function retrieves the next segment in the work global, returns
101 ; an array of field values and the segment's work global index. If
102 ; the next segment does not exist, then the function returns a zero.
103 ;
104 ; Input:
105 ; DGROOT - close root name of work global
106 ; DGCURR - index of current segment
107 ; DGFS - HL7 field separator character
108 ;
109 ; Output:
110 ; Function Value - index of the next segment on success, 0 on failure
111 ; DGFLD - array of segment field values
112 ;
113 N NXTSEG
114 ;
115 S DGCURR=DGCURR+1
116 S NXTSEG=$G(@DGROOT@(DGCURR,0))
117 I NXTSEG]"" D
118 . D GETFLDS(NXTSEG,DGFS,.DGFLD)
119 E D
120 . S DGCURR=0
121 Q DGCURR
122 ;
123GETFLDS(DGSEG,DGFS,DGFLD) ;retrieve HL7 segment fields into an array
124 ;This procedure parses a single HL7 segment and builds an array
125 ;subscripted by the field number that contains the data for that field.
126 ;An additional subscript node, "TYPE" is created containing the segment
127 ;type.
128 ;
129 ; Input:
130 ; DGSEG - HL7 segment to parse
131 ; DGFS - HL7 field separator
132 ;
133 ; Output:
134 ; DGFLD - array of segment field values subscripted by field #
135 ; Example: DGFLD(2)="DOE,JOHN"
136 ;
137 N DGI
138 ;
139 S DGFLD("TYPE")=$P(DGSEG,DGFS)
140 F DGI=2:1:$L(DGSEG,DGFS) D
141 . S DGFLD($S(DGFLD("TYPE")="MSH":DGI,1:DGI-1))=$P(DGSEG,DGFS,DGI)
142 Q
143 ;
144STRIPTS(DGSTR) ;Strip trailing spaces from a line of text
145 ;
146 ; Input:
147 ; DGSTR - Text string
148 ;
149 ; Output:
150 ; Function Value - Input text string with trailing spaces removed
151 ;
152 N SPACE
153 S SPACE=$C(32)
154 F Q:$E(DGSTR,$L(DGSTR))'=SPACE S DGSTR=$E(DGSTR,1,$L(DGSTR)-1)
155 Q DGSTR
156 ;
157BLDSEG(DGTYP,DGVAL,DGHL) ;generic segment builder
158 ;
159 ; Input:
160 ; DGTYP - segment type
161 ; DGVAL - field data array [SUB1:field, SUB2:repetition,
162 ; SUB3:component, SUB4:sub-component]
163 ; DGHL - HL7 environment array
164 ;
165 ; Output:
166 ; Function Value - Formatted HL7 segment on success, "" on failure
167 ;
168 N DGCMP ;component subscript
169 N DGCMPVAL ;component value
170 N DGFLD ;field subscript
171 N DGFLDVAL ;field value
172 N DGREP ;repetition subscript
173 N DGREPVAL ;repetition value
174 N DGSUB ;sub-component subscript
175 N DGSUBVAL ;suc-component value
176 N DGFS ;field separator
177 N DGCS ;component separator
178 N DGRS ;repetition separator
179 N DGSS ;sub-component separator
180 N DGSEG
181 N DGSEP
182 ;
183 Q:($G(DGTYP)']"") ""
184 ;
185 S DGSEG=DGTYP
186 S DGFS=DGHL("FS")
187 S DGCS=$E(DGHL("ECH"))
188 S DGRS=$E(DGHL("ECH"),2)
189 S DGSS=$E(DGHL("ECH"),4)
190 ;
191 F DGFLD=1:1:$O(DGVAL(""),-1) D
192 . S DGFLDVAL=$G(DGVAL(DGFLD)),DGSEP=DGFS
193 . D ADD(DGFLDVAL,DGSEP,.DGSEG)
194 . F DGREP=1:1:$O(DGVAL(DGFLD,""),-1) D
195 . . S DGREPVAL=$G(DGVAL(DGFLD,DGREP))
196 . . S DGSEP=$S(DGREP=1:"",1:DGRS)
197 . . D ADD(DGREPVAL,DGSEP,.DGSEG)
198 . . F DGCMP=1:1:$O(DGVAL(DGFLD,DGREP,""),-1) D
199 . . . S DGCMPVAL=$G(DGVAL(DGFLD,DGREP,DGCMP))
200 . . . S DGSEP=$S(DGCMP=1:"",1:DGCS)
201 . . . D ADD(DGCMPVAL,DGSEP,.DGSEG)
202 . . . F DGSUB=1:1:$O(DGVAL(DGFLD,DGREP,DGCMP,""),-1) D
203 . . . . S DGSUBVAL=$G(DGVAL(DGFLD,DGREP,DGCMP,DGSUB))
204 . . . . S DGSEP=$S(DGSUB=1:"",1:DGSS)
205 . . . . D ADD(DGSUBVAL,DGSEP,.DGSEG)
206 Q DGSEG
207 ;
208ADD(DGVAL,DGSEP,DGSEG) ;append a value onto segment
209 ;
210 ; Input:
211 ; DGVAL - value to append
212 ; DGSEP - HL7 separator
213 ;
214 ; Output:
215 ; DGSEG - segment passed by reference
216 ;
217 S DGSEP=$G(DGSEP)
218 S DGVAL=$G(DGVAL)
219 S DGSEG=DGSEG_DGSEP_DGVAL
220 Q
221 ;
222CKSTR(DGFLDS,DGSTR) ;validate comma-delimited HL7 field string
223 ;
224 ; Input:
225 ; DGFLDS - (required) comma delimited string of required fields
226 ; DGSTR - (optional) comma delimited string of fields to include
227 ; in an HL7 segment.
228 ;
229 ; Output:
230 ; Function Value - validated string of fields
231 ;
232 N DGI ;generic index
233 N DGREQ ;required field
234 ;
235 Q:($G(DGFLDS)']"") ""
236 S DGSTR=$G(DGSTR)
237 F DGI=1:1 S DGREQ=$P(DGFLDS,",",DGI) Q:DGREQ="" D
238 . I ","_DGSTR_","'[(","_DGREQ_",") S DGSTR=DGSTR_$S($L(DGSTR)>0:",",1:"")_DGREQ
239 Q DGSTR
240 ;
241CONVMID(DGID) ;convert #772 msgid to #773 msgid
242 ;This function takes the HL7 message ID from the DIRECT^HLMA API result,
243 ;which is based on the HL7 MESSAGE TEXT (#772) file IEN and converts it
244 ;into a message ID based on the HL7 MESSAGE ADMINISTRATION (#773) file.
245 ;
246 ; Integration Agreements:
247 ; #4564 - allows access to the "C" index of HL7 MESSAGE TEXT (#772)
248 ; #4669 - allows access to the "B" index and MESSAGE ID (#2) field
249 ; of HL7 MESSAGE ADMINISTRATION (#773) file.
250 ; Input:
251 ; DGID - HL7 message id returned from DIRECT^HLMA
252 ;
253 ; Output:
254 ; Function value - returns HL7 message control ID from HL MESSAGE
255 ; ADMINISTRATION (#773) file on success;
256 ; 0 on failure
257 ;
258 N DG772 ;HL7 MESSAGE TEXT (#772) file IEN
259 N DG773 ;HL7 MESSAGE ADMINISTRATION (#773) file IEN
260 N DGERR ;FM error array
261 N DGMCID ;message ID
262 ;
263 S DG772=+$O(^HL(772,"C",+$G(DGID),0))
264 S DG773=+$O(^HLMA("B",DG772,0))
265 S DGMCID=+$$GET1^DIQ(773,DG773_",",2,"I","","DGERR")
266 Q $S(DGMCID&('$D(DGERR)):DGMCID,1:0)
Note: See TracBrowser for help on using the repository browser.