- 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 Feb 18, 2025@23:09:18 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 ;