BGP1D6 ; IHS/CMI/LAB - measure 31 ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
I031 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I BGPAGEB<2 S BGPSTOP=1 Q
I BGPAGEB>74 S BGPSTOP=1 Q
I BGPAGEB>1 S BGPD1=1
I BGPAGEB>1,BGPAGEB<6 S BGPD2=1
I BGPAGEB>5,BGPAGEB<12 S BGPD3=1
I BGPAGEB>11,BGPAGEB<20 S BGPD4=1
I BGPAGEB>19,BGPAGEB<25 S BGPD5=1
I BGPAGEB>24,BGPAGEB<35 S BGPD6=1
I BGPAGEB>34,BGPAGEB<45 S BGPD7=1
I BGPAGEB>44,BGPAGEB<55 S BGPD8=1
I BGPAGEB>54,BGPAGEB<75 S BGPD9=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9) S BGPSTOP=1 Q
S BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE),BGPN1=$S(BGPBMI]"":1,1:0)
S BGPXPBV=$$SB^BGP1PDL1($J($P(BGPBMI,U),6,2)) S:BGPXPBV="0.00" BGPXPBV=""
S BGPN2=$$OW(DFN,BGPBMI,BGPAGEE)
S BGPN3=$$OB(DFN,BGPBMI,BGPAGEE)
I BGPN2!(BGPN3) S BGPN4=1
I 'BGPN1 S BGPREF=$$REF(DFN,BGP365,BGPEDATE,BGPAGEB) I $P(BGPREF,U)=1 S BGPN5=1
;I BGPN5 S BGPN1=1
S BGPVALUE=$S(BGPD1:"UP",1:"") I BGPD1,BGPACTCL S BGPVALUE=BGPVALUE_";AC"
S BGPVALUE=BGPVALUE_"|||"_$S(BGPBMI]"":$$SB^BGP1PDL1($J($P(BGPBMI,U),6,2)),1:"")_$S(BGPN2:" [OVERWEIGHT]",1:"")_$S(BGPN3:" [OBESE]",1:"")
I BGPN5 S BGPVALUE=BGPVALUE_"Refused " ;_$P(BGPREF,U,2)_" "_$$DATE^BGP1UTL($P(BGPREF,U,3))_" "_$P(BGPREF,U,5)_" "_$$DATE^BGP1UTL($P(BGPREF,U,6))
K BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
Q
I031A ;
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I BGPAGEB<2 S BGPSTOP=1 Q
I BGPAGEB>5 S BGPSTOP=1 Q
I BGPAGEE>5 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
S BGPD1=1
S BGPBMI=$$BMIOR(DFN,BGPBDATE,BGPEDATE,BGPAGEE)
I $P(BGPBMI,U)="" S BGPSTOP=1 Q ;no bmi
S BGPOW=$$OW(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
S BGPOB=$$OB(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOB S BGPN2=1
I BGPN1!(BGPN2) S BGPN3=1
S A=$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))
I A=2 S BGPD2=1
I A=3 S BGPD3=1
I A=4 S BGPD4=1
I A=5 S BGPD5=1
I '(BGPD2+BGPD3+BGPD4+BGPD5) W !,BGPBOMB
S BGPVALUE=$S(BGPD1:"AC",1:"")
I $P(BGPBMI,U)]"" S BGPVALUE=BGPVALUE_"|||"_" Age at BMI: "_A_"; "_$$DATE^BGP1UTL($P(BGPBMI,U,2))_" "_$P(BGPBMI,U)
I $P(BGPOW,U,2)]""!($P(BGPOB,U,2)]"") S BGPVALUE=BGPVALUE_" [Outside Data Check Limits]"
I BGPN1 S BGPVALUE=BGPVALUE_" [OVERWEIGHT] "
I BGPN2 S BGPVALUE=BGPVALUE_" [OBESE] "
K BGPBMIH,BGPBMI,BGPOW,BGPOB
Q
BMIOR(P,BDATE,EDATE,AGE) ;EP
KILL %,W,H,B,D,%DT
S BGPBMIH=""
D Q BGPBMIH
.S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S X=$$HTWTSDOR(P,BDATE,EDATE)
.I '$P(X,"^") Q
.S W=$P(X,"^",2),H=$P(X,"^",3)
.S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=$$SB^BGP1PDL1($J((W/H),6,2))_U_$P(X,U,1)
.;S W=$P(X,"^",5),H=$P(X,"^",6)
.;S W=W*.45359,H=(H*.0254),H=(H*H),$P(BGPBMIH,U,3)=$$SB^BGP1PDL1($J((W/H),6,2))_U_$P(X,U,4)
.Q
Q ""
HTWTSDOR(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLHTS(")
S Y=0 F S Y=$O(BGPLHTS(Y)) Q:Y'=+Y I $P(BGPLHTS(Y),U,2)="?"!($P(BGPLHTS(Y),U,2)="") K BGPLHTS(Y)
;set the array up by date
K BGPLHTS1 S X=0 F S X=$O(BGPLHTS(X)) Q:X'=+X S BGPLHTS1($P(BGPLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLWTS(")
S Y=0 F S Y=$O(BGPLWTS(Y)) Q:Y'=+Y I $P(BGPLWTS(Y),U,2)="?"!($P(BGPLWTS(Y),U,2)="") K BGPLWTS(Y)
;set the array up by date
K BGPLWTS1 S X=0 F S X=$O(BGPLWTS(X)) Q:X'=+X S BGPLWTS1($P(BGPLWTS(X),U))=X
S BGPLCHT="",X=9999999 F S X=$O(BGPLWTS1(X),-1) Q:X=""!(BGPLCHT]"") I $D(BGPLHTS1(X)) S BGPLCHT=$P(BGPLWTS(BGPLWTS1(X)),U)_U_$P(BGPLWTS(BGPLWTS1(X)),U,2)_U_$P(BGPLHTS(BGPLHTS1(X)),U,2)
Q BGPLCHT
;KEEP IN CASE
K BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
S EDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(BGPLCHT,U),-91))
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLHTS(")
S Y=0 F S Y=$O(BGPLHTS(Y)) Q:Y'=+Y I $P(BGPLHTS(Y),U,2)="?"!($P(BGPLHTS(Y),U,2)="") K BGPLHTS(Y)
;set the array up by date
K BGPLHTS1 S X=0 F S X=$O(BGPLHTS(X)) Q:X'=+X S BGPLHTS1($P(BGPLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLWTS(")
S Y=0 F S Y=$O(BGPLWTS(Y)) Q:Y'=+Y I $P(BGPLWTS(Y),U,2)="?"!($P(BGPLWTS(Y),U,2)="") K BGPLWTS(Y)
;set the array up by date
K BGPLWTS1 S X=0 F S X=$O(BGPLWTS(X)) Q:X'=+X S BGPLWTS1($P(BGPLWTS(X),U))=X
S X=0 F S X=$O(BGPLWTS1(X)) Q:X=""!($P(BGPLCHT,U,4)]"") I $D(BGPLHTS1(X)) S $P(BGPLCHT,U,4)=$P(BGPLWTS(BGPLWTS1(X)),U)_U_$P(BGPLWTS(BGPLWTS1(X)),U,2)_U_$P(BGPLHTS(BGPLHTS1(X)),U,2)
Q BGPLCHT
OB(P,BMI,A) ;EP obese
I $G(BMI)="" Q ""
S S=$P(^DPT(P,0),U,2)
I S="" Q ""
S R=0,R=$O(^APCLBMI("H",S,A,R))
I 'R S R=$O(^APCLBMI("H",S,A)) I R S R=$O(^APCLBMI("H",S,R,""))
I 'R Q ""
I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q "0^Outside Data Check Limits"
I BMI'<$P(^APCLBMI(R,0),U,5) Q 1
Q ""
OW(P,BMI,A) ;EP overweight
I $G(BMI)="" Q ""
S S=$P(^DPT(P,0),U,2)
I S="" Q ""
S R=0,R=$O(^APCLBMI("H",S,A,R))
I 'R S R=$O(^APCLBMI("H",S,A)) I R S R=$O(^APCLBMI("H",S,R,""))
I 'R Q ""
I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q "0^Outside Data Check Limits"
I BMI'<$P(^APCLBMI(R,0),U,4),BMI<$P(^APCLBMI(R,0),U,5) Q 1
Q ""
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
KILL %,BGPARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPARRY(") S H=$P($G(BGPARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
S H=$J(H,2,0)
Q H
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
KILL %,E,BGPLW,X,BGPLN,BGPL,BGPLD,BGPLZ,BGPLX,ICD
K BGPL S BGPLW="" S BGPLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BGPLX,"BGPL(")
S BGPLN=0 F S BGPLN=$O(BGPL(BGPLN)) Q:BGPLN'=+BGPLN!(BGPLW]"") D
.S BGPLZ=$P(BGPL(BGPLN),U,5)
.I '$D(^AUPNVPOV("AD",BGPLZ)) S BGPLW=$P(BGPL(BGPLN),U,2) Q
. S BGPLD=0 F S BGPLD=$O(^AUPNVPOV("AD",BGPLZ,BGPLD)) Q:'BGPLD!(BGPLW]"") D
.. S D=$P(BGPL(BGPLN),U)
.. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BGPLD,0),U),D),U,2) D
...I $E(ICD,1,3)="V22" Q
...I $E(ICD,1,3)="V23" Q
...I $E(ICD,1,3)="V27" Q
...I $E(ICD,1,3)="V28" Q
...I ICD>629.9999&(ICD<676.95) Q
...I ICD>61.49&(ICD<61.71) Q
...S BGPLW=$P(BGPL(BGPLN),U,2)
..Q
Q BGPLW
;
BMI(P,EDATE,AGE) ;EP
KILL %,W,H,B,D,%DT,BDATE
;S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
S BGPBMIH=""
I AGE>18,AGE<51 D Q BGPBMIH
.S BDATE=$$FMADD^XLFDT(EDATE,-(5*365)),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S W=$$WT(P,BDATE,EDATE) I W=""!(W="?") Q
.;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
.S HDATE=BDATE
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
I AGE>50 D Q BGPBMIH
.S BDATE=$$FMADD^XLFDT(EDATE,-(2*365)),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S W=$$WT(P,BDATE,EDATE) I W=""!(W="?") Q
.;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
.S HDATE=BDATE
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
I AGE<19 D Q BGPBMIH
.S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S X=$$HTWTSD(P,BDATE,EDATE)
.I '$P(X,"^") Q
.I '$P(X,"^",2) Q
.S W=$P(X,"^"),H=$P(X,"^",2)
.S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
.Q
Q
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLHTS(")
S Y=0 F S Y=$O(BGPLHTS(Y)) Q:Y'=+Y I $P(BGPLHTS(Y),U,2)="?"!($P(BGPLHTS(Y),U,2)="") K BGPLHTS(Y)
;set the array up by date
K BGPLHTS1 S X=0 F S X=$O(BGPLHTS(X)) Q:X'=+X S BGPLHTS1($P(BGPLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLWTS(")
S Y=0 F S Y=$O(BGPLWTS(Y)) Q:Y'=+Y I $P(BGPLWTS(Y),U,2)="?"!($P(BGPLWTS(Y),U,2)="") K BGPLWTS(Y)
;set the array up by date
K BGPLWTS1 S X=0 F S X=$O(BGPLWTS(X)) Q:X'=+X S BGPLWTS1($P(BGPLWTS(X),U))=X
S BGPLCHT="",X=9999999 F S X=$O(BGPLWTS1(X),-1) Q:X=""!(BGPLCHT]"") I $D(BGPLHTS1(X)) S BGPLCHT=$P(BGPLWTS(BGPLWTS1(X)),U,2)_U_$P(BGPLHTS(BGPLHTS1(X)),U,2)
Q BGPLCHT
;
REF(P,BDATE,EDATE,AGE) ;EP - get ht/wt refusal in past year, same date for 18 and under
S R=""
I AGE<19 G AGE18R
S X=$$REFUSAL^BGP1UTL1(P,9999999.07,$O(^AUTTMSR("B","HT",0)),BDATE,EDATE) I X S R=1_U_"HT"_U_$P(X,U,2)
S Y=$$REFUSAL^BGP1UTL1(P,9999999.07,$O(^AUTTMSR("B","WT",0)),BDATE,EDATE) I Y S $P(R,U,4)=1,$P(R,U,5)="WT",$P(R,U,6)=$P(Y,U,2)
I X="",Y="" Q ""
Q R
AGE18R ;
K H,W
S H=$O(^AUTTMSR("B","HT",0))
S Z=0 F S Z=$O(^AUPNPREF("AA",P,9999999.07,H,Z)) Q:Z'=+Z D
.S V=0 F S V=$O(^AUPNPREF("AA",P,9999999.07,H,Z,V)) Q:V'=+V D
..Q:'$D(^AUPNPREF(V,0))
..S D=$P(^AUPNPREF(V,0),U,3)
..Q:D>EDATE
..Q:D<BDATE
..S H(D)=""
..Q
.Q
S W=$O(^AUTTMSR("B","WT",0))
S Z=0 F S Z=$O(^AUPNPREF("AA",P,9999999.07,W,Z)) Q:Z'=+Z D
.S V=0 F S V=$O(^AUPNPREF("AA",P,9999999.07,W,Z,V)) Q:V'=+V D
..Q:'$D(^AUPNPREF(V,0))
..S D=$P(^AUPNPREF(V,0),U,3)
..Q:D>EDATE
..Q:D<BDATE
..Q:"NRU"'[$P(^AUPNPREF(V,0),U,7)
..S W(D)=""
..Q
.Q
;is there an H and w on same day?
S X=0 F S X=$O(H(X)) Q:X'=+X!(R]"") I $D(W(X)) S R=1_U_"HT/WT"_U_X
Q R
BGP1D6 ; IHS/CMI/LAB - measure 31 ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
I031 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF BGPAGEB<2
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB>74
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB>1
SET BGPD1=1
+5 IF BGPAGEB>1
IF BGPAGEB<6
SET BGPD2=1
+6 IF BGPAGEB>5
IF BGPAGEB<12
SET BGPD3=1
+7 IF BGPAGEB>11
IF BGPAGEB<20
SET BGPD4=1
+8 IF BGPAGEB>19
IF BGPAGEB<25
SET BGPD5=1
+9 IF BGPAGEB>24
IF BGPAGEB<35
SET BGPD6=1
+10 IF BGPAGEB>34
IF BGPAGEB<45
SET BGPD7=1
+11 IF BGPAGEB>44
IF BGPAGEB<55
SET BGPD8=1
+12 IF BGPAGEB>54
IF BGPAGEB<75
SET BGPD9=1
+13 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9)
SET BGPSTOP=1
QUIT
+14 SET BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE)
SET BGPN1=$SELECT(BGPBMI]"":1,1:0)
+15 SET BGPXPBV=$$SB^BGP1PDL1($JUSTIFY($PIECE(BGPBMI,U),6,2))
IF BGPXPBV="0.00"
SET BGPXPBV=""
+16 SET BGPN2=$$OW(DFN,BGPBMI,BGPAGEE)
+17 SET BGPN3=$$OB(DFN,BGPBMI,BGPAGEE)
+18 IF BGPN2!(BGPN3)
SET BGPN4=1
+19 IF 'BGPN1
SET BGPREF=$$REF(DFN,BGP365,BGPEDATE,BGPAGEB)
IF $PIECE(BGPREF,U)=1
SET BGPN5=1
+20 ;I BGPN5 S BGPN1=1
+21 SET BGPVALUE=$SELECT(BGPD1:"UP",1:"")
IF BGPD1
IF BGPACTCL
SET BGPVALUE=BGPVALUE_";AC"
+22 SET BGPVALUE=BGPVALUE_"|||"_$SELECT(BGPBMI]"":$$SB^BGP1PDL1($JUSTIFY($PIECE(BGPBMI,U),6,2)),1:"")_$SELECT(BGPN2:" [OVERWEIGHT]",1:"")_$SELECT(BGPN3:" [OBESE]",1:"")
+23 ;_$P(BGPREF,U,2)_" "_$$DATE^BGP1UTL($P(BGPREF,U,3))_" "_$P(BGPREF,U,5)_" "_$$DATE^BGP1UTL($P(BGPREF,U,6))
IF BGPN5
SET BGPVALUE=BGPVALUE_"Refused "
+24 KILL BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+25 QUIT
I031A ;
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF BGPAGEB<2
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB>5
SET BGPSTOP=1
QUIT
+4 IF BGPAGEE>5
SET BGPSTOP=1
QUIT
+5 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+6 SET BGPD1=1
+7 SET BGPBMI=$$BMIOR(DFN,BGPBDATE,BGPEDATE,BGPAGEE)
+8 ;no bmi
IF $PIECE(BGPBMI,U)=""
SET BGPSTOP=1
QUIT
+9 SET BGPOW=$$OW(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOW
SET BGPN1=1
+10 SET BGPOB=$$OB(DFN,$PIECE(BGPBMI,U),$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2)))
IF BGPOB
SET BGPN2=1
+11 IF BGPN1!(BGPN2)
SET BGPN3=1
+12 SET A=$$AGE^AUPNPAT(DFN,$PIECE(BGPBMI,U,2))
+13 IF A=2
SET BGPD2=1
+14 IF A=3
SET BGPD3=1
+15 IF A=4
SET BGPD4=1
+16 IF A=5
SET BGPD5=1
+17 IF '(BGPD2+BGPD3+BGPD4+BGPD5)
WRITE !,BGPBOMB
+18 SET BGPVALUE=$SELECT(BGPD1:"AC",1:"")
+19 IF $PIECE(BGPBMI,U)]""
SET BGPVALUE=BGPVALUE_"|||"_" Age at BMI: "_A_"; "_$$DATE^BGP1UTL($PIECE(BGPBMI,U,2))_" "_$PIECE(BGPBMI,U)
+20 IF $PIECE(BGPOW,U,2)]""!($PIECE(BGPOB,U,2)]"")
SET BGPVALUE=BGPVALUE_" [Outside Data Check Limits]"
+21 IF BGPN1
SET BGPVALUE=BGPVALUE_" [OVERWEIGHT] "
+22 IF BGPN2
SET BGPVALUE=BGPVALUE_" [OBESE] "
+23 KILL BGPBMIH,BGPBMI,BGPOW,BGPOB
+24 QUIT
BMIOR(P,BDATE,EDATE,AGE) ;EP
+1 KILL %,W,H,B,D,%DT
+2 SET BGPBMIH=""
+3 Begin DoDot:1
+4 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+5 SET X=$$HTWTSDOR(P,BDATE,EDATE)
+6 IF '$PIECE(X,"^")
QUIT
+7 SET W=$PIECE(X,"^",2)
SET H=$PIECE(X,"^",3)
+8 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=$$SB^BGP1PDL1($JUSTIFY((W/H),6,2))_U_$PIECE(X,U,1)
+9 ;S W=$P(X,"^",5),H=$P(X,"^",6)
+10 ;S W=W*.45359,H=(H*.0254),H=(H*H),$P(BGPBMIH,U,3)=$$SB^BGP1PDL1($J((W/H),6,2))_U_$P(X,U,4)
+11 QUIT
End DoDot:1
QUIT BGPBMIH
+12 QUIT ""
HTWTSDOR(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(BGPLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLHTS(Y),U,2)="?"!($PIECE(BGPLHTS(Y),U,2)="")
KILL BGPLHTS(Y)
+6 ;set the array up by date
+7 KILL BGPLHTS1
SET X=0
FOR
SET X=$ORDER(BGPLHTS(X))
IF X'=+X
QUIT
SET BGPLHTS1($PIECE(BGPLHTS(X),U))=X
+8 ;get all wts during time frame
+9 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLWTS(")
+10 SET Y=0
FOR
SET Y=$ORDER(BGPLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLWTS(Y),U,2)="?"!($PIECE(BGPLWTS(Y),U,2)="")
KILL BGPLWTS(Y)
+11 ;set the array up by date
+12 KILL BGPLWTS1
SET X=0
FOR
SET X=$ORDER(BGPLWTS(X))
IF X'=+X
QUIT
SET BGPLWTS1($PIECE(BGPLWTS(X),U))=X
+13 SET BGPLCHT=""
SET X=9999999
FOR
SET X=$ORDER(BGPLWTS1(X),-1)
IF X=""!(BGPLCHT]"")
QUIT
IF $DATA(BGPLHTS1(X))
SET BGPLCHT=$PIECE(BGPLWTS(BGPLWTS1(X)),U)_U_$PIECE(BGPLWTS(BGPLWTS1(X)),U,2)_U_$PIECE(BGPLHTS(BGPLHTS1(X)),U,2)
+14 QUIT BGPLCHT
+15 ;KEEP IN CASE
+16 KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+17 SET EDATE=$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(BGPLCHT,U),-91))
+18 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLHTS(")
+19 SET Y=0
FOR
SET Y=$ORDER(BGPLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLHTS(Y),U,2)="?"!($PIECE(BGPLHTS(Y),U,2)="")
KILL BGPLHTS(Y)
+20 ;set the array up by date
+21 KILL BGPLHTS1
SET X=0
FOR
SET X=$ORDER(BGPLHTS(X))
IF X'=+X
QUIT
SET BGPLHTS1($PIECE(BGPLHTS(X),U))=X
+22 ;get all wts during time frame
+23 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLWTS(")
+24 SET Y=0
FOR
SET Y=$ORDER(BGPLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLWTS(Y),U,2)="?"!($PIECE(BGPLWTS(Y),U,2)="")
KILL BGPLWTS(Y)
+25 ;set the array up by date
+26 KILL BGPLWTS1
SET X=0
FOR
SET X=$ORDER(BGPLWTS(X))
IF X'=+X
QUIT
SET BGPLWTS1($PIECE(BGPLWTS(X),U))=X
+27 SET X=0
FOR
SET X=$ORDER(BGPLWTS1(X))
IF X=""!($PIECE(BGPLCHT,U,4)]"")
QUIT
IF $DATA(BGPLHTS1(X))
SET $PIECE(BGPLCHT,U,4)=$PIECE(BGPLWTS(BGPLWTS1(X)),U)_U_$PIECE(BGPLWTS(BGPLWTS1(X)),U,2)_U_$PIECE(BGPLHTS(BGPLHTS1(X)),U,2)
+28 QUIT BGPLCHT
OB(P,BMI,A) ;EP obese
+1 IF $GET(BMI)=""
QUIT ""
+2 SET S=$PIECE(^DPT(P,0),U,2)
+3 IF S=""
QUIT ""
+4 SET R=0
SET R=$ORDER(^APCLBMI("H",S,A,R))
+5 IF 'R
SET R=$ORDER(^APCLBMI("H",S,A))
IF R
SET R=$ORDER(^APCLBMI("H",S,R,""))
+6 IF 'R
QUIT ""
+7 IF BMI>$PIECE(^APCLBMI(R,0),U,7)!(BMI<$PIECE(^APCLBMI(R,0),U,6))
QUIT "0^Outside Data Check Limits"
+8 IF BMI'<$PIECE(^APCLBMI(R,0),U,5)
QUIT 1
+9 QUIT ""
OW(P,BMI,A) ;EP overweight
+1 IF $GET(BMI)=""
QUIT ""
+2 SET S=$PIECE(^DPT(P,0),U,2)
+3 IF S=""
QUIT ""
+4 SET R=0
SET R=$ORDER(^APCLBMI("H",S,A,R))
+5 IF 'R
SET R=$ORDER(^APCLBMI("H",S,A))
IF R
SET R=$ORDER(^APCLBMI("H",S,R,""))
+6 IF 'R
QUIT ""
+7 IF BMI>$PIECE(^APCLBMI(R,0),U,7)!(BMI<$PIECE(^APCLBMI(R,0),U,6))
QUIT "0^Outside Data Check Limits"
+8 IF BMI'<$PIECE(^APCLBMI(R,0),U,4)
IF BMI<$PIECE(^APCLBMI(R,0),U,5)
QUIT 1
+9 QUIT ""
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 KILL %,BGPARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPARRY(")
SET H=$PIECE($GET(BGPARRY(1)),U,2)
+4 IF H=""
QUIT H
+5 IF H["?"
QUIT ""
+6 SET H=$JUSTIFY(H,2,0)
+7 QUIT H
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 KILL %,E,BGPLW,X,BGPLN,BGPL,BGPLD,BGPLZ,BGPLX,ICD
+3 KILL BGPL
SET BGPLW=""
SET BGPLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BGPLX,"BGPL(")
+4 SET BGPLN=0
FOR
SET BGPLN=$ORDER(BGPL(BGPLN))
IF BGPLN'=+BGPLN!(BGPLW]"")
QUIT
Begin DoDot:1
+5 SET BGPLZ=$PIECE(BGPL(BGPLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",BGPLZ))
SET BGPLW=$PIECE(BGPL(BGPLN),U,2)
QUIT
+7 SET BGPLD=0
FOR
SET BGPLD=$ORDER(^AUPNVPOV("AD",BGPLZ,BGPLD))
IF 'BGPLD!(BGPLW]"")
QUIT
Begin DoDot:2
+8 SET D=$PIECE(BGPL(BGPLN),U)
+9 SET ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BGPLD,0),U),D),U,2)
Begin DoDot:3
+10 IF $EXTRACT(ICD,1,3)="V22"
QUIT
+11 IF $EXTRACT(ICD,1,3)="V23"
QUIT
+12 IF $EXTRACT(ICD,1,3)="V27"
QUIT
+13 IF $EXTRACT(ICD,1,3)="V28"
QUIT
+14 IF ICD>629.9999&(ICD<676.95)
QUIT
+15 IF ICD>61.49&(ICD<61.71)
QUIT
+16 SET BGPLW=$PIECE(BGPL(BGPLN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT BGPLW
+19 ;
BMI(P,EDATE,AGE) ;EP
+1 KILL %,W,H,B,D,%DT,BDATE
+2 ;S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
+3 SET BGPBMIH=""
+4 IF AGE>18
IF AGE<51
Begin DoDot:1
+5 SET BDATE=$$FMADD^XLFDT(EDATE,-(5*365))
SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+6 SET W=$$WT(P,BDATE,EDATE)
IF W=""!(W="?")
QUIT
+7 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
+8 SET HDATE=BDATE
+9 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+10 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=(W/H)
End DoDot:1
QUIT BGPBMIH
+11 IF AGE>50
Begin DoDot:1
+12 SET BDATE=$$FMADD^XLFDT(EDATE,-(2*365))
SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+13 SET W=$$WT(P,BDATE,EDATE)
IF W=""!(W="?")
QUIT
+14 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
+15 SET HDATE=BDATE
+16 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+17 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=(W/H)
End DoDot:1
QUIT BGPBMIH
+18 IF AGE<19
Begin DoDot:1
+19 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+20 SET X=$$HTWTSD(P,BDATE,EDATE)
+21 IF '$PIECE(X,"^")
QUIT
+22 IF '$PIECE(X,"^",2)
QUIT
+23 SET W=$PIECE(X,"^")
SET H=$PIECE(X,"^",2)
+24 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=(W/H)
+25 QUIT
End DoDot:1
QUIT BGPBMIH
+26 QUIT
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(BGPLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLHTS(Y),U,2)="?"!($PIECE(BGPLHTS(Y),U,2)="")
KILL BGPLHTS(Y)
+6 ;set the array up by date
+7 KILL BGPLHTS1
SET X=0
FOR
SET X=$ORDER(BGPLHTS(X))
IF X'=+X
QUIT
SET BGPLHTS1($PIECE(BGPLHTS(X),U))=X
+8 ;get all wts during time frame
+9 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLWTS(")
+10 SET Y=0
FOR
SET Y=$ORDER(BGPLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLWTS(Y),U,2)="?"!($PIECE(BGPLWTS(Y),U,2)="")
KILL BGPLWTS(Y)
+11 ;set the array up by date
+12 KILL BGPLWTS1
SET X=0
FOR
SET X=$ORDER(BGPLWTS(X))
IF X'=+X
QUIT
SET BGPLWTS1($PIECE(BGPLWTS(X),U))=X
+13 SET BGPLCHT=""
SET X=9999999
FOR
SET X=$ORDER(BGPLWTS1(X),-1)
IF X=""!(BGPLCHT]"")
QUIT
IF $DATA(BGPLHTS1(X))
SET BGPLCHT=$PIECE(BGPLWTS(BGPLWTS1(X)),U,2)_U_$PIECE(BGPLHTS(BGPLHTS1(X)),U,2)
+14 QUIT BGPLCHT
+15 ;
REF(P,BDATE,EDATE,AGE) ;EP - get ht/wt refusal in past year, same date for 18 and under
+1 SET R=""
+2 IF AGE<19
GOTO AGE18R
+3 SET X=$$REFUSAL^BGP1UTL1(P,9999999.07,$ORDER(^AUTTMSR("B","HT",0)),BDATE,EDATE)
IF X
SET R=1_U_"HT"_U_$PIECE(X,U,2)
+4 SET Y=$$REFUSAL^BGP1UTL1(P,9999999.07,$ORDER(^AUTTMSR("B","WT",0)),BDATE,EDATE)
IF Y
SET $PIECE(R,U,4)=1
SET $PIECE(R,U,5)="WT"
SET $PIECE(R,U,6)=$PIECE(Y,U,2)
+5 IF X=""
IF Y=""
QUIT ""
+6 QUIT R
AGE18R ;
+1 KILL H,W
+2 SET H=$ORDER(^AUTTMSR("B","HT",0))
+3 SET Z=0
FOR
SET Z=$ORDER(^AUPNPREF("AA",P,9999999.07,H,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+4 SET V=0
FOR
SET V=$ORDER(^AUPNPREF("AA",P,9999999.07,H,Z,V))
IF V'=+V
QUIT
Begin DoDot:2
+5 IF '$DATA(^AUPNPREF(V,0))
QUIT
+6 SET D=$PIECE(^AUPNPREF(V,0),U,3)
+7 IF D>EDATE
QUIT
+8 IF D<BDATE
QUIT
+9 SET H(D)=""
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET W=$ORDER(^AUTTMSR("B","WT",0))
+13 SET Z=0
FOR
SET Z=$ORDER(^AUPNPREF("AA",P,9999999.07,W,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+14 SET V=0
FOR
SET V=$ORDER(^AUPNPREF("AA",P,9999999.07,W,Z,V))
IF V'=+V
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNPREF(V,0))
QUIT
+16 SET D=$PIECE(^AUPNPREF(V,0),U,3)
+17 IF D>EDATE
QUIT
+18 IF D<BDATE
QUIT
+19 IF "NRU"'[$PIECE(^AUPNPREF(V,0),U,7)
QUIT
+20 SET W(D)=""
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 ;is there an H and w on same day?
+24 SET X=0
FOR
SET X=$ORDER(H(X))
IF X'=+X!(R]"")
QUIT
IF $DATA(W(X))
SET R=1_U_"HT/WT"_U_X
+25 QUIT R
