BDMDG16 ; IHS/CMI/LAB - 2019 DIABETES AUDIT 02 Feb 2014 2:41 PM ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
;
;
TBCODE(P,EDATE,R) ;EP
NEW BDMJ,BDMI,X,BDMR
S BDMJ=""
S BDMR=$$PPD^BDMDG18(P,EDATE)
I $E($P(BDMR,"||",2))=1 D Q BDMJ
.I $$TBTX^BDMDG12(P)["TX COMPLETE" S BDMJ=1 Q
.S BDMJ=2
.Q
I $E($P(BDMR,"||",2))=2 S BDMJ=4 D Q BDMJ
.I $$DODX(P,R,"I")="" S BDMJ=6 Q
.S D=$$DODX(P,R,"I"),E=$$PPD^BDMDG18(P,EDATE,"I") S BDMJ=$S(D>E:4,1:3)
.Q
I $E(BDMR)=4 S BDMJ=5
I $E(BDMR)=3 S BDMJ=5
I $E($P(BDMR,"||",2))=3 S BDMJ=5
I $E($P(BDMR,"||",2))=4 S BDMJ=5
Q BDMJ
;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated/treatment incomplete or unknown treatment
3 ;;PPD -, placed on or after date of DM dx
4 ;;PPD -, placed before date of DM dx
5 ;;PPD Status unknown
6 ;;PPD -, date of DX or PPD date unknown
7 ;;PPD Refused
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^BDMDG13(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C,Z S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S Z=C
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/")+C
Q C\Z
DIAMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^BDMDG13(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C,Z S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S Z=C
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/",2)+C
Q C\Z
PPDDATE(P,EDATE) ;EP
NEW X S X=$$LASTNP^BDMDG18(P,EDATE)
Q X
STATIN(P,BDATE,EDATE) ;EP
NEW X,BDM,E,BDMALL,ED,BD
S X=P_"^LAST MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S BDMALL($P(BDM(1),U,1))=BDM(1) ;Q "1 Yes "_$$DATE^BDMS9B1($P(BDM(1),U,1))_" "_$P(BDM(1),U,2)
NEW BDMSMEDS
K BDMSMEDS
K %DT S %DT="P",X=BDATE D ^%DT S BD=Y
D GETMEDS^BDMSMU1(P,BD,EDATE,"BGP PQA STATIN MEDS","BGP PQA STATIN NDC",,,.BDMSMEDS)
S (X,C)=0 F S X=$O(BDMSMEDS(X)) Q:X'=+X S C=X
I C S BDMALL($P(BDMSMEDS(C),U,1))=BDMSMEDS(C) ;Q "1 Yes "_$$DATE^BDMS9B1($P(BDMSMEDS(1),U,1))_" "_$P(BDMSMEDS(1),U,2)
S (X,C)=0 F S X=$O(BDMALL(X)) Q:X'=+X S C=X
I C Q "1 Yes "_$$DATE^BDMS9B1($P(BDMALL(C),U,1))_" "_$P(BDMALL(C),U,2)
;
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRESD^BDMDG18(P,$O(^ATXAX("B","DM AUDIT STATIN DRUGS",0)),ED,186)
I BDM]"" Q BDM
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRESD^BDMDG18(P,$O(^ATXAX("B","BGP PQA STATIN MEDS",0)),ED,186)
I BDM]"" Q BDM
;check allergy/intolerence
S E=$$STATALG(P,$$DOB^AUPNPAT(P),EDATE,BDATE)
I E Q "3 "_$P(E,U,2)
S E=$$STATCON(P,BDATE,EDATE)
I E Q "3 "_$P(E,U,2)
Q "2 No"
;
STATALG(P,BDATE,EDATE,RPB) ;EP
NEW BDMG,BDMY,Y,X,N,Z,BDMC
S BDMC=""
K BDMG,BDMY S Y="BDMG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BDMG(X)) Q:X'=+X S Y=+$P(BDMG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["STATIN"!(N["STATINS") S BDMC=1_U_$$DATE^BDMS9B1($P(BDMG(X),U))_" ADR POV "_$P(BDMG(X),U,2)
.S T="BGP ADV EFF CARDIOVASC NEC"
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BDMUTL(Z,T,9) S BDMC=1_U_$$DATE^BDMS9B1($P(BDMG(X),U))_" ADR POV ["_$P(BDMG(X),U,2)_" + "_$P($$ICDDX^BDMUTL(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BDMUTL(Z,T,9) S BDMC=1_U_$$DATE^BDMS9B1($P(BDMG(X),U))_" ADR POV ["_$P(BDMG(X),U,2)_" + "_$P($$ICDDX^BDMUTL(Z),U,2)_"] "_N Q
.S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BDMUTL(Z,T,9) S BDMC=1_U_$$DATE^BDMS9B1($P(BDMG(X),U))_" ADR POV ["_$P(BDMG(X),U,2)_" + "_$P($$ICDDX^BDMUTL(Z),U,2)_"] "_N Q
.Q
I BDMC Q BDMC
K BDMG S BDMC=0 S Y="BDMG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BDMG(X)) Q:X'=+X S Y=+$P(BDMG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["STATIN"!(N["STATINS") S BDMC=1_U_$$DATE^BDMS9B1($P(BDMG(X),U))_" ADR POV "_$P(BDMG(X),U,2) ;_"]"
I BDMC Q BDMC
;PL
S BDMC=0
S T="",T="BGP ASA ALLERGY 995.0-995.3"
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BDMUTL(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.I $$ICD^BDMUTL(I,"BGP HX DRUG ALLERGY NEC",9)!($$ICD^BDMUTL(I,T,9)),N["STATIN"!(N["STATINS") S BDMC=1_U_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y ;_"]"
.Q
I BDMC Q BDMC
;ART
S BDMC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>EDATE
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["STATIN" S BDMC=1_U_$$DATE^BDMS9B1($P(^GMR(120.8,X,0),U,4))_" ADR Allergy Tracking "_N
I BDMC Q BDMC
K BDMG S Y="BDMG(",X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(RPB)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BDMG(1)) Q 1_U_$$DATE^BDMS9B1($P(BDMG(1),U))_" ADR POV "_$P(BDMG(1),U,2) ;_"]"
S BDMG=""
S T=$O(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
S BDMLT=$O(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
S B=9999999-RPB,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BDMG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) I $$RESCK(X) S BDMG=1_U_$$DATE^BDMS9B1((9999999-D))_" ADR creat kinase of "_$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BDMDG1C(J,T)
...I $$RESCK(X) S BDMG=1_U_$$DATE^BDMS9B1((9999999-D))_" ADR creat kinase of "_$P(^AUPNVLAB(X,0),U,4) Q
...Q
I BDMG Q BDMG
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BDMLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
S T2=$O(^ATXAX("B","BGP AST LOINC",0))
S BDMLT2=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
S B=9999999-$$FMADD^XLFDT(EDATE,-365),E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BDMG) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BDMLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BDMC=BDMC+1,BDMC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...I BDMLT2,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BDMLT2,21,"B",$P(^AUPNVLAB(X,0),U))) S BDMC=BDMC+1,BDMC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I '$$LOINC^BDMDG1C(J,T),'$$LOINC^BDMDG1C(J,T2)
...S BDMC=BDMC+1,BDMC((9999999-D))=X_U_$P(^AUPNVLAB(X,0),U,4)_U_$P($G(^AUPNVLAB(X,11)),U,5) Q
...Q
S BDMG=""
S X=0 F S X=$O(BDMC(X)) Q:X'=+X!(BDMG) D
.Q:'$$RESAL(BDMC(X))
.S Y=$O(BDMC(X))
.Q:Y=""
.I $$RESAL(BDMC(Y)) S BDMG=1_U_" ADR AST/ALT" Q
.Q
I BDMG Q BDMG
Q 0
;
RESAL(Y) ;
NEW V,ULN
S V=+$P(Y,U,2),ULN=$P(Y,U,3)
I ULN="" Q ""
I V>(ULN*3) Q 1
Q ""
RESCK(Y) ;
NEW V,ULN
S V=+$P(^AUPNVLAB(X,0),U,4)
I V>10000 Q 1
S ULN=$P($G(^AUPNVLAB(X,11)),U,5)
I ULN="" Q 0 ;no upper limit
I V>(ULN*10) Q 1
Q 0
STATCON(P,BDATE,EDATE) ;EP does patient have an STATIN Contra
NEW ED,BD,BDMG,BDMC,X,Y,Z,N,E
;
;pregnant
S X=$$PREG^BDMDG1B(P,BDATE,EDATE,1,1) I X Q 1_U_"Contraindication pregnant"
;nmi
S BDMG=""
S T=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
S X=0 F S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X D
.Q:'$D(^ATXAX(T,21,"B",X)) ;not an STATI
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D I Y<BDATE Q
..I Y>EDATE Q
..S N=0 F S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N D
...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
...S BDMG=1_U_$$DATE^BDMS9B1($P(^AUPNPREF(N,0),U,3))_" Contraindication NMI "_$$VAL^XBDIQ1(9000022,N,.04) ;_" "_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
I BDMG Q BDMG
;breastfeeding
K BDMG S Y="BDMG(",X=P_"^LAST DX [BGP BREASTFEEDING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BDMG(1)) Q 1_U_$$DATE^BDMS9B1($P(BDMG(1),U))_" Contraindication Breastfeeding "_$P(BDMG(1),U,2) ;_"]" ;_$$VAL^XBDIQ1(9000010.07,+$P(BDMG(1),U,4),.04)
;now check education
K BDMG
S Y="BDMG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S (X,D)=0,%="",T="" F S X=$O(BDMG(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BDMG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="BF-BC" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-BP" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-CS" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-EQ" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-FU" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-HC" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-ON" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-M" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-MK" S %=T_U_$P(BDMG(X),U) Q
.I T="BF-N" S %=T_U_$P(BDMG(X),U) Q
.I $P(T,"-",1)]"",$$SNOMED^BDMUTL(2019,"BREASTFEEDING PATIENT ED",$P(T,"-",1)) S %=T_U_$P(BDMG(X),U) Q
I %]"" Q 1_U_$$DATE^BDMS9B1($P(%,U,2))_" Contraindication Breastfeeding " ;_$P(%,U,1)
;NOW CHECK ALCOHOL HEPATITIS
K BDMG S Y="BDMG(",X=P_"^LAST DX [BGP ALCOHOL HEPATITIS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BDMG(1)) Q 1_U_$$DATE^BDMS9B1($P(BDMG(1),U))_" Contraindication Alcohol Hepatitis " ;_$P(BDMG(1),U,2) ;_"]" ;_$$VAL^XBDIQ1(9000010.07,+$P(BDMG(1),U,4),.04)
Q ""
ACE(P,BDATE,EDATE) ;EP
NEW X,BDM,E,X,Y,%DT,BD,G
S X=P_"^LAST MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "1 Yes "_$$DATE^BDMS9B1($P(BDM(1),U))_" "_$P(BDM(1),U,3)
NEW D,%DT K %DT S X=BDATE,%DT="P" D ^%DT S D=Y
NEW V,I,%
K %DT S X=EDATE,%DT="P" D ^%DT S E=Y
S %=""
S I=9999999-E,I=I-1 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.S V=0 F S V=$O(^AUPNVMED("AA",P,I,V)) Q:V'=+V S G=$P(^AUPNVMED(V,0),U) I $P($G(^PSDRUG(G,0)),U,2)="CV800"!($P($G(^PSDRUG(G,0)),U,2)="CV805") S %=$P($P(^AUPNVSIT($P(^AUPNVMED(V,0),U,3),0),U),".")_U_G
I %]"" Q "1 Yes "_$$DATE^BDMS9B1($P(%,U,1))_" "_$P(^PSDRUG($P(%,U,2),0),U)
K %DT S %DT="P",X=EDATE D ^%DT S ED=Y
S BDM=$$PRESD^BDMDG18(P,$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0)),ED,186)
I BDM]"" Q BDM
;refusals
NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'T Q "2 No"
S (G,X)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMDG17(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" S G=""
Q "2 No"_$S(G:" - Not Medically Indicated",1:"")
;
;
ASPIRIN(P,BDATE,EDATE) ;EP
G ASPIRIN^BDMDG1D
;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
I '$G(P) Q ""
NEW STR,TNAME,X,Y,%DT,HO,TOTAL
S STR="",TNAME="",HO="",TOTAL=0
S X=$$INSULIN^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_2_U,HO=1
S X=$$SULF^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_4_U,HO=1
S X=$$SULFLIKE^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_10_U,HO=1
S X=$$MET^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_3_U,HO=1
S X=$$ACAR^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_9_U,HO=1
S X=$$TROG^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_8_U,HO=1
S X=$$GLP1^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_6_U,HO=1
S X=$$DPP4^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_5_U,HO=1
S X=$$AMYLIN^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_11_U,HO=1
S X=$$BROM^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_12_U,HO=1
S X=$$COLE^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_13_U,HO=1
S X=$$SGLT2^BDMDG12(P,BD,EDATE)
I X]"" S TOTAL=TOTAL+1,STR=STR_7_U,HO=1
I HO Q STR_"|||"_TOTAL
Q 1
;
DIETONLY(P,BD,EDATE) ;EP - diet and exercise for audit export
NEW STR,TNAME,X,Y,%DT
S STR="",TNAME=""
S X=$$INSULIN^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$SULF^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$SULFLIKE^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$MET^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$ACAR^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$TROG^BDMDG12(P,BD,EDATE)
I X]"" Q 2
;S X=$$INCR^BDMDG12(P,BD,EDATE)
;I X]"" Q 2
S X=$$DPP4^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$AMYLIN^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$GLP1^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$BROM^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$COLE^BDMDG12(P,BD,EDATE)
I X]"" Q 2
S X=$$SGLT2^BDMDG12(P,BD,EDATE)
I X]"" Q 2
Q 1
;
;
;
TYPE(P,R,EDATE) ;EP return type 1 or 2 for epi file
I '$G(P) Q ""
NEW TYPE S TYPE=""
I $G(R) S TYPE=$$CMSFDX^BDMDG13(P,R,"DX")
I TYPE="NIDDM" Q 2
I TYPE["TYPE II" Q 2
I TYPE="IDDM" Q 1
I TYPE="TYPE I" Q 1
I TYPE["2" Q 2
I TYPE["1" Q 1
S TYPE="" NEW X,I,C S X=$$PLDMDXS^BDMDG13(P)
F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"") S J=$P($$CODEN^BDMUTL(C,80),"~") I J>0,$$ICD^BDMUTL(J,"DM AUDIT TYPE II DXS",9) S TYPE=2
I TYPE]"" Q TYPE
F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"") S J=$P($$CODEN^BDMUTL(C,80),"~") I J>0,$$ICD^BDMUTL(J,"DM AUDIT TYPE I DXS",9) S TYPE=1
I TYPE]"" Q TYPE
S X=$$LASTDMDX^BDMDG13(P,EDATE)
I X[2 Q 2
I X[1 Q 1
Q ""
;
DURDM(P,R,EDATE) ;EP
I '$G(P) Q ""
NEW Y S Y=$$DODX(P,R,"I")
I Y="" Q ""
I 'Y Q ""
I Y>EDATE Q ""
Q $P(($$FMDIFF^XLFDT(EDATE,Y,1)\365.25),".")
;
DODX(P,R,F) ;EP - date of dx for export file
I $G(F)="" S F="E"
NEW DATE,EARLY
S DATE="",EARLY=9999999
I $G(R) S DATE=$$CMSFDX^BDMDG13(P,R,"ID")
I DATE S EARLY=DATE
S DATE=$$PLDMDOO^BDMDG13(P,"I")
I DATE,DATE<EARLY S EARLY=DATE
I EARLY=9999999 S EARLY=""
Q $S(F="I":$$DI(EARLY),1:$$D(EARLY))
;
D(D) ;
I D="" Q ""
Q $S($E(D,4,5)="00":"07",1:$E(D,4,5))_"/"_$S($E(D,6,7)="00":"01",1:$E(D,6,7))_"/"_(1700+$E(D,1,3))
;
DI(D) ;EP
I D="" Q ""
Q $E(D,1,3)_$S($E(D,4,5)="00":"07",1:$E(D,4,5))_$S($E(D,6,7)="00":"01",1:$E(D,6,7))
BDMDG16 ; IHS/CMI/LAB - 2019 DIABETES AUDIT 02 Feb 2014 2:41 PM ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
TBCODE(P,EDATE,R) ;EP
+1 NEW BDMJ,BDMI,X,BDMR
+2 SET BDMJ=""
+3 SET BDMR=$$PPD^BDMDG18(P,EDATE)
+4 IF $EXTRACT($PIECE(BDMR,"||",2))=1
Begin DoDot:1
+5 IF $$TBTX^BDMDG12(P)["TX COMPLETE"
SET BDMJ=1
QUIT
+6 SET BDMJ=2
+7 QUIT
End DoDot:1
QUIT BDMJ
+8 IF $EXTRACT($PIECE(BDMR,"||",2))=2
SET BDMJ=4
Begin DoDot:1
+9 IF $$DODX(P,R,"I")=""
SET BDMJ=6
QUIT
+10 SET D=$$DODX(P,R,"I")
SET E=$$PPD^BDMDG18(P,EDATE,"I")
SET BDMJ=$SELECT(D>E:4,1:3)
+11 QUIT
End DoDot:1
QUIT BDMJ
+12 IF $EXTRACT(BDMR)=4
SET BDMJ=5
+13 IF $EXTRACT(BDMR)=3
SET BDMJ=5
+14 IF $EXTRACT($PIECE(BDMR,"||",2))=3
SET BDMJ=5
+15 IF $EXTRACT($PIECE(BDMR,"||",2))=4
SET BDMJ=5
+16 QUIT BDMJ
+17 ;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated/treatment incomplete or unknown treatment
3 ;;PPD -, placed on or after date of DM dx
4 ;;PPD -, placed before date of DM dx
5 ;;PPD Status unknown
6 ;;PPD -, date of DX or PPD date unknown
7 ;;PPD Refused
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^BDMDG13(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C,Z
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C<2
QUIT ""
+5 SET Z=C
+6 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/")+C
+7 QUIT C\Z
DIAMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^BDMDG13(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C,Z
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C<2
QUIT ""
+5 SET Z=C
+6 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/",2)+C
+7 QUIT C\Z
PPDDATE(P,EDATE) ;EP
+1 NEW X
SET X=$$LASTNP^BDMDG18(P,EDATE)
+2 QUIT X
STATIN(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E,BDMALL,ED,BD
+2 SET X=P_"^LAST MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 ;Q "1 Yes "_$$DATE^BDMS9B1($P(BDM(1),U,1))_" "_$P(BDM(1),U,2)
IF $DATA(BDM(1))
SET BDMALL($PIECE(BDM(1),U,1))=BDM(1)
+4 NEW BDMSMEDS
+5 KILL BDMSMEDS
+6 KILL %DT
SET %DT="P"
SET X=BDATE
DO ^%DT
SET BD=Y
+7 DO GETMEDS^BDMSMU1(P,BD,EDATE,"BGP PQA STATIN MEDS","BGP PQA STATIN NDC",,,.BDMSMEDS)
+8 SET (X,C)=0
FOR
SET X=$ORDER(BDMSMEDS(X))
IF X'=+X
QUIT
SET C=X
+9 ;Q "1 Yes "_$$DATE^BDMS9B1($P(BDMSMEDS(1),U,1))_" "_$P(BDMSMEDS(1),U,2)
IF C
SET BDMALL($PIECE(BDMSMEDS(C),U,1))=BDMSMEDS(C)
+10 SET (X,C)=0
FOR
SET X=$ORDER(BDMALL(X))
IF X'=+X
QUIT
SET C=X
+11 IF C
QUIT "1 Yes "_$$DATE^BDMS9B1($PIECE(BDMALL(C),U,1))_" "_$PIECE(BDMALL(C),U,2)
+12 ;
+13 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+14 SET BDM=$$PRESD^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT STATIN DRUGS",0)),ED,186)
+15 IF BDM]""
QUIT BDM
+16 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+17 SET BDM=$$PRESD^BDMDG18(P,$ORDER(^ATXAX("B","BGP PQA STATIN MEDS",0)),ED,186)
+18 IF BDM]""
QUIT BDM
+19 ;check allergy/intolerence
+20 SET E=$$STATALG(P,$$DOB^AUPNPAT(P),EDATE,BDATE)
+21 IF E
QUIT "3 "_$PIECE(E,U,2)
+22 SET E=$$STATCON(P,BDATE,EDATE)
+23 IF E
QUIT "3 "_$PIECE(E,U,2)
+24 QUIT "2 No"
+25 ;
STATALG(P,BDATE,EDATE,RPB) ;EP
+1 NEW BDMG,BDMY,Y,X,N,Z,BDMC
+2 SET BDMC=""
+3 KILL BDMG,BDMY
SET Y="BDMG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BDMG(X),U,4)
Begin DoDot:1
+5 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+6 IF N["STATIN"!(N["STATINS")
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(BDMG(X),U))_" ADR POV "_$PIECE(BDMG(X),U,2)
+7 SET T="BGP ADV EFF CARDIOVASC NEC"
+8 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $$ICD^BDMUTL(Z,T,9)
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(BDMG(X),U))_" ADR POV ["_$PIECE(BDMG(X),U,2)_" + "_$PIECE($$ICDDX^BDMUTL(Z),U,2)_"] "_N
QUIT
+9 SET Z=$PIECE(^AUPNVPOV(Y,0),U,18)
IF Z]""
IF $$ICD^BDMUTL(Z,T,9)
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(BDMG(X),U))_" ADR POV ["_$PIECE(BDMG(X),U,2)_" + "_$PIECE($$ICDDX^BDMUTL(Z),U,2)_"] "_N
QUIT
+10 SET Z=$PIECE(^AUPNVPOV(Y,0),U,19)
IF Z]""
IF $$ICD^BDMUTL(Z,T,9)
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(BDMG(X),U))_" ADR POV ["_$PIECE(BDMG(X),U,2)_" + "_$PIECE($$ICDDX^BDMUTL(Z),U,2)_"] "_N
QUIT
+11 QUIT
End DoDot:1
+12 IF BDMC
QUIT BDMC
+13 KILL BDMG
SET BDMC=0
SET Y="BDMG("
SET X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+14 SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BDMG(X),U,4)
Begin DoDot:1
+15 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+16 ;_"]"
IF N["STATIN"!(N["STATINS")
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(BDMG(X),U))_" ADR POV "_$PIECE(BDMG(X),U,2)
End DoDot:1
+17 IF BDMC
QUIT BDMC
+18 ;PL
+19 SET BDMC=0
+20 SET T=""
SET T="BGP ASA ALLERGY 995.0-995.3"
+21 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+22 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^BDMUTL(I),U,2)
+23 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+24 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+25 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+26 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+27 ;_"]"
IF $$ICD^BDMUTL(I,"BGP HX DRUG ALLERGY NEC",9)!($$ICD^BDMUTL(I,T,9))
IF N["STATIN"!(N["STATINS")
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,8))_" ADR Problem List "_Y
+28 QUIT
End DoDot:1
+29 IF BDMC
QUIT BDMC
+30 ;ART
+31 SET BDMC=0
+32 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+33 IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>EDATE
QUIT
+34 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+35 IF N["STATIN"
SET BDMC=1_U_$$DATE^BDMS9B1($PIECE(^GMR(120.8,X,0),U,4))_" ADR Allergy Tracking "_N
End DoDot:1
+36 IF BDMC
QUIT BDMC
+37 KILL BDMG
SET Y="BDMG("
SET X=P_"^LAST DX [BGP MYOPATHY/MYALGIA;DURING "_$$FMTE^XLFDT(RPB)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+38 ;_"]"
IF $DATA(BDMG(1))
QUIT 1_U_$$DATE^BDMS9B1($PIECE(BDMG(1),U))_" ADR POV "_$PIECE(BDMG(1),U,2)
+39 SET BDMG=""
+40 SET T=$ORDER(^ATXAX("B","BGP CREATINE KINASE LOINC",0))
+41 SET BDMLT=$ORDER(^ATXLAB("B","BGP CREATINE KINASE TAX",0))
+42 SET B=9999999-RPB
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BDMG)
QUIT
Begin DoDot:1
+43 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+44 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+45 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+46 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
IF $$RESCK(X)
SET BDMG=1_U_$$DATE^BDMS9B1((9999999-D))_" ADR creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+47 IF 'T
QUIT
+48 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+49 IF '$$LOINC^BDMDG1C(J,T)
QUIT
+50 IF $$RESCK(X)
SET BDMG=1_U_$$DATE^BDMS9B1((9999999-D))_" ADR creat kinase of "_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+51 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+52 IF BDMG
QUIT BDMG
+53 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+54 SET BDMLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+55 SET T2=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+56 SET BDMLT2=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+57 SET B=9999999-$$FMADD^XLFDT(EDATE,-365)
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BDMG)
QUIT
Begin DoDot:1
+58 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+59 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+60 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+61 IF BDMLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BDMC=BDMC+1
SET BDMC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+62 IF BDMLT2
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BDMLT2,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BDMC=BDMC+1
SET BDMC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+63 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+64 IF '$$LOINC^BDMDG1C(J,T)
IF '$$LOINC^BDMDG1C(J,T2)
+65 SET BDMC=BDMC+1
SET BDMC((9999999-D))=X_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_$PIECE($GET(^AUPNVLAB(X,11)),U,5)
QUIT
+66 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+67 SET BDMG=""
+68 SET X=0
FOR
SET X=$ORDER(BDMC(X))
IF X'=+X!(BDMG)
QUIT
Begin DoDot:1
+69 IF '$$RESAL(BDMC(X))
QUIT
+70 SET Y=$ORDER(BDMC(X))
+71 IF Y=""
QUIT
+72 IF $$RESAL(BDMC(Y))
SET BDMG=1_U_" ADR AST/ALT"
QUIT
+73 QUIT
End DoDot:1
+74 IF BDMG
QUIT BDMG
+75 QUIT 0
+76 ;
RESAL(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(Y,U,2)
SET ULN=$PIECE(Y,U,3)
+3 IF ULN=""
QUIT ""
+4 IF V>(ULN*3)
QUIT 1
+5 QUIT ""
RESCK(Y) ;
+1 NEW V,ULN
+2 SET V=+$PIECE(^AUPNVLAB(X,0),U,4)
+3 IF V>10000
QUIT 1
+4 SET ULN=$PIECE($GET(^AUPNVLAB(X,11)),U,5)
+5 ;no upper limit
IF ULN=""
QUIT 0
+6 IF V>(ULN*10)
QUIT 1
+7 QUIT 0
STATCON(P,BDATE,EDATE) ;EP does patient have an STATIN Contra
+1 NEW ED,BD,BDMG,BDMC,X,Y,Z,N,E
+2 ;
+3 ;pregnant
+4 SET X=$$PREG^BDMDG1B(P,BDATE,EDATE,1,1)
IF X
QUIT 1_U_"Contraindication pregnant"
+5 ;nmi
+6 SET BDMG=""
+7 SET T=$ORDER(^ATXAX("B","BGP PQA STATIN MEDS",0))
+8 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,50,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 ;not an STATI
IF '$DATA(^ATXAX(T,21,"B",X))
QUIT
+10 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+11 SET Y=9999999-D
IF Y<BDATE
QUIT
+12 IF Y>EDATE
QUIT
+13 SET N=0
FOR
SET N=$ORDER(^AUPNPREF("AA",P,50,X,D,N))
IF N'=+N
QUIT
Begin DoDot:3
+14 IF $PIECE($GET(^AUPNPREF(N,0)),U,7)'="N"
QUIT
+15 ;_" "_" "_$$VAL^XBDIQ1(9000022,X,1101)
SET BDMG=1_U_$$DATE^BDMS9B1($PIECE(^AUPNPREF(N,0),U,3))_" Contraindication NMI "_$$VAL^XBDIQ1(9000022,N,.04)
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF BDMG
QUIT BDMG
+19 ;breastfeeding
+20 KILL BDMG
SET Y="BDMG("
SET X=P_"^LAST DX [BGP BREASTFEEDING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+21 ;_"]" ;_$$VAL^XBDIQ1(9000010.07,+$P(BDMG(1),U,4),.04)
IF $DATA(BDMG(1))
QUIT 1_U_$$DATE^BDMS9B1($PIECE(BDMG(1),U))_" Contraindication Breastfeeding "_$PIECE(BDMG(1),U,2)
+22 ;now check education
+23 KILL BDMG
+24 SET Y="BDMG("
+25 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+26 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+27 SET T=$PIECE(^AUPNVPED(+$PIECE(BDMG(X),U,4),0),U)
+28 IF 'T
QUIT
+29 IF '$DATA(^AUTTEDT(T,0))
QUIT
+30 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+31 IF T="BF-BC"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+32 IF T="BF-BP"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+33 IF T="BF-CS"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+34 IF T="BF-EQ"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+35 IF T="BF-FU"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+36 IF T="BF-HC"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+37 IF T="BF-ON"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+38 IF T="BF-M"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+39 IF T="BF-MK"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+40 IF T="BF-N"
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
+41 IF $PIECE(T,"-",1)]""
IF $$SNOMED^BDMUTL(2019,"BREASTFEEDING PATIENT ED",$PIECE(T,"-",1))
SET %=T_U_$PIECE(BDMG(X),U)
QUIT
End DoDot:1
+42 ;_$P(%,U,1)
IF %]""
QUIT 1_U_$$DATE^BDMS9B1($PIECE(%,U,2))_" Contraindication Breastfeeding "
+43 ;NOW CHECK ALCOHOL HEPATITIS
+44 KILL BDMG
SET Y="BDMG("
SET X=P_"^LAST DX [BGP ALCOHOL HEPATITIS DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+45 ;_$P(BDMG(1),U,2) ;_"]" ;_$$VAL^XBDIQ1(9000010.07,+$P(BDMG(1),U,4),.04)
IF $DATA(BDMG(1))
QUIT 1_U_$$DATE^BDMS9B1($PIECE(BDMG(1),U))_" Contraindication Alcohol Hepatitis "
+46 QUIT ""
ACE(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E,X,Y,%DT,BD,G
+2 SET X=P_"^LAST MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "1 Yes "_$$DATE^BDMS9B1($PIECE(BDM(1),U))_" "_$PIECE(BDM(1),U,3)
+4 NEW D,%DT
KILL %DT
SET X=BDATE
SET %DT="P"
DO ^%DT
SET D=Y
+5 NEW V,I,%
+6 KILL %DT
SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+7 SET %=""
+8 SET I=9999999-E
SET I=I-1
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+9 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $PIECE($GET(^PSDRUG(G,0)),U,2)="CV800"!($PIECE($GET(^PSDRUG(G,0)),U,2)="CV805")
SET %=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(V,0),U,3),0),U),".")_U_G
End DoDot:1
+10 IF %]""
QUIT "1 Yes "_$$DATE^BDMS9B1($PIECE(%,U,1))_" "_$PIECE(^PSDRUG($PIECE(%,U,2),0),U)
+11 KILL %DT
SET %DT="P"
SET X=EDATE
DO ^%DT
SET ED=Y
+12 SET BDM=$$PRESD^BDMDG18(P,$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0)),ED,186)
+13 IF BDM]""
QUIT BDM
+14 ;refusals
+15 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+16 IF 'T
QUIT "2 No"
+17 SET (G,X)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMDG17(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+18 IF G
IF $PIECE(G,U,2)'="N"
SET G=""
+19 QUIT "2 No"_$SELECT(G:" - Not Medically Indicated",1:"")
+20 ;
+21 ;
ASPIRIN(P,BDATE,EDATE) ;EP
+1 GOTO ASPIRIN^BDMDG1D
+2 ;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
+1 IF '$GET(P)
QUIT ""
+2 NEW STR,TNAME,X,Y,%DT,HO,TOTAL
+3 SET STR=""
SET TNAME=""
SET HO=""
SET TOTAL=0
+4 SET X=$$INSULIN^BDMDG12(P,BD,EDATE)
+5 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_2_U
SET HO=1
+6 SET X=$$SULF^BDMDG12(P,BD,EDATE)
+7 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_4_U
SET HO=1
+8 SET X=$$SULFLIKE^BDMDG12(P,BD,EDATE)
+9 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_10_U
SET HO=1
+10 SET X=$$MET^BDMDG12(P,BD,EDATE)
+11 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_3_U
SET HO=1
+12 SET X=$$ACAR^BDMDG12(P,BD,EDATE)
+13 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_9_U
SET HO=1
+14 SET X=$$TROG^BDMDG12(P,BD,EDATE)
+15 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_8_U
SET HO=1
+16 SET X=$$GLP1^BDMDG12(P,BD,EDATE)
+17 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_6_U
SET HO=1
+18 SET X=$$DPP4^BDMDG12(P,BD,EDATE)
+19 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_5_U
SET HO=1
+20 SET X=$$AMYLIN^BDMDG12(P,BD,EDATE)
+21 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_11_U
SET HO=1
+22 SET X=$$BROM^BDMDG12(P,BD,EDATE)
+23 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_12_U
SET HO=1
+24 SET X=$$COLE^BDMDG12(P,BD,EDATE)
+25 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_13_U
SET HO=1
+26 SET X=$$SGLT2^BDMDG12(P,BD,EDATE)
+27 IF X]""
SET TOTAL=TOTAL+1
SET STR=STR_7_U
SET HO=1
+28 IF HO
QUIT STR_"|||"_TOTAL
+29 QUIT 1
+30 ;
DIETONLY(P,BD,EDATE) ;EP - diet and exercise for audit export
+1 NEW STR,TNAME,X,Y,%DT
+2 SET STR=""
SET TNAME=""
+3 SET X=$$INSULIN^BDMDG12(P,BD,EDATE)
+4 IF X]""
QUIT 2
+5 SET X=$$SULF^BDMDG12(P,BD,EDATE)
+6 IF X]""
QUIT 2
+7 SET X=$$SULFLIKE^BDMDG12(P,BD,EDATE)
+8 IF X]""
QUIT 2
+9 SET X=$$MET^BDMDG12(P,BD,EDATE)
+10 IF X]""
QUIT 2
+11 SET X=$$ACAR^BDMDG12(P,BD,EDATE)
+12 IF X]""
QUIT 2
+13 SET X=$$TROG^BDMDG12(P,BD,EDATE)
+14 IF X]""
QUIT 2
+15 ;S X=$$INCR^BDMDG12(P,BD,EDATE)
+16 ;I X]"" Q 2
+17 SET X=$$DPP4^BDMDG12(P,BD,EDATE)
+18 IF X]""
QUIT 2
+19 SET X=$$AMYLIN^BDMDG12(P,BD,EDATE)
+20 IF X]""
QUIT 2
+21 SET X=$$GLP1^BDMDG12(P,BD,EDATE)
+22 IF X]""
QUIT 2
+23 SET X=$$BROM^BDMDG12(P,BD,EDATE)
+24 IF X]""
QUIT 2
+25 SET X=$$COLE^BDMDG12(P,BD,EDATE)
+26 IF X]""
QUIT 2
+27 SET X=$$SGLT2^BDMDG12(P,BD,EDATE)
+28 IF X]""
QUIT 2
+29 QUIT 1
+30 ;
+31 ;
+32 ;
TYPE(P,R,EDATE) ;EP return type 1 or 2 for epi file
+1 IF '$GET(P)
QUIT ""
+2 NEW TYPE
SET TYPE=""
+3 IF $GET(R)
SET TYPE=$$CMSFDX^BDMDG13(P,R,"DX")
+4 IF TYPE="NIDDM"
QUIT 2
+5 IF TYPE["TYPE II"
QUIT 2
+6 IF TYPE="IDDM"
QUIT 1
+7 IF TYPE="TYPE I"
QUIT 1
+8 IF TYPE["2"
QUIT 2
+9 IF TYPE["1"
QUIT 1
+10 SET TYPE=""
NEW X,I,C
SET X=$$PLDMDXS^BDMDG13(P)
+11 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(TYPE]"")
QUIT
SET J=$PIECE($$CODEN^BDMUTL(C,80),"~")
IF J>0
IF $$ICD^BDMUTL(J,"DM AUDIT TYPE II DXS",9)
SET TYPE=2
+12 IF TYPE]""
QUIT TYPE
+13 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(TYPE]"")
QUIT
SET J=$PIECE($$CODEN^BDMUTL(C,80),"~")
IF J>0
IF $$ICD^BDMUTL(J,"DM AUDIT TYPE I DXS",9)
SET TYPE=1
+14 IF TYPE]""
QUIT TYPE
+15 SET X=$$LASTDMDX^BDMDG13(P,EDATE)
+16 IF X[2
QUIT 2
+17 IF X[1
QUIT 1
+18 QUIT ""
+19 ;
DURDM(P,R,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW Y
SET Y=$$DODX(P,R,"I")
+3 IF Y=""
QUIT ""
+4 IF 'Y
QUIT ""
+5 IF Y>EDATE
QUIT ""
+6 QUIT $PIECE(($$FMDIFF^XLFDT(EDATE,Y,1)\365.25),".")
+7 ;
DODX(P,R,F) ;EP - date of dx for export file
+1 IF $GET(F)=""
SET F="E"
+2 NEW DATE,EARLY
+3 SET DATE=""
SET EARLY=9999999
+4 IF $GET(R)
SET DATE=$$CMSFDX^BDMDG13(P,R,"ID")
+5 IF DATE
SET EARLY=DATE
+6 SET DATE=$$PLDMDOO^BDMDG13(P,"I")
+7 IF DATE
IF DATE<EARLY
SET EARLY=DATE
+8 IF EARLY=9999999
SET EARLY=""
+9 QUIT $SELECT(F="I":$$DI(EARLY),1:$$D(EARLY))
+10 ;
D(D) ;
+1 IF D=""
QUIT ""
+2 QUIT $SELECT($EXTRACT(D,4,5)="00":"07",1:$EXTRACT(D,4,5))_"/"_$SELECT($EXTRACT(D,6,7)="00":"01",1:$EXTRACT(D,6,7))_"/"_(1700+$EXTRACT(D,1,3))
+3 ;
DI(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,1,3)_$SELECT($EXTRACT(D,4,5)="00":"07",1:$EXTRACT(D,4,5))_$SELECT($EXTRACT(D,6,7)="00":"01",1:$EXTRACT(D,6,7))
