APCLV2 ; IHS/CMI/LAB - get values for stat record ;
;;2.0;IHS PCC SUITE;**2,4,10,11**;MAY 14, 2009;Build 58
;
;IHS/TUCSON/LAB - patch 1 - 06/02/97 - added this new routine to
;support additions to the statistical database record
;;CMI/LAB - Patch 2 -02/23/98 - modified subroutines ACE and DMNUTR
;;to fix problems with the data being passed to the data center
;cmi/anch/maw 9/12/2007 code set versioning in WT
;
HGBA1C(V) ;EP - called to return value of HGBA1C if done on this visit
;V is visit ien
NEW R
S R=""
I '$D(^AUPNVSIT(V)) Q R
I '$D(^AUPNVLAB("AD",V)) Q R ;no v labs to check
I '$D(^ATXLAB("B","DM AUDIT HGB A1C TAX")) Q R
NEW Y S Y=$O(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
I 'Y Q R ;no taxonomy to look at
NEW X,Z
S X=0 F S X=$O(^AUPNVLAB("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVLAB(X,0),U) I Z,$D(^ATXLAB(Y,21,"B",Z)) S R=$P(^AUPNVLAB(X,0),U,4)
Q R
;
HTN(P) ;EP - is htn documented for this patient ever? Y or N retured
NEW R,X,E,APCLV2
S R=""
I '$D(^DPT(P)) Q R
I $P(^DPT(P,0),U,19) Q R
I '$D(^AUPNVPOV("AC",P)) Q R ;no povs on file
NEW X,E S X=P_"^LAST DX [SURVEILLANCE HYPERTENSION" S E=$$START1^APCLDF(X,"APCLV2(")
Q $P($G(APCLV2(1)),U)
;
BP(V) ;EP - systolic pressure this visit
;V is visit ien
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVMSR("AD",V)) Q ""
NEW Y S Y=$O(^AUTTMSR("B","BP",0))
I 'Y Q ""
NEW X,Z,R S R=""
S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),U)=Y,'$P($G(^AUPNVMSR(X,2)),U,1) S R=$P(^AUPNVMSR(X,0),U,4)
Q R
;
ACE(V) ;EP - ace inhibitor filled this visit
;V is visit ien
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVMED("AD",V)) Q "N" ;no v meds to check
NEW Y S Y=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'Y Q ""
;CMI/LAB 02/23/98 Patch #2 Modified subroutine to fix problems with
;data being passed to the Data Center.
;Added R to NEW statement below and added the setting of R=""
;in the line that follows
;BEG ORG CODE
;NEW X,Z
;END ORG CODE
;BEG NEW CODE
NEW X,Z,R
S R=""
;END NEW CODE
S X=0 F S X=$O(^AUPNVMED("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVMED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1
Q $S($G(R):"Y",1:"N")
;
RW(V) ;EP called to return %recommended weight
I '$G(V) Q ""
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVMSR("AD",V)) Q ""
NEW Y S Y=$O(^AUTTMSR("B","WT",0))
I 'Y Q ""
NEW X,Z,R S R=""
S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),U)=Y S R=$P(^AUPNVMSR(X,0),U,4)
S R=$$RW^APCL2A3($P(^AUPNVSIT(V,0),U,5),R,$P(^AUPNVSIT(V,0),U))
Q R
;
DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N
I '$G(V) Q "N"
I '$D(^AUPNVSIT(V)) Q "N"
I '$D(^AUPNVPED("AD",V)) Q "N"
NEW Y S Y=$O(^ATXAX("B","APCL DM NUTRITION EDUC TOPICS",0))
I 'Y Q ""
;CMI/LAB 02/23/98 Patch #2 - Modified subroutine to fix problems with
;data being passed to the Data Center
;Added R to NEW statement below and added the setting of R=""
;in the line that follows.
;BEG ORG CODE
;NEW X,Z
;END ORG CODE
;BEG NEW CODE
NEW X,Z,R
S R=""
;END NEW CODE
S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X S Z=$P(^AUPNVPED(X,0),U) I $D(^ATXAX(Y,21,"B",Z)) S R=1
Q $S($G(R):"Y",1:"N")
;
HC(V) ;EP - return y or n if head circumference done
;V is visit ien
I '$D(^AUPNVSIT(V)) Q ""
I '$D(^AUPNVMSR("AD",V)) Q "N"
NEW Y S Y=$O(^AUTTMSR("B","HC",0))
I 'Y Q ""
NEW X,Z,R S R=""
S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X I $P(^AUPNVMSR(X,0),U)=Y S R=1
Q $S($G(R):"Y",1:"N")
;
;
DISPER(V) ;EP - called to get ER disposition
I '$G(V) Q ""
I '$D(^AUPNVSIT(V)) Q ""
I $$CLINIC^APCLV(V,"C")'=30 Q ""
NEW Y S Y=$O(^AUPNVER("AD",V,0)) I 'Y Q ""
Q $$VALI^XBDIQ1(9000010.29,Y,.11)
;
PBMI ;EP
NEW %,W,H,B,D,%DT,BDATE,AGE,WD,HD,VALUE,V,ERRC,ERR,BMI,CD,WD,HD,WV,HV,OW,OH,LBMI
S ERRC=0
S VALUE=""
I $G(EDATE)="" S EDATE=DT
I $G(P)="" Q "^^^^^^^PATIENT DFN INVALID"
I '$D(^AUPNPAT(P,0)) Q "^^^^^^^PATIENT DFN INVALID"
I '$D(^DPT(P,0)) Q "^^^^^^^PATIENT DFN INVALID"
;GET LAST STORED BMI IF DOESN'T EXIT THEN MOVE ON TO CALCULATE IT
;S LBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",,EDATE,"A")
;I LBMI]"" D Q VALUE
;.S W=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",,EDATE,"A")
;.S H=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",,EDATE,"A")
;.S VALUE=$P(LBMI,U,3)_U_$P(H,U,3)_U_$P(H,U,1)_U_$P(H,U,4)_U_$P(W,U,3)_U_$P(W,U,1)_U_$P(W,U,4)_U_U_$P(LBMI,U,1)_U_$P(LBMI,U,6)
S AGE=$$AGE^AUPNPAT(P,EDATE)
S VALUE=""
I AGE>18,AGE<50 D Q VALUE
.S CD=$$FMADD^XLFDT(EDATE,-(5*365)) ;5 yrs
.S BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
.S EDATE=$$FMTE^XLFDT(EDATE)
.;get last weight on file
.S V=$$WT(P,BDATE,EDATE)
.S (W,OW)=$P(V,U,1) ;weight value
.I W=""!(W="?") S ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S WD=$P(V,U,2) ;weight date
.I WD<CD S ERR="WARNING: WEIGHT IS GREATER THAN 5 YRS OLD" D ERR
.S WV=$P(V,U,3)
.S V=$$HT(P,BDATE,EDATE)
.S (H,OH)=$P(V,U,1)
.I H="" S ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S HD=$P(V,U,2)
.I HD<CD S ERR="WARNING: HEIGHT IS GREATER THAN 5 YRS OLD" D ERR
.S HV=$P(V,U,3)
.S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
.D SETV
I AGE>49 D Q VALUE
.S CD=$$FMADD^XLFDT(EDATE,-(2*365)) ;5 yrs
.S BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
.S EDATE=$$FMTE^XLFDT(EDATE)
.;get last weight on file
.S V=$$WT(P,BDATE,EDATE)
.S (W,OW)=$P(V,U,1) ;weight value
.I W=""!(W="?") S ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S WD=$P(V,U,2) ;weight date
.I WD<CD S ERR="WARNING: WEIGHT IS GREATER THAN 2 YRS OLD" D ERR
.S WV=$P(V,U,3)
.S V=$$HT(P,BDATE,EDATE)
.S (H,OH)=$P(V,U,1)
.I H="" S ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE) D ERR Q
.S HD=$P(V,U,2)
.I HD<CD S ERR="WARNING: HEIGHT IS GREATER THAN 2 YRS OLD" D ERR
.S HV=$P(V,U,3)
.S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
.D SETV
.Q
I AGE<19 D Q VALUE
.S CD=$$FMADD^XLFDT(EDATE,-365)
.S BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
.S EDATE=$$FMTE^XLFDT(EDATE)
.S X=$$HTWTSD(P,BDATE,EDATE)
.I '$P(X,"^") S ERR="NO WEIGHT FOUND ON SAME DAY AS HT ON OR PRIOR TO "_EDATE D ERR Q
.I '$P(X,"^",4) S ERR="NO HEIGHT FOUND ON SAME DAY AS WT ON OR PRIOR TO "_EDATE D ERR Q
.S (W,OW)=$P(X,"^"),(H,OH)=$P(X,"^",4)
.S WD=$P(X,U,2)
.I WD<CD S ERR="WARNING: WEIGHT IS OVER 1 YEAR OLD" D ERR
.S WV=$P(X,U,3)
.S HD=$P(X,U,5)
.I HD<CD S ERR="WARNING: HEIGHT IS OVER 1 YEAR OLD" D ERR
.S HV=$P(X,U,6)
.S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)
.D SETV
.Q
Q
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
NEW APCLWTS,APCLHTS,%,X,APCLWTS1,APCLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"APCLHTS(")
S Y=0 F S Y=$O(APCLHTS(Y)) Q:Y'=+Y I $P(APCLHTS(Y),U,2)="?"!($P(APCLHTS(Y),U,2)="") K APCLHTS(Y)
;set the array up by date
K APCLHTS1 S X=0 F S X=$O(APCLHTS(X)) Q:X'=+X S APCLHTS1($P(APCLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"APCLWTS(")
S Y=0 F S Y=$O(APCLWTS(Y)) Q:Y'=+Y I $P(APCLWTS(Y),U,2)="?"!($P(APCLWTS(Y),U,2)="") K APCLWTS(Y)
;set the array up by date
K APCLWTS1 S X=0 F S X=$O(APCLWTS(X)) Q:X'=+X S APCLWTS1($P(APCLWTS(X),U))=X
S APCLCHT="",X=9999999 F S X=$O(APCLWTS1(X),-1) Q:X=""!(APCLCHT]"") I $D(APCLHTS1(X)) D
.S APCLCHT=$P(APCLWTS(APCLWTS1(X)),U,2)_U_$P(APCLWTS(APCLWTS1(X)),U,1)_U_$P(APCLWTS(APCLWTS1(X)),U,5)_U_$P(APCLHTS(APCLHTS1(X)),U,2)_U_$P(APCLHTS(APCLHTS1(X)),U,1)_U_$P(APCLHTS(APCLHTS1(X)),U,5)
Q APCLCHT
;
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,APCLARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"APCLARRY(")
S H=$P($G(APCLARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
S H=H_U_$P(APCLARRY(1),U,1)_U_$P(APCLARRY(1),U,5)
Q H
;
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,APCLLW,X,APCLLN,APCLL,APCLLD,APCLLZ,APCLLX,APCLICD
K APCLL S APCLLW="" S APCLLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(APCLLX,"APCLL(")
S APCLLN=0 F S APCLLN=$O(APCLL(APCLLN)) Q:APCLLN'=+APCLLN!(APCLLW]"") D
.S APCLLZ=$P(APCLL(APCLLN),U,5)
.I '$D(^AUPNVPOV("AD",APCLLZ)) S APCLLW=$P(APCLL(APCLLN),U,2)_U_$P(APCLL(APCLLN),U,1)_U_$P(APCLL(APCLLN),U,5) Q
. S APCLLD=0,G=0 F S APCLLD=$O(^AUPNVPOV("AD",APCLLZ,APCLLD)) Q:'APCLLD!(G) D
.. S APCLICD=$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLLD,0),U)),U,2) D ;cmi/anch/maw 9/12/2007 csv
...I $$ICD^ATXAPI(APCLICD,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) S G=1
..I 'G S APCLLW=$P(APCLL(APCLLN),U,2)_U_$P(APCLL(APCLLN),U,1)_U_$P(APCLL(APCLLN),U,5)
..Q
Q APCLLW
;
ERR ;
S ERRC=ERRC+1
NEW C
S C=$P(VALUE,U,8)
S $P(C,"|",ERRC)=ERR
S $P(VALUE,U,8)=C
Q
;
SETV ;
S $P(VALUE,U,1)=BMI
S $P(VALUE,U,2)=OH
S $P(VALUE,U,3)=HD
S $P(VALUE,U,4)=HV
S $P(VALUE,U,5)=OW
S $P(VALUE,U,6)=WD
S $P(VALUE,U,7)=WV
Q
APCLV2 ; IHS/CMI/LAB - get values for stat record ;
+1 ;;2.0;IHS PCC SUITE;**2,4,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;IHS/TUCSON/LAB - patch 1 - 06/02/97 - added this new routine to
+4 ;support additions to the statistical database record
+5 ;;CMI/LAB - Patch 2 -02/23/98 - modified subroutines ACE and DMNUTR
+6 ;;to fix problems with the data being passed to the data center
+7 ;cmi/anch/maw 9/12/2007 code set versioning in WT
+8 ;
HGBA1C(V) ;EP - called to return value of HGBA1C if done on this visit
+1 ;V is visit ien
+2 NEW R
+3 SET R=""
+4 IF '$DATA(^AUPNVSIT(V))
QUIT R
+5 ;no v labs to check
IF '$DATA(^AUPNVLAB("AD",V))
QUIT R
+6 IF '$DATA(^ATXLAB("B","DM AUDIT HGB A1C TAX"))
QUIT R
+7 NEW Y
SET Y=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+8 ;no taxonomy to look at
IF 'Y
QUIT R
+9 NEW X,Z
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AD",V,X))
IF X'=+X
QUIT
SET Z=$PIECE(^AUPNVLAB(X,0),U)
IF Z
IF $DATA(^ATXLAB(Y,21,"B",Z))
SET R=$PIECE(^AUPNVLAB(X,0),U,4)
+11 QUIT R
+12 ;
HTN(P) ;EP - is htn documented for this patient ever? Y or N retured
+1 NEW R,X,E,APCLV2
+2 SET R=""
+3 IF '$DATA(^DPT(P))
QUIT R
+4 IF $PIECE(^DPT(P,0),U,19)
QUIT R
+5 ;no povs on file
IF '$DATA(^AUPNVPOV("AC",P))
QUIT R
+6 NEW X,E
SET X=P_"^LAST DX [SURVEILLANCE HYPERTENSION"
SET E=$$START1^APCLDF(X,"APCLV2(")
+7 QUIT $PIECE($GET(APCLV2(1)),U)
+8 ;
BP(V) ;EP - systolic pressure this visit
+1 ;V is visit ien
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$DATA(^AUPNVMSR("AD",V))
QUIT ""
+4 NEW Y
SET Y=$ORDER(^AUTTMSR("B","BP",0))
+5 IF 'Y
QUIT ""
+6 NEW X,Z,R
SET R=""
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=Y
IF '$PIECE($GET(^AUPNVMSR(X,2)),U,1)
SET R=$PIECE(^AUPNVMSR(X,0),U,4)
+8 QUIT R
+9 ;
ACE(V) ;EP - ace inhibitor filled this visit
+1 ;V is visit ien
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 ;no v meds to check
IF '$DATA(^AUPNVMED("AD",V))
QUIT "N"
+4 NEW Y
SET Y=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+5 IF 'Y
QUIT ""
+6 ;CMI/LAB 02/23/98 Patch #2 Modified subroutine to fix problems with
+7 ;data being passed to the Data Center.
+8 ;Added R to NEW statement below and added the setting of R=""
+9 ;in the line that follows
+10 ;BEG ORG CODE
+11 ;NEW X,Z
+12 ;END ORG CODE
+13 ;BEG NEW CODE
+14 NEW X,Z,R
+15 SET R=""
+16 ;END NEW CODE
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVMED("AD",V,X))
IF X'=+X
QUIT
SET Z=$PIECE(^AUPNVMED(X,0),U)
IF $DATA(^ATXAX(Y,21,"B",Z))
SET R=1
+18 QUIT $SELECT($GET(R):"Y",1:"N")
+19 ;
RW(V) ;EP called to return %recommended weight
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$DATA(^AUPNVMSR("AD",V))
QUIT ""
+4 NEW Y
SET Y=$ORDER(^AUTTMSR("B","WT",0))
+5 IF 'Y
QUIT ""
+6 NEW X,Z,R
SET R=""
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=Y
SET R=$PIECE(^AUPNVMSR(X,0),U,4)
+8 SET R=$$RW^APCL2A3($PIECE(^AUPNVSIT(V,0),U,5),R,$PIECE(^AUPNVSIT(V,0),U))
+9 QUIT R
+10 ;
DMNUTR(V) ;EP - was dm nutrition educ done on this visit, Y or N
+1 IF '$GET(V)
QUIT "N"
+2 IF '$DATA(^AUPNVSIT(V))
QUIT "N"
+3 IF '$DATA(^AUPNVPED("AD",V))
QUIT "N"
+4 NEW Y
SET Y=$ORDER(^ATXAX("B","APCL DM NUTRITION EDUC TOPICS",0))
+5 IF 'Y
QUIT ""
+6 ;CMI/LAB 02/23/98 Patch #2 - Modified subroutine to fix problems with
+7 ;data being passed to the Data Center
+8 ;Added R to NEW statement below and added the setting of R=""
+9 ;in the line that follows.
+10 ;BEG ORG CODE
+11 ;NEW X,Z
+12 ;END ORG CODE
+13 ;BEG NEW CODE
+14 NEW X,Z,R
+15 SET R=""
+16 ;END NEW CODE
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X
QUIT
SET Z=$PIECE(^AUPNVPED(X,0),U)
IF $DATA(^ATXAX(Y,21,"B",Z))
SET R=1
+18 QUIT $SELECT($GET(R):"Y",1:"N")
+19 ;
HC(V) ;EP - return y or n if head circumference done
+1 ;V is visit ien
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF '$DATA(^AUPNVMSR("AD",V))
QUIT "N"
+4 NEW Y
SET Y=$ORDER(^AUTTMSR("B","HC",0))
+5 IF 'Y
QUIT ""
+6 NEW X,Z,R
SET R=""
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
IF $PIECE(^AUPNVMSR(X,0),U)=Y
SET R=1
+8 QUIT $SELECT($GET(R):"Y",1:"N")
+9 ;
+10 ;
DISPER(V) ;EP - called to get ER disposition
+1 IF '$GET(V)
QUIT ""
+2 IF '$DATA(^AUPNVSIT(V))
QUIT ""
+3 IF $$CLINIC^APCLV(V,"C")'=30
QUIT ""
+4 NEW Y
SET Y=$ORDER(^AUPNVER("AD",V,0))
IF 'Y
QUIT ""
+5 QUIT $$VALI^XBDIQ1(9000010.29,Y,.11)
+6 ;
PBMI ;EP
+1 NEW %,W,H,B,D,%DT,BDATE,AGE,WD,HD,VALUE,V,ERRC,ERR,BMI,CD,WD,HD,WV,HV,OW,OH,LBMI
+2 SET ERRC=0
+3 SET VALUE=""
+4 IF $GET(EDATE)=""
SET EDATE=DT
+5 IF $GET(P)=""
QUIT "^^^^^^^PATIENT DFN INVALID"
+6 IF '$DATA(^AUPNPAT(P,0))
QUIT "^^^^^^^PATIENT DFN INVALID"
+7 IF '$DATA(^DPT(P,0))
QUIT "^^^^^^^PATIENT DFN INVALID"
+8 ;GET LAST STORED BMI IF DOESN'T EXIT THEN MOVE ON TO CALCULATE IT
+9 ;S LBMI=$$LASTITEM^APCLAPIU(P,"BMI","MEASUREMENT",,EDATE,"A")
+10 ;I LBMI]"" D Q VALUE
+11 ;.S W=$$LASTITEM^APCLAPIU(P,"WT","MEASUREMENT",,EDATE,"A")
+12 ;.S H=$$LASTITEM^APCLAPIU(P,"HT","MEASUREMENT",,EDATE,"A")
+13 ;.S VALUE=$P(LBMI,U,3)_U_$P(H,U,3)_U_$P(H,U,1)_U_$P(H,U,4)_U_$P(W,U,3)_U_$P(W,U,1)_U_$P(W,U,4)_U_U_$P(LBMI,U,1)_U_$P(LBMI,U,6)
+14 SET AGE=$$AGE^AUPNPAT(P,EDATE)
+15 SET VALUE=""
+16 IF AGE>18
IF AGE<50
Begin DoDot:1
+17 ;5 yrs
SET CD=$$FMADD^XLFDT(EDATE,-(5*365))
+18 SET BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
+19 SET EDATE=$$FMTE^XLFDT(EDATE)
+20 ;get last weight on file
+21 SET V=$$WT(P,BDATE,EDATE)
+22 ;weight value
SET (W,OW)=$PIECE(V,U,1)
+23 IF W=""!(W="?")
SET ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+24 ;weight date
SET WD=$PIECE(V,U,2)
+25 IF WD<CD
SET ERR="WARNING: WEIGHT IS GREATER THAN 5 YRS OLD"
DO ERR
+26 SET WV=$PIECE(V,U,3)
+27 SET V=$$HT(P,BDATE,EDATE)
+28 SET (H,OH)=$PIECE(V,U,1)
+29 IF H=""
SET ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+30 SET HD=$PIECE(V,U,2)
+31 IF HD<CD
SET ERR="WARNING: HEIGHT IS GREATER THAN 5 YRS OLD"
DO ERR
+32 SET HV=$PIECE(V,U,3)
+33 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+34 DO SETV
End DoDot:1
QUIT VALUE
+35 IF AGE>49
Begin DoDot:1
+36 ;5 yrs
SET CD=$$FMADD^XLFDT(EDATE,-(2*365))
+37 SET BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
+38 SET EDATE=$$FMTE^XLFDT(EDATE)
+39 ;get last weight on file
+40 SET V=$$WT(P,BDATE,EDATE)
+41 ;weight value
SET (W,OW)=$PIECE(V,U,1)
+42 IF W=""!(W="?")
SET ERR="NO WEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+43 ;weight date
SET WD=$PIECE(V,U,2)
+44 IF WD<CD
SET ERR="WARNING: WEIGHT IS GREATER THAN 2 YRS OLD"
DO ERR
+45 SET WV=$PIECE(V,U,3)
+46 SET V=$$HT(P,BDATE,EDATE)
+47 SET (H,OH)=$PIECE(V,U,1)
+48 IF H=""
SET ERR="NO HEIGHT FOUND ON OR PRIOR TO "_$$FMTE^XLFDT(EDATE)
DO ERR
QUIT
+49 SET HD=$PIECE(V,U,2)
+50 IF HD<CD
SET ERR="WARNING: HEIGHT IS GREATER THAN 2 YRS OLD"
DO ERR
+51 SET HV=$PIECE(V,U,3)
+52 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+53 DO SETV
+54 QUIT
End DoDot:1
QUIT VALUE
+55 IF AGE<19
Begin DoDot:1
+56 SET CD=$$FMADD^XLFDT(EDATE,-365)
+57 SET BDATE=$$FMTE^XLFDT($$DOB^AUPNPAT(P))
+58 SET EDATE=$$FMTE^XLFDT(EDATE)
+59 SET X=$$HTWTSD(P,BDATE,EDATE)
+60 IF '$PIECE(X,"^")
SET ERR="NO WEIGHT FOUND ON SAME DAY AS HT ON OR PRIOR TO "_EDATE
DO ERR
QUIT
+61 IF '$PIECE(X,"^",4)
SET ERR="NO HEIGHT FOUND ON SAME DAY AS WT ON OR PRIOR TO "_EDATE
DO ERR
QUIT
+62 SET (W,OW)=$PIECE(X,"^")
SET (H,OH)=$PIECE(X,"^",4)
+63 SET WD=$PIECE(X,U,2)
+64 IF WD<CD
SET ERR="WARNING: WEIGHT IS OVER 1 YEAR OLD"
DO ERR
+65 SET WV=$PIECE(X,U,3)
+66 SET HD=$PIECE(X,U,5)
+67 IF HD<CD
SET ERR="WARNING: HEIGHT IS OVER 1 YEAR OLD"
DO ERR
+68 SET HV=$PIECE(X,U,6)
+69 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BMI=(W/H)
+70 DO SETV
+71 QUIT
End DoDot:1
QUIT VALUE
+72 QUIT
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 NEW APCLWTS,APCLHTS,%,X,APCLWTS1,APCLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(APCLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(APCLHTS(Y),U,2)="?"!($PIECE(APCLHTS(Y),U,2)="")
KILL APCLHTS(Y)
+6 ;set the array up by date
+7 KILL APCLHTS1
SET X=0
FOR
SET X=$ORDER(APCLHTS(X))
IF X'=+X
QUIT
SET APCLHTS1($PIECE(APCLHTS(X),U))=X
+8 ;get all wts during time frame
+9 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLWTS(")
+10 SET Y=0
FOR
SET Y=$ORDER(APCLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(APCLWTS(Y),U,2)="?"!($PIECE(APCLWTS(Y),U,2)="")
KILL APCLWTS(Y)
+11 ;set the array up by date
+12 KILL APCLWTS1
SET X=0
FOR
SET X=$ORDER(APCLWTS(X))
IF X'=+X
QUIT
SET APCLWTS1($PIECE(APCLWTS(X),U))=X
+13 SET APCLCHT=""
SET X=9999999
FOR
SET X=$ORDER(APCLWTS1(X),-1)
IF X=""!(APCLCHT]"")
QUIT
IF $DATA(APCLHTS1(X))
Begin DoDot:1
+14 SET APCLCHT=$PIECE(APCLWTS(APCLWTS1(X)),U,2)_U_$PIECE(APCLWTS(APCLWTS1(X)),U,1)_U_$PIECE(APCLWTS(APCLWTS1(X)),U,5)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,2)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,1)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,5)
End DoDot:1
+15 QUIT APCLCHT
+16 ;
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,APCLARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCLARRY(")
+4 SET H=$PIECE($GET(APCLARRY(1)),U,2)
+5 IF H=""
QUIT H
+6 IF H["?"
QUIT ""
+7 SET H=H_U_$PIECE(APCLARRY(1),U,1)_U_$PIECE(APCLARRY(1),U,5)
+8 QUIT H
+9 ;
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,APCLLW,X,APCLLN,APCLL,APCLLD,APCLLZ,APCLLX,APCLICD
+3 KILL APCLL
SET APCLLW=""
SET APCLLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(APCLLX,"APCLL(")
+4 SET APCLLN=0
FOR
SET APCLLN=$ORDER(APCLL(APCLLN))
IF APCLLN'=+APCLLN!(APCLLW]"")
QUIT
Begin DoDot:1
+5 SET APCLLZ=$PIECE(APCLL(APCLLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",APCLLZ))
SET APCLLW=$PIECE(APCLL(APCLLN),U,2)_U_$PIECE(APCLL(APCLLN),U,1)_U_$PIECE(APCLL(APCLLN),U,5)
QUIT
+7 SET APCLLD=0
SET G=0
FOR
SET APCLLD=$ORDER(^AUPNVPOV("AD",APCLLZ,APCLLD))
IF 'APCLLD!(G)
QUIT
Begin DoDot:2
+8 ;cmi/anch/maw 9/12/2007 csv
SET APCLICD=$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCLLD,0),U)),U,2)
Begin DoDot:3
+9 IF $$ICD^ATXAPI(APCLICD,$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
SET G=1
End DoDot:3
+10 IF 'G
SET APCLLW=$PIECE(APCLL(APCLLN),U,2)_U_$PIECE(APCLL(APCLLN),U,1)_U_$PIECE(APCLL(APCLLN),U,5)
+11 QUIT
End DoDot:2
End DoDot:1
+12 QUIT APCLLW
+13 ;
ERR ;
+1 SET ERRC=ERRC+1
+2 NEW C
+3 SET C=$PIECE(VALUE,U,8)
+4 SET $PIECE(C,"|",ERRC)=ERR
+5 SET $PIECE(VALUE,U,8)=C
+6 QUIT
+7 ;
SETV ;
+1 SET $PIECE(VALUE,U,1)=BMI
+2 SET $PIECE(VALUE,U,2)=OH
+3 SET $PIECE(VALUE,U,3)=HD
+4 SET $PIECE(VALUE,U,4)=HV
+5 SET $PIECE(VALUE,U,5)=OW
+6 SET $PIECE(VALUE,U,6)=WD
+7 SET $PIECE(VALUE,U,7)=WV
+8 QUIT
