BDMD112 ; IHS/CMI/LAB - 2011 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**4**;JUN 14, 2007
;
;cmi/anch/maw 9/12/2011 code set versioning in DEPDX
;
SETN ;
S N="" NEW A,G S (A,G)=0 F S A=$O(BDM(A)) Q:A'=+A!(G) I $P(^AUPNVLAB(+$P(BDM(A),U,4),0),U,4)]"" S G=A
S N=$S(G:G,1:1)
Q
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 ""
I $D(BDM(1)) Q $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")_U_$P(BDM(1),U,3)
N T,Y S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
I 'T Q ""
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 $S(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")_U_G
Q ""
CPT(P,BDATE,EDATE,T,F) ;EP return ien of CPT entry if patient had this CPT
NEW X
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry in date range
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVRAD("AD",V))
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
...Q:'$D(^AUPNVRAD(X,0))
...S Y=$P(^AUPNVRAD(X,0),U) Q:'Y Q:'$D(^RAMIS(71,Y,0))
...S Y=$P($G(^RAMIS(71,Y,0)),U,9) Q:'Y
...Q:'$$ICD^ATXCHK(Y,T,1)
...S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
EKG(P,EDATE,F) ;EP
I $G(F)="" S F="E"
S %DT="P",X=EDATE D ^%DT S ED=Y
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;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM("),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;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM("),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;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM("),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.50;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM("),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 DX 794.31;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"BDM("),E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) D
.Q:LEKG>$P(BDM(1),U)
.S LEKG=$P(BDM(1),U)
;check CPT codes in year prior to date range
S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))
K BDM I T S BDM(1)=$$CPT^BDMD112(P,$$DOB^AUPNPAT(P),ED,T,3) D
.I BDM(1)="" K BDM Q
.Q:LEKG>$P(BDM(1),U)
.S LEKG=$P(BDM(1),U)
K BDM I T S BDM(1)=$$RAD^BDMD112(P,$$DOB^AUPNPAT(P),ED,T,3) D
.I BDM(1)="" K BDM Q
.Q:LEKG>$P(BDM(1),U)
.S LEKG=$P(BDM(1),U)
Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
;
REFMED(P,BDATE,EDATE) ;EP
NEW T,T1,T2,T3,T4,T5,T6,T7,T8,A,G,B,Y,X,I,Z,E
S T=$O(^ATXAX("B","DM AUDIT INSULIN DRUGS",0))
S T1=$O(^ATXAX("B","DM AUDIT SULFONYLUREA DRUGS",0))
S T2=$O(^ATXAX("B","DM AUDIT METFORMIN DRUGS",0))
S T3=$O(^ATXAX("B","DM AUDIT ACARBOSE DRUGS",0))
S T4=$O(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0))
S T5=$O(^ATXAX("B","DM AUDIT INCRETIN MIMETIC",0))
S T6=$O(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0))
S T7=$O(^ATXAX("B","DM AUDIT AMYLIN ANALOGUES",0))
S T8=$O(^ATXAX("B","DM AUDIT SULFONYLUREA-LIKE",0))
S G=0
NEW %DT S X=BDATE,%DT="P" D ^%DT S B=Y
S X=EDATE,%DT="P" D ^%DT S E=Y
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",BDMPD,50,I)) Q:I'=+I!(G) D
.S A=0
.I T,$D(^ATXAX(T,21,"B",I)) S A=1
.I T1,$D(^ATXAX(T1,21,"B",I)) S A=1
.I T2,$D(^ATXAX(T2,21,"B",I)) S A=1
.I T3,$D(^ATXAX(T3,21,"B",I)) S A=1
.I T4,$D(^ATXAX(T4,21,"B",I)) S A=1
.I T5,$D(^ATXAX(T5,21,"B",I)) S A=1
.I T6,$D(^ATXAX(T6,21,"B",I)) S A=1
.I T7,$D(^ATXAX(T7,21,"B",I)) S A=1
.I T8,$D(^ATXAX(T8,21,"B",I)) S A=1
.Q:'A
.S X=0 F S X=$O(^AUPNPREF("AA",BDMPD,50,I,X)) Q:X'=+X!(G) D
..S Y=0 F S Y=$O(^AUPNPREF("AA",BDMPD,50,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="R" S G=1
Q G
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 ""
;
SULFLIKE(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA-LIKE"_";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 ""
INCR(P,BDATE,EDATE) ;EP cmi/maw 12/18/2007 DM2011
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT INCRETIN MIMETIC"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
DPP4(P,BDATE,EDATE) ;EP cmi/maw 12/18/2011 DM2011
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT DPP4 INHIBITOR DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
AMYLIN(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT AMYLIN ANALOGUES"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
GLP1(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT GLP-1 ANALOG DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
BROM(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT BROMOCRIPTINE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
DEPDX(P,BDATE,EDATE) ;EP
NEW BDM,X,BDMP,BDMP1,T,I,G,J,D
K BDM
S (G,X,I)=""
;is depression on the problem list?
S T=$O(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"") D
.S I=$P($G(^AUPNPROB(X,0)),U)
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:'$$ICD^ATXCHK(I,T,9)
.S G="1 Yes - Problem List "_$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
.Q
I G]"" Q G
S (G,X,I)=""
;is depression on the BH problem list?
S T=$O(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
S X=0 F S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G]"") D
.S I=$P($G(^AMHPPROB(X,0)),U)
.S I=$P($G(^AMHPROB(I,0)),U,5)
.Q:I=""
.S I=+$$CODEN^ICDCODE(I,80)
.Q:I=""
.Q:'$$ICD^ATXCHK(I,T,9)
.Q:$P(^AMHPPROB(X,0),U,12)'="A"
.S G="1 Yes - BH Problem List "_$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
.Q
I G]"" Q G
;now check for 2 dxs in past year
S Y="BDM(",BDMV=""
S X=P_"^LAST 2 DX [DM AUDIT DEPRESSIVE DISORDERS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BDM(2)) Q "1 Yes 2 dxs in PCC"
S BDM=0 I $D(BDM(1)) S BDM=1
;go through BH record file and find up to 2 visits in date range
S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BDM>1) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BDM>1) D
.Q:'$D(^AMHREC(V,0))
.I $P(^AMHREC(V,0),U,16)]"",BDMV]"",$P(^AMHREC(V,0),U,16)=BDMV Q
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BDM>1) S BDMP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BDMP
..S BDMP1=$P($G(^AMHPROB(BDMP,0)),U)
..I BDMP1=14 S BDM=BDM+1 Q
..I BDMP1=15 S BDM=BDM+1 Q
..I BDMP1=18 S BDM=BDM+1 Q
..I BDMP1=24 S BDM=BDM+1 Q
..S J=$P(^AMHPROB(BDMP,0),U,5)
..S J=$P($$ICDDX^ICDCODE(J),U,1)
..I $$ICD^ATXCHK(J,$O(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0)),9) S BDM=BDM+1 Q
..Q
I BDM>1 Q "1 Yes 2 dx PCC/BH"
Q "2 No"
;
DEPSCR(P,BDATE,EDATE,F,R) ;EP
NEW X,BDMC
I $G(P)="" Q ""
I $G(F)="" S F="E"
S BDMC=$$LASTDEPS(P,BDATE,EDATE,"A")
I $G(R) Q $S(F="D":$P(BDMC,U),1:"1 Yes - "_$P(BDMC,U,2)_" "_$$DATE^BDMS9B1($P(BDMC,U)))
I BDMC]"" Q "1 Yes - "_$E($P(BDMC,U,2),1,20)_" "_$$DATE^BDMS9B1($P(BDMC,U))
;refusal
NEW G S G=$$REFUSAL^BDMD117(P,9999999.15,$O(^AUTTEXAM("B","DEPRESSION SCREENING",0)),BDATE,EDATE)
I G,'$G(R) Q "3 Refused "_$P(G,U,3)
S D=0,BDMC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BDMC]"") S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BDMC]"") D
.I $P($G(^AMHREC(V,14)),U,5)]"",($P(^AMHREC(V,14),U,5)="UAS"!($P(^AMHREC(V,14),U,5)'="REF")) S BDMC="3 Refused BH Exam 36 "_$$DATE^BDMD110(9999999-D) Q
I BDMC]"" Q BDMC
Q "2 No"
;
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
PLCODE(P,A) ;EP
I $G(P)="" Q ""
I $G(A)="" Q ""
N T S T=+$$CODEN^ICDCODE(A,80)
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
Q I
PLTAX(P,A) ;EP - is DX on problem list 1 or 0
I $G(P)="" Q ""
I $G(A)="" Q ""
N T S T=$O(^ATXAX("B",A,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
Q I
;
E ;
I $P(BDMLVAL,U,1)>$P(BDMLLAST,U,1) S BDMLLAST=BDMLVAL
Q
;
LASTDEPS(BDMLPDFN,BDMLBD,BDMLED,BDMLFORM) ;PEP - return last depression screen
;
I $G(BDMLBD)="" S BDMLBD=$$DOB^AUPNPAT(BDMLPDFN)
I $G(BDMLED)="" S BDMLED=DT
I $G(BDMLFORM)="" S BDMLFORM="D"
NEW BDMLLAST,BDMLVAL,BDMLX
S BDMLLAST=""
S BDMLVAL=$$LASTDEP(BDMLPDFN,BDMLBD,BDMLED,"A")
D E
S BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"V79.0","DX",$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
D E
S BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"PHQ2","MEASUREMENT",$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
D E
S BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"PHQ9","MEASUREMENT",$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
D E
S BDMLX=0 F S BDMLX=$O(^AUTTEDT("C","DEP-SCR",BDMLX)) Q:BDMLX'=+BDMLX D
.S BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"`"_BDMLX,"EDUCATION",$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
.D E
S BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"14.1","A")
D E
S BDMLVAL=$$LASTBHED^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"DEP-SCR","A")
D E
;now check for mood disorders
S BDMLVAL=$$LASTDXT^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP MOOD DISORDERS","A")
D E
S BDMLVAL=$$LASTBHDT^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP MOOD DISORDERS","A")
D E
S BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"14","A")
D E
S BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"15","A")
D E
S BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQ2","A")
D E
S BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQ9","A")
D E
I BDMLFORM="D" Q $P(BDMLLAST,U)
Q BDMLLAST
;
LASTDEP(P,BD,ED,F) ;
NEW %,E,D,V,X,G
NEW BDMLG,BDMLX,BDMLC,BDMLV
S %=P_"^LAST EXAM 36;DURING "_BD_"-"_ED,E=$$START1^APCLDF(%,"BDMLG(")
I $D(BDMLG(1)) S BDMLX(9999999-$P(BDMLG(1),U))=$$VE(BDMLG(1))
;now look at AMHREC
S BDMLC=0,BDMLV=""
S E=(9999999-BD),D=9999999-ED-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!(BDMLC)!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BDMLC) D
.S X=$P($G(^AMHREC(V,14)),U,5)
.I X="" Q ;no test
.I $E(X)="U" Q ;don't count refusal here
.I X="REF" Q
.S G=9999999-$P(D,".")
.Q:$D(BDMLX($P(D,".")))
.S BDMLX($P(D,"."))=G_"^BH: DEPRESSION SCREENING^"_$$VAL^XBDIQ1(9002011,V,1405)_"^^9002011^"_V
I $O(BDMLX(0)) S G=$O(BDMLX(0)) Q $S(F="D":$P(BDMLX(G),U,1),1:BDMLX(G))
Q ""
;
;
VE(Y,F,T) ;EP
Q $P(Y,U,1)_"^Exam: "_$P(Y,U,3)_"^"_$$VAL^XBDIQ1(9000010.13,+$P(Y,U,4),.04)_"^"_$P(Y,U,5)_"^9000010.13^"_+$P(Y,U,4)
;
BDMD112 ; IHS/CMI/LAB - 2011 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**4**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/12/2011 code set versioning in DEPDX
+4 ;
SETN ;
+1 SET N=""
NEW A,G
SET (A,G)=0
FOR
SET A=$ORDER(BDM(A))
IF A'=+A!(G)
QUIT
IF $PIECE(^AUPNVLAB(+$PIECE(BDM(A),U,4),0),U,4)]""
SET G=A
+2 SET N=$SELECT(G:G,1:1)
+3 QUIT
TBTX(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BDM,E,X
+3 KILL BDM
+4 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BDM(")
+5 IF E
QUIT ""
+6 IF $DATA(BDM(1))
QUIT $SELECT($PIECE(BDM(1),U,3)["TX COMPLETE":"1 Yes",$PIECE(BDM(1),U,3)["TX INCOMPLETE"!($PIECE(BDM(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")_U_$PIECE(BDM(1),U,3)
+7 NEW T,Y
SET T=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
+8 IF 'T
QUIT ""
+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 $SELECT(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")_U_G
+11 QUIT ""
CPT(P,BDATE,EDATE,T,F) ;EP return ien of CPT entry if patient had this CPT
+1 NEW X
+2 IF '$GET(P)
QUIT ""
+3 IF '$GET(T)
QUIT ""
+4 IF '$GET(F)
SET F=1
+5 IF $GET(EDATE)=""
QUIT ""
+6 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+7 ;go through visits in a date range for this patient, check cpts
+8 NEW D,BD,ED,X,Y,D,G,V
+9 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+10 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+11 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+13 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+15 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 IF F=1
QUIT $SELECT(G:1,1:"")
+21 IF F=2
QUIT G
+22 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+23 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+24 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry in date range
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVRAD(X,0))
QUIT
+15 SET Y=$PIECE(^AUPNVRAD(X,0),U)
IF 'Y
QUIT
IF '$DATA(^RAMIS(71,Y,0))
QUIT
+16 SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
IF 'Y
QUIT
+17 IF '$$ICD^ATXCHK(Y,T,1)
QUIT
+18 SET G=X
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 IF 'G
QUIT ""
+23 IF F=1
QUIT $SELECT(G:1,1:"")
+24 IF F=2
QUIT G
+25 IF F=3
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+26 IF F=4
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+27 QUIT ""
EKG(P,EDATE,F) ;EP
+1 IF $GET(F)=""
SET F="E"
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+3 NEW BDM,X,%,E,LEKG
SET LEKG=""
SET %=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+4 IF $DATA(BDM)
SET LEKG=$PIECE(BDM(1),U)
+5 KILL BDM
SET %=P_"^LAST PROCEDURE 89.51;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
SET E=$$START1^APCLDF(%,"BDM(")
+6 IF $DATA(BDM(1))
Begin DoDot:1
+7 IF LEKG>$PIECE(BDM(1),U)
QUIT
+8 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+9 KILL BDM
SET %=P_"^LAST PROCEDURE 89.52;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
SET E=$$START1^APCLDF(%,"BDM(")
+10 IF $DATA(BDM(1))
Begin DoDot:1
+11 IF LEKG>$PIECE(BDM(1),U)
QUIT
+12 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+13 KILL BDM
SET %=P_"^LAST PROCEDURE 89.53;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
SET E=$$START1^APCLDF(%,"BDM(")
+14 IF $DATA(BDM(1))
Begin DoDot:1
+15 IF LEKG>$PIECE(BDM(1),U)
QUIT
+16 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+17 KILL BDM
SET %=P_"^LAST PROCEDURE 89.50;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
SET E=$$START1^APCLDF(%,"BDM(")
+18 IF $DATA(BDM(1))
Begin DoDot:1
+19 IF LEKG>$PIECE(BDM(1),U)
QUIT
+20 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+21 KILL BDM
SET %=P_"^LAST DX 794.31;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
SET E=$$START1^APCLDF(%,"BDM(")
+22 IF $DATA(BDM(1))
Begin DoDot:1
+23 IF LEKG>$PIECE(BDM(1),U)
QUIT
+24 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+25 ;check CPT codes in year prior to date range
+26 SET T=$ORDER(^ATXAX("B","DM AUDIT EKG CPTS",0))
+27 KILL BDM
IF T
SET BDM(1)=$$CPT^BDMD112(P,$$DOB^AUPNPAT(P),ED,T,3)
Begin DoDot:1
+28 IF BDM(1)=""
KILL BDM
QUIT
+29 IF LEKG>$PIECE(BDM(1),U)
QUIT
+30 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+31 KILL BDM
IF T
SET BDM(1)=$$RAD^BDMD112(P,$$DOB^AUPNPAT(P),ED,T,3)
Begin DoDot:1
+32 IF BDM(1)=""
KILL BDM
QUIT
+33 IF LEKG>$PIECE(BDM(1),U)
QUIT
+34 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+35 QUIT $SELECT(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
+36 ;
REFMED(P,BDATE,EDATE) ;EP
+1 NEW T,T1,T2,T3,T4,T5,T6,T7,T8,A,G,B,Y,X,I,Z,E
+2 SET T=$ORDER(^ATXAX("B","DM AUDIT INSULIN DRUGS",0))
+3 SET T1=$ORDER(^ATXAX("B","DM AUDIT SULFONYLUREA DRUGS",0))
+4 SET T2=$ORDER(^ATXAX("B","DM AUDIT METFORMIN DRUGS",0))
+5 SET T3=$ORDER(^ATXAX("B","DM AUDIT ACARBOSE DRUGS",0))
+6 SET T4=$ORDER(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0))
+7 SET T5=$ORDER(^ATXAX("B","DM AUDIT INCRETIN MIMETIC",0))
+8 SET T6=$ORDER(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0))
+9 SET T7=$ORDER(^ATXAX("B","DM AUDIT AMYLIN ANALOGUES",0))
+10 SET T8=$ORDER(^ATXAX("B","DM AUDIT SULFONYLUREA-LIKE",0))
+11 SET G=0
+12 NEW %DT
SET X=BDATE
SET %DT="P"
DO ^%DT
SET B=Y
+13 SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+14 SET G=""
+15 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",BDMPD,50,I))
IF I'=+I!(G)
QUIT
Begin DoDot:1
+16 SET A=0
+17 IF T
IF $DATA(^ATXAX(T,21,"B",I))
SET A=1
+18 IF T1
IF $DATA(^ATXAX(T1,21,"B",I))
SET A=1
+19 IF T2
IF $DATA(^ATXAX(T2,21,"B",I))
SET A=1
+20 IF T3
IF $DATA(^ATXAX(T3,21,"B",I))
SET A=1
+21 IF T4
IF $DATA(^ATXAX(T4,21,"B",I))
SET A=1
+22 IF T5
IF $DATA(^ATXAX(T5,21,"B",I))
SET A=1
+23 IF T6
IF $DATA(^ATXAX(T6,21,"B",I))
SET A=1
+24 IF T7
IF $DATA(^ATXAX(T7,21,"B",I))
SET A=1
+25 IF T8
IF $DATA(^ATXAX(T8,21,"B",I))
SET A=1
+26 IF 'A
QUIT
+27 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",BDMPD,50,I,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+28 SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",BDMPD,50,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="R"
SET G=1
End DoDot:2
End DoDot:1
+29 QUIT G
INSULIN(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
SULF(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
SULFLIKE(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA-LIKE"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
MET(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
ACAR(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
TROG(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
INCR(P,BDATE,EDATE) ;EP cmi/maw 12/18/2007 DM2011
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT INCRETIN MIMETIC"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
DPP4(P,BDATE,EDATE) ;EP cmi/maw 12/18/2011 DM2011
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT DPP4 INHIBITOR DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
AMYLIN(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT AMYLIN ANALOGUES"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
GLP1(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT GLP-1 ANALOG DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
BROM(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT BROMOCRIPTINE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
DEPDX(P,BDATE,EDATE) ;EP
+1 NEW BDM,X,BDMP,BDMP1,T,I,G,J,D
+2 KILL BDM
+3 SET (G,X,I)=""
+4 ;is depression on the problem list?
+5 SET T=$ORDER(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
+6 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+7 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
+8 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+9 IF '$$ICD^ATXCHK(I,T,9)
QUIT
+10 ;cmi/anch/maw 9/12/2007 csv
SET G="1 Yes - Problem List "_$PIECE($$ICDDX^ICDCODE(I),U,2)
+11 QUIT
End DoDot:1
+12 IF G]""
QUIT G
+13 SET (G,X,I)=""
+14 ;is depression on the BH problem list?
+15 SET T=$ORDER(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))
+16 SET X=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+17 SET I=$PIECE($GET(^AMHPPROB(X,0)),U)
+18 SET I=$PIECE($GET(^AMHPROB(I,0)),U,5)
+19 IF I=""
QUIT
+20 SET I=+$$CODEN^ICDCODE(I,80)
+21 IF I=""
QUIT
+22 IF '$$ICD^ATXCHK(I,T,9)
QUIT
+23 IF $PIECE(^AMHPPROB(X,0),U,12)'="A"
QUIT
+24 ;cmi/anch/maw 9/12/2007 csv
SET G="1 Yes - BH Problem List "_$PIECE($$ICDDX^ICDCODE(I),U,2)
+25 QUIT
End DoDot:1
+26 IF G]""
QUIT G
+27 ;now check for 2 dxs in past year
+28 SET Y="BDM("
SET BDMV=""
+29 SET X=P_"^LAST 2 DX [DM AUDIT DEPRESSIVE DISORDERS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+30 IF $DATA(BDM(2))
QUIT "1 Yes 2 dxs in PCC"
+31 SET BDM=0
IF $DATA(BDM(1))
SET BDM=1
+32 ;go through BH record file and find up to 2 visits in date range
+33 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BDM>1)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BDM>1)
QUIT
Begin DoDot:1
+34 IF '$DATA(^AMHREC(V,0))
QUIT
+35 IF $PIECE(^AMHREC(V,0),U,16)]""
IF BDMV]""
IF $PIECE(^AMHREC(V,0),U,16)=BDMV
QUIT
+36 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BDM>1)
QUIT
SET BDMP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+37 IF 'BDMP
QUIT
+38 SET BDMP1=$PIECE($GET(^AMHPROB(BDMP,0)),U)
+39 IF BDMP1=14
SET BDM=BDM+1
QUIT
+40 IF BDMP1=15
SET BDM=BDM+1
QUIT
+41 IF BDMP1=18
SET BDM=BDM+1
QUIT
+42 IF BDMP1=24
SET BDM=BDM+1
QUIT
+43 SET J=$PIECE(^AMHPROB(BDMP,0),U,5)
+44 SET J=$PIECE($$ICDDX^ICDCODE(J),U,1)
+45 IF $$ICD^ATXCHK(J,$ORDER(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0)),9)
SET BDM=BDM+1
QUIT
+46 QUIT
End DoDot:2
End DoDot:1
+47 IF BDM>1
QUIT "1 Yes 2 dx PCC/BH"
+48 QUIT "2 No"
+49 ;
DEPSCR(P,BDATE,EDATE,F,R) ;EP
+1 NEW X,BDMC
+2 IF $GET(P)=""
QUIT ""
+3 IF $GET(F)=""
SET F="E"
+4 SET BDMC=$$LASTDEPS(P,BDATE,EDATE,"A")
+5 IF $GET(R)
QUIT $SELECT(F="D":$PIECE(BDMC,U),1:"1 Yes - "_$PIECE(BDMC,U,2)_" "_$$DATE^BDMS9B1($PIECE(BDMC,U)))
+6 IF BDMC]""
QUIT "1 Yes - "_$EXTRACT($PIECE(BDMC,U,2),1,20)_" "_$$DATE^BDMS9B1($PIECE(BDMC,U))
+7 ;refusal
+8 NEW G
SET G=$$REFUSAL^BDMD117(P,9999999.15,$ORDER(^AUTTEXAM("B","DEPRESSION SCREENING",0)),BDATE,EDATE)
+9 IF G
IF '$GET(R)
QUIT "3 Refused "_$PIECE(G,U,3)
+10 SET D=0
SET BDMC=""
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(BDMC]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BDMC]"")
QUIT
Begin DoDot:1
+11 IF $PIECE($GET(^AMHREC(V,14)),U,5)]""
IF ($PIECE(^AMHREC(V,14),U,5)="UAS"!($PIECE(^AMHREC(V,14),U,5)'="REF"))
SET BDMC="3 Refused BH Exam 36 "_$$DATE^BDMD110(9999999-D)
QUIT
End DoDot:1
+12 IF BDMC]""
QUIT BDMC
+13 QUIT "2 No"
+14 ;
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
PLCODE(P,A) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 NEW T
SET T=+$$CODEN^ICDCODE(A,80)
+4 IF 'T
QUIT ""
+5 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
+6 QUIT I
PLTAX(P,A) ;EP - is DX on problem list 1 or 0
+1 IF $GET(P)=""
QUIT ""
+2 IF $GET(A)=""
QUIT ""
+3 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+4 IF 'T
QUIT ""
+5 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
+6 QUIT I
+7 ;
E ;
+1 IF $PIECE(BDMLVAL,U,1)>$PIECE(BDMLLAST,U,1)
SET BDMLLAST=BDMLVAL
+2 QUIT
+3 ;
LASTDEPS(BDMLPDFN,BDMLBD,BDMLED,BDMLFORM) ;PEP - return last depression screen
+1 ;
+2 IF $GET(BDMLBD)=""
SET BDMLBD=$$DOB^AUPNPAT(BDMLPDFN)
+3 IF $GET(BDMLED)=""
SET BDMLED=DT
+4 IF $GET(BDMLFORM)=""
SET BDMLFORM="D"
+5 NEW BDMLLAST,BDMLVAL,BDMLX
+6 SET BDMLLAST=""
+7 SET BDMLVAL=$$LASTDEP(BDMLPDFN,BDMLBD,BDMLED,"A")
+8 DO E
+9 SET BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"V79.0","DX",$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
+10 DO E
+11 SET BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"PHQ2","MEASUREMENT",$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
+12 DO E
+13 SET BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"PHQ9","MEASUREMENT",$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
+14 DO E
+15 SET BDMLX=0
FOR
SET BDMLX=$ORDER(^AUTTEDT("C","DEP-SCR",BDMLX))
IF BDMLX'=+BDMLX
QUIT
Begin DoDot:1
+16 SET BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"`"_BDMLX,"EDUCATION",$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
+17 DO E
End DoDot:1
+18 SET BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"14.1","A")
+19 DO E
+20 SET BDMLVAL=$$LASTBHED^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"DEP-SCR","A")
+21 DO E
+22 ;now check for mood disorders
+23 SET BDMLVAL=$$LASTDXT^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP MOOD DISORDERS","A")
+24 DO E
+25 SET BDMLVAL=$$LASTBHDT^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP MOOD DISORDERS","A")
+26 DO E
+27 SET BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"14","A")
+28 DO E
+29 SET BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"15","A")
+30 DO E
+31 SET BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQ2","A")
+32 DO E
+33 SET BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQ9","A")
+34 DO E
+35 IF BDMLFORM="D"
QUIT $PIECE(BDMLLAST,U)
+36 QUIT BDMLLAST
+37 ;
LASTDEP(P,BD,ED,F) ;
+1 NEW %,E,D,V,X,G
+2 NEW BDMLG,BDMLX,BDMLC,BDMLV
+3 SET %=P_"^LAST EXAM 36;DURING "_BD_"-"_ED
SET E=$$START1^APCLDF(%,"BDMLG(")
+4 IF $DATA(BDMLG(1))
SET BDMLX(9999999-$PIECE(BDMLG(1),U))=$$VE(BDMLG(1))
+5 ;now look at AMHREC
+6 SET BDMLC=0
SET BDMLV=""
+7 SET E=(9999999-BD)
SET D=9999999-ED-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!(BDMLC)!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BDMLC)
QUIT
Begin DoDot:1
+8 SET X=$PIECE($GET(^AMHREC(V,14)),U,5)
+9 ;no test
IF X=""
QUIT
+10 ;don't count refusal here
IF $EXTRACT(X)="U"
QUIT
+11 IF X="REF"
QUIT
+12 SET G=9999999-$PIECE(D,".")
+13 IF $DATA(BDMLX($PIECE(D,".")))
QUIT
+14 SET BDMLX($PIECE(D,"."))=G_"^BH: DEPRESSION SCREENING^"_$$VAL^XBDIQ1(9002011,V,1405)_"^^9002011^"_V
End DoDot:1
+15 IF $ORDER(BDMLX(0))
SET G=$ORDER(BDMLX(0))
QUIT $SELECT(F="D":$PIECE(BDMLX(G),U,1),1:BDMLX(G))
+16 QUIT ""
+17 ;
+18 ;
VE(Y,F,T) ;EP
+1 QUIT $PIECE(Y,U,1)_"^Exam: "_$PIECE(Y,U,3)_"^"_$$VAL^XBDIQ1(9000010.13,+$PIECE(Y,U,4),.04)_"^"_$PIECE(Y,U,5)_"^9000010.13^"_+$PIECE(Y,U,4)
+2 ;
