BDMPA18 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**6,8**;JUN 14, 2007;Build 53
;
;cmi/anch/maw 9/10/2007 code set versioning in WT
;
HT(P,BDATE,EDATE) ;PEP - CALLED TO GET LAST HEIGHT VALUE IN DATE RANGE BDATE TO EDATE
I 'P Q ""
NEW %,BDMARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
S H=$J(H,4,1)
Q H
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD
K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
S BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"") D
.S BDMZ=$P(BDM(BDMN),U,5)
.I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2) Q
. S BDMD=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"") D
.. ;S ICD=$P(^ICD9($P(^AUPNVPOV(BDMD,0),U),0),U) D ;cmi/anch/maw 9/12/2007 orig line
.. S ICD=$P($$ICDDX^BDMUTL($P(^AUPNVPOV(BDMD,0),U)),U,2) D ;cmi/anch/maw 9/12/2007 csv
...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 BDMW=$P(BDM(BDMN),U,2)
..Q
Q BDMW
BMI(P,BDATE,EDATE) ;EP
I 'P Q -1
NEW %,W,H,B,D,%DT
S %DT="P",X=EDATE D ^%DT S D=Y
S %=""
I $$AGE^AUPNPAT(P,D)>19 D Q %
.S W=$$WT(P,BDATE,EDATE) I 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*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)
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),%=(W/H),%=$J(%,4,1)
Q %
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
NEW BDMWTS,BDMHTS,%,X,BDMWTS1,BDMHTS1
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMHTS(")
;set the array up by date
K BDMHTS1 S X=0 F S X=$O(BDMHTS(X)) Q:X'=+X S BDMHTS1($P(BDMHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMWTS(")
;set the array up by date
K BDMWTS1 S X=0 F S X=$O(BDMWTS(X)) Q:X'=+X S BDMWTS1($P(BDMWTS(X),U))=X
NEW BDMCHT S BDMCHT="",X=9999999 F S X=$O(BDMWTS1(X),-1) Q:X=""!(BDMCHT]"") I $D(BDMHTS1(X)) S BDMCHT=$P(BDMWTS(BDMWTS1(X)),U,2)_U_$P(BDMHTS(BDMHTS1(X)),U,2)
Q BDMCHT
BDMPA18 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**6,8**;JUN 14, 2007;Build 53
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in WT
+4 ;
HT(P,BDATE,EDATE) ;PEP - CALLED TO GET LAST HEIGHT VALUE IN DATE RANGE BDATE TO EDATE
+1 IF 'P
QUIT ""
+2 NEW %,BDMARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"BDMARRY(")
SET H=$PIECE($GET(BDMARRY(1)),U,2)
+4 IF H=""
QUIT H
+5 IF H["?"
QUIT ""
+6 SET H=$JUSTIFY(H,4,1)
+7 QUIT H
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX,ICD
+3 KILL BDM
SET BDMW=""
SET BDMX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BDMX,"BDM(")
+4 SET BDMN=0
FOR
SET BDMN=$ORDER(BDM(BDMN))
IF BDMN'=+BDMN!(BDMW]"")
QUIT
Begin DoDot:1
+5 SET BDMZ=$PIECE(BDM(BDMN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",BDMZ))
SET BDMW=$PIECE(BDM(BDMN),U,2)
QUIT
+7 SET BDMD=0
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD!(BDMW]"")
QUIT
Begin DoDot:2
+8 ;S ICD=$P(^ICD9($P(^AUPNVPOV(BDMD,0),U),0),U) D ;cmi/anch/maw 9/12/2007 orig line
+9 ;cmi/anch/maw 9/12/2007 csv
SET ICD=$PIECE($$ICDDX^BDMUTL($PIECE(^AUPNVPOV(BDMD,0),U)),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 BDMW=$PIECE(BDM(BDMN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT BDMW
BMI(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT -1
+2 NEW %,W,H,B,D,%DT
+3 SET %DT="P"
SET X=EDATE
DO ^%DT
SET D=Y
+4 SET %=""
+5 IF $$AGE^AUPNPAT(P,D)>19
Begin DoDot:1
+6 SET W=$$WT(P,BDATE,EDATE)
IF 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 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
End DoDot:1
QUIT %
+10 SET X=$$HTWTSD(P,BDATE,EDATE)
+11 IF '$PIECE(X,"^")
QUIT %
+12 IF '$PIECE(X,"^",2)
QUIT %
+13 SET W=$PIECE(X,"^")
SET H=$PIECE(X,"^",2)
+14 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET %=(W/H)
SET %=$JUSTIFY(%,4,1)
+15 QUIT %
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 NEW BDMWTS,BDMHTS,%,X,BDMWTS1,BDMHTS1
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"BDMHTS(")
+5 ;set the array up by date
+6 KILL BDMHTS1
SET X=0
FOR
SET X=$ORDER(BDMHTS(X))
IF X'=+X
QUIT
SET BDMHTS1($PIECE(BDMHTS(X),U))=X
+7 ;get all wts during time frame
+8 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"BDMWTS(")
+9 ;set the array up by date
+10 KILL BDMWTS1
SET X=0
FOR
SET X=$ORDER(BDMWTS(X))
IF X'=+X
QUIT
SET BDMWTS1($PIECE(BDMWTS(X),U))=X
+11 NEW BDMCHT
SET BDMCHT=""
SET X=9999999
FOR
SET X=$ORDER(BDMWTS1(X),-1)
IF X=""!(BDMCHT]"")
QUIT
IF $DATA(BDMHTS1(X))
SET BDMCHT=$PIECE(BDMWTS(BDMWTS1(X)),U,2)_U_$PIECE(BDMHTS(BDMHTS1(X)),U,2)
+12 QUIT BDMCHT
