BDMD812 ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;cmi/anch/maw 9/12/2008 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 $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 ""
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 ""
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)
;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^BDMD812(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^BDMD812(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
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)) ;cmi/maw 12/18/2007 DM2008
S T6=$O(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0)) ;cmi/maw 12/18/2007 DM2008
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 $D(^ATXAX(T,21,"B",I)) S A=1
.I $D(^ATXAX(T1,21,"B",I)) S A=1
.I $D(^ATXAX(T2,21,"B",I)) S A=1
.I $D(^ATXAX(T3,21,"B",I)) S A=1
.I $D(^ATXAX(T4,21,"B",I)) S A=1
.I $D(^ATXAX(T5,21,"B",I)) S A=1 ;cmi/maw 12/18/2008 DM2008
.I $D(^ATXAX(T6,21,"B",I)) S A=1 ;cmi/maw 12/18/2008 DM2008
.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 ""
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 DM2008
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/2008 DM2008
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 ""
TXNAME(V) ;EP
I $G(V)="" Q ""
S V=$$TXNAMES(V)
Q $E(V,1,16)
TXNAMES(Y) ;
I Y=9 Q "REFUSED"
I Y=1 Q "DIET"
I Y=2 Q "INSULIN"
I Y=3 Q "SULFONYLUREA"
I Y=4 Q "METFORMIN (GLUCOPHAGE)"
I Y=5 Q "ACARBOSE OR MIGLITOL"
I Y=6 Q "GLITAZONE"
I Y=7 Q "INCRETIN MIMETIC"
I Y=8 Q "DPP4"
I Y=9 Q "UNKNOWN/REFUSED"
I Y=23 Q "INSULIN+S'UREA"
I Y=24 Q "INSULIN+MET"
I Y=25 Q "INSULIN+ACAR"
I Y=26 Q "INSULIN+GLITAZONE"
I Y=27 Q "INSULIN+INCR"
I Y=28 Q "INSULIN+DPP4"
I Y=34 Q "S'UREA+MET"
I Y=35 Q "S'UREA+ACAR"
I Y=36 Q "S'UREA+GLITAZONE"
I Y=37 Q "S'UREA+INCR"
I Y=38 Q "S'UREA+DPP4"
I Y=45 Q "MET+ACAR"
I Y=46 Q "MET+GLITAZONE"
I Y=47 Q "MET+INCR"
I Y=48 Q "MET+DPP4"
I Y=56 Q "ACAR+GLITAZONE"
I Y=57 Q "ACAR+INCR"
I Y=58 Q "ACAR+DPP4"
I Y=67 Q "GLITAZONE+INCR"
I Y=68 Q "GLITAZONE+DPP4"
I Y=78 Q "INCR+DPP4"
I Y=234 Q "INS+S'UREA+MET"
I Y=235 Q "INS+S'UREA+ACAR"
I Y=236 Q "INS+S'UREA+GLIT"
I Y=237 Q "INS+S'UREA+INCR"
I Y=238 Q "INS+S'UREA+DPP4"
I Y=245 Q "INS+MET+ACAR"
I Y=246 Q "INS+MET+GLITAZONE"
I Y=247 Q "INS+MET+INCR"
I Y=248 Q "INS+MET+DPP4"
I Y=256 Q "INS+ACAR+GLITAZONE"
I Y=257 Q "INS+ACAR+INCR"
I Y=258 Q "INS+ACAR+DPP4"
I Y=267 Q "INS+GLIT+INCR"
I Y=268 Q "INS+GLIT+DPP4"
I Y=278 Q "INS+INCR+DPP4"
I Y=345 Q "S'UREA+MET+ACAR"
I Y=346 Q "S'UREA+MET+GLIT"
I Y=347 Q "S'UREA+MET+INCR"
I Y=348 Q "S'UREA+MET+DPP4"
I Y=356 Q "S'UREA+ACAR+GLIT"
I Y=357 Q "S'UREA+ACAR+INCR"
I Y=358 Q "S'UREA+ACAR+DPP4"
I Y=456 Q "MET+ACAR+GLIT"
I Y=457 Q "MET+ACAR+INCR"
I Y=458 Q "MET+ACAR+DPP4"
I Y=567 Q "ACAR+GLIT+INCR"
I Y=568 Q "ACAR+GLIT+DPP4"
I Y=578 Q "GLIT+INCR+DPP4"
Q ""
;
DEPDX(P,BDATE,EDATE) ;EP
NEW BDM,X
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:'$$ICD^ATXCHK(I,T,9)
.;S G="Yes - Problem List "_$P(^ICD9(I,0),U) ;cmi/anch/maw orig line
.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)
.;S G="Yes - BH Problem List "_$P(^ICD9(I,0),U) ;cmi/anch/maw orig line
.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
;S X=BDATE,%DT="P" D ^%DT S BD=Y
;S X=EDATE,%DT="P" D ^%DT S ED=Y
;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 BDMP=$P($G(^AMHPROB(BDMP,0)),U)
..I BDMP=14 S BDM=BDM+1 Q
..I BDMP=15 S BDM=BDM+1 Q
..I BDMP=18 S BDM=BDM+1 Q
..I BDMP=24 S BDM=BDM+1 Q
..I $E(BDMP,1,3)=296 S BDM=BDM+1 Q
..I $E(BDMP,1,3)=300 S BDM=BDM+1 Q
..I $E(BDMP,1,3)=309 S BDM=BDM+1 Q
..I BDMP="301.13" S BDM=BDM+1 Q
..I BDMP=308.3 S BDM=BDM+1 Q
..I BDMP="311." S BDM=BDM+1 Q
..Q
I BDM>1 Q "1 Yes 2 dx PCC/BH"
Q "2 No"
DEPSCR(P,BDATE,EDATE) ;EP
NEW X
I $G(P)="" Q ""
K BDM
S Y="BDM("
S X=P_"^LAST DX V79.0;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BDM(1)) Q "1 Yes V79.0"_" "_$$DATE^BDMD810($P(BDM(1),U))
;check patient education
S Y="BDM("
S X=P_"^LAST EXAM 36;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BDM(1)) Q "1 Yes Exam 36-Dep Screen "_$$DATE^BDMD810($P(BDM(1),U))
S Y="BDM("
S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(BDM(1)) G BHSCR
S (X,E)=0,%="",T="",D="" F S X=$O(BDM(X)) Q:X'=+X!(D) D
.S T=$P(^AUPNVPED(+$P(BDM(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-",1)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="GAD")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP") S D="1 Yes pt ed "_T_" "_$$DATE^BDMD810($P(BDM(X),U))
K BDM
I $P(D,U)]"" Q D
BHSCR ;
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="1 Yes BH Exam 36 "_$$DATE^BDMD810(9999999-D) Q
.S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BDMC]"") S BDMP=$P($G(^AMHRPRO(X,0)),U) D
..Q:'BDMP
..S BDMP=$P($G(^AMHPROB(BDMP,0)),U)
..I BDMP=14.1 S BDMC="1 Yes BH 14.1 "_$$DATE^BDMD810(9999999-D) Q
..I '$D(^AMHREDU("AD",V)) Q
..S Y=0 F S Y=$O(^AMHREDU("AD",V,Y)) Q:Y'=+Y!(BDMC) D
...S T=$P(^AMHREDU(Y,0),U)
...Q:'T
...Q:'$D(^AUTTEDT(T,0))
...S T=$P(^AUTTEDT(T,0),U,2)
...I $P(T,"-",1)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="GAD")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP") S BDMC="1 Yes BH pt ed "_T_" "_$$DATE^BDMD810(9999999-D)
...Q
I BDMC]"" Q BDMC
;refusal
NEW G S G=$$REFUSAL^BDMD817(P,9999999.15,$O(^AUTTEXAM("B","DEPRESSION SCREENING",0)),BDATE,EDATE)
I G Q "3 Refused"
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^BDMD810(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
BDMD812 ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/12/2008 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 $PIECE(BDM(1),U,3)_U_$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")
+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 G_U_$SELECT(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")
+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 ;check CPT codes in year prior to date range
+18 SET T=$ORDER(^ATXAX("B","DM AUDIT EKG CPTS",0))
+19 KILL BDM
IF T
SET BDM(1)=$$CPT^BDMD812(P,$$DOB^AUPNPAT(P),ED,T,3)
Begin DoDot:1
+20 IF BDM(1)=""
KILL BDM
QUIT
+21 IF LEKG>$PIECE(BDM(1),U)
QUIT
+22 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+23 KILL BDM
IF T
SET BDM(1)=$$RAD^BDMD812(P,$$DOB^AUPNPAT(P),ED,T,3)
Begin DoDot:1
+24 IF BDM(1)=""
KILL BDM
QUIT
+25 IF LEKG>$PIECE(BDM(1),U)
QUIT
+26 SET LEKG=$PIECE(BDM(1),U)
End DoDot:1
+27 QUIT $SELECT(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)
+28 ;
REFMED(P,BDATE,EDATE) ;EP
+1 SET T=$ORDER(^ATXAX("B","DM AUDIT INSULIN DRUGS",0))
+2 SET T1=$ORDER(^ATXAX("B","DM AUDIT SULFONYLUREA DRUGS",0))
+3 SET T2=$ORDER(^ATXAX("B","DM AUDIT METFORMIN DRUGS",0))
+4 SET T3=$ORDER(^ATXAX("B","DM AUDIT ACARBOSE DRUGS",0))
+5 SET T4=$ORDER(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0))
+6 ;cmi/maw 12/18/2007 DM2008
SET T5=$ORDER(^ATXAX("B","DM AUDIT INCRETIN MIMETIC",0))
+7 ;cmi/maw 12/18/2007 DM2008
SET T6=$ORDER(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0))
+8 SET G=0
+9 NEW %DT
SET X=BDATE
SET %DT="P"
DO ^%DT
SET B=Y
+10 SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+11 SET G=""
+12 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",BDMPD,50,I))
IF I'=+I!(G)
QUIT
Begin DoDot:1
+13 SET A=0
+14 IF $DATA(^ATXAX(T,21,"B",I))
SET A=1
+15 IF $DATA(^ATXAX(T1,21,"B",I))
SET A=1
+16 IF $DATA(^ATXAX(T2,21,"B",I))
SET A=1
+17 IF $DATA(^ATXAX(T3,21,"B",I))
SET A=1
+18 IF $DATA(^ATXAX(T4,21,"B",I))
SET A=1
+19 ;cmi/maw 12/18/2008 DM2008
IF $DATA(^ATXAX(T5,21,"B",I))
SET A=1
+20 ;cmi/maw 12/18/2008 DM2008
IF $DATA(^ATXAX(T6,21,"B",I))
SET A=1
+21 IF 'A
QUIT
+22 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",BDMPD,50,I,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+23 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
+24 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 ""
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 DM2008
+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/2008 DM2008
+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 ""
TXNAME(V) ;EP
+1 IF $GET(V)=""
QUIT ""
+2 SET V=$$TXNAMES(V)
+3 QUIT $EXTRACT(V,1,16)
TXNAMES(Y) ;
+1 IF Y=9
QUIT "REFUSED"
+2 IF Y=1
QUIT "DIET"
+3 IF Y=2
QUIT "INSULIN"
+4 IF Y=3
QUIT "SULFONYLUREA"
+5 IF Y=4
QUIT "METFORMIN (GLUCOPHAGE)"
+6 IF Y=5
QUIT "ACARBOSE OR MIGLITOL"
+7 IF Y=6
QUIT "GLITAZONE"
+8 IF Y=7
QUIT "INCRETIN MIMETIC"
+9 IF Y=8
QUIT "DPP4"
+10 IF Y=9
QUIT "UNKNOWN/REFUSED"
+11 IF Y=23
QUIT "INSULIN+S'UREA"
+12 IF Y=24
QUIT "INSULIN+MET"
+13 IF Y=25
QUIT "INSULIN+ACAR"
+14 IF Y=26
QUIT "INSULIN+GLITAZONE"
+15 IF Y=27
QUIT "INSULIN+INCR"
+16 IF Y=28
QUIT "INSULIN+DPP4"
+17 IF Y=34
QUIT "S'UREA+MET"
+18 IF Y=35
QUIT "S'UREA+ACAR"
+19 IF Y=36
QUIT "S'UREA+GLITAZONE"
+20 IF Y=37
QUIT "S'UREA+INCR"
+21 IF Y=38
QUIT "S'UREA+DPP4"
+22 IF Y=45
QUIT "MET+ACAR"
+23 IF Y=46
QUIT "MET+GLITAZONE"
+24 IF Y=47
QUIT "MET+INCR"
+25 IF Y=48
QUIT "MET+DPP4"
+26 IF Y=56
QUIT "ACAR+GLITAZONE"
+27 IF Y=57
QUIT "ACAR+INCR"
+28 IF Y=58
QUIT "ACAR+DPP4"
+29 IF Y=67
QUIT "GLITAZONE+INCR"
+30 IF Y=68
QUIT "GLITAZONE+DPP4"
+31 IF Y=78
QUIT "INCR+DPP4"
+32 IF Y=234
QUIT "INS+S'UREA+MET"
+33 IF Y=235
QUIT "INS+S'UREA+ACAR"
+34 IF Y=236
QUIT "INS+S'UREA+GLIT"
+35 IF Y=237
QUIT "INS+S'UREA+INCR"
+36 IF Y=238
QUIT "INS+S'UREA+DPP4"
+37 IF Y=245
QUIT "INS+MET+ACAR"
+38 IF Y=246
QUIT "INS+MET+GLITAZONE"
+39 IF Y=247
QUIT "INS+MET+INCR"
+40 IF Y=248
QUIT "INS+MET+DPP4"
+41 IF Y=256
QUIT "INS+ACAR+GLITAZONE"
+42 IF Y=257
QUIT "INS+ACAR+INCR"
+43 IF Y=258
QUIT "INS+ACAR+DPP4"
+44 IF Y=267
QUIT "INS+GLIT+INCR"
+45 IF Y=268
QUIT "INS+GLIT+DPP4"
+46 IF Y=278
QUIT "INS+INCR+DPP4"
+47 IF Y=345
QUIT "S'UREA+MET+ACAR"
+48 IF Y=346
QUIT "S'UREA+MET+GLIT"
+49 IF Y=347
QUIT "S'UREA+MET+INCR"
+50 IF Y=348
QUIT "S'UREA+MET+DPP4"
+51 IF Y=356
QUIT "S'UREA+ACAR+GLIT"
+52 IF Y=357
QUIT "S'UREA+ACAR+INCR"
+53 IF Y=358
QUIT "S'UREA+ACAR+DPP4"
+54 IF Y=456
QUIT "MET+ACAR+GLIT"
+55 IF Y=457
QUIT "MET+ACAR+INCR"
+56 IF Y=458
QUIT "MET+ACAR+DPP4"
+57 IF Y=567
QUIT "ACAR+GLIT+INCR"
+58 IF Y=568
QUIT "ACAR+GLIT+DPP4"
+59 IF Y=578
QUIT "GLIT+INCR+DPP4"
+60 QUIT ""
+61 ;
DEPDX(P,BDATE,EDATE) ;EP
+1 NEW BDM,X
+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 '$$ICD^ATXCHK(I,T,9)
QUIT
+9 ;S G="Yes - Problem List "_$P(^ICD9(I,0),U) ;cmi/anch/maw orig line
+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 ;S G="Yes - BH Problem List "_$P(^ICD9(I,0),U) ;cmi/anch/maw orig line
+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 ;S X=BDATE,%DT="P" D ^%DT S BD=Y
+33 ;S X=EDATE,%DT="P" D ^%DT S ED=Y
+34 ;go through BH record file and find up to 2 visits in date range
+35 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
+36 IF '$DATA(^AMHREC(V,0))
QUIT
+37 IF $PIECE(^AMHREC(V,0),U,16)]""
IF BDMV]""
IF $PIECE(^AMHREC(V,0),U,16)=BDMV
QUIT
+38 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
+39 IF 'BDMP
QUIT
+40 SET BDMP=$PIECE($GET(^AMHPROB(BDMP,0)),U)
+41 IF BDMP=14
SET BDM=BDM+1
QUIT
+42 IF BDMP=15
SET BDM=BDM+1
QUIT
+43 IF BDMP=18
SET BDM=BDM+1
QUIT
+44 IF BDMP=24
SET BDM=BDM+1
QUIT
+45 IF $EXTRACT(BDMP,1,3)=296
SET BDM=BDM+1
QUIT
+46 IF $EXTRACT(BDMP,1,3)=300
SET BDM=BDM+1
QUIT
+47 IF $EXTRACT(BDMP,1,3)=309
SET BDM=BDM+1
QUIT
+48 IF BDMP="301.13"
SET BDM=BDM+1
QUIT
+49 IF BDMP=308.3
SET BDM=BDM+1
QUIT
+50 IF BDMP="311."
SET BDM=BDM+1
QUIT
+51 QUIT
End DoDot:2
End DoDot:1
+52 IF BDM>1
QUIT "1 Yes 2 dx PCC/BH"
+53 QUIT "2 No"
DEPSCR(P,BDATE,EDATE) ;EP
+1 NEW X
+2 IF $GET(P)=""
QUIT ""
+3 KILL BDM
+4 SET Y="BDM("
+5 SET X=P_"^LAST DX V79.0;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF $DATA(BDM(1))
QUIT "1 Yes V79.0"_" "_$$DATE^BDMD810($PIECE(BDM(1),U))
+7 ;check patient education
+8 SET Y="BDM("
+9 SET X=P_"^LAST EXAM 36;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+10 IF $DATA(BDM(1))
QUIT "1 Yes Exam 36-Dep Screen "_$$DATE^BDMD810($PIECE(BDM(1),U))
+11 SET Y="BDM("
+12 SET X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+13 IF '$DATA(BDM(1))
GOTO BHSCR
+14 SET (X,E)=0
SET %=""
SET T=""
SET D=""
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(D)
QUIT
Begin DoDot:1
+15 SET T=$PIECE(^AUPNVPED(+$PIECE(BDM(X),U,4),0),U)
+16 IF 'T
QUIT
+17 IF '$DATA(^AUTTEDT(T,0))
QUIT
+18 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+19 IF $PIECE(T,"-",1)="DEP"!($PIECE(T,"-",1)="BH")!($PIECE(T,"-",1)="GAD")!($PIECE(T,"-",1)="SB")!($PIECE(T,"-",1)="PDEP")
SET D="1 Yes pt ed "_T_" "_$$DATE^BDMD810($PIECE(BDM(X),U))
End DoDot:1
+20 KILL BDM
+21 IF $PIECE(D,U)]""
QUIT D
BHSCR ;
+1 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
+2 IF $PIECE($GET(^AMHREC(V,14)),U,5)]""
IF $PIECE(^AMHREC(V,14),U,5)'="UAS"
IF $PIECE(^AMHREC(V,14),U,5)'="REF"
SET BDMC="1 Yes BH Exam 36 "_$$DATE^BDMD810(9999999-D)
QUIT
+3 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BDMC]"")
QUIT
SET BDMP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+4 IF 'BDMP
QUIT
+5 SET BDMP=$PIECE($GET(^AMHPROB(BDMP,0)),U)
+6 IF BDMP=14.1
SET BDMC="1 Yes BH 14.1 "_$$DATE^BDMD810(9999999-D)
QUIT
+7 IF '$DATA(^AMHREDU("AD",V))
QUIT
+8 SET Y=0
FOR
SET Y=$ORDER(^AMHREDU("AD",V,Y))
IF Y'=+Y!(BDMC)
QUIT
Begin DoDot:3
+9 SET T=$PIECE(^AMHREDU(Y,0),U)
+10 IF 'T
QUIT
+11 IF '$DATA(^AUTTEDT(T,0))
QUIT
+12 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+13 IF $PIECE(T,"-",1)="DEP"!($PIECE(T,"-",1)="BH")!($PIECE(T,"-",1)="GAD")!($PIECE(T,"-",1)="SB")!($PIECE(T,"-",1)="PDEP")
SET BDMC="1 Yes BH pt ed "_T_" "_$$DATE^BDMD810(9999999-D)
+14 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF BDMC]""
QUIT BDMC
+16 ;refusal
+17 NEW G
SET G=$$REFUSAL^BDMD817(P,9999999.15,$ORDER(^AUTTEXAM("B","DEPRESSION SCREENING",0)),BDATE,EDATE)
+18 IF G
QUIT "3 Refused"
+19 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
+20 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^BDMD810(9999999-D)
QUIT
End DoDot:1
+21 IF BDMC]""
QUIT BDMC
+22 QUIT "2 No"
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
