BDMDG12 ; IHS/CMI/LAB - 2019 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
;
;
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:"3 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")!(G["TX IN PROGRESS"):"2 No",1:"3 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)
;
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^BDMUTL($P(^AUPNVCPT(X,0),U),$P(^ATXAX(T,0),U),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 $$DATE^BDMS9B1($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry
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^BDMUTL(Y,$P(^ATXAX(T,0),U),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 $$DATE^BDMS9B1($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
;
INSULIN(P,BDATE,EDATE) ;EP
NEW X,BDM,E,ED,%DT
S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT INSULIN DRUGS",0)),ED)
Q BDM
;
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT SULFONYLUREA DRUGS",0)),ED)
Q BDM
;
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT SULFONYLUREA-LIKE",0)),ED)
Q BDM
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT METFORMIN DRUGS",0)),ED)
Q BDM
;
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT ACARBOSE DRUGS",0)),ED)
Q BDM
;
;
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0)),ED)
Q BDM
;
SGLT2(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT SGLT-2 INHIBITOR DRUG"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT SGLT-2 INHIBITOR DRUG",0)),ED)
Q BDM
;
DPP4(P,BDATE,EDATE) ;EP
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0)),ED)
Q BDM
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT AMYLIN ANALOGUES",0)),ED)
Q BDM
;
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"
;
S X=P_"^LAST MEDS [DM AUDIT INCRETIN MIMETIC"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT GLP-1 ANALOG DRUGS",0)),ED)
I BDM="X" Q BDM
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT INCRETIN MIMETIC",0)),ED)
Q BDM
;
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"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT BROMOCRIPTINE DRUGS",0)),ED)
Q BDM
;
COLE(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT COLESEVELAM DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRES^BDMDG18(P,$O(^ATXAX("B","DM AUDIT COLESEVELAM DRUGS",0)),ED)
Q BDM
DEPDX(P,BDATE,EDATE) ;EP
NEW BDM,X,BDMP,BDMP4,T,I,G,J,D,BDMD
K BDM
S (G,X,I)=""
;is depression on the problem list?
S T=$O(^ATXAX("B","BGP MOOD 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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BDMUTL(I,$P(^ATXAX(T,0),U),9) S G="1 Yes Problem List ("_$P($$ICDDX^BDMUTL(I),U,2)_") " Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL(2019,"DEPRESSION DIAGNOSES",$P(^AUPNPROB(X,800),U,1)) S G="1 Yes Problem List (SNOMED: "_$P(^AUPNPROB(X,800),U,1)_") "
.Q
I G]"" Q G
S (G,X,I)=""
;is depression on the BH problem list?
S T=$O(^ATXAX("B","BGP MOOD 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 J=$P(^AMHPROB(I,0),U,1)
.I J=14!(J=15) S G="1 Yes BH Problem List ("_J_")" Q
.S I=$P($G(^AMHPROB(I,0)),U,5)
.Q:I=""
.S I=+$$CODEN^BDMUTL(I,80)
.Q:I=""
.Q:'$$ICD^BDMUTL(I,$P(^ATXAX(T,0),U),9)
.;Q:'$$ICD^ATXCHK(I,T,9)
.Q:$P(^AMHPPROB(X,0),U,12)="D"
.Q:$P(^AMHPPROB(X,0),U,12)="I"
.S G="1 Yes BH Problem List ("_$P($$ICDDX^BDMUTL(I),U,2)_")"
.Q
I G]"" Q G
;now check for 2 dxs in past year
S Y="BDM(",BDMV=""
S X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BDM(2)) Q "1 Yes 2 DXs"
S BDM=0,BDMD=""
I $D(BDM(1)) S BDM=1,BDMD=$P(BDM(1),U,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))
.Q:BDMD=$P($P(^AMHREC(V,0),U,1),".")
.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 BDMP4=$P($G(^AMHPROB(BDMP,0)),U)
..I BDMP4=14 S BDM=BDM+1 Q
..I BDMP4=15 S BDM=BDM+1 Q
..S J=$P(^AMHPROB(BDMP,0),U,5)
..S J=$P($$ICDDX^BDMUTL(J),U,1)
..I $$ICD^BDMUTL(J,"BGP MOOD DISORDERS",9) S BDM=BDM+1 Q
..Q
I BDM>1 Q "1 Yes 2 DXs 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))
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)
S T=+$$CODEN^BDMUTL(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)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),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)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BDMUTL(Y,$P(^ATXAX(T,0),U),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 BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"PHQT","MEASUREMENT",$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
D E
S BDMLVAL=$$CPT^BDMDGDU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),5)
D E
S BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"14.1","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
S BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQT","A")
D E
S BDMLVAL=$$LASTBHCT^APCLAPIU(BDMLPDFN,$S($P(BDMLLAST,U)]"":$P(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP DEPRESSION SCREEN CPTS","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
.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)
;
CVD(P,EDATE) ;EP
I '$G(P) Q ""
I '$D(^DPT(P)) Q ""
NEW %,BDM,E,X,G,Z,Y,T
;is cvd on the problem list?
S G=""
S T=$O(^ATXAX("B","DM AUDIT CVD DIAGNOSES",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)="D"
.Q:'$$ICD^BDMUTL(I,$P(^ATXAX(T,0),U),9)
.S G="1 Yes - Problem List "_$$VAL^XBDIQ1(9000011,X,.01)
.Q
I G Q G
K BDM
S X=P_"^LAST DX [BGP CABG DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S Y=$$DATE^BDMS9B1($P(BDM(1),U,1)) Q "1 Yes - DX "_Y
K BDM
S X=P_"^LAST DX [BGP PCI DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S Y=$$DATE^BDMS9B1($P(BDM(1),U,1)) Q "1 Yes - DX "_Y
K BDM
S X=P_"^LAST 2 DX [DM AUDIT CVD DIAGNOSES;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(2)) S Y=$$DATE^BDMS9B1($P(BDM(1),U,1)),Z=$$DATE^BDMS9B1($P(BDM(2),U,1)) Q "1 Yes - DX "_Y_" | "_Z
S X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP PCI CM PROCS","A")
I X Q "1 Yes - "_$P(X,U,2)_" "_$$DATE^BDMS9B1($P(X,U,1))
S X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP CABG PROCS","A")
I X Q "1 Yes - "_$P(X,U,2)_" "_$$DATE^BDMS9B1($P(X,U,1))
S X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP PCI CM CPTS","A")
I X Q "1 Yes - CPT "_$P(X,U,2)_" "_$$DATE^BDMS9B1($P(X,U,1))
S X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP CABG CPTS","A")
I X Q "1 Yes - CPT "_$P(X,U,2)_" "_$$DATE^BDMS9B1($P(X,U,1))
Q "2 No"
BDMDG12 ; IHS/CMI/LAB - 2019 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
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:"3 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")!(G["TX IN PROGRESS"):"2 No",1:"3 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 ;
+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^BDMUTL($PIECE(^AUPNVCPT(X,0),U),$PIECE(^ATXAX(T,0),U),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 $$DATE^BDMS9B1($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+24 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry
+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^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),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 $$DATE^BDMS9B1($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+27 QUIT ""
+28 ;
INSULIN(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E,ED,%DT
+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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT INSULIN DRUGS",0)),ED)
+6 QUIT BDM
+7 ;
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT SULFONYLUREA DRUGS",0)),ED)
+6 QUIT BDM
+7 ;
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT SULFONYLUREA-LIKE",0)),ED)
+6 QUIT BDM
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT METFORMIN DRUGS",0)),ED)
+6 QUIT BDM
+7 ;
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT ACARBOSE DRUGS",0)),ED)
+6 QUIT BDM
+7 ;
+8 ;
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0)),ED)
+6 QUIT BDM
+7 ;
SGLT2(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT SGLT-2 INHIBITOR DRUG"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT SGLT-2 INHIBITOR DRUG",0)),ED)
+6 QUIT BDM
+7 ;
DPP4(P,BDATE,EDATE) ;EP
+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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0)),ED)
+6 QUIT BDM
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT AMYLIN ANALOGUES",0)),ED)
+6 QUIT BDM
+7 ;
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 ;
+5 SET X=P_"^LAST MEDS [DM AUDIT INCRETIN MIMETIC"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 IF $DATA(BDM(1))
QUIT "X"
+7 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+8 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT GLP-1 ANALOG DRUGS",0)),ED)
+9 IF BDM="X"
QUIT BDM
+10 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+11 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT INCRETIN MIMETIC",0)),ED)
+12 QUIT BDM
+13 ;
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 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT BROMOCRIPTINE DRUGS",0)),ED)
+6 QUIT BDM
+7 ;
COLE(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT COLESEVELAM DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+5 SET BDM=$$PRES^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT COLESEVELAM DRUGS",0)),ED)
+6 QUIT BDM
DEPDX(P,BDATE,EDATE) ;EP
+1 NEW BDM,X,BDMP,BDMP4,T,I,G,J,D,BDMD
+2 KILL BDM
+3 SET (G,X,I)=""
+4 ;is depression on the problem list?
+5 SET T=$ORDER(^ATXAX("B","BGP MOOD 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)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $$ICD^BDMUTL(I,$PIECE(^ATXAX(T,0),U),9)
SET G="1 Yes Problem List ("_$PIECE($$ICDDX^BDMUTL(I),U,2)_") "
QUIT
+11 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL(2019,"DEPRESSION DIAGNOSES",$PIECE(^AUPNPROB(X,800),U,1))
SET G="1 Yes Problem List (SNOMED: "_$PIECE(^AUPNPROB(X,800),U,1)_") "
+12 QUIT
End DoDot:1
+13 IF G]""
QUIT G
+14 SET (G,X,I)=""
+15 ;is depression on the BH problem list?
+16 SET T=$ORDER(^ATXAX("B","BGP MOOD DISORDERS",0))
+17 SET X=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+18 SET I=$PIECE($GET(^AMHPPROB(X,0)),U)
+19 SET J=$PIECE(^AMHPROB(I,0),U,1)
+20 IF J=14!(J=15)
SET G="1 Yes BH Problem List ("_J_")"
QUIT
+21 SET I=$PIECE($GET(^AMHPROB(I,0)),U,5)
+22 IF I=""
QUIT
+23 SET I=+$$CODEN^BDMUTL(I,80)
+24 IF I=""
QUIT
+25 IF '$$ICD^BDMUTL(I,$PIECE(^ATXAX(T,0),U),9)
QUIT
+26 ;Q:'$$ICD^ATXCHK(I,T,9)
+27 IF $PIECE(^AMHPPROB(X,0),U,12)="D"
QUIT
+28 IF $PIECE(^AMHPPROB(X,0),U,12)="I"
QUIT
+29 SET G="1 Yes BH Problem List ("_$PIECE($$ICDDX^BDMUTL(I),U,2)_")"
+30 QUIT
End DoDot:1
+31 IF G]""
QUIT G
+32 ;now check for 2 dxs in past year
+33 SET Y="BDM("
SET BDMV=""
+34 SET X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+35 IF $DATA(BDM(2))
QUIT "1 Yes 2 DXs"
+36 SET BDM=0
SET BDMD=""
+37 IF $DATA(BDM(1))
SET BDM=1
SET BDMD=$PIECE(BDM(1),U,1)
+38 ;go through BH record file and find up to 2 visits in date range
+39 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
+40 IF '$DATA(^AMHREC(V,0))
QUIT
+41 IF BDMD=$PIECE($PIECE(^AMHREC(V,0),U,1),".")
QUIT
+42 IF $PIECE(^AMHREC(V,0),U,16)]""
IF BDMV]""
IF $PIECE(^AMHREC(V,0),U,16)=BDMV
QUIT
+43 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
+44 IF 'BDMP
QUIT
+45 SET BDMP4=$PIECE($GET(^AMHPROB(BDMP,0)),U)
+46 IF BDMP4=14
SET BDM=BDM+1
QUIT
+47 IF BDMP4=15
SET BDM=BDM+1
QUIT
+48 SET J=$PIECE(^AMHPROB(BDMP,0),U,5)
+49 SET J=$PIECE($$ICDDX^BDMUTL(J),U,1)
+50 IF $$ICD^BDMUTL(J,"BGP MOOD DISORDERS",9)
SET BDM=BDM+1
QUIT
+51 QUIT
End DoDot:2
End DoDot:1
+52 IF BDM>1
QUIT "1 Yes 2 DXs PCC/BH"
+53 QUIT "2 No"
+54 ;
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 QUIT "2 No"
+8 ;
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
+4 ;S T=+$$CODEN^ICDCODE(A,80)
+5 SET T=+$$CODEN^BDMUTL(A,80)
+6 IF 'T
QUIT ""
+7 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))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),9)
SET I=1
+8 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))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),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 BDMLVAL=$$LASTITEM^APCLAPIU(BDMLPDFN,"PHQT","MEASUREMENT",$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"A")
+16 DO E
+17 SET BDMLVAL=$$CPT^BDMDGDU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),5)
+18 DO E
+19 SET BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"14.1","A")
+20 DO E
+21 ;now check for mood disorders
+22 SET BDMLVAL=$$LASTDXT^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP MOOD DISORDERS","A")
+23 DO E
+24 SET BDMLVAL=$$LASTBHDT^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP MOOD DISORDERS","A")
+25 DO E
+26 SET BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"14","A")
+27 DO E
+28 SET BDMLVAL=$$LASTBHDX^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"15","A")
+29 DO E
+30 SET BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQ2","A")
+31 DO E
+32 SET BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQ9","A")
+33 DO E
+34 SET BDMLVAL=$$LASTBHME^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"PHQT","A")
+35 DO E
+36 SET BDMLVAL=$$LASTBHCT^APCLAPIU(BDMLPDFN,$SELECT($PIECE(BDMLLAST,U)]"":$PIECE(BDMLLAST,U),1:BDMLBD),BDMLED,"BGP DEPRESSION SCREEN CPTS","A")
+37 DO E
+38 IF BDMLFORM="D"
QUIT $PIECE(BDMLLAST,U)
+39 QUIT BDMLLAST
+40 ;
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 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 ;
CVD(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P))
QUIT ""
+3 NEW %,BDM,E,X,G,Z,Y,T
+4 ;is cvd on the problem list?
+5 SET G=""
+6 SET T=$ORDER(^ATXAX("B","DM AUDIT CVD DIAGNOSES",0))
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+8 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+10 IF '$$ICD^BDMUTL(I,$PIECE(^ATXAX(T,0),U),9)
QUIT
+11 SET G="1 Yes - Problem List "_$$VAL^XBDIQ1(9000011,X,.01)
+12 QUIT
End DoDot:1
+13 IF G
QUIT G
+14 KILL BDM
+15 SET X=P_"^LAST DX [BGP CABG DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+16 IF $DATA(BDM(1))
SET Y=$$DATE^BDMS9B1($PIECE(BDM(1),U,1))
QUIT "1 Yes - DX "_Y
+17 KILL BDM
+18 SET X=P_"^LAST DX [BGP PCI DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+19 IF $DATA(BDM(1))
SET Y=$$DATE^BDMS9B1($PIECE(BDM(1),U,1))
QUIT "1 Yes - DX "_Y
+20 KILL BDM
+21 SET X=P_"^LAST 2 DX [DM AUDIT CVD DIAGNOSES;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+22 IF $DATA(BDM(2))
SET Y=$$DATE^BDMS9B1($PIECE(BDM(1),U,1))
SET Z=$$DATE^BDMS9B1($PIECE(BDM(2),U,1))
QUIT "1 Yes - DX "_Y_" | "_Z
+23 SET X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP PCI CM PROCS","A")
+24 IF X
QUIT "1 Yes - "_$PIECE(X,U,2)_" "_$$DATE^BDMS9B1($PIECE(X,U,1))
+25 SET X=$$LASTPRCT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP CABG PROCS","A")
+26 IF X
QUIT "1 Yes - "_$PIECE(X,U,2)_" "_$$DATE^BDMS9B1($PIECE(X,U,1))
+27 SET X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP PCI CM CPTS","A")
+28 IF X
QUIT "1 Yes - CPT "_$PIECE(X,U,2)_" "_$$DATE^BDMS9B1($PIECE(X,U,1))
+29 SET X=$$LASTCPTT^BDMAPIU(P,$$DOB^AUPNPAT(P),EDATE,"BGP CABG CPTS","A")
+30 IF X
QUIT "1 Yes - CPT "_$PIECE(X,U,2)_" "_$$DATE^BDMS9B1($PIECE(X,U,1))
+31 QUIT "2 No"
