source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL.m@ 701

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

initial load of WorldVistAEHR
File size: 7.8 KB
Line 
1ECXUTL ;ALB/JAP - Utilities for DSS Extracts ; 12/12/05 8:43am
2 ;;3.0;DSS EXTRACTS;**1,5,8,84,90**;Dec 22, 1997
3 ;
4ECXYM(ECXFMDT) ;extrinsic function
5 ;converts any FM internal format date or date/time to a 6-character string
6 ;
7 ; input
8 ; ECXFMDT = date or date/time; FM internal format (required)
9 ; output
10 ; ECXYM = YYYYMM string
11 ;
12 N MONTH,YEAR,CENTURY,ECXYM
13 ;
14 ;error checks
15 I +ECXFMDT'=ECXFMDT S ECXYM="000000" Q ECXYM
16 I $L($P(ECXFMDT,"."))'=7 S ECXYM="000000" Q ECXYM
17 I +$E(ECXFMDT,4,5)<1!(+$E(ECXFMDT,4,5)>12) S ECXYM="000000" Q ECXYM
18 ;
19 S MONTH=$E(ECXFMDT,4,5),YEAR=$E(ECXFMDT,2,3),CENTURY=$E(ECXFMDT,1)+17
20 S ECXYM=CENTURY_YEAR_MONTH
21 Q ECXYM
22 ;
23ECXYMX(ECXYM) ;extrinsic function
24 ;converts a 6-character numeric string of format YYYYMM
25 ;to a FM external format date
26 ;
27 ; input
28 ; ECXYM = YYYYMM string (required)
29 ; output
30 ; ECXYMX = FM external format date;
31 ; SEP 1997
32 ; error code
33 ; if input problem, then "000000" returned
34 ;
35 N Y,%DT,CENTURY,FMCENT,ECXYMX
36 ;
37 ;error checks
38 I ECXYM="" S ECXYMX="000000" Q ECXYMX
39 I +ECXYM'=ECXYM S ECXYMX="000000" Q ECXYMX
40 I $L(ECXYM)'=6 S ECXYMX="000000" Q ECXYMX
41 I +$E(ECXYM,1,4)<1800 S ECXYMX="000000" Q ECXYMX
42 I +$E(ECXYM,5,6)<1!(+$E(ECXYM,5,6)>12) S ECXYMX="000000" Q ECXYMX
43 ;
44 S CENTURY=$E(ECXYM,1,2)
45 S FMCENT=CENTURY-17
46 S Y=FMCENT_$E(ECXYM,3,6) D DD^%DT S ECXYMX=Y
47 ;
48 ;error checks
49 I $L(ECXYMX)'=8 S ECXYMX="000000"
50 I "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"'[$E(ECXYMX,1,3) S ECXYMX="000000"
51 Q ECXYMX
52 ;
53ECXDATE(ECXFMDT,ECXYM) ;extrinsic function
54 ;converts any FM internal format date or date/time to a 8-character string
55 ;
56 ; input
57 ; ECXFMDT = date or date/time; FM internal format (required)
58 ; ECXYM = YYYYMM; year/month 6-character string (required)
59 ; output
60 ; ECXDATE = YYYYMMDD string
61 ; error code
62 ; "000000" returned, if problem with input
63 ;
64 N MONTH,YEAR,CENTURY,DAY,ECXDATE
65 ;
66 ;error checks
67 I +ECXYM'=ECXYM S ECXDATE="000000" Q ECXDATE
68 I $L(ECXYM)'=6 S ECXDATE="000000" Q ECXDATE
69 I +$E(ECXYM,1,4)<1800 S ECXDATE="000000" Q ECXDATE
70 I +$E(ECXYM,5,6)<1!($E(ECXYM,5,6)>12) S ECXDATE="000000" Q ECXDATE
71 ;special case where ecxfmdt is null; default to year/month of ecxym
72 I ECXFMDT="" S ECXDATE=ECXYM_"01" Q ECXDATE
73 ;error checks
74 I +ECXFMDT'=ECXFMDT S ECXDATE=ECXYM_"01" Q ECXDATE
75 I $L(ECXFMDT)<7 S ECXDATE=ECXYM_"01" Q ECXDATE
76 I +$E(ECXFMDT,4,5)>12 S ECXDATE=ECXYM_"01" Q ECXDATE
77 I +$E(ECXFMDT,6,7)>31 S ECXFMDT=$E(ECXFMDT,1,5)_"01"
78 ;default to 1st day of month
79 S DAY=$E(ECXFMDT,6,7) S:DAY="00" DAY="01"
80 ;default to month of ecxym
81 S MONTH=$E(ECXFMDT,4,5) S:MONTH="00" MONTH=$E(ECXYM,5,6)
82 S YEAR=$E(ECXFMDT,2,3)
83 S CENTURY=$E(ECXFMDT,1)+17
84 S ECXDATE=CENTURY_YEAR_MONTH_DAY
85 Q ECXDATE
86 ;
87ECXDATEX(ECXDATE) ;extrinsic function
88 ;converts an 8-character numeric string of format YYYYMMDD
89 ;to a FM external format date
90 ;
91 ; input
92 ; ECXDATE = YYYYMMDD string (required)
93 ; output
94 ; ECXDATEX = FM external format date;
95 ; SEP 12, 1997
96 ; error code
97 ; if input problem, then "000000" returned
98 ;
99 N Y,%DT,CENTURY,FMCENT,ECXDATEX
100 ;
101 ;error checks
102 I +ECXDATE'=ECXDATE S ECXDATEX="000000" Q ECXDATEX
103 I $L(ECXDATE)'=8 S ECXDATEX="000000" Q ECXDATEX
104 I +$E(ECXDATE,7,8)>31 S ECXDATEX="000000" Q ECXDATEX
105 ;
106 S CENTURY=$E(ECXDATE,1,2)
107 S FMCENT=CENTURY-17
108 S Y=FMCENT_$E(ECXDATE,3,8) D DD^%DT S ECXDATEX=Y
109 ;
110 ;error checks
111 I $L(ECXDATEX)'=12 S ECXDATEX="000000"
112 I "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"'[$E(ECXDATEX,1,3) S ECXDATEX="000000"
113 Q ECXDATEX
114 ;
115ECXDOB(ECXFMDT) ;extrinsic function
116 ;converts a FM internal format date or date/time to a 6-character string
117 ;if ecxfmdt is null, the function returns 19420101
118 ; input
119 ; ECXFMDT = date or date/time (required);
120 ; must be valid FM internal format
121 ; output
122 ; ECXDOB = YYYYMMDD string (required);
123 ; defaults to 19420101
124 ;
125 N MONTH,YEAR,CENTURY,DAY,ECXDOB
126 ;only consider date portion
127 S ECXFMDT=$P(ECXFMDT,".",1)
128 ;special case where ecxfmdt is null
129 I ECXFMDT="" S ECXDOB="19420101" Q ECXDOB
130 ;error checks - return default
131 I +ECXFMDT'=ECXFMDT S ECXDOB="19420101" Q ECXDOB
132 I $L(ECXFMDT)<7 S ECXDOB="19420101" Q ECXDOB
133 I +ECXFMDT>DT S ECXDOB="19420101" Q ECXDOB
134 ;default to 1st day of month
135 S DAY=$E(ECXFMDT,6,7) S:DAY="00"!(+DAY>31) DAY="01"
136 ;default to 1st month of year
137 S MONTH=$E(ECXFMDT,4,5) S:MONTH="00"!(+MONTH>12) MONTH="01",DAY="01"
138 S YEAR=$E(ECXFMDT,2,3)
139 S CENTURY=$E(ECXFMDT,1)+17
140 S ECXDOB=CENTURY_YEAR_MONTH_DAY
141 Q ECXDOB
142 ;
143ECXTIME(ECXFMDT) ;extrinsic function
144 ;converts Fileman internal date/time to 6-character time string
145 ;format HHMMSS
146 ;
147 ; input
148 ; ECXFMDT = date or date/time (required);
149 ; must be valid FM internal format
150 ; output
151 ; ECXTIME = 6-character numeric string;
152 ; format HHMMSS; string length always 6
153 ;
154 N J,JJ,TIME,HH,MM,SS,ECXTIME
155 ;if any non-numerics, set default
156 I +ECXFMDT=0 S ECXTIME="000300" Q ECXTIME
157 ;use only time portion of fileman internal format
158 S TIME=$P(ECXFMDT,".",2),TIME=$E(TIME,1,6)
159 ;if time unknown, set default
160 I TIME="" S ECXTIME="000300" Q ECXTIME
161 ;be sure time is 6 characters
162 S TIME=$$LJ^XLFSTR(TIME,6,0)
163 ;error checks -- set default
164 S HH=$E(TIME,1,2),MM=$E(TIME,3,4),SS=$E(TIME,5,6)
165 I +HH>23 S ECXTIME="000300" Q ECXTIME
166 I +MM>59 S MM="59"
167 I +SS>59 S SS="59"
168 S ECXTIME=HH_MM_SS
169 Q ECXTIME
170 ;
171ECXTIMEX(ECXTIME,ECXMIL) ;extrinsic function
172 ;converts a 6-character time string to external, user readable format
173 ;used as output transform for time fields in many dss extract files
174 ; input
175 ; ECXTIME = 6-character numeric string (required);
176 ; ECXMIL = if "1", then return military time (optional)
177 ; output
178 ; ECXTIMEX = character string;
179 ; if ECXMIL=1, format HH:MM:SS
180 ; otherwise, hours:mins AM/PM
181 ; error code
182 ; if input problem, then "000000" returned
183 ;
184 N TIME,HH,MM,SS,ECXTIMEX,J,JJ
185 ;error checks
186 I $L(ECXTIME)'=6 S ECXTIMEX="000000" Q ECXTIMEX
187 F J=1:1:6 S JJ=$E(ECXTIME,J) I $A(JJ)<48!($A(JJ)>57) S ECXTIMEX="000000" Q
188 I $D(ECXTIMEX) Q ECXTIMEX
189 S HH=$E(ECXTIME,1,2),MM=$E(ECXTIME,3,4),SS=$E(ECXTIME,5,6)
190 I +HH>23!(+MM>59)!(+SS>59) S ECXTIMEX="000000" Q ECXTIMEX
191 ;if ecxmil=1, return military time
192 I $G(ECXMIL) S ECXTIMEX=HH_":"_MM_":"_SS Q ECXTIMEX
193 ;otherwise, use am/pm format
194 S X="0."_ECXTIME
195 S X=$E($P(X,".",2)_"0000",1,4),%=X>1159 S:X>1259 X=X-1200
196 S X=X\100_":"_$E(X#100+100,2,3)_" "_$E("AP",%+1)_"M"
197 S ECXTIMEX=X
198 Q ECXTIMEX
199 ;
200AOIRPOW(ECXDFN,ECXAIP) ;get data on ao, ir, pow status
201 ;
202 ; input
203 ; ECXDFN = ien in file #2 (required)
204 ; ECXAIP = array for returned data (required)
205 ; (passed by reference)
206 ;
207 ; output
208 ; ECXAIP("AO") = agent orange status
209 ; ECXAIP("IR") = ion. radiation status
210 ; ECXAIP("POW") = pow status
211 ; ECXAIP("POWL") = pow location/period
212 ;
213 N J
214 S ECXAIP("AO")="",ECXAIP("IR")="",ECXAIP("POW")="",ECXAIP("POWL")=""
215 S ECXAIP("AO")=$P($G(^DPT(ECXDFN,.321)),U,2),ECXAIP("IR")=$P($G(^(.321)),U,3)
216 S ECXAIP("POW")=$P($G(^DPT(ECXDFN,.52)),U,5),ECXAIP("POWL")=$P($G(^(.52)),U,6)
217 F J="AO","IR","POW" I ECXAIP(J)="" S ECXAIP(J)="U"
218 I ECXAIP("POWL"),ECXAIP("POW")'="Y" S ECXAIP("POWL")=""
219 Q
220 ;
221PRVCLASS(PERS,DATE) ;determine the person class and return va code
222 ; input
223 ; PERS = pointer to file #200 (required)
224 ; DATE = date on which person class must be active (required)
225 ; (internal Fileman format)
226 ; output
227 ; VACODE = VA code field from file #8932.1
228 ; (exactly 7 characters in length)
229 N ECX,VACODE
230 S VACODE=""
231 S ECHEAD=$G(ECHEAD)
232 S ECX=$$GET^XUA4A72(PERS,DATE)
233 ;if no person class use alternate date to resolve person class
234 I +ECX'>0 D
235 .N DATE
236 .S DATE=$S(ECHEAD="LAB":$P(EC1,U,14),ECHEAD="LAR":$P(EC1,U,4),ECHEAD="PRE":$P(ECDATA,U,13),ECHEAD="RAD":$P($G(^RAO(75.1,+$G(ECXIEN),0)),U,16),1:"")
237 .S ECX=$$GET^XUA4A72(PERS,DATE)
238 .Q
239 S VACODE=$P(ECX,U,7) I $L(VACODE)'=7 S VACODE=""
240 Q VACODE
Note: See TracBrowser for help on using the repository browser.