BDMD998.m

BDMD998 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in WT

 ;

BI() ;

 Q $S($O(^AUTTIMM(0))>100:1,1:0)

HT(P,BDATE,EDATE) ;EP

 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,2,0)

 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/10/2007 orig line

 .. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BDMD,0),U)),U,2) D  ;cmi/anch/maw 9/10/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)>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/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)

 .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/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)

 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

PAP(P,BDATE,EDATE) ; EP

 I $$SEX^AUPNPAT(P)'="F" Q "N/A"

 NEW BDM S %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) Q "Yes  "_$$FMTE^XLFDT($P(BDM(1),U))

 K BDM S %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) Q "Yes  "_$$FMTE^XLFDT($P(BDM(1),U))

 K BDM S %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) Q "Yes  "_$$FMTE^XLFDT($P(BDM(1),U))

 ;check pov

 ;check proc

 Q "No"

ALT(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"  "_$$FMTE^XLFDT($P(BDM(1),U),5)

AST(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"  "_$$FMTE^XLFDT($P(BDM(1),U),5)

CREAT(P,BDATE,EDATE,F) ;EP

 I $G(F)="" S F="E"

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT CREATININE TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 I F="I" Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"^"_$P(BDM(1),U)

 Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(1),U),5)

CHOL(P,BDATE,EDATE,F) ;EP

 S:$G(F)="" F="E"

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT CHOLESTEROL TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 I F="I" Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"^"_$P(BDM(1),U)

 Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(1),U),5)

LDL(P,BDATE,EDATE,F) ;EP

 I $G(F)="" S F="E"

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT LDL CHOLESTEROL TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 I F="I" Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"^"_$P(BDM(1),U)

 Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(1),U),5)

TRIG(P,BDATE,EDATE,F) ;EP

 I $G(F)="" S F="E"

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT TRIGLYCERIDE TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 I F="I" Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_"^"_$P(BDM(1),U)

 Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(1),U),5)

URIN(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT URINALYSIS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) Q "Yes  "_$$FMTE^XLFDT($P(BDM(1),U),5)

 NEW G S G=0

 NEW T S T=$O(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0))

 I 'T Q ""

 S X=0 F  S X=$O(^ATXLAB(T,21,X)) Q:X'=+X!(G)  I $$REFUSAL^BDMD997(P,60,$P(^ATXLAB(T,21,X,0),U),BDATE,EDATE) S G=1

 Q $S(G:"Refused",1:"No")

PROTEIN(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 ;Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)

 NEW %,%1 S %=$P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)

 S %1=$S(%="":"No result",%["+":"Yes ",+%>30:"Yes ",1:"No ")

 Q %1_%_" "_$$FMTE^XLFDT($P(BDM(1),U),"5")

MICRO(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST LAB [DM AUDIT MICROALBUMINURIA TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 ;Q $P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)

 NEW %,%1 S %=$P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4)

 S %1=$S(%="":"No result",+%>30:"Pos ",1:"Neg ")

 Q %1_%_" "_$$FMTE^XLFDT($P(BDM(1),U),"5")

HGBA1C(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST 2 LAB [DM AUDIT HGB A1C;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 K X S X(9999999-$P(BDM(1),U),1)=$P(^AUPNVLAB(+$P(BDM(1),U,4),0),U,4) S:$D(BDM(2)) X(9999999-$P(BDM(2),U),2)=$P(^AUPNVLAB(+$P(BDM(2),U,4),0),U,4)

 S %=0,R="" F  S %=$O(X(%)) Q:%=""  S V=0 F  S V=$O(X(%,V)) Q:V=""  S R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"

 Q R

BS(P,BDATE,EDATE) ;EP

 NEW BDM,X,%,E,R,V

 K BDM

 S %=P_"^LAST 3 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I '$D(BDM(1)) Q ""

 S (%,R)="" F  S %=$O(BDM(%)) Q:%=""  S R=R_$P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(BDM(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(BDM(%),U))_"^"

 Q R

EKG(P,EDATE,F) ;EP

 I $G(F)="" S F="E"

 NEW BDM,X,%,E,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM) S LEKG=$P(BDM(1),U)

 K BDM S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LEKG>$P(BDM(1),U)

 .S LEKG=$P(BDM(1),U)

 K BDM S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LEKG>$P(BDM(1),U)

 .S LEKG=$P(BDM(1),U)

 K BDM S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"BDM(")

 I $D(BDM(1)) D

 .Q:LEKG>$P(BDM(1),U)

 .S LEKG=$P(BDM(1),U)

 Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)

 ;

PPDS(P) ;

 NEW BDMS,E,X

 K BDMS

 S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")

 I $D(BDMS) Q 1

 N T S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))

 I 'T G PPDSPL

 N G S G=0,X=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X  I $D(^ATXAX(T,21,"B",X)) S G=1

 I G Q 1

