source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMAGE.m@ 1259

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

initial load of WorldVistAEHR

File size: 5.9 KB
Line 
1PXRMAGE ; SLC/PKR - Utilities for age calculations. ;1/27/07 17:46
2 ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU General Public License
17 ; along with this program; if not, write to the Free Software
18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
19 ;===========================================
20AGE(DOB,DOD,DATE) ;Given a date of birth, date of death, and a date
21 ;return the age on that date. If the date of death is not null the
22 ;return the age on the date of death. All dates should be in VA
23 ;Fileman format.
24 N CDATE,X,X1,X2,X3
25 S CDATE=$S(DOD="":DATE,DOD'="":DOD)
26 S X=(CDATE-DOB)\10000 Q:X>1 X ; Begin VOE changes to support pediatrics
27 S X1=CDATE,X2=DOB
28 D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,1:X_"D")
29 Q X ; End VOE changes to support pediatric ages
30 ;
31 ;===========================================
32AGECHECK(PXRMAGE,MINAGE,MAXAGE) ;Given an AGE (with "Y", "M" or "D"), MINimumAGE, and MAXimumAGE
33 ;return true if age lies within the range.
34 ;Special values of NULL or 0 mean there are no limits.
35 ;
36 ; IHS/CIA/MGH - 5/12/2004 PATCH 1001 Changed to function call to calculate age
37 ; Two lines changed and one added ; for VOE too
38 ;S MAXAGE=+MAXAGE
39 ;S MINAGE=+MINAGE
40 ;
41 S MAXAGE=$$DECODE(MAXAGE) ; DECODE used in VOE Pediatric patients
42 S MINAGE=$$DECODE(MINAGE)
43 S AGEDAYS=$$DECODE(PXRMAGE)
44 ;
45 ;See if too old.
46 I (AGEDAYS>MAXAGE)&(MAXAGE>0) Q 0
47 ;
48 ;See if too young.
49 I MINAGE=0 Q 1
50 I AGEDAYS<MINAGE Q 0
51 Q 1
52 ;
53DECODE(AGEVALUE) ; Put age from VADPT into format for reminders ; for VOE too
54 ; IHS/CIA/MGH - 5/12/2004 PATCH 1001 Added function to change age into days
55 N NUM,CODE,MULT
56 S NUM=+AGEVALUE,CODE=$P(AGEVALUE,NUM,2)
57 S MULT=1.0
58 I CODE="M" S MULT=30.42
59 I CODE=""!(CODE="Y") S MULT=365.25
60 Q +(MULT*NUM)
61 ;======================================================================
62FMTAGE(MINAGE,MAXAGE) ;Format the minimum age and maximum age for display.
63 N STR
64 I $L(MINAGE)!$L(MAXAGE) D
65 . I $L(MINAGE)&$L(MAXAGE) S STR=" for ages "_MINAGE_" to "_MAXAGE Q
66 . I $L(MINAGE) S STR=" for ages "_MINAGE_" and older" Q
67 . I $L(MAXAGE) S STR=" for ages "_MAXAGE_" and younger" Q
68 E S STR=" for all ages"
69 Q STR
70 ;
71 ;===========================================
72FMTFREQ(FREQ) ;Format the frequency for display.
73 N FREQT,STR
74 S STR="Frequency: "
75 S FREQT=$$FREQ^PXRMPTD2(FREQ)
76 I FREQ=-1 Q STR_FREQT
77 Q STR_"Due every "_FREQT
78 ;
79 ;===========================================
80MMF(DEFARR,PXRMPDEM,MINAGE,MAXAGE,FREQ,FIEVAL) ;Set the baseline minimum age,
81 ;maximum age, and frequency. If there are multiple intervals they
82 ;cannot overlap.
83 N FR,IC,INDEX,MATCH,MAXA,MINA,NAR,TEMP
84 ;Initialize MINAGE, MAXAGE, and FREQ.
85 S (MINAGE,MAXAGE,FREQ)=""
86 S (IC,NAR)=0
87 F S IC=$O(DEFARR(7,IC)) Q:+IC=0 D
88 . S NAR=NAR+1
89 . S TEMP=DEFARR(7,IC,0)
90 . S FR(NAR)=$$UP^XLFSTR($P(TEMP,U,1))
91 . S MINA(NAR)=$P(TEMP,U,2)
92 . S MAXA(NAR)=$P(TEMP,U,3)
93 . S INDEX(NAR)=IC
94 . S FIEVAL("AGE",IC)=0
95 I NAR=0 Q
96 ;
97 ;Make sure that none of the age ranges overlap.
98 I $D(PXRMDEBG),$$OVERLAP(NAR,.MINA,.MAXA) Q
99 ;
100 ;Look for an age range match.
101 S FREQ=-1
102 S MATCH=0
103 F IC=1:1:NAR Q:MATCH D
104 . I $$AGECHECK(PXRMPDEM("AGE"),MINA(IC),MAXA(IC)) D
105 .. S MATCH=1
106 .. S MINAGE=MINA(IC)
107 .. S MAXAGE=MAXA(IC)
108 .. S FREQ=FR(IC)
109 .. S FIEVAL("AGE",INDEX(IC))=1
110 Q
111 ;
112 ;===========================================
113OVERLAP(NAR,MINA,MAXA) ;Check age ranges for overlap. Return an error message
114 ;if an overlap is found.
115 ;IHS/CIA/MGH Changes made to decode the ages into numeric results
116 I NAR'>1 Q 0
117 N IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
118 S OVRLAP=0
119 F IC=1:1:NAR-1 D
120 . S MAXI=$$DECODE(MAXA(IC)) ; DECODE used in VOE Pediatric patients
121 . I MAXI="" S MAXI=1000
122 . S MINI=$$DECODE(MINA(IC))
123 . I MINI="" S MINI=0
124 . F JC=IC+1:1:NAR D
125 .. S MAXJ=$$DECODE(MAXA(JC))
126 .. I MAXJ="" S MAXJ=1000
127 .. S MINJ=$$DECODE(MINA(JC))
128 .. I MINJ="" S MINJ=0
129 .. S IN=0
130 .. I (MINJ'<MINI)&(MINJ'>MAXI) S IN=1
131 .. I (MAXJ'<MINI)&(MAXJ'>MAXI) S IN=1
132 .. I IN D
133 ... S OVRLAP=OVRLAP+1
134 ... S TEXT=MINA(IC)_" to "_MAXA(IC)_" and "_MINA(JC)_" to "_MAXA(JC)
135 ... I $D(PXRMPID) S ^TMP(PXRMPID,$J,PXRMITEM,"FERROR","AGE OVERLAP",OVRLAP)=TEXT
136 ... E S ^TMP($J,"OVERLAP",OVRLAP)=TEXT
137 I OVRLAP>1 S OVRLAP=1
138 Q OVRLAP
139 ;
140 ;===========================================
141OVLAP() ;Check age ranges for overlap. Called from definition editor after
142 ;input of baseline frequency/age ranges.
143 N IC,NAR,MAXA,MINA,OVERLAP,TEMP
144 S (IC,NAR)=0
145 F S IC=$O(^PXD(811.9,DA,7,IC)) Q:+IC=0 D
146 . S NAR=NAR+1
147 . S TEMP=^PXD(811.9,DA,7,IC,0)
148 . S MINA(NAR)=$P(TEMP,U,2)
149 . S MAXA(NAR)=$P(TEMP,U,3)
150 S OVERLAP=$$OVERLAP^PXRMAGE(NAR,.MINA,.MAXA)
151 I OVERLAP D
152 . W !,"Error - the following age ranges overlap:"
153 . S IC=0
154 . F S IC=$O(^TMP($J,"OVERLAP",IC)) Q:IC="" W !,?2,^TMP($J,"OVERLAP",IC)
155 . K ^TMP($J,"OVERLAP")
156 . W !,"Please correct this problem."
157 Q OVERLAP
158 ;
159 ;======================================================================
160RESTORE(SOURCE,INDEX,FREQ,MINAGE,MAXAGE) ;Restore FREQ, MINAGE, and
161 ;MAXAGE back to the original form. From IHS for VOE
162 N IND,TEMP
163 I SOURCE="CFIND" D
164 . S IND=$O(^PXD(811.9,PXRMITEM,10,"B",INDEX,""))
165 . S TEMP=^PXD(811.9,PXRMITEM,10,IND,0)
166 ;
167 I SOURCE="HFIND" D
168 . S IND=$O(^PXD(811.9,PXRMITEM,6,"B",INDEX,""))
169 . S TEMP=^PXD(811.9,PXRMITEM,6,IND,0)
170 ;
171 I SOURCE="TFIND" D
172 . S IND=$O(^PXD(811.9,PXRMITEM,4,"B",INDEX,""))
173 . S TEMP=^PXD(811.9,PXRMITEM,4,IND,0)
174 ;
175 S MINAGE=$P(TEMP,U,2)
176 S MAXAGE=$P(TEMP,U,3)
177 S FREQ=$P(TEMP,U,4)
178 Q
179 ;
Note: See TracBrowser for help on using the repository browser.