- 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)
