- BDMP718 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
- ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
- ;
- ;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^ICDCODE($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
- BDMP718 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
- +1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
- +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^ICDCODE($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
