PXRMAGE ; SLC/PKR - Utilities for age calculations. ;10/07/2005
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;===========================================
AGE(DOB,DOD,DATE) ;Given a date of birth, date of death, and a date
;return the age on that date. If the date of death is not null the
;return the age on the date of death. All dates should be in VA
;Fileman format.
N CDATE
S CDATE=$S(DOD="":DATE,DOD'="":DOD)
Q (CDATE-DOB)\10000
;
;===========================================
AGECHECK(AGE,MINAGE,MAXAGE) ;Given an AGE, MINimumAGE, and MAXimumAGE
;return true if age lies within the range.
;Special values of NULL or 0 mean there are no limits.
;
S MAXAGE=+MAXAGE
S MINAGE=+MINAGE
;See if too old.
I (AGE>MAXAGE)&(MAXAGE>0) Q 0
;
;See if too young.
I MINAGE=0 Q 1
I AGE<MINAGE Q 0
Q 1
;
;===========================================
FMTAGE(MINAGE,MAXAGE) ;Format the minimum age and maximum age for display.
N STR
I $L(MINAGE)!$L(MAXAGE) D
. I $L(MINAGE)&$L(MAXAGE) S STR=" for ages "_MINAGE_" to "_MAXAGE Q
. I $L(MINAGE) S STR=" for ages "_MINAGE_" and older" Q
. I $L(MAXAGE) S STR=" for ages "_MAXAGE_" and younger" Q
E S STR=" for all ages"
Q STR
;
;===========================================
FMTFREQ(FREQ) ;Format the frequency for display.
N FREQT,STR
S STR="Frequency: "
S FREQT=$$FREQ^PXRMPTD2(FREQ)
I FREQ=-1 Q STR_FREQT
Q STR_"Due every "_FREQT
;
;===========================================
MMF(DEFARR,PXRMPDEM,MINAGE,MAXAGE,FREQ,FIEVAL) ;Set the baseline minimum age,
;maximum age, and frequency. If there are multiple intervals they
;cannot overlap.
N FR,IC,INDEX,MATCH,MAXA,MINA,NAR,TEMP
;Initialize MINAGE, MAXAGE, and FREQ.
S (MINAGE,MAXAGE,FREQ)=""
S (IC,NAR)=0
F S IC=$O(DEFARR(7,IC)) Q:+IC=0 D
. S NAR=NAR+1
. S TEMP=DEFARR(7,IC,0)
. S FR(NAR)=$$UP^XLFSTR($P(TEMP,U,1))
. S MINA(NAR)=$P(TEMP,U,2)
. S MAXA(NAR)=$P(TEMP,U,3)
. S INDEX(NAR)=IC
. S FIEVAL("AGE",IC)=0
I NAR=0 Q
;
;Make sure that none of the age ranges overlap.
I $D(PXRMDEBG),$$OVERLAP(NAR,.MINA,.MAXA) Q
;
;Look for an age range match.
S FREQ=-1
S MATCH=0
F IC=1:1:NAR Q:MATCH D
. I $$AGECHECK(PXRMPDEM("AGE"),MINA(IC),MAXA(IC)) D
.. S MATCH=1
.. S MINAGE=MINA(IC)
.. S MAXAGE=MAXA(IC)
.. S FREQ=FR(IC)
.. S FIEVAL("AGE",INDEX(IC))=1
Q
;
;===========================================
OVERLAP(NAR,MINA,MAXA) ;Check age ranges for overlap. Return an error message
;if an overlap is found.
I NAR'>1 Q 0
N IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
S OVRLAP=0
F IC=1:1:NAR-1 D
. S MAXI=MAXA(IC)
. I MAXI="" S MAXI=1000
. S MINI=MINA(IC)
. I MINI="" S MINI=0
. F JC=IC+1:1:NAR D
.. S MAXJ=MAXA(JC)
.. I MAXJ="" S MAXJ=1000
.. S MINJ=MINA(JC)
.. I MINJ="" S MINJ=0
.. S IN=0
.. I (MINJ'<MINI)&(MINJ'>MAXI) S IN=1
.. I (MAXJ'<MINI)&(MAXJ'>MAXI) S IN=1
.. I IN D
... S OVRLAP=OVRLAP+1
... S TEXT=MINA(IC)_" to "_MAXA(IC)_" and "_MINA(JC)_" to "_MAXA(JC)
... I $D(PXRMPID) S ^TMP(PXRMPID,$J,PXRMITEM,"FERROR","AGE OVERLAP",OVRLAP)=TEXT
... E S ^TMP($J,"OVERLAP",OVRLAP)=TEXT
I OVRLAP>1 S OVRLAP=1
Q OVRLAP
;
;===========================================
OVLAP() ;Check age ranges for overlap. Called from definition editor after
;input of baseline frequency/age ranges.
N IC,NAR,MAXA,MINA,OVERLAP,TEMP
S (IC,NAR)=0
F S IC=$O(^PXD(811.9,DA,7,IC)) Q:+IC=0 D
. S NAR=NAR+1
. S TEMP=^PXD(811.9,DA,7,IC,0)
. S MINA(NAR)=$P(TEMP,U,2)
. S MAXA(NAR)=$P(TEMP,U,3)
S OVERLAP=$$OVERLAP^PXRMAGE(NAR,.MINA,.MAXA)
I OVERLAP D
. W !,"Error - the following age ranges overlap:"
. S IC=0
. F S IC=$O(^TMP($J,"OVERLAP",IC)) Q:IC="" W !,?2,^TMP($J,"OVERLAP",IC)
. K ^TMP($J,"OVERLAP")
. W !,"Please correct this problem."
Q OVERLAP
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMAGE 3848 printed Dec 13, 2024@01:42:56 Page 2
PXRMAGE ; SLC/PKR - Utilities for age calculations. ;10/07/2005
+1 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+2 ;===========================================
AGE(DOB,DOD,DATE) ;Given a date of birth, date of death, and a date
+1 ;return the age on that date. If the date of death is not null the
+2 ;return the age on the date of death. All dates should be in VA
+3 ;Fileman format.
+4 NEW CDATE
+5 SET CDATE=$SELECT(DOD="":DATE,DOD'="":DOD)
+6 QUIT (CDATE-DOB)\10000
+7 ;
+8 ;===========================================
AGECHECK(AGE,MINAGE,MAXAGE) ;Given an AGE, MINimumAGE, and MAXimumAGE
+1 ;return true if age lies within the range.
+2 ;Special values of NULL or 0 mean there are no limits.
+3 ;
+4 SET MAXAGE=+MAXAGE
+5 SET MINAGE=+MINAGE
+6 ;See if too old.
+7 IF (AGE>MAXAGE)&(MAXAGE>0)
QUIT 0
+8 ;
+9 ;See if too young.
+10 IF MINAGE=0
QUIT 1
+11 IF AGE<MINAGE
QUIT 0
+12 QUIT 1
+13 ;
+14 ;===========================================
FMTAGE(MINAGE,MAXAGE) ;Format the minimum age and maximum age for display.
+1 NEW STR
+2 IF $LENGTH(MINAGE)!$LENGTH(MAXAGE)
Begin DoDot:1
+3 IF $LENGTH(MINAGE)&$LENGTH(MAXAGE)
SET STR=" for ages "_MINAGE_" to "_MAXAGE
QUIT
+4 IF $LENGTH(MINAGE)
SET STR=" for ages "_MINAGE_" and older"
QUIT
+5 IF $LENGTH(MAXAGE)
SET STR=" for ages "_MAXAGE_" and younger"
QUIT
End DoDot:1
+6 IF '$TEST
SET STR=" for all ages"
+7 QUIT STR
+8 ;
+9 ;===========================================
FMTFREQ(FREQ) ;Format the frequency for display.
+1 NEW FREQT,STR
+2 SET STR="Frequency: "
+3 SET FREQT=$$FREQ^PXRMPTD2(FREQ)
+4 IF FREQ=-1
QUIT STR_FREQT
+5 QUIT STR_"Due every "_FREQT
+6 ;
+7 ;===========================================
MMF(DEFARR,PXRMPDEM,MINAGE,MAXAGE,FREQ,FIEVAL) ;Set the baseline minimum age,
+1 ;maximum age, and frequency. If there are multiple intervals they
+2 ;cannot overlap.
+3 NEW FR,IC,INDEX,MATCH,MAXA,MINA,NAR,TEMP
+4 ;Initialize MINAGE, MAXAGE, and FREQ.
+5 SET (MINAGE,MAXAGE,FREQ)=""
+6 SET (IC,NAR)=0
+7 FOR
SET IC=$ORDER(DEFARR(7,IC))
if +IC=0
QUIT
Begin DoDot:1
+8 SET NAR=NAR+1
+9 SET TEMP=DEFARR(7,IC,0)
+10 SET FR(NAR)=$$UP^XLFSTR($PIECE(TEMP,U,1))
+11 SET MINA(NAR)=$PIECE(TEMP,U,2)
+12 SET MAXA(NAR)=$PIECE(TEMP,U,3)
+13 SET INDEX(NAR)=IC
+14 SET FIEVAL("AGE",IC)=0
End DoDot:1
+15 IF NAR=0
QUIT
+16 ;
+17 ;Make sure that none of the age ranges overlap.
+18 IF $DATA(PXRMDEBG)
IF $$OVERLAP(NAR,.MINA,.MAXA)
QUIT
+19 ;
+20 ;Look for an age range match.
+21 SET FREQ=-1
+22 SET MATCH=0
+23 FOR IC=1:1:NAR
if MATCH
QUIT
Begin DoDot:1
+24 IF $$AGECHECK(PXRMPDEM("AGE"),MINA(IC),MAXA(IC))
Begin DoDot:2
+25 SET MATCH=1
+26 SET MINAGE=MINA(IC)
+27 SET MAXAGE=MAXA(IC)
+28 SET FREQ=FR(IC)
+29 SET FIEVAL("AGE",INDEX(IC))=1
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
+32 ;===========================================
OVERLAP(NAR,MINA,MAXA) ;Check age ranges for overlap. Return an error message
+1 ;if an overlap is found.
+2 IF NAR'>1
QUIT 0
+3 NEW IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
+4 SET OVRLAP=0
+5 FOR IC=1:1:NAR-1
Begin DoDot:1
+6 SET MAXI=MAXA(IC)
+7 IF MAXI=""
SET MAXI=1000
+8 SET MINI=MINA(IC)
+9 IF MINI=""
SET MINI=0
+10 FOR JC=IC+1:1:NAR
Begin DoDot:2
+11 SET MAXJ=MAXA(JC)
+12 IF MAXJ=""
SET MAXJ=1000
+13 SET MINJ=MINA(JC)
+14 IF MINJ=""
SET MINJ=0
+15 SET IN=0
+16 IF (MINJ'<MINI)&(MINJ'>MAXI)
SET IN=1
+17 IF (MAXJ'<MINI)&(MAXJ'>MAXI)
SET IN=1
+18 IF IN
Begin DoDot:3
+19 SET OVRLAP=OVRLAP+1
+20 SET TEXT=MINA(IC)_" to "_MAXA(IC)_" and "_MINA(JC)_" to "_MAXA(JC)
+21 IF $DATA(PXRMPID)
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"FERROR","AGE OVERLAP",OVRLAP)=TEXT
+22 IF '$TEST
SET ^TMP($JOB,"OVERLAP",OVRLAP)=TEXT
End DoDot:3
End DoDot:2
End DoDot:1
+23 IF OVRLAP>1
SET OVRLAP=1
+24 QUIT OVRLAP
+25 ;
+26 ;===========================================
OVLAP() ;Check age ranges for overlap. Called from definition editor after
+1 ;input of baseline frequency/age ranges.
+2 NEW IC,NAR,MAXA,MINA,OVERLAP,TEMP
+3 SET (IC,NAR)=0
+4 FOR
SET IC=$ORDER(^PXD(811.9,DA,7,IC))
if +IC=0
QUIT
Begin DoDot:1
+5 SET NAR=NAR+1
+6 SET TEMP=^PXD(811.9,DA,7,IC,0)
+7 SET MINA(NAR)=$PIECE(TEMP,U,2)
+8 SET MAXA(NAR)=$PIECE(TEMP,U,3)
End DoDot:1
+9 SET OVERLAP=$$OVERLAP^PXRMAGE(NAR,.MINA,.MAXA)
+10 IF OVERLAP
Begin DoDot:1
+11 WRITE !,"Error - the following age ranges overlap:"
+12 SET IC=0
+13 FOR
SET IC=$ORDER(^TMP($JOB,"OVERLAP",IC))
if IC=""
QUIT
WRITE !,?2,^TMP($JOB,"OVERLAP",IC)
+14 KILL ^TMP($JOB,"OVERLAP")
+15 WRITE !,"Please correct this problem."
End DoDot:1
+16 QUIT OVERLAP
+17 ;
