source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCDXMSG1.m@ 812

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1SCDXMSG1 ;ALB/JRP - AMB CARE MESSAGE BUILDER UTILS;08-MAY-1996 ; 6/21/05 2:08pm
2 ;;5.3;Scheduling;**44,55,70,77,85,66,143,142,162,172,180,239,245,254,293,325,387,459,472**;AUG 13, 1993
3 ;
4 ;-- Line tags for building HL7 segment
5BLDEVN S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,ENCNDT,VAFSTR,HL("Q"),HL("FS"))
6 ;SD*5.3*387 replaced EVNTDATE with ENCNDT
7 Q
8BLDPID S VAFPID=$$EN^VAFHLPID(DFN,VAFSTR)
9 D SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS"))
10 Q
11BLDZPD S VAFZPD=$$EN1^VAFHLZPD(DFN,VAFSTR)
12 D SETPOW^SCMSVUT0(DFN,.VAFZPD,HL("Q"),HL("FS"))
13 Q
14BLDPV1 D SETID^SCMSVUT0(ENCPTR,DELPTR)
15 S VAFPV1=$$EN^VAFHLPV1(ENCPTR,DELPTR,VAFSTR,1,HL("Q"),HL("FS"))
16 Q
17BLDDG1 K @VAFARRY
18 D EN^VAFHLDG1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
19 Q
20BLDPR1 K @VAFARRY
21 D SETPRTY^SCMSVUT0(ENCPTR)
22 D EN^VAFHLPR1(ENCPTR,VAFSTR,HL("Q"),HL("FS"),HL("ECH"),VAFARRY)
23 Q
24BLDZEL N ELCOD,ELIGENC,I,VAFMSTDT
25 S VAFMSTDT=ENCDT
26 D EN1^VAFHLZEL(DFN,VAFSTR,1,.VAFZEL)
27 S ELCOD=$P($G(^SCE(ENCPTR,0)),"^",13),ELIGENC=$P($G(^DIC(8,+ELCOD,0)),"^",9)
28 S $P(VAFZEL(1),HL("FS"),3)=ELIGENC
29 Q
30BLDZIR K DGREL,DGINC,DGINR,DGDEP
31 D ALL^DGMTU21(DFN,"V",ENCDT,"R")
32 S VAFZIR=$$EN^VAFHLZIR(+$G(DGINR("V")),VAFSTR,1,ENCPTR)
33 K DGREL,DGINC,DGINR,DGDEP
34 Q
35BLDZCL K @VAFARRY
36 D EN^VAFHLZCL(DFN,ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
37 Q
38BLDZSC K @VAFARRY
39 D EN^VAFHLZSC(ENCPTR,VAFSTR,HL("Q"),HL("FS"),VAFARRY)
40 Q
41BLDZSP S VAFZSP=$$EN^VAFHLZSP(DFN,1,1)
42 S VAFZSP=$$SETVSI^SCMSVUT0(DFN,$G(VAFZSP),HL("Q"),HL("FS"))
43 Q
44BLDROL K @VAFARRY
45 N SCDXPRV,SCDXPAR,SCDXROL,PTRPRV,NODE,PRVNUM,TMP
46 D GETPRV^SDOE(ENCPTR,"SCDXPRV")
47 S PTRPRV=0
48 F PRVNUM=1:1 S PTRPRV=+$O(SCDXPRV(PTRPRV)) Q:('PTRPRV) D
49 .K SCDXPAR,SCDXROL
50 .S NODE=SCDXPRV(PTRPRV)
51 .S SCDXPAR("PTR200")=+NODE
52 .S SCDXPAR("INSTID")=$$VID4XMIT^SCDXFU11(XMITPTR)_"-"_(+NODE)_"*"_PRVNUM
53 .S SCDXPAR("ACTION")="CO"
54 .S SCDXPAR("ALTROLE")=($TR($P(NODE,"^",4),"PS","10"))_$E(HL("ECH"),1)_HL("Q")_$E(HL("ECH"),1)_"VA01"
55 .S SCDXPAR("CODEONLY")=0
56 .S SCDXPAR("RDATE")=ENCDT
57 .D OUTPAT^VAFHLROL("SCDXPAR","SCDXROL",VAFSTR,HL("FS"),HL("ECH"),HL("Q"),240)
58 .K SCDXROL("ERROR"),SCDXROL("WARNING")
59 .M @VAFARRY@(PRVNUM)=SCDXROL
60 Q
61BLDPD1 S VAFPD1=$$EN^VAFHLPD1(DFN,VAFSTR)
62 Q
63BLDZEN S VAFZEN=$$EN^VAFHLZEN(DFN,VAFSTR,1,HL("Q"),HL("FS"))
64 Q
65 ;
66 ;-- Line tags for validating HL7 segments
67VLDEVN S ERROR=$$EN^SCMSVEVN(VAFEVN,HL("Q"),HL("FS"),VALERR)
68 S:(ERROR>0) ERROR=0
69 Q
70VLDPID S ERROR=$$EN^SCMSVPID(.VAFPID,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT,EVNTHL7)
71 S:(ERROR>0) ERROR=0
72 Q
73VLDZPD S ERROR=$$EN^SCMSVZPD(.VAFZPD,HL("Q"),HL("FS"),VALERR,ENCDT,NODE)
74 S:(ERROR>0) ERROR=0
75 Q
76VLDPV1 S ERROR=$$EN^SCMSVPV1(VAFPV1,HL("Q"),HL("FS"),VALERR,NODE,EVNTHL7,ENCNDT)
77 S:(ERROR>0) ERROR=0
78 Q
79VLDDG1 S ERROR=$$EN^SCMSVDG1(VAFARRY,HL("Q"),HL("FS"),ENCPTR,VALERR,ENCDT)
80 S:(ERROR>0) ERROR=0
81 Q
82VLDPR1 S ERROR=$$EN^SCMSVPR1(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR,ENCDT)
83 S:(ERROR>0) ERROR=0
84 Q
85VLDZEL S ERROR=$$EN^SCMSVZEL(.VAFZEL,HL("Q"),HL("FS"),VALERR,DFN)
86 S:(ERROR>0) ERROR=0
87 Q
88VLDZIR S ERROR=$$EN^SCMSVZIR(VAFZIR,HL("Q"),HL("FS"),VALERR)
89 S:(ERROR>0) ERROR=0
90 Q
91VLDZCL S ERROR=$$EN^SCMSVZCL(VAFARRY,HL("Q"),HL("FS"),VALERR,DFN)
92 S:(ERROR>0) ERROR=0
93 Q
94VLDZSC S ERROR=$$EN^SCMSVZSC(VAFARRY,HL("Q"),HL("FS"),VALERR,ENCPTR)
95 S:(ERROR>0) ERROR=0
96 Q
97VLDZSP S ERROR=$$EN^SCMSVZSP(VAFZSP,HL("Q"),HL("FS"),VALERR,DFN)
98 S:(ERROR>0) ERROR=0
99 Q
100VLDROL S ERROR=$$EN^SCMSVROL(VAFARRY,HL("Q"),HL("FS"),HL("ECH"),VALERR)
101 S:(ERROR>0) ERROR=0
102 Q
103VLDPD1 S ERROR=0
104 Q
105VLDZEN S ERROR=0
106 Q
107 ;
108 ;-- Line tags for copying HL7 segments into HL7 message
109CPYEVN N I
110 S @XMITARRY@(CURLINE)=VAFEVN
111 S LINESADD=LINESADD+1
112 S I=""
113 F S I=+$O(VAFEVN(I)) Q:('I) D
114 .S @XMITARRY@(CURLINE,I)=VAFEVN(I)
115 .S LINESADD=LINESADD+1
116 Q
117CPYPID N I
118 S @XMITARRY@(CURLINE)=VAFPID
119 S LINESADD=LINESADD+1
120 S I=""
121 F S I=+$O(VAFPID(I)) Q:('I) D
122 .S @XMITARRY@(CURLINE,I)=VAFPID(I)
123 .S LINESADD=LINESADD+1
124 Q
125CPYZPD N I
126 S @XMITARRY@(CURLINE)=VAFZPD
127 S LINESADD=LINESADD+1
128 S I=""
129 F S I=+$O(VAFZPD(I)) Q:('I) D
130 .S @XMITARRY@(CURLINE,I)=VAFZPD(I)
131 .S LINESADD=LINESADD+1
132 Q
133CPYPV1 N I
134 S @XMITARRY@(CURLINE)=VAFPV1
135 S LINESADD=LINESADD+1
136 S I=""
137 F S I=+$O(VAFPV1(I)) Q:('I) D
138 .S @XMITARRY@(CURLINE,I)=VAFPV1(I)
139 .S LINESADD=LINESADD+1
140 Q
141CPYDG1 N I,J,K
142 S I=""
143 F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
144 .S J=""
145 .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
146 ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
147 ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
148 ..S LINESADD=LINESADD+1
149 S CURLINE=CURLINE+K-1
150 Q
151CPYPR1 N I,J,K
152 S I=""
153 F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
154 .S J=""
155 .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
156 ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
157 ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
158 ..S LINESADD=LINESADD+1
159 S CURLINE=CURLINE+K-1
160 Q
161CPYZEL N I
162 S @XMITARRY@(CURLINE)=VAFZEL(1)
163 S LINESADD=LINESADD+1
164 S I=""
165 F S I=+$O(VAFZEL(1,I)) Q:('I) D
166 .S @XMITARRY@(CURLINE,I)=VAFZEL(1,I)
167 .S LINESADD=LINESADD+1
168 Q
169CPYZIR N I
170 S @XMITARRY@(CURLINE)=VAFZIR
171 S LINESADD=LINESADD+1
172 N I
173 S I=""
174 F S I=+$O(VAFZIR(I)) Q:('I) D
175 .S @XMITARRY@(CURLINE,I)=VAFZIR(I)
176 .S LINESADD=LINESADD+1
177 Q
178CPYZCL N I,J,K
179 S I=""
180 F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
181 .S J=""
182 .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
183 ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
184 ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
185 ..S LINESADD=LINESADD+1
186 S CURLINE=CURLINE+K-1
187 Q
188CPYZSC N I,J,K
189 S I=""
190 F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
191 .S J=""
192 .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
193 ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
194 ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
195 ..S LINESADD=LINESADD+1
196 S CURLINE=CURLINE+K-1
197 Q
198CPYZSP N I
199 S @XMITARRY@(CURLINE)=VAFZSP
200 S LINESADD=LINESADD+1
201 S I=""
202 F S I=+$O(VAFZSP(I)) Q:('I) D
203 .S @XMITARRY@(CURLINE,I)=VAFZSP(I)
204 .S LINESADD=LINESADD+1
205 Q
206CPYROL N I,J,K
207 S I=""
208 F K=0:1 S I=+$O(@VAFARRY@(I)) Q:('I) D
209 .S J=""
210 .F S J=$O(@VAFARRY@(I,J)) Q:(J="") D
211 ..S:('J) @XMITARRY@(CURLINE+K)=@VAFARRY@(I,J)
212 ..S:(J) @XMITARRY@(CURLINE+K,J)=@VAFARRY@(I,J)
213 ..S LINESADD=LINESADD+1
214 S CURLINE=CURLINE+K-1
215 Q
216CPYPD1 N I
217 S @XMITARRY@(CURLINE)=VAFPD1
218 S LINESADD=LINESADD+1
219 S I=""
220 F S I=+$O(VAFPD1(I)) Q:('I) D
221 .S @XMITARRY@(CURLINE,I)=VAFPD1(I)
222 .S LINESADD=LINESADD+1
223 Q
224CPYZEN N I
225 S @XMITARRY@(CURLINE)=VAFZEN
226 S LINESADD=LINESADD+1
227 S I=""
228 F S I=+$O(VAFZEN(I)) Q:('I) D
229 .S @XMITARRY@(CURLINE,I)=VAFZEN(I)
230 .S LINESADD=LINESADD+1
231 Q
232 ;
233 ;-- Line tags for deleting HL7 segments
234DELEVN K VAFEVN
235 Q
236DELPID K VAFPID
237 Q
238DELZPD K VAFZPD
239 Q
240DELPV1 K VAFPV1
241 Q
242DELDG1 K @VAFARRY
243 Q
244DELPR1 K @VAFARRY
245 Q
246DELZEL K VAFZEL
247 Q
248DELZIR K VAFZIR
249 Q
250DELZCL K @VAFARRY
251 Q
252DELZSC K @VAFARRY
253 Q
254DELZSP K VAFZSP
255 Q
256DELROL K @VAFARRY
257 Q
258DELPD1 K VAFPD1
259 Q
260DELZEN K VAFZEN
261 Q
262 ;
263 ;
264SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given
265 ; event type
266 ;
267 ;Input : EVNTTYPE - Event type to build list for
268 ; A08 & A23 are the only types currently supported
269 ; (Defaults to A08)
270 ; SEGARRY - Array to place output in (full global reference)
271 ; (Defaults to ^TMP("SCDX SEGMENTS",$J))
272 ;Output : None
273 ; SEGARRY(Seq,Name) = Fields
274 ; Seq - Sequencing number to order the segments as
275 ; they should be placed in the HL7 message
276 ; Name - Name of HL7 segment
277 ; Fields - List of fields used by Ambulatory Care
278 ; VAFSTR would be set to this value
279 ; : MSH segment is not included
280 ;
281 ;Check input
282 S EVNTTYPE=$G(EVNTTYPE)
283 S:(EVNTTYPE'="A23") EVNTTYPE="A08"
284 S SEGARRY=$G(SEGARRY)
285 S:(SEGARRY="") SEGARRY="^TMP(""SCDX SEGMENTS"","_$J_")"
286 ;Segments used by A08 & A23
287 S @SEGARRY@(1,"EVN")="1,2"
288 S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10N,11PC,13,14,16,17,19,22N"
289 S @SEGARRY@(3,"PD1")="3,4"
290 S @SEGARRY@(4,"PV1")="1,2,4,14,19,39,44,50"
291 ;Building list for A23 - add ZPD segment and quit
292 I (EVNTTYPE="A23") D Q
293 .S @SEGARRY@(5,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,40"
294 S @SEGARRY@(5,"DG1")="1,2,3,4,5,15"
295 S @SEGARRY@(6,"PR1")="1,3,16"
296 S @SEGARRY@(7,"ROL")="1,2,3,4"
297 S @SEGARRY@(8,"ZPD")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,40"
298 S @SEGARRY@(9,"ZEL")="1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,29,37,38"
299 S @SEGARRY@(10,"ZIR")="1,2,3,4,5,6,7,8,9,10,11,12,13"
300 S @SEGARRY@(11,"ZCL")="1,2,3"
301 S @SEGARRY@(12,"ZSC")="1,2,3"
302 S @SEGARRY@(13,"ZSP")="1,2,3,4"
303 S @SEGARRY@(14,"ZEN")="1,2,3,4,5,6,7,8,9,10"
304 Q
305 ;
306UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into HL7 message
307 ;
308 ;Input : XMITARRY - Array containing HL7 message (full global ref)
309 ; (Defaults to ^TMP("HLS",$J))
310 ; INSRTPNT - Where to begin deletion from (Defaults to 1)
311 ;Output : None
312 ;
313 ;Check input
314 S XMITARRY=$G(XMITARRY)
315 S:(XMITARRY="") XMITARRY="^TMP(""HLS"","_$J_")"
316 S INSRTPNT=$G(INSRTPNT)
317 S:(INSRTPNT="") INSRTPNT=1
318 ;Remove insertion point from array
319 K @XMITARRY@(INSRTPNT)
320 ;Remove everything from insertion point to end of array
321 F S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:(INSRTPNT="") K @XMITARRY@(INSRTPNT)
322 ;Done
323 Q
Note: See TracBrowser for help on using the repository browser.