BDMD012 ; IHS/CMI/LAB - 2010 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3**;JUN 14, 2007
;
;cmi/anch/maw 9/12/2010 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^BDMD012(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^BDMD012(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 DM2010
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/2010 DM2010
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 ""
;
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^APCLAPI(P,BDATE,EDATE,"A")
I $G(R) Q $S(F="D":$P(BDMC,U),1:"1 Yes - "_$P(BDMC,U,2)_" "_$$FMTE^XLFDT($P(BDMC,U)))
I BDMC]"" Q "1 Yes - "_$P(BDMC,U,2)_" "_$$FMTE^XLFDT($P(BDMC,U))
;refusal
NEW G S G=$$REFUSAL^BDMD017(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^BDMD010(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
BDMD012 ; IHS/CMI/LAB - 2010 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/12/2010 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^BDMD012(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^BDMD012(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 DM2010
+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/2010 DM2010
+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 ""
+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^APCLAPI(P,BDATE,EDATE,"A")
+5 IF $GET(R)
QUIT $SELECT(F="D":$PIECE(BDMC,U),1:"1 Yes - "_$PIECE(BDMC,U,2)_" "_$$FMTE^XLFDT($PIECE(BDMC,U)))
+6 IF BDMC]""
QUIT "1 Yes - "_$PIECE(BDMC,U,2)_" "_$$FMTE^XLFDT($PIECE(BDMC,U))
+7 ;refusal
+8 NEW G
SET G=$$REFUSAL^BDMD017(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^BDMD010(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
