source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMAGE.m@ 1008

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

initial load of FOIAVistA 6/30/08 version

File size: 3.6 KB
Line 
1PXRMAGE ; SLC/PKR - Utilities for age calculations. ;10/07/2005
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;===========================================
4AGE(DOB,DOD,DATE) ;Given a date of birth, date of death, and a date
5 ;return the age on that date. If the date of death is not null the
6 ;return the age on the date of death. All dates should be in VA
7 ;Fileman format.
8 N CDATE
9 S CDATE=$S(DOD="":DATE,DOD'="":DOD)
10 Q (CDATE-DOB)\10000
11 ;
12 ;===========================================
13AGECHECK(AGE,MINAGE,MAXAGE) ;Given an AGE, MINimumAGE, and MAXimumAGE
14 ;return true if age lies within the range.
15 ;Special values of NULL or 0 mean there are no limits.
16 ;
17 S MAXAGE=+MAXAGE
18 S MINAGE=+MINAGE
19 ;See if too old.
20 I (AGE>MAXAGE)&(MAXAGE>0) Q 0
21 ;
22 ;See if too young.
23 I MINAGE=0 Q 1
24 I AGE<MINAGE Q 0
25 Q 1
26 ;
27 ;===========================================
28FMTAGE(MINAGE,MAXAGE) ;Format the minimum age and maximum age for display.
29 N STR
30 I $L(MINAGE)!$L(MAXAGE) D
31 . I $L(MINAGE)&$L(MAXAGE) S STR=" for ages "_MINAGE_" to "_MAXAGE Q
32 . I $L(MINAGE) S STR=" for ages "_MINAGE_" and older" Q
33 . I $L(MAXAGE) S STR=" for ages "_MAXAGE_" and younger" Q
34 E S STR=" for all ages"
35 Q STR
36 ;
37 ;===========================================
38FMTFREQ(FREQ) ;Format the frequency for display.
39 N FREQT,STR
40 S STR="Frequency: "
41 S FREQT=$$FREQ^PXRMPTD2(FREQ)
42 I FREQ=-1 Q STR_FREQT
43 Q STR_"Due every "_FREQT
44 ;
45 ;===========================================
46MMF(DEFARR,PXRMPDEM,MINAGE,MAXAGE,FREQ,FIEVAL) ;Set the baseline minimum age,
47 ;maximum age, and frequency. If there are multiple intervals they
48 ;cannot overlap.
49 N FR,IC,INDEX,MATCH,MAXA,MINA,NAR,TEMP
50 ;Initialize MINAGE, MAXAGE, and FREQ.
51 S (MINAGE,MAXAGE,FREQ)=""
52 S (IC,NAR)=0
53 F S IC=$O(DEFARR(7,IC)) Q:+IC=0 D
54 . S NAR=NAR+1
55 . S TEMP=DEFARR(7,IC,0)
56 . S FR(NAR)=$$UP^XLFSTR($P(TEMP,U,1))
57 . S MINA(NAR)=$P(TEMP,U,2)
58 . S MAXA(NAR)=$P(TEMP,U,3)
59 . S INDEX(NAR)=IC
60 . S FIEVAL("AGE",IC)=0
61 I NAR=0 Q
62 ;
63 ;Make sure that none of the age ranges overlap.
64 I $D(PXRMDEBG),$$OVERLAP(NAR,.MINA,.MAXA) Q
65 ;
66 ;Look for an age range match.
67 S FREQ=-1
68 S MATCH=0
69 F IC=1:1:NAR Q:MATCH D
70 . I $$AGECHECK(PXRMPDEM("AGE"),MINA(IC),MAXA(IC)) D
71 .. S MATCH=1
72 .. S MINAGE=MINA(IC)
73 .. S MAXAGE=MAXA(IC)
74 .. S FREQ=FR(IC)
75 .. S FIEVAL("AGE",INDEX(IC))=1
76 Q
77 ;
78 ;===========================================
79OVERLAP(NAR,MINA,MAXA) ;Check age ranges for overlap. Return an error message
80 ;if an overlap is found.
81 I NAR'>1 Q 0
82 N IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
83 S OVRLAP=0
84 F IC=1:1:NAR-1 D
85 . S MAXI=MAXA(IC)
86 . I MAXI="" S MAXI=1000
87 . S MINI=MINA(IC)
88 . I MINI="" S MINI=0
89 . F JC=IC+1:1:NAR D
90 .. S MAXJ=MAXA(JC)
91 .. I MAXJ="" S MAXJ=1000
92 .. S MINJ=MINA(JC)
93 .. I MINJ="" S MINJ=0
94 .. S IN=0
95 .. I (MINJ'<MINI)&(MINJ'>MAXI) S IN=1
96 .. I (MAXJ'<MINI)&(MAXJ'>MAXI) S IN=1
97 .. I IN D
98 ... S OVRLAP=OVRLAP+1
99 ... S TEXT=MINA(IC)_" to "_MAXA(IC)_" and "_MINA(JC)_" to "_MAXA(JC)
100 ... I $D(PXRMPID) S ^TMP(PXRMPID,$J,PXRMITEM,"FERROR","AGE OVERLAP",OVRLAP)=TEXT
101 ... E S ^TMP($J,"OVERLAP",OVRLAP)=TEXT
102 I OVRLAP>1 S OVRLAP=1
103 Q OVRLAP
104 ;
105 ;===========================================
106OVLAP() ;Check age ranges for overlap. Called from definition editor after
107 ;input of baseline frequency/age ranges.
108 N IC,NAR,MAXA,MINA,OVERLAP,TEMP
109 S (IC,NAR)=0
110 F S IC=$O(^PXD(811.9,DA,7,IC)) Q:+IC=0 D
111 . S NAR=NAR+1
112 . S TEMP=^PXD(811.9,DA,7,IC,0)
113 . S MINA(NAR)=$P(TEMP,U,2)
114 . S MAXA(NAR)=$P(TEMP,U,3)
115 S OVERLAP=$$OVERLAP^PXRMAGE(NAR,.MINA,.MAXA)
116 I OVERLAP D
117 . W !,"Error - the following age ranges overlap:"
118 . S IC=0
119 . F S IC=$O(^TMP($J,"OVERLAP",IC)) Q:IC="" W !,?2,^TMP($J,"OVERLAP",IC)
120 . K ^TMP($J,"OVERLAP")
121 . W !,"Please correct this problem."
122 Q OVERLAP
123 ;
Note: See TracBrowser for help on using the repository browser.