PXRMAGE ; SLC/PKR - Utilities for age calculations. ;07-Jun-2012 09:58;DU
;;2.0;CLINICAL REMINDERS;**4,1001**;Feb 04, 2005;Build 21
;IHS/MSC/MGH Make changes for babies and toddlers
;===========================================
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.
;IHS/MSC/MGH patch 1001 was not returning correct data for babies
N CDATE,BAGE,VADM
S CDATE=$S(DOD="":DATE,DOD'="":DOD)
S BAGE=(CDATE-DOB)\10000
I BAGE<2 D
.D DEM^VADPT
.S BAGE=VADM(4)
Q BAGE
;
;===========================================
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.
;
;IHS/MSC/MGH Put back in age check patch 1001
;S MAXAGE=+MAXAGE
;S MINAGE=+MINAGE
N PTAGE
S AGE=$$DECAGE(AGE)
S MAXAGE=$$DECODE(MAXAGE)
S MINAGE=$$DECODE(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
;
;===========================================
DECAGE(AGEVALUE) ; Put age from VADPT into format for reminders
; IHS/MSC/MGH - 2/28/2012 PATCH 1001 Added function to change age into days or months
N NUM,CODE,MULT
S NUM=$P(AGEVALUE," ",1),CODE=$P(AGEVALUE," ",2)
S MULT=1.0
I CODE="MOS" S MULT=30.42
I CODE=""!(CODE="YRS") S MULT=365.25
Q +(MULT*NUM)
;====================================================================
DECODE(AGEVALUE) ;Determine the age in years or months
; IHS/MSC/MGH - 2/28/2012 PATCH 1001 Added function to change reminder
N CODE,LEN,MULT,NUM
S LEN=$L(AGEVALUE)
S NUM=$E(AGEVALUE,1,LEN-1)
S CODE=$E(AGEVALUE,LEN,LEN)
S MULT=1.0
I CODE="M" S MULT=30.42
I CODE="Y"!(CODE="") S MULT=365.25
Q +(MULT*NUM)
;==================================================================
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.
;IHS/MSC/MGH Decode added for IHS ages
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=$$DECODE(MAXA(IC))
. I MAXI="" S MAXI=1000
. S MINI=$$DECODE(MINA(IC))
. I MINI="" S MINI=0
. F JC=IC+1:1:NAR D
.. S MAXJ=$$DECODE(MAXA(JC))
.. I MAXJ="" S MAXJ=1000
.. S MINJ=$$DECODE(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
;
PXRMAGE ; SLC/PKR - Utilities for age calculations. ;07-Jun-2012 09:58;DU
+1 ;;2.0;CLINICAL REMINDERS;**4,1001**;Feb 04, 2005;Build 21
+2 ;IHS/MSC/MGH Make changes for babies and toddlers
+3 ;===========================================
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 ;IHS/MSC/MGH patch 1001 was not returning correct data for babies
+5 NEW CDATE,BAGE,VADM
+6 SET CDATE=$SELECT(DOD="":DATE,DOD'="":DOD)
+7 SET BAGE=(CDATE-DOB)\10000
+8 IF BAGE<2
Begin DoDot:1
+9 DO DEM^VADPT
+10 SET BAGE=VADM(4)
End DoDot:1
+11 QUIT BAGE
+12 ;
+13 ;===========================================
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 ;IHS/MSC/MGH Put back in age check patch 1001
+5 ;S MAXAGE=+MAXAGE
+6 ;S MINAGE=+MINAGE
+7 NEW PTAGE
+8 SET AGE=$$DECAGE(AGE)
+9 SET MAXAGE=$$DECODE(MAXAGE)
+10 SET MINAGE=$$DECODE(MINAGE)
+11 ;See if too old.
+12 IF (AGE>MAXAGE)&(MAXAGE>0)
QUIT 0
+13 ;
+14 ;See if too young.
+15 IF MINAGE=0
QUIT 1
+16 IF AGE<MINAGE
QUIT 0
+17 QUIT 1
+18 ;
+19 ;===========================================
DECAGE(AGEVALUE) ; Put age from VADPT into format for reminders
+1 ; IHS/MSC/MGH - 2/28/2012 PATCH 1001 Added function to change age into days or months
+2 NEW NUM,CODE,MULT
+3 SET NUM=$PIECE(AGEVALUE," ",1)
SET CODE=$PIECE(AGEVALUE," ",2)
+4 SET MULT=1.0
+5 IF CODE="MOS"
SET MULT=30.42
+6 IF CODE=""!(CODE="YRS")
SET MULT=365.25
+7 QUIT +(MULT*NUM)
+8 ;====================================================================
DECODE(AGEVALUE) ;Determine the age in years or months
+1 ; IHS/MSC/MGH - 2/28/2012 PATCH 1001 Added function to change reminder
+2 NEW CODE,LEN,MULT,NUM
+3 SET LEN=$LENGTH(AGEVALUE)
+4 SET NUM=$EXTRACT(AGEVALUE,1,LEN-1)
+5 SET CODE=$EXTRACT(AGEVALUE,LEN,LEN)
+6 SET MULT=1.0
+7 IF CODE="M"
SET MULT=30.42
+8 IF CODE="Y"!(CODE="")
SET MULT=365.25
+9 QUIT +(MULT*NUM)
+10 ;==================================================================
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 ;IHS/MSC/MGH Decode added for IHS ages
+3 IF NAR'>1
QUIT 0
+4 NEW IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
+5 SET OVRLAP=0
+6 FOR IC=1:1:NAR-1
Begin DoDot:1
+7 SET MAXI=$$DECODE(MAXA(IC))
+8 IF MAXI=""
SET MAXI=1000
+9 SET MINI=$$DECODE(MINA(IC))
+10 IF MINI=""
SET MINI=0
+11 FOR JC=IC+1:1:NAR
Begin DoDot:2
+12 SET MAXJ=$$DECODE(MAXA(JC))
+13 IF MAXJ=""
SET MAXJ=1000
+14 SET MINJ=$$DECODE(MINA(JC))
+15 IF MINJ=""
SET MINJ=0
+16 SET IN=0
+17 IF (MINJ'<MINI)&(MINJ'>MAXI)
SET IN=1
+18 IF (MAXJ'<MINI)&(MAXJ'>MAXI)
SET IN=1
+19 IF IN
Begin DoDot:3
+20 SET OVRLAP=OVRLAP+1
+21 SET TEXT=MINA(IC)_" to "_MAXA(IC)_" and "_MINA(JC)_" to "_MAXA(JC)
+22 IF $DATA(PXRMPID)
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"FERROR","AGE OVERLAP",OVRLAP)=TEXT
+23 IF '$TEST
SET ^TMP($JOB,"OVERLAP",OVRLAP)=TEXT
End DoDot:3
End DoDot:2
End DoDot:1
+24 IF OVRLAP>1
SET OVRLAP=1
+25 QUIT OVRLAP
+26 ;
+27 ;===========================================
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 ;
