BQIAGE ;PRXM/HC/ALA - Age Function calls ; 06 Nov 2006 1:23 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
AGE(D0,PDATE,QUAL) ;EP
; Description
; This program is copied from the computed AGE field (2,.033) which
; calculates the AGE of a person based on their DOB (date of birth)
; and either the current date (DT) or their DOD (date of death)
;
; It has been modified to use another date passed into this function
; instead of just the previous two dates, DT and DOD.
;
; Input
; D0 - Patient IEN
; PDATE - Other date to compare patient's date of birth with
; QUAL - Include qualifier (YRS, DYS, MOS)
;
; Assumes variables U,DT
;
S PDATE=$G(PDATE,""),QUAL=$G(QUAL,"")
Q $$AGE^AUPNPAT(D0,PDATE,QUAL)
;
NEW X,Y,AUX,QFLR
S QUAL=$G(QUAL,0)
I 'QUAL D
. S Y(2,.033,5)=$S($D(^DPT(D0,0)):^(0),1:""),X=$S($G(PDATE)<+$G(^DPT(D0,.35))&$G(PDATE):PDATE,$G(^DPT(D0,.35)):+^(.35),$G(PDATE)'="":PDATE,1:DT)
. S X=X,Y(2,.033,1)=X
. S X=1,Y(2,.033,2)=X
. S X=3,X=$E(Y(2,.033,1),Y(2,.033,2),X),Y(2,.033,3)=X,Y(2,.033,4)=X
. S X=$P(Y(2,.033,5),U,3),X=X
. S X=X,Y(2,.033,6)=X
. S X=1,Y(2,.033,7)=X
. S X=3,X=$E(Y(2,.033,6),Y(2,.033,7),X)
. S Y=X,X=Y(2,.033,3),X=X-Y
. S Y(2,.033,8)=X,Y(2,.033,9)=X,Y(2,.033,10)=X,X=$S($G(PDATE)<+$G(^DPT(D0,.35))&$G(PDATE):PDATE,$G(^DPT(D0,.35)):+^(.35),$G(PDATE)'="":PDATE,1:DT)
. S X=X,Y(2,.033,11)=X
. S X=4,Y(2,.033,12)=X
. S X=7,X=$E(Y(2,.033,11),Y(2,.033,12),X)
. S Y(2,.033,13)=X,Y(2,.033,14)=X
. S X=$P(Y(2,.033,5),U,3),X=X
. S X=X,Y(2,.033,15)=X
. S X=4,Y(2,.033,16)=X
. S X=7
. S X=$E(Y(2,.033,15),Y(2,.033,16),X)
. S Y=X,X=Y(2,.033,13),X=X<Y,Y=X,X=Y(2,.033,8),X=X-Y
;
; if the qualifier flag is set, then the returned value is the same
; as the PRINTED AGE value which includes YRS, DYS, or MOS.
I QUAL D
. S X=$$FMDIFF^XLFDT($S($G(PDATE)<+$G(^DPT(D0,.35))&$G(PDATE):PDATE,$G(^DPT(D0,.35)):+^(.35),$G(PDATE)'="":PDATE,1:DT),$P(^DPT(D0,0),U,3))
. S AUX=X\365.25
. S QFLR=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
Q $S(QUAL=1:QFLR,1:X)
BQIAGE ;PRXM/HC/ALA - Age Function calls ; 06 Nov 2006 1:23 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
AGE(D0,PDATE,QUAL) ;EP
+1 ; Description
+2 ; This program is copied from the computed AGE field (2,.033) which
+3 ; calculates the AGE of a person based on their DOB (date of birth)
+4 ; and either the current date (DT) or their DOD (date of death)
+5 ;
+6 ; It has been modified to use another date passed into this function
+7 ; instead of just the previous two dates, DT and DOD.
+8 ;
+9 ; Input
+10 ; D0 - Patient IEN
+11 ; PDATE - Other date to compare patient's date of birth with
+12 ; QUAL - Include qualifier (YRS, DYS, MOS)
+13 ;
+14 ; Assumes variables U,DT
+15 ;
+16 SET PDATE=$GET(PDATE,"")
SET QUAL=$GET(QUAL,"")
+17 QUIT $$AGE^AUPNPAT(D0,PDATE,QUAL)
+18 ;
+19 NEW X,Y,AUX,QFLR
+20 SET QUAL=$GET(QUAL,0)
+21 IF 'QUAL
Begin DoDot:1
+22 SET Y(2,.033,5)=$SELECT($DATA(^DPT(D0,0)):^(0),1:"")
SET X=$SELECT($GET(PDATE)<+$GET(^DPT(D0,.35))&$GET(PDATE):PDATE,$GET(^DPT(D0,.35)):+^(.35),$GET(PDATE)'="":PDATE,1:DT)
+23 SET X=X
SET Y(2,.033,1)=X
+24 SET X=1
SET Y(2,.033,2)=X
+25 SET X=3
SET X=$EXTRACT(Y(2,.033,1),Y(2,.033,2),X)
SET Y(2,.033,3)=X
SET Y(2,.033,4)=X
+26 SET X=$PIECE(Y(2,.033,5),U,3)
SET X=X
+27 SET X=X
SET Y(2,.033,6)=X
+28 SET X=1
SET Y(2,.033,7)=X
+29 SET X=3
SET X=$EXTRACT(Y(2,.033,6),Y(2,.033,7),X)
+30 SET Y=X
SET X=Y(2,.033,3)
SET X=X-Y
+31 SET Y(2,.033,8)=X
SET Y(2,.033,9)=X
SET Y(2,.033,10)=X
SET X=$SELECT($GET(PDATE)<+$GET(^DPT(D0,.35))&$GET(PDATE):PDATE,$GET(^DPT(D0,.35)):+^(.35),$GET(PDATE)'="":PDATE,1:DT)
+32 SET X=X
SET Y(2,.033,11)=X
+33 SET X=4
SET Y(2,.033,12)=X
+34 SET X=7
SET X=$EXTRACT(Y(2,.033,11),Y(2,.033,12),X)
+35 SET Y(2,.033,13)=X
SET Y(2,.033,14)=X
+36 SET X=$PIECE(Y(2,.033,5),U,3)
SET X=X
+37 SET X=X
SET Y(2,.033,15)=X
+38 SET X=4
SET Y(2,.033,16)=X
+39 SET X=7
+40 SET X=$EXTRACT(Y(2,.033,15),Y(2,.033,16),X)
+41 SET Y=X
SET X=Y(2,.033,13)
SET X=X<Y
SET Y=X
SET X=Y(2,.033,8)
SET X=X-Y
End DoDot:1
+42 ;
+43 ; if the qualifier flag is set, then the returned value is the same
+44 ; as the PRINTED AGE value which includes YRS, DYS, or MOS.
+45 IF QUAL
Begin DoDot:1
+46 SET X=$$FMDIFF^XLFDT($SELECT($GET(PDATE)<+$GET(^DPT(D0,.35))&$GET(PDATE):PDATE,$GET(^DPT(D0,.35)):+^(.35),$GET(PDATE)'="":PDATE,1:DT),$PIECE(^DPT(D0,0),U,3))
+47 SET AUX=X\365.25
+48 SET QFLR=$SELECT(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
End DoDot:1
+49 QUIT $SELECT(QUAL=1:QFLR,1:X)
