BGPD29 ; IHS/CMI/LAB - indicator 29 ;
;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
;
I29 ;EP ;EP - indicator 29
;Q:'$D(BGPIND(25))
S BGPSEX=$P(^DPT(DFN,0),U,2),BGPSEX=$S(BGPSEX="M":1,1:2)
S BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE),BGPBMIC=$S(BGPBMI]"":1,1:0)
S BGPOVW=$$OW(DFN,BGPBMI,BGPAGEE)
S BGPOBE=$$OB(DFN,BGPBMI,BGPAGEE)
S BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE),BGPBMIC=$S(BGPBMI]"":1,1:0)
S BGPOVW=$$OW(DFN,BGPBMI,BGPAGEE)
S BGPOBE=$$OB(DFN,BGPBMI,BGPAGEE)
I BGPAGEE>1,BGPAGEE<6 S BGPPN=$S(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999),BGPPP=1 D S1
I BGPAGEE>6,BGPAGEE<12 S BGPPN=$S(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999),BGPPP=2 D S1
I BGPAGEE>11,BGPAGEE<20 S BGPPN=$S(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999),BGPPP=3 D S1
I BGPAGEE>19,BGPAGEE<25 S BGPPN=$S(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999),BGPPP=4 D S1
I BGPAGEE>24,BGPAGEE<35 S BGPPN=$S(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999),BGPPP=5 D S1
I BGPAGEE>34,BGPAGEE<45 S BGPPN=$S(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999),BGPPP=3 D S1
I BGPAGEE>44,BGPAGEE<55 S BGPPN=$S(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999),BGPPP=4 D S1
I BGPAGEE>54,BGPAGEE<65 S BGPPN=$S(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999),BGPPP=5 D S1
I BGPAGEE>64 S BGPPN=$S(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999),BGPPP=6 D S1
I $D(BGPLIST(25)),BGPTIME=1 S ^XTMP("BGPD",BGPJ,BGPH,"LIST",25,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPBMI
Q
S1 ;
;set denominator
D SETPA(BGPRPT,BGPPN,BGPPP,1,BGPSEX,1) ;set denominator # of pats
D SETPA(BGPRPT,BGPPN,BGPPP,2,BGPSEX,BGPBMIC) ;set # with bmi calc
D SETPA(BGPRPT,BGPPN,BGPPP,3,BGPSEX,BGPOVW)
D SETPA(BGPRPT,BGPPN,BGPPP,4,BGPSEX,BGPOBE)
Q
SETPA(R,N,P,P1,S,V) ;
NEW X,Y,F,M
S X=$P($G(^BGPD(R,N)),U,P) ;whole string
S M=$P(X,"!",1) ;males
S F=$P(X,"!",2)
I S=2 S $P(F,"~",P1)=$P(F,"~",P1)+V
I S=1 S $P(M,"~",P1)=$P(M,"~",P1)+V
S X=M_"!"_F
S $P(^BGPD(R,N),U,P)=X
Q
OB(P,BMI,A) ;EP obese
I $G(BMI)="" Q ""
NEW S S S=$P(^DPT(P,0),U,2)
I S="" Q ""
NEW R 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 ""
I BMI'<$P(^APCLBMI(R,0),U,5) Q 1
Q ""
OW(P,BMI,A) ;EP overweight
I $G(BMI)="" Q ""
NEW S S S=$P(^DPT(P,0),U,2)
I S="" Q ""
NEW R 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 ""
I BMI'<$P(^APCLBMI(R,0),U,4) Q 1
Q ""
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,BGPARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X 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 ""
NEW %,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 ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BGPLD,0),U)),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
I 'P Q -1
NEW %,W,H,B,D,%DT,BDATE
S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
S %=""
I AGE>19 D Q %
.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 H=$$HT(P,HDATE,EDATE) I H="" Q
.;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
.;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H)
.S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H)
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/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H)
S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H)
Q %
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
NEW BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE NEW X 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 NEW X 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
NEW BGPLCHT 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
BGPD29 ; IHS/CMI/LAB - indicator 29 ;
+1 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
+2 ;
I29 ;EP ;EP - indicator 29
+1 ;Q:'$D(BGPIND(25))
+2 SET BGPSEX=$PIECE(^DPT(DFN,0),U,2)
SET BGPSEX=$SELECT(BGPSEX="M":1,1:2)
+3 SET BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE)
SET BGPBMIC=$SELECT(BGPBMI]"":1,1:0)
+4 SET BGPOVW=$$OW(DFN,BGPBMI,BGPAGEE)
+5 SET BGPOBE=$$OB(DFN,BGPBMI,BGPAGEE)
+6 SET BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE)
SET BGPBMIC=$SELECT(BGPBMI]"":1,1:0)
+7 SET BGPOVW=$$OW(DFN,BGPBMI,BGPAGEE)
+8 SET BGPOBE=$$OB(DFN,BGPBMI,BGPAGEE)
+9 IF BGPAGEE>1
IF BGPAGEE<6
SET BGPPN=$SELECT(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999)
SET BGPPP=1
DO S1
+10 IF BGPAGEE>6
IF BGPAGEE<12
SET BGPPN=$SELECT(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999)
SET BGPPP=2
DO S1
+11 IF BGPAGEE>11
IF BGPAGEE<20
SET BGPPN=$SELECT(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999)
SET BGPPP=3
DO S1
+12 IF BGPAGEE>19
IF BGPAGEE<25
SET BGPPN=$SELECT(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999)
SET BGPPP=4
DO S1
+13 IF BGPAGEE>24
IF BGPAGEE<35
SET BGPPN=$SELECT(BGPTIME=1:16,BGPTIME=0:46,BGPTIME=8:86,1:999)
SET BGPPP=5
DO S1
+14 IF BGPAGEE>34
IF BGPAGEE<45
SET BGPPN=$SELECT(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999)
SET BGPPP=3
DO S1
+15 IF BGPAGEE>44
IF BGPAGEE<55
SET BGPPN=$SELECT(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999)
SET BGPPP=4
DO S1
+16 IF BGPAGEE>54
IF BGPAGEE<65
SET BGPPN=$SELECT(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999)
SET BGPPP=5
DO S1
+17 IF BGPAGEE>64
SET BGPPN=$SELECT(BGPTIME=1:20,BGPTIME=0:50,BGPTIME=8:90,1:999)
SET BGPPP=6
DO S1
+18 IF $DATA(BGPLIST(25))
IF BGPTIME=1
SET ^XTMP("BGPD",BGPJ,BGPH,"LIST",25,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEE,DFN)=BGPBMI
+19 QUIT
S1 ;
+1 ;set denominator
+2 ;set denominator # of pats
DO SETPA(BGPRPT,BGPPN,BGPPP,1,BGPSEX,1)
+3 ;set # with bmi calc
DO SETPA(BGPRPT,BGPPN,BGPPP,2,BGPSEX,BGPBMIC)
+4 DO SETPA(BGPRPT,BGPPN,BGPPP,3,BGPSEX,BGPOVW)
+5 DO SETPA(BGPRPT,BGPPN,BGPPP,4,BGPSEX,BGPOBE)
+6 QUIT
SETPA(R,N,P,P1,S,V) ;
+1 NEW X,Y,F,M
+2 ;whole string
SET X=$PIECE($GET(^BGPD(R,N)),U,P)
+3 ;males
SET M=$PIECE(X,"!",1)
+4 SET F=$PIECE(X,"!",2)
+5 IF S=2
SET $PIECE(F,"~",P1)=$PIECE(F,"~",P1)+V
+6 IF S=1
SET $PIECE(M,"~",P1)=$PIECE(M,"~",P1)+V
+7 SET X=M_"!"_F
+8 SET $PIECE(^BGPD(R,N),U,P)=X
+9 QUIT
OB(P,BMI,A) ;EP obese
+1 IF $GET(BMI)=""
QUIT ""
+2 NEW S
SET S=$PIECE(^DPT(P,0),U,2)
+3 IF S=""
QUIT ""
+4 NEW R
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 ""
+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 NEW S
SET S=$PIECE(^DPT(P,0),U,2)
+3 IF S=""
QUIT ""
+4 NEW R
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 ""
+8 IF BMI'<$PIECE(^APCLBMI(R,0),U,4)
QUIT 1
+9 QUIT ""
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,BGPARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
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 NEW %,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 ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BGPLD,0),U)),U,2)
Begin DoDot:3
+9 IF $EXTRACT(ICD,1,3)="V22"
QUIT
+10 IF $EXTRACT(ICD,1,3)="V23"
QUIT
+11 IF $EXTRACT(ICD,1,3)="V27"
QUIT
+12 IF $EXTRACT(ICD,1,3)="V28"
QUIT
+13 IF ICD>629.9999&(ICD<676.95)
QUIT
+14 IF ICD>61.49&(ICD<61.71)
QUIT
+15 SET BGPLW=$PIECE(BGPL(BGPLN),U,2)
End DoDot:3
+16 QUIT
End DoDot:2
End DoDot:1
+17 QUIT BGPLW
BMI(P,EDATE,AGE) ;EP
+1 IF 'P
QUIT -1
+2 NEW %,W,H,B,D,%DT,BDATE
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+4 SET %=""
+5 IF AGE>19
Begin DoDot:1
+6 SET W=$$WT(P,BDATE,EDATE)
IF W=""!(W="?")
QUIT
+7 SET HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($PIECE(^DPT(P,0),U,3),(19*365)))
+8 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+9 ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
+10 ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H)
+11 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
End DoDot:1
QUIT %
+12 SET X=$$HTWTSD(P,BDATE,EDATE)
+13 IF '$PIECE(X,"^")
QUIT %
+14 IF '$PIECE(X,"^",2)
QUIT %
+15 SET W=$PIECE(X,"^")
SET H=$PIECE(X,"^",2)
+16 ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)
+17 ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H)
+18 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
+19 QUIT %
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 NEW BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
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
NEW X
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 NEW BGPLCHT
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
