APCLD998 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;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 %,APCLARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(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,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX,ICD
K APCL S APCLW="" S APCLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(APCLX,"APCL(")
S APCLN=0 F S APCLN=$O(APCL(APCLN)) Q:APCLN'=+APCLN!(APCLW]"") D
.S APCLZ=$P(APCL(APCLN),U,5)
.I '$D(^AUPNVPOV("AD",APCLZ)) S APCLW=$P(APCL(APCLN),U,2) Q
. S APCLD=0 F S APCLD=$O(^AUPNVPOV("AD",APCLZ,APCLD)) Q:'APCLD!(APCLW]"") D
.. ;S ICD=$P(^ICD9($P(^AUPNVPOV(APCLD,0),U),0),U) D ;cmi/anch/maw 9/10/2007 orig line
.. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(APCLD,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 APCLW=$P(APCL(APCLN),U,2)
..Q
Q APCLW
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 APCLWTS,APCLHTS,%,X,APCLWTS1,APCLHTS1
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLHTS(")
;set the array up by date
K APCLHTS1 S X=0 F S X=$O(APCLHTS(X)) Q:X'=+X S APCLHTS1($P(APCLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLWTS(")
;set the array up by date
K APCLWTS1 S X=0 F S X=$O(APCLWTS(X)) Q:X'=+X S APCLWTS1($P(APCLWTS(X),U))=X
NEW APCLCHT S APCLCHT="",X=9999999 F S X=$O(APCLWTS1(X),-1) Q:X=""!(APCLCHT]"") I $D(APCLHTS1(X)) S APCLCHT=$P(APCLWTS(APCLWTS1(X)),U,2)_U_$P(APCLHTS(APCLHTS1(X)),U,2)
Q APCLCHT
PAP(P,BDATE,EDATE) ; EP
I $$SEX^AUPNPAT(P)'="F" Q "N/A"
NEW APCL S %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
K APCL S %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
K APCL S %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
;check pov
;check proc
Q "No"
ALT(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_" "_$$FMTE^XLFDT($P(APCL(1),U),5)
AST(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_" "_$$FMTE^XLFDT($P(APCL(1),U),5)
CREAT(P,BDATE,EDATE,F) ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT CREATININE TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
I F="I" Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_"^"_$P(APCL(1),U)
Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(1),U),5)
CHOL(P,BDATE,EDATE,F) ;EP
S:$G(F)="" F="E"
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT CHOLESTEROL TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
I F="I" Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_"^"_$P(APCL(1),U)
Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(1),U),5)
LDL(P,BDATE,EDATE,F) ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT LDL CHOLESTEROL TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
I F="I" Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_"^"_$P(APCL(1),U)
Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(1),U),5)
TRIG(P,BDATE,EDATE,F) ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT TRIGLYCERIDE TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
I F="I" Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_"^"_$P(APCL(1),U)
Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(1),U),5)
URIN(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT URINALYSIS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(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^APCLD997(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 APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
;Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)
NEW %,%1 S %=$P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)
S %1=$S(%="":"No result",%["+":"Yes ",+%>30:"Yes ",1:"No ")
Q %1_%_" "_$$FMTE^XLFDT($P(APCL(1),U),"5")
MICRO(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST LAB [DM AUDIT MICROALBUMINURIA TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
;Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)
NEW %,%1 S %=$P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)
S %1=$S(%="":"No result",+%>30:"Pos ",1:"Neg ")
Q %1_%_" "_$$FMTE^XLFDT($P(APCL(1),U),"5")
HGBA1C(P,BDATE,EDATE) ;EP
NEW APCL,X,%,E,R,V
K APCL
S %=P_"^LAST 2 LAB [DM AUDIT HGB A1C;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
K X S X(9999999-$P(APCL(1),U),1)=$P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4) S:$D(APCL(2)) X(9999999-$P(APCL(2),U),2)=$P(^AUPNVLAB(+$P(APCL(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 APCL,X,%,E,R,V
K APCL
S %=P_"^LAST 3 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I '$D(APCL(1)) Q ""
S (%,R)="" F S %=$O(APCL(%)) Q:%="" S R=R_$P(^AUPNVLAB(+$P(APCL(%),U,4),0),U,4)_$S($P(^AUPNVLAB(+$P(APCL(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($P(APCL(%),U))_"^"
Q R
EKG(P,EDATE,F) ;EP
I $G(F)="" S F="E"
NEW APCL,X,%,E,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL) S LEKG=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LEKG>$P(APCL(1),U)
.S LEKG=$P(APCL(1),U)
Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
;
PPDS(P) ;
NEW APCLS,E,X
K APCLS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCLS(")
I $D(APCLS) 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 APCLS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"APCLS(")
I $D(APCLS(1)) Q 1
Q ""
PPD(P,EDATE,F) ;EP
I $G(F)="" S F="E"
NEW APCL,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 APCL
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 APCL(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(APCL(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^APCLD997(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(APCL(D)) Q:D'=+D!(G) S X=0 F S X=$O(APCL(D,X)) Q:X'=+X S R=$P(APCL(D,X),U,2),R1=$P(APCL(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 APCL,E,X
K APCL
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCL(")
I E Q "Unknown"
I $D(APCL(1)) Q $P(APCL(1),U,3)_U_$S($P(APCL(1),U,3)["TX COMPLETE":"1 Yes",$P(APCL(1),U,3)["TX INCOMPLETE"!($P(APCL(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,APCL,E
S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
SULF(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
MET(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
ACAR(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
TROG(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "X"
Q ""
;
;
APCLD998 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+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 %,APCLARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"APCLARRY(")
SET H=$PIECE($GET(APCLARRY(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,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX,ICD
+3 KILL APCL
SET APCLW=""
SET APCLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(APCLX,"APCL(")
+4 SET APCLN=0
FOR
SET APCLN=$ORDER(APCL(APCLN))
IF APCLN'=+APCLN!(APCLW]"")
QUIT
Begin DoDot:1
+5 SET APCLZ=$PIECE(APCL(APCLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",APCLZ))
SET APCLW=$PIECE(APCL(APCLN),U,2)
QUIT
+7 SET APCLD=0
FOR
SET APCLD=$ORDER(^AUPNVPOV("AD",APCLZ,APCLD))
IF 'APCLD!(APCLW]"")
QUIT
Begin DoDot:2
+8 ;S ICD=$P(^ICD9($P(^AUPNVPOV(APCLD,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(APCLD,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 APCLW=$PIECE(APCL(APCLN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT APCLW
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 APCLWTS,APCLHTS,%,X,APCLWTS1,APCLHTS1
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"APCLHTS(")
+5 ;set the array up by date
+6 KILL APCLHTS1
SET X=0
FOR
SET X=$ORDER(APCLHTS(X))
IF X'=+X
QUIT
SET APCLHTS1($PIECE(APCLHTS(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(%,"APCLWTS(")
+9 ;set the array up by date
+10 KILL APCLWTS1
SET X=0
FOR
SET X=$ORDER(APCLWTS(X))
IF X'=+X
QUIT
SET APCLWTS1($PIECE(APCLWTS(X),U))=X
+11 NEW APCLCHT
SET APCLCHT=""
SET X=9999999
FOR
SET X=$ORDER(APCLWTS1(X),-1)
IF X=""!(APCLCHT]"")
QUIT
IF $DATA(APCLHTS1(X))
SET APCLCHT=$PIECE(APCLWTS(APCLWTS1(X)),U,2)_U_$PIECE(APCLHTS(APCLHTS1(X)),U,2)
+12 QUIT APCLCHT
PAP(P,BDATE,EDATE) ; EP
+1 IF $$SEX^AUPNPAT(P)'="F"
QUIT "N/A"
+2 NEW APCL
SET %=P_"^LAST LAB PAP SMEAR;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+4 KILL APCL
SET %=P_"^LAST DX V76.2;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+6 KILL APCL
SET %=P_"^LAST PROCEDURE 91.46;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+7 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+8 ;check pov
+9 ;check proc
+10 QUIT "No"
ALT(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT ALT TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_" "_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
AST(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT AST TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_" "_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
CREAT(P,BDATE,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V
+3 KILL APCL
+4 SET %=P_"^LAST LAB [DM AUDIT CREATININE TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF '$DATA(APCL(1))
QUIT ""
+6 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_"^"_$PIECE(APCL(1),U)
+7 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
CHOL(P,BDATE,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V
+3 KILL APCL
+4 SET %=P_"^LAST LAB [DM AUDIT CHOLESTEROL TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF '$DATA(APCL(1))
QUIT ""
+6 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_"^"_$PIECE(APCL(1),U)
+7 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
LDL(P,BDATE,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V
+3 KILL APCL
+4 SET %=P_"^LAST LAB [DM AUDIT LDL CHOLESTEROL TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF '$DATA(APCL(1))
QUIT ""
+6 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_"^"_$PIECE(APCL(1),U)
+7 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
TRIG(P,BDATE,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,R,V
+3 KILL APCL
+4 SET %=P_"^LAST LAB [DM AUDIT TRIGLYCERIDE TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF '$DATA(APCL(1))
QUIT ""
+6 IF F="I"
QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_"^"_$PIECE(APCL(1),U)
+7 QUIT $PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
URIN(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT URINALYSIS TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U),5)
+5 NEW G
SET G=0
+6 NEW T
SET T=$ORDER(^ATXLAB("B","DM AUDIT URINALYSIS TAX",0))
+7 IF 'T
QUIT ""
+8 SET X=0
FOR
SET X=$ORDER(^ATXLAB(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL^APCLD997(P,60,$PIECE(^ATXLAB(T,21,X,0),U),BDATE,EDATE)
SET G=1
+9 QUIT $SELECT(G:"Refused",1:"No")
PROTEIN(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT URINE PROTEIN TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 ;Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)
+6 NEW %,%1
SET %=$PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)
+7 SET %1=$SELECT(%="":"No result",%["+":"Yes ",+%>30:"Yes ",1:"No ")
+8 QUIT %1_%_" "_$$FMTE^XLFDT($PIECE(APCL(1),U),"5")
MICRO(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST LAB [DM AUDIT MICROALBUMINURIA TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 ;Q $P(^AUPNVLAB(+$P(APCL(1),U,4),0),U,4)
+6 NEW %,%1
SET %=$PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)
+7 SET %1=$SELECT(%="":"No result",+%>30:"Pos ",1:"Neg ")
+8 QUIT %1_%_" "_$$FMTE^XLFDT($PIECE(APCL(1),U),"5")
HGBA1C(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST 2 LAB [DM AUDIT HGB A1C;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 KILL X
SET X(9999999-$PIECE(APCL(1),U),1)=$PIECE(^AUPNVLAB(+$PIECE(APCL(1),U,4),0),U,4)
IF $DATA(APCL(2))
SET X(9999999-$PIECE(APCL(2),U),2)=$PIECE(^AUPNVLAB(+$PIECE(APCL(2),U,4),0),U,4)
+6 SET %=0
SET R=""
FOR
SET %=$ORDER(X(%))
IF %=""
QUIT
SET V=0
FOR
SET V=$ORDER(X(%,V))
IF V=""
QUIT
SET R=R_X(%,V)_"^"_$$FMTE^XLFDT(9999999-%)_"^"_(9999999-%)_"^"
+7 QUIT R
BS(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,%,E,R,V
+2 KILL APCL
+3 SET %=P_"^LAST 3 LAB [DM AUDIT GLUCOSE TESTS TAX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 IF '$DATA(APCL(1))
QUIT ""
+5 SET (%,R)=""
FOR
SET %=$ORDER(APCL(%))
IF %=""
QUIT
SET R=R_$PIECE(^AUPNVLAB(+$PIECE(APCL(%),U,4),0),U,4)_$SELECT($PIECE(^AUPNVLAB(+$PIECE(APCL(%),U,4),0),U,4)]"":" mg/dl ",1:"")_$$FMTE^XLFDT($PIECE(APCL(%),U))_"^"
+6 QUIT R
EKG(P,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,%,E,LEKG
SET LEKG=""
SET %=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+3 IF $DATA(APCL)
SET LEKG=$PIECE(APCL(1),U)
+4 KILL APCL
SET %=P_"^LAST PROCEDURE 89.51"
SET E=$$START1^APCLDF(%,"APCL(")
+5 IF $DATA(APCL(1))
Begin DoDot:1
+6 IF LEKG>$PIECE(APCL(1),U)
QUIT
+7 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+8 KILL APCL
SET %=P_"^LAST PROCEDURE 89.52"
SET E=$$START1^APCLDF(%,"APCL(")
+9 IF $DATA(APCL(1))
Begin DoDot:1
+10 IF LEKG>$PIECE(APCL(1),U)
QUIT
+11 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+12 KILL APCL
SET %=P_"^LAST PROCEDURE 89.53"
SET E=$$START1^APCLDF(%,"APCL(")
+13 IF $DATA(APCL(1))
Begin DoDot:1
+14 IF LEKG>$PIECE(APCL(1),U)
QUIT
+15 SET LEKG=$PIECE(APCL(1),U)
End DoDot:1
+16 QUIT $SELECT(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
+17 ;
PPDS(P) ;
+1 NEW APCLS,E,X
+2 KILL APCLS
+3 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"APCLS(")
+4 IF $DATA(APCLS)
QUIT 1
+5 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+6 IF 'T
GOTO PPDSPL
+7 NEW G
SET G=0
SET X=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X
QUIT
IF $DATA(^ATXAX(T,21,"B",X))
SET G=1
+8 IF G
QUIT 1
PPDSPL ;CHECK PL
+1 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
+2 IF 'T
QUIT ""
+3 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^ATXCHK(Y,T,9)
SET I=1
+4 IF I
QUIT 1
+5 ;check povs
+6 KILL APCLS
SET X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS"
SET E=$$START1^APCLDF(X,"APCLS(")
+7 IF $DATA(APCLS(1))
QUIT 1
+8 QUIT ""
PPD(P,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 NEW APCL,X,E,G,BDATE,Y,%DT,D,R,R1,R2,ED
+3 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+4 IF $$PPDS(P)
QUIT "POS"
+5 KILL APCL
+6 SET X=$ORDER(^AUTTSK("B","PPD",0))
IF 'X
QUIT ""
+7 SET G=0
SET D=9999999-ED-1
FOR
SET D=$ORDER(^AUPNVSK("AA",P,X,D))
IF D=""
QUIT
SET G=0
FOR
SET G=$ORDER(^AUPNVSK("AA",P,X,D,G))
IF G'=+G
QUIT
SET APCL(D,G)=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVSK(G,0),U,3),0),U),".")_U_$PIECE(^AUPNVSK(G,0),U,5)_U_$PIECE(^AUPNVSK(G,0),U,4)
+8 IF '$ORDER(APCL(0))
Begin DoDot:1
+9 SET X=EDATE
SET %DT="P"
DO ^%DT
SET BDATE=$$FMADD^XLFDT(Y,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
SET G=0
IF $$REFUSAL^APCLD997(P,9999999.28,$ORDER(^AUTTSK("B","PPD",0)),BDATE,EDATE)
SET G=1
End DoDot:1
QUIT $SELECT(G:"Refused",1:"Unknown")
+10 ;go through all ppds and find last reading or result
+11 SET G=""
SET D=0
SET X=0
FOR
SET D=$ORDER(APCL(D))
IF D'=+D!(G)
QUIT
SET X=0
FOR
SET X=$ORDER(APCL(D,X))
IF X'=+X
QUIT
SET R=$PIECE(APCL(D,X),U,2)
SET R1=$PIECE(APCL(D,X),U,3)
IF R]""!(R1]"")
SET G=1
SET R2=9999999-D
+12 IF F="I"
IF (R]""!(R1]""))
QUIT R2
+13 IF R]""
IF R>10
QUIT "POS"
+14 IF R]""
IF R<10
QUIT "NEG"
+15 IF R1]""
IF R1="P"
QUIT "POS"
+16 IF R1]""
IF R1="N"
QUIT "NEG"
+17 QUIT "Unknown"
+18 ;
LASTNP(P,EDATE) ;EP - last negative ppd
+1 IF $$PPD(P,EDATE)'="NEG"
QUIT ""
+2 QUIT $$PPD(P,EDATE,"I")
TBTX(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW APCL,E,X
+3 KILL APCL
+4 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"APCL(")
+5 IF E
QUIT "Unknown"
+6 IF $DATA(APCL(1))
QUIT $PIECE(APCL(1),U,3)_U_$SELECT($PIECE(APCL(1),U,3)["TX COMPLETE":"1 Yes",$PIECE(APCL(1),U,3)["TX INCOMPLETE"!($PIECE(APCL(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")
+7 NEW T,Y
SET T=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+8 IF 'T
QUIT "Unknown"
+9 NEW G
SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(G]"")
QUIT
IF $DATA(^ATXAX(T,21,"B",X))
SET G=$PIECE(^AUTTHF(X,0),U)
+10 IF G]""
QUIT G_U_$SELECT(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")
+11 QUIT ""
INSULIN(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
SULF(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
MET(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
ACAR(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
TROG(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "X"
+4 QUIT ""
+5 ;
+6 ;