PPDSPL ;CHECK PL

 N T S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))

 I 'T Q ""

 N X,Y,I S (X,Y,I)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXCHK(Y,T,9) S I=1

 I I Q 1

 ;check povs

 K BDMS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BDMS(")

 I $D(BDMS(1)) Q 1

 Q ""

PPD(P,EDATE,F) ;EP

 I $G(F)="" S F="E"

 NEW BDM,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED

 S X=EDATE,%DT="P" D ^%DT S ED=Y

 I $$PPDS(P) Q "POS"

 K BDM

 S X=$O(^AUTTSK("B","PPD",0)) I 'X Q ""

 S G=0,D=9999999-ED-1 F  S D=$O(^AUPNVSK("AA",P,X,D)) Q:D=""  S G=0 F  S G=$O(^AUPNVSK("AA",P,X,D,G)) Q:G'=+G  S BDM(D,G)=$P($P(^AUPNVSIT($P(^AUPNVSK(G,0),U,3),0),U),".")_U_$P(^AUPNVSK(G,0),U,5)_U_$P(^AUPNVSK(G,0),U,4)

 I '$O(BDM(0)) D  Q $S(G:"Refused",1:"Unknown")

 .S X=EDATE,%DT="P" D ^%DT S BDATE=$$FMADD^XLFDT(Y,-365),BDATE=$$FMTE^XLFDT(BDATE),G=0 I $$REFUSAL^BDMD997(P,9999999.28,$O(^AUTTSK("B","PPD",0)),BDATE,EDATE) S G=1

 ;go through all ppds and find last reading or result

 S G="",D=0,X=0 F  S D=$O(BDM(D)) Q:D'=+D!(G)  S X=0 F  S X=$O(BDM(D,X)) Q:X'=+X  S R=$P(BDM(D,X),U,2),R1=$P(BDM(D,X),U,3) I R]""!(R1]"") S G=1,R2=9999999-D

 I F="I",(R]""!(R1]"")) Q R2

 I R]"",R>10 Q "POS"

 I R]"",R<10 Q "NEG"

 I R1]"",R1="P" Q "POS"

 I R1]"",R1="N" Q "NEG"

 Q "Unknown"

 ;

LASTNP(P,EDATE) ;EP - last negative ppd

 I $$PPD(P,EDATE)'="NEG" Q ""

 Q $$PPD(P,EDATE,"I")

TBTX(P) ;EP

 I '$G(P) Q ""

 NEW BDM,E,X

 K BDM

 S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDM(")

 I E Q "Unknown"

 I $D(BDM(1)) Q $P(BDM(1),U,3)_U_$S($P(BDM(1),U,3)["TX COMPLETE":"1 Yes",$P(BDM(1),U,3)["TX INCOMPLETE"!($P(BDM(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")

 N T,Y S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))

 I 'T Q "Unknown"

 N G S G="",X=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G]"")  I $D(^ATXAX(T,21,"B",X)) S G=$P(^AUTTHF(X,0),U)

 I G]"" Q G_U_$S(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")

 Q ""

INSULIN(P,BDATE,EDATE) ;EP

 NEW X,BDM,E

 S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) Q "X"

 Q ""

 ;

SULF(P,BDATE,EDATE) ;EP

 NEW X,BDM,E

 S X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) Q "X"

 Q ""

MET(P,BDATE,EDATE) ;EP

 NEW X,BDM,E

 S X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) Q "X"

 Q ""

 ;

