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

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

initial load of WorldVistAEHR
File size: 8.5 KB
RevLine 
[613]1VAFHLZM1 ;BAY/JAT - Create HL7 Military History segment (ZMH) Cont ; 9/20/00 11:51am
2 ;;5.3;Registration;**314,673**;Aug 13, 1993
3 ;
4 ; This routine creates HL7 VA-specific Military History ("ZMH") segments
5 ; It is a continuation of VAFHLZMH and uses those variables.
6 ;
7 Q
8ENTER ;
9 N VAFSETID ;seg setid
10 S VAFSETID=0
11 N VAFNUM
12 ;build segments as requested in VAFTYPE
13 F VAFX=1:1 S VAFZ=$P(VAFTYPE,",",VAFX) Q:VAFZ="" D
14 .S VAFY=""
15 .S VAFINDX=(VAFINDX\1)+1
16 .S VAFSETID=VAFSETID+1
17 .S $P(VAFY,VAFHLS,1)=VAFSETID
18 .S VAFTAG=$S(VAFZ=1:"SL",VAFZ=2:"SNL",VAFZ=3:"SNNL",VAFZ=4:"POW",VAFZ=5:"COMB",VAFZ=6:"VIET",VAFZ=7:"LEBA",VAFZ=8:"GREN",VAFZ=9:"PANA",VAFZ=10:"GULF",VAFZ=11:"SOMA",VAFZ=12:"YUGO",VAFZ=13:"PH",VAFZ=14:"OEIF",1:"NOSEG")
19 .D @VAFTAG
20 .;if mult episodes, add decimal to output array subscript (Ex: 14.001)
21 .I $D(VAFY(2)) D
22 ..S VAFNUM=0
23 ..F S VAFNUM=$O(VAFY(VAFNUM)) Q:'$G(VAFNUM) D
24 ...S VAFINDX=VAFINDX+.001
25 ...;if >1 conflict then increment seg setid
26 ...I VAFNUM>1 S VAFSETID=VAFSETID+1 S $P(VAFY(VAFNUM),VAFHLS,1)=VAFSETID
27 ...S @VAFARRAY@(VAFINDX,0)="ZMH"_VAFHLS_$G(VAFY(VAFNUM))
28 .;if not mult episodes
29 .I '$D(VAFY(2)) S @VAFARRAY@(VAFINDX,0)="ZMH"_VAFHLS_$G(VAFY)
30 .K VAFY
31 Q
32SL ; last Service branch
33 S $P(VAFY,VAFHLS,2)="SL"
34 N VAF325,VAF328,VAF324,VAF326,VAF327,VAFSCL
35 I VAFSTR[",3," D
36 .S VAF325=$P(VAF32N,U,5) S VAF325=$S(VAF325:$P($G(^DIC(23,VAF325,0)),U),1:VAFHLQ)
37 .S VAF328=$P(VAF32N,U,8) I VAF328="" S VAF328=VAFHLQ
38 .S VAF324=$P(VAF32N,U,4) S VAF324=$S(VAF324:$P($G(^DIC(25,VAF324,0)),U),1:VAFHLQ)
39 .; Service branch~Service number~Service discharge type
40 .S $P(VAFY,VAFHLS,3)=VAF325_$E(VAFHLC)_VAF328_$E(VAFHLC)_VAF324
41 I VAFSTR[",4," D
42 .S VAF326=$P(VAF32N,U,6) S VAF326=$S(VAF326:$$HLDATE^HLFNC(VAF326),1:VAFHLQ)
43 .S VAF327=$P(VAF32N,U,7) S VAF327=$S(VAF327:$$HLDATE^HLFNC(VAF327),1:VAFHLQ)
44 .; Service entry date~Service separation date
45 .S $P(VAFY,VAFHLS,4)=VAF326_$E(VAFHLC)_VAF327
46 I VAFSTR[",5," D
47 .; Service Component [L]
48 .S VAFSCL=$P(VAF3291N,U,1) I VAFSCL="" S VAFSCL=VAFHLQ
49 .S $P(VAFY,VAFHLS,5)=VAFSCL
50 Q
51SNL ; next to last Service branch
52 S $P(VAFY,VAFHLS,2)="SNL"
53 N VAF3291,VAF3294,VAF329,VAF3292,VAF3293,VAFSCNL
54 I VAFSTR[",3," D
55 .S VAF3291=$P(VAF32N,U,10) S VAF3291=$S(VAF3291:$P($G(^DIC(23,VAF3291,0)),U),1:VAFHLQ)
56 .S VAF3294=$P(VAF32N,U,13) I VAF3294="" S VAF3294=VAFHLQ
57 .S VAF329=$P(VAF32N,U,9) S VAF329=$S(VAF329:$P($G(^DIC(25,VAF329,0)),U),1:VAFHLQ)
58 .S $P(VAFY,VAFHLS,3)=VAF3291_$E(VAFHLC)_VAF3294_$E(VAFHLC)_VAF329
59 I VAFSTR[",4," D
60 .S VAF3292=$P(VAF32N,U,11) S VAF3292=$S(VAF3292:$$HLDATE^HLFNC(VAF3292),1:VAFHLQ)
61 .S VAF3293=$P(VAF32N,U,12) S VAF3293=$S(VAF3293:$$HLDATE^HLFNC(VAF3293),1:VAFHLQ)
62 .S $P(VAFY,VAFHLS,4)=VAF3292_$E(VAFHLC)_VAF3293
63 I VAFSTR[",5," D
64 .; Service Component [NL]
65 .S VAFSCNL=$P(VAF3291N,U,2) I VAFSCNL="" S VAFSCNL=VAFHLQ
66 .S $P(VAFY,VAFHLS,5)=VAFSCNL
67 Q
68SNNL ; next to next to last Service branch
69 S $P(VAFY,VAFHLS,2)="SNNL"
70 N VAF3296,VAF3299,VAF3295,VAF3297,VAF3298,VAFSCNNL
71 I VAFSTR[",3," D
72 .S VAF3296=$P(VAF32N,U,15) S VAF3296=$S(VAF3296:$P($G(^DIC(23,VAF3296,0)),U),1:VAFHLQ)
73 .S VAF3299=$P(VAF32N,U,18) I VAF3299="" S VAF3299=VAFHLQ
74 .S VAF3295=$P(VAF32N,U,14) S VAF3295=$S(VAF3295:$P($G(^DIC(25,VAF3295,0)),U),1:VAFHLQ)
75 .S $P(VAFY,VAFHLS,3)=VAF3296_$E(VAFHLC)_VAF3299_$E(VAFHLC)_VAF3295
76 I VAFSTR[",4," D
77 .S VAF3297=$P(VAF32N,U,16) S VAF3297=$S(VAF3297:$$HLDATE^HLFNC(VAF3297),1:VAFHLQ)
78 .S VAF3298=$P(VAF32N,U,17) S VAF3298=$S(VAF3298:$$HLDATE^HLFNC(VAF3298),1:VAFHLQ)
79 .S $P(VAFY,VAFHLS,4)=VAF3297_$E(VAFHLC)_VAF3298
80 I VAFSTR[",5," D
81 .; Service Component [NNL]
82 .S VAFSCNNL=$P(VAF3291N,U,3) I VAFSCNNL="" S VAFSCNNL=VAFHLQ
83 .S $P(VAFY,VAFHLS,5)=VAFSCNNL
84 Q
85POW ; Prisoner of War
86 S $P(VAFY,VAFHLS,2)="POW"
87 N VAF525,VAF526,VAF527,VAF528
88 I VAFSTR[",3," D
89 .S VAF525=$P(VAF52N,U,5) I VAF525="" S VAF525=VAFHLQ
90 .;S VAF526=$P(VAF52N,U,6) S VAF526=$S(VAF526:$P($G(^DIC(22,VAF526,0)),U),1:VAFHLQ)
91 .; translate pointer to coded value for VA0023 table
92 .S VAF526=$P(VAF52N,U,6) S VAF526=$S(VAF526>0&(VAF526<7):VAF526+3,VAF526>6&(VAF526<9):$C(VAF526+58),1:VAFHLQ)
93 .S $P(VAFY,VAFHLS,3)=VAF525_$E(VAFHLC)_VAF526
94 I VAFSTR[",4," D
95 .S VAF527=$P(VAF52N,U,7) S VAF527=$S(VAF527:$$HLDATE^HLFNC(VAF527),1:VAFHLQ)
96 .S VAF528=$P(VAF52N,U,8) S VAF528=$S(VAF528:$$HLDATE^HLFNC(VAF528),1:VAFHLQ)
97 .S $P(VAFY,VAFHLS,4)=VAF527_$E(VAFHLC)_VAF528
98 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
99 Q
100COMB ; Combat
101 S $P(VAFY,VAFHLS,2)="COMB"
102 N VAF5291,VAF5292,VAF5293,VAF5294
103 I VAFSTR[",3," D
104 .S VAF5291=$P(VAF52N,U,11) I VAF5291="" S VAF5291=VAFHLQ
105 .S VAF5292=$P(VAF52N,U,12) S VAF5292=$S(VAF5292:$P($G(^DIC(22,VAF5292,0)),U),1:VAFHLQ)
106 .S $P(VAFY,VAFHLS,3)=VAF5291_$E(VAFHLC)_VAF5292
107 I VAFSTR[",4," D
108 .S VAF5293=$P(VAF52N,U,13) S VAF5293=$S(VAF5293:$$HLDATE^HLFNC(VAF5293),1:VAFHLQ)
109 .S VAF5294=$P(VAF52N,U,14) S VAF5294=$S(VAF5294:$$HLDATE^HLFNC(VAF5294),1:VAFHLQ)
110 .S $P(VAFY,VAFHLS,4)=VAF5293_$E(VAFHLC)_VAF5294
111 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
112 Q
113VIET ; Vietnam
114 S $P(VAFY,VAFHLS,2)="VIET"
115 N VAF32101,VAF32104,VAF32105
116 I VAFSTR[",3," D
117 .S VAF32101=$P(VAF321N,U) I VAF32101="" S VAF32101=VAFHLQ
118 .S $P(VAFY,VAFHLS,3)=VAF32101
119 I VAFSTR[",4," D
120 .S VAF32104=$P(VAF321N,U,4) S VAF32104=$S(VAF32104:$$HLDATE^HLFNC(VAF32104),1:VAFHLQ)
121 .S VAF32105=$P(VAF321N,U,5) S VAF32105=$S(VAF32105:$$HLDATE^HLFNC(VAF32105),1:VAFHLQ)
122 .S $P(VAFY,VAFHLS,4)=VAF32104_$E(VAFHLC)_VAF32105
123 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
124 Q
125LEBA ; Lebanon
126 S $P(VAFY,VAFHLS,2)="LEBA"
127 N VAF3221,VAF3222,VAF3223
128 I VAFSTR[",3," D
129 .S VAF3221=$P(VAF322N,U) I VAF3221="" S VAF3221=VAFHLQ
130 .S $P(VAFY,VAFHLS,3)=VAF3221
131 I VAFSTR[",4," D
132 .S VAF3222=$P(VAF322N,U,2) S VAF3222=$S(VAF3222:$$HLDATE^HLFNC(VAF3222),1:VAFHLQ)
133 .S VAF3223=$P(VAF322N,U,3) S VAF3223=$S(VAF3223:$$HLDATE^HLFNC(VAF3223),1:VAFHLQ)
134 .S $P(VAFY,VAFHLS,4)=VAF3222_$E(VAFHLC)_VAF3223
135 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
136 Q
137GREN ; Grenada
138 S $P(VAFY,VAFHLS,2)="GREN"
139 N VAF3224,VAF3225,VAF3226
140 I VAFSTR[",3," D
141 .S VAF3224=$P(VAF322N,U,4) I VAF3224="" S VAF3224=VAFHLQ
142 .S $P(VAFY,VAFHLS,3)=VAF3224
143 I VAFSTR[",4," D
144 .S VAF3225=$P(VAF322N,U,5) S VAF3225=$S(VAF3225:$$HLDATE^HLFNC(VAF3225),1:VAFHLQ)
145 .S VAF3226=$P(VAF322N,U,6) S VAF3226=$S(VAF3226:$$HLDATE^HLFNC(VAF3226),1:VAFHLQ)
146 .S $P(VAFY,VAFHLS,4)=VAF3225_$E(VAFHLC)_VAF3226
147 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
148 Q
149PANA ; Panama
150 S $P(VAFY,VAFHLS,2)="PANA"
151 N VAF3227,VAF3228,VAF3229
152 I VAFSTR[",3," D
153 .S VAF3227=$P(VAF322N,U,7) I VAF3227="" S VAF3227=VAFHLQ
154 .S $P(VAFY,VAFHLS,3)=VAF3227
155 I VAFSTR[",4," D
156 .S VAF3228=$P(VAF322N,U,8) S VAF3228=$S(VAF3228:$$HLDATE^HLFNC(VAF3228),1:VAFHLQ)
157 .S VAF3229=$P(VAF322N,U,9) S VAF3229=$S(VAF3229:$$HLDATE^HLFNC(VAF3229),1:VAFHLQ)
158 .S $P(VAFY,VAFHLS,4)=VAF3228_$E(VAFHLC)_VAF3229
159 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
160 Q
161GULF ; Persian Gulf
162 S $P(VAFY,VAFHLS,2)="GULF"
163 N VAF32201,VA322011,VA322012
164 I VAFSTR[",3," D
165 .S VAF32201=$P(VAF322N,U,10) I VAF32201="" S VAF32201=VAFHLQ
166 .S $P(VAFY,VAFHLS,3)=VAF32201
167 I VAFSTR[",4," D
168 .S VA322011=$P(VAF322N,U,11) S VA322011=$S(VA322011:$$HLDATE^HLFNC(VA322011),1:VAFHLQ)
169 .S VA322012=$P(VAF322N,U,12) S VA322012=$S(VA322012:$$HLDATE^HLFNC(VA322012),1:VAFHLQ)
170 .S $P(VAFY,VAFHLS,4)=VA322011_$E(VAFHLC)_VA322012
171 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
172 Q
173SOMA ; Somalia
174 S $P(VAFY,VAFHLS,2)="SOMA"
175 N VA322016,VA322017,VA322018
176 I VAFSTR[",3," D
177 .S VA322016=$P(VAF322N,U,16) I VA322016="" S VA322016=VAFHLQ
178 .S $P(VAFY,VAFHLS,3)=VA322016
179 I VAFSTR[",4," D
180 .S VA322017=$P(VAF322N,U,17) S VA322017=$S(VA322017:$$HLDATE^HLFNC(VA322017),1:VAFHLQ)
181 .S VA322018=$P(VAF322N,U,18) S VA322018=$S(VA322018:$$HLDATE^HLFNC(VA322018),1:VAFHLQ)
182 .S $P(VAFY,VAFHLS,4)=VA322017_$E(VAFHLC)_VA322018
183 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
184 Q
185YUGO ; Yugoslavia
186 S $P(VAFY,VAFHLS,2)="YUGO"
187 N VA322019,VA32202,VA322021
188 I VAFSTR[",3," D
189 .S VA322019=$P(VAF322N,U,19) I VA322019="" S VA322019=VAFHLQ
190 .S $P(VAFY,VAFHLS,3)=VA322019
191 I VAFSTR[",4," D
192 .S VA32202=$P(VAF322N,U,20) S VA32202=$S(VA32202:$$HLDATE^HLFNC(VA32202),1:VAFHLQ)
193 .S VA322021=$P(VAF322N,U,21) S VA322021=$S(VA322021:$$HLDATE^HLFNC(VA322021),1:VAFHLQ)
194 .S $P(VAFY,VAFHLS,4)=VA32202_$E(VAFHLC)_VA322021
195 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
196 Q
197PH ; Purple Heart Recipent
198 S $P(VAFY,VAFHLS,2)="PH"
199 N VAF531,VAF532,VAF533
200 I VAFSTR[",3," D
201 .S VAF531=$P(VAF53N,U,1) I VAF531="" S VAF531=VAFHLQ
202 .S VAF532=$P(VAF53N,U,2) I VAF532="" S VAF532=VAFHLQ
203 .S VAF533=$P(VAF53N,U,3) I VAF533="" S VAF533=VAFHLQ
204 .S $P(VAFY,VAFHLS,3)=VAF531_$E(VAFHLC)_VAF532_$E(VAFHLC)_VAF533
205 I VAFSTR[",4," D
206 .S $P(VAFY,VAFHLS,4)=VAFHLQ
207 I VAFSTR[",5," S $P(VAFY,VAFHLS,5)=VAFHLQ
208 Q
209OEIF ;build Operation Enduring/Iraqi Freedom segments
210 D OEIF^VAFHLZM2
211 Q
212NOSEG ;
213 D NOSEG^VAFHLZM2
214 Q
Note: See TracBrowser for help on using the repository browser.