source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m@ 1540

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

initial load of FOIAVistA 6/30/08 version

File size: 8.0 KB
Line 
1PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ;==================================================
5CEFD(FDA) ;Called by the Exchange Utility only if the input packed
6 ;reminder was packed under v1.5 Move Effective Date to Beginning Date.
7 N IND
8 S IND=""
9 F S IND=$O(FDA(811.902,IND)) Q:IND="" D
10 . I '$D(FDA(811.902,IND,12)) Q
11 .;If the EFFECTIVE PERIOD exists don't do anything.
12 . I $D(FDA(811.902,IND,9)) Q
13 . S FDA(811.902,IND,9)=FDA(811.902,IND,12)
14 . K FDA(811.902,IND,12)
15 Q
16 ;
17 ;==================================================
18COMPARE(X) ;Compare beginning and ending dates, give a warning if
19 ;Ending Date comes before Beginning Date. Called by ADATE xref in
20 ;definitions and terms.
21 ;Do not execute as part of exchange.
22 I $G(PXRMEXCH) Q
23 N BDT,EDT
24 S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
25 S EDT=X(2)
26 I EDT="" S EDT="T"
27 S EDT=$$CTFMD^PXRMDATE(EDT)
28 ;If EDT does not contain a time set it to the end of the day.
29 I EDT'["." S EDT=EDT_".235959"
30 I EDT<BDT D
31 . S BDT=$S(X(1)'="":X(1),1:"")
32 . S EDT=$S(X(2)'="":X(2),1:"T@2400")
33 . S TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
34 . D EN^DDIOL(TEXT)
35 Q
36 ;
37 ;==================================================
38COTN(EFP) ;Convert an Effective Period to the new date/time format.
39 ;Possible effective periods are ND, NM, or NY where N is an integer.
40 S EFP=$$UP^XLFSTR(EFP)
41 I (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y") D
42 . S NUM=+EFP
43 . S EFP=$S(NUM=0:"T",1:"T-"_EFP)
44 Q EFP
45 ;
46 ;==================================================
47CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
48 ;forms as well as T-NY to a FileMan date. Also understands LAD for
49 ;Last Admission Date.
50 N %DT,ND,X,Y
51 ;Already a FileMan date?
52 S ND=+DATE
53 I (ND'<1000000),(ND'>9991231) Q DATE
54 ;Check for a date FileMan understands.
55 S X=DATE,%DT="ST"
56 D ^%DT
57 ;If it is not a FileMan date check for a symbolic date.
58 I Y=-1 S Y=$$SYMDATE(DATE)
59 ;If it is not a date that is understood by SYMDATE return -1
60 I Y=-1 Q -1
61 I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D
62 . N DIFFS
63 . S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2)
64 . S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
65 I DATE["LAD" D
66 . I $G(PXRMLAD)="" S Y=0
67 . E D
68 .. N DIFFS
69 .. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2)
70 .. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
71 Q Y
72 ;
73 ;=================================================
74DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE.
75 ;Used in DIR("PRE") for date inputs.
76 I $D(DTOUT) Q DATE
77 I DATE="" Q DATE
78 I DATE["^" Q DATE
79 I DATE["?" Q DATE
80 Q $$CTFMD^PXRMDATE(DATE)
81 ;
82 ;==================================================
83DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date.
84 ;This is the date of the resolution finding + the reminder frequency.
85 ;Subtract the due in advance time to see if the reminder should be
86 ;marked as due soon.
87 ;
88 N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY
89 S PXRMITEM=DEFARR("IEN")
90 ;If the final frequency is 0Y then the reminder is not due.
91 I FREQ="0Y" S DUE=0,DUEDATE="" Q
92 ;
93 S DUEDATE=""
94 ;Check for custom date due.
95 I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
96 I DUEDATE'="",DUEDATE'=-1 G SETDUE
97 ;
98 ;No custom date due, do regular date calculation.
99 I (FREQ="")!(FREQ=-1) D Q
100 . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
101 . S (DUE,DUEDATE)="CNBD"
102 ;
103 S LDATE=$S(RESDATE["X":0,1:+RESDATE)
104 I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q
105 S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ)
106 ;
107SETDUE ;If the due date is less than or equal to today's date the reminder
108 ;is due.
109 S TODAY=$$NOW^PXRMDATE
110 I +DUEDATE'>TODAY S DUE="DUE NOW" Q
111 ;
112 S DIAT="-"_$P(DEFARR(0),U,4)
113 I DIAT="-" D
114 . S DIATOK=0
115 . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time"
116 E S DIATOK=1
117 ;
118 S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE)
119 S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED")
120 Q
121 ;
122 ;==================================================
123DURATION(START,STOP) ;Return the number days between the Start Date and
124 ;Stop Date.
125 I +START=0 Q 0
126 N PXRMNOW
127 S PXRMNOW=$$NOW^PXRMDATE
128 I START>PXRMNOW Q 0
129 I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW
130 Q $$FMDIFF^XLFDT(STOP,START)
131 ;
132 ;==================================================
133EDATE(DATE) ;Check for an historical (event) date, format as appropriate.
134 Q $$FMTE^XLFDT(DATE,"5DZ")
135 ;
136 ;==================================================
137FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and
138 ;a day along with a year. If the month is missing assume Jan. If the
139 ;day is missing assume the first. Issue a warning so the user knows
140 ;what happened. DATE should be in Fileman format.
141 N DAY,MISSING,MONTH,TDATE,YEAR
142 S TDATE=DATE
143 S MISSING=0
144 S DAY=$E(DATE,6,7)
145 S MONTH=$E(DATE,4,5)
146 S YEAR=$E(DATE,1,3)
147 I +DAY=0 D
148 . S DAY=1
149 . S MISSING=1
150 . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
151 I +MONTH=0 D
152 . S MONTH=1
153 . S MISSING=1
154 . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
155 I MISSING D
156 . S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
157 . I DATE["E" S TDATE=TDATE_"E"
158 Q TDATE
159 ;
160 ;==================================================
161FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a
162 ;number and D stands for days, M for months, and Y for years return
163 ;the value in days.
164 I FREQ="" Q ""
165 N CODE,LEN,MULT,NUM
166 S LEN=$L(FREQ)
167 S NUM=$E(FREQ,1,LEN-1)
168 S CODE=$E(FREQ,LEN,LEN)
169 S MULT=1.0
170 I CODE="M" S MULT=30.42
171 I CODE="Y" S MULT=365.25
172 Q +(MULT*NUM)
173 ;
174 ;==================================================
175ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date.
176 N P1,P1OK,P2,P2OK,OP,PAT
177 S DATE=$P(DATE,"@",1)
178 S OP=$S(DATE["+":"+",1:"-")
179 S P1=$P(DATE,OP,1),P1OK=0
180 F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK
181 I PAT=DATE Q 1
182 S P2=$P(DATE,OP,2),P2OK=0
183 F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK
184 Q P1OK&P2OK
185 ;
186 ;==================================================
187NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an
188 ;offset of the form NY, NM, ND where N is a number and Y stands for
189 ;years, M for months, and D for days return the new date in VA Fileman
190 ;format.
191 I FMDATE=0 Q 0
192 N LEN,NEWDATE,NUM,UNIT
193 S LEN=$L(OFFSET)
194 S NUM=+$E(OFFSET,1,LEN-1)
195 S UNIT=$E(OFFSET,LEN)
196 I UNIT="D" G DAY
197 I UNIT="M" G MONTH
198 I UNIT="Y" G YEAR
199 ;Unknown unit just return the original date
200 Q FMDATE
201DAY ;
202 S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM)
203 Q NEWDATE
204MONTH ;
205 ;Convert the months to days and then add the days using the DAY code.
206 ;Multiply the number of months by the average number of days in a month.
207 N INT,FRAC
208 S NUM=30.42*NUM
209 ;Round the number of days, FMADD^XLFDT has problems with non-integer
210 ;days.
211 S INT=+$P(NUM,".",1)
212 S FRAC=NUM-INT
213 I FRAC<0.5 S NUM=INT
214 E S NUM=INT+1
215 G DAY
216 Q
217YEAR ;
218 Q FMDATE+(10000*NUM)
219 ;
220 ;==================================================
221NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
222 ;return the current date and time.
223 Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT)
224 ;
225 ;==================================================
226SYMDATE(DATE) ;Convert a symbolic date into a FileMan date.
227 N %DT,OPER,PFSTACK,SYM,TIME,X,Y
228 S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1)
229 S X=$S(DATE="LAD":$G(PXRMLAD),1:"")
230 I X="" D
231 . S OPER="+-"
232 . D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK)
233 I PFSTACK(0)=3 D
234 . S SYM=PFSTACK(1)
235 . S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"")
236 . I SYM="" S Y=-1 Q
237 .;FileMan only handles D, W, or M so convert Y to months.
238 . I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M"
239 . S X=SYM_PFSTACK(3)_PFSTACK(2)
240 I PFSTACK(0)=1 S X=PFSTACK(1)
241 I TIME'="" S X=X_"@"_TIME
242 S %DT="ST"
243 D ^%DT
244 Q Y
245 ;
246 ;==================================================
247VDATE(VIEN) ;Given a visit ien return the visit date.
248 N DATE
249 I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
250 E S DATE=0
251 I $L(DATE)=0 S DATE=0
252 ;Check for historical encounter.
253 I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
254 Q DATE
255 ;
Note: See TracBrowser for help on using the repository browser.