- 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