ACAR(P,BDATE,EDATE) ;EP

 NEW X,BDM,E

 S X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) Q "X"

 Q ""

 ;

TROG(P,BDATE,EDATE) ;EP

 NEW X,BDM,E

 S X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")

 I $D(BDM(1)) Q "X"

 Q ""

 ;

 ;

BDMD998   ; IHS/CMI/LAB - 1999 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       ;

BI()      ;

 +1        QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)

HT(P,BDATE,EDATE) ;EP

 +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,2,0)

 +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/10/2007 orig line

 +9       ;cmi/anch/maw 9/10/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)>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       ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)

 +10               SET W=W*.45359

                   SET H=(H*.0254)

                   SET H=(H*H)

                   SET %=(W/H)

                   SET %=$JUSTIFY(%,4,1)

               End DoDot:1

               QUIT %

 +11       SET X=$$HTWTSD(P,BDATE,EDATE)

 +12       IF '$PIECE(X,"^")

               QUIT %

 +13       IF '$PIECE(X,"^",2)

               QUIT %

 +14       SET W=$PIECE(X,"^")

           SET H=$PIECE(X,"^",2)

 +15      ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)

 +16       SET W=W*.45359

           SET H=(H*.0254)

           SET H=(H*H)

           SET %=(W/H)

           SET %=$JUSTIFY(%,4,1)

 +17       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

PAP(P,BDATE,EDATE) ; EP

 +1        IF $$SEX^AUPNPAT(P)'="F"

               QUIT "N/A"

 +2        NEW BDM

           SET %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BDM(")

 +3        IF $DATA(BDM(1))

               QUIT "Yes  "_$$FMTE^XLFDT($PIECE(BDM(1),U))

 +4        KILL BDM

           SET %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BDM(")

 +5        IF $DATA(BDM(1))

               QUIT "Yes  "_$$FMTE^XLFDT($PIECE(BDM(1),U))

 +6        KILL BDM

           SET %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BDM(")

 +7        IF $DATA(BDM(1))

               QUIT "Yes  "_$$FMTE^XLFDT($PIECE(BDM(1),U))

 +8       ;check pov

 +9       ;check proc

 +10       QUIT "No"

ALT(P,BDATE,EDATE) ;EP

 +1        NEW BDM,X,%,E,R,V

 +2        KILL BDM

 +3        SET %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BDM(")

 +4        IF '$DATA(BDM(1))

               QUIT ""

 +5        QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)_"  "_$$FMTE^XLFDT($PIECE(BDM(1),U),5)

AST(P,BDATE,EDATE) ;EP

 +1        NEW BDM,X,%,E,R,V

 +2        KILL BDM

 +3        SET %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BDM(")

 +4        IF '$DATA(BDM(1))

               QUIT ""

 +5        QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)_"  "_$$FMTE^XLFDT($PIECE(BDM(1),U),5)

CREAT(P,BDATE,EDATE,F) ;EP

 +1        IF $GET(F)=""

               SET F="E"

 +2        NEW BDM,X,%,E,R,V

 +3        KILL BDM

 +4        SET %=P_"^LAST LAB [DM AUDIT CREATININE TAX;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BDM(")

 +5        IF '$DATA(BDM(1))

               QUIT ""

 +6        IF F="I"

               QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)_"^"_$PIECE(BDM(1),U)

 +7        QUIT $PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(BDM(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(BDM(1),U),5)

CHOL(P,BDATE,EDATE,F) ;EP