BDMD416 ; IHS/CMI/LAB - 2012 DIABETES AUDIT ; 02 Feb 2012 2:41 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
;
;
TBCODE(P,EDATE,R) ;EP
NEW BDMJ,BDMI,X,BDMR
S BDMJ=""
;return computed TB Status Code
S X=$$TBTX^BDMD412(P)
I $E(X)=1 Q 1
I $E(X) Q 2
S BDMR=$$PPD^BDMD418(P,EDATE)
I $E($P(BDMR,"||",2))=1 D Q BDMJ
.I $$TBTX^BDMD412(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^BDMD418(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=7
I $E($P(BDMR,"||",2))=3 S BDMJ=7
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^BDMD413(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^BDMD413(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^BDMD418(P,EDATE)
Q X
XLIPID(P,BDATE,EDATE) ;EP
NEW X,BDM,E,G,S,O
S (S,O,G)="",X=P_"^MEDS [DM AUDIT LIPID LOWERING DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S O=1
K BDM
S X=P_"^MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S S=1
I S,O Q "3 Both"
I S Q "1 Statin"
I O Q "2 Other"
;refusal
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT LIPID LOWERING DRUGS",0))
I 'T G LIPIDN
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G Q "5 Refused or Adverse Rxn"
LIPIDN ;
NEW T S T=$O(^ATXAX("B","DM AUDIT STATIN DRUGS",0))
I 'T G LIPIDA
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G Q "5 Refused or Adverse Rxn"
LIPIDA ;
;check patient allergies file for any with va drug class CV350
S X=EDATE,%DT="P" D ^%DT S B=Y
S X=0,G="" 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),".")>B ;entered after discharge date
.S C=$O(^PS(50.605,"B","CV350",0))
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="5 Refused/Adverse Rxn (Allergy Tracking)"
I G]"" Q G
Q "4 None"
;
REFMEDL(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 STATIN DRUGS",0))
S T1=$O(^ATXAX("B","DM AUDIT FIBRATE DRUGS",0))
S T2=$O(^ATXAX("B","DM AUDIT NIACIN DRUGS",0))
S T3=$O(^ATXAX("B","DM AUDIT BILE ACID DRUGS",0))
S T4=$O(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0))
S T5=$O(^ATXAX("B","DM AUDIT EZETIMIBE DRUGS",0))
S T6=$O(^ATXAX("B","DM AUDIT FISH OIL DRUGS",0))
S T7=$O(^ATXAX("B","DM AUDIT LOVAZA DRUGS",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="",A=""
S I=0 F S I=$O(^AUPNPREF("AA",BDMPD,50,I)) Q:I'=+I!(A) 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
.;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 $S(A:2,1:1)
STATIN(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
FIBRATE(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT FIBRATE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
NIACIN(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT NIACIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
BILE(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT BILE ACID DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
EZET(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT EZETIMIBE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
FISHOIL(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT FISH OIL DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
LOVAZA(P,BDATE,EDATE) ;EP
NEW X,BDM,E
S X=P_"^LAST MEDS [DM AUDIT LOVAZA DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "X"
Q ""
;
ACE(P,BDATE,EDATE) ;EP
NEW X,BDM,E,X,Y,%DT,BD,G
S X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "1 Yes "_$P(BDM(1),U,3)_" "_$$FMTE^XLFDT($P(BDM(1),U))
;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
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 "_$P(^PSDRUG($P(%,U,2),0),U)_" "_$$FMTE^XLFDT($P(%,U,1))
;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^BDMD417(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "3 Refused or adverse reaction"
Q "2 No"_$S(G:" - Not Medically Indicated",1:"")
;
SELF(P,BDATE,EDATE) ;EP
NEW T,BDM,E,X,%DT,Y,ED,BD
S X=EDATE,%DT="P" D ^%DT S ED=Y
S X=BDATE,%DT="P" D ^%DT S BD=Y
S E=$$LASTHF^BDMD419(P,"DIABETES SELF MONITORING",BD,ED,"F")
I E]"" Q $S(E["YES":"Yes",E["NO":"No",E["REFUSED":"Refused",1:"")
S X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "Yes"
Q "No"
SDM(P,BDATE,EDATE) ;EP
NEW T,BDM,E,X,%DT,Y,ED,BD
S X=EDATE,%DT="P" D ^%DT S ED=Y
S X=BDATE,%DT="P" D ^%DT S BD=Y
S E=$$LASTHF^BDMD419(P,"STAGED DIABETES MANAGEMENT",BD,ED)
I E Q "Yes"
S T=$O(^ATXAX("B","DM AUDIT SDM PROVIDERS",0))
I 'T Q ""
S %=P_"^ALL DX [SURVEILLANCE DIABETES;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
;check to see if one of the providers was the primary prov
NEW X,V,G,P,P1 S (G,X)=0 F S X=$O(BDM(X)) Q:X'=+X!(G) S V=$P(BDM(X),U,5) D
.S P=0 F S P=$O(^AUPNVPRV("AD",V,P)) Q:P'=+P!(G) S P1=$P(^AUPNVPRV(P,0),U) I $D(^ATXAX(T,21,"B",P1)) S G=1
.Q
Q $S(G:"Yes",1:"No")
;
ASPIRIN(P,BDATE,EDATE) ;EP
G ASPIRIN^BDMD418
;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
I '$G(P) Q ""
NEW STR,TNAME,X,Y,%DT,HO
S STR="",TNAME="",HO=""
S X=$$INSULIN^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_2_U,HO=1
S X=$$SULF^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_3_U,HO=1
S X=$$SULFLIKE^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_4_U,HO=1
S X=$$MET^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_5_U,HO=1
S X=$$ACAR^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_6_U,HO=1
S X=$$TROG^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_7_U,HO=1
S X=$$INCR^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_8_U,HO=1
S X=$$DPP4^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_9_U,HO=1
S X=$$AMYLIN^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_10_U,HO=1
S X=$$GLP1^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_11_U,HO=1
S X=$$BROM^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_12_U,HO=1
S X=$$COLE^BDMD412(P,BD,EDATE)
I X]"" S STR=STR_13_U,HO=1
I HO Q STR
S X=$$REFMED^BDMD412(P,BD,EDATE)
I X Q "R"
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^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$SULF^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$SULFLIKE^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$MET^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$ACAR^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$TROG^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$INCR^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$DPP4^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$AMYLIN^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$GLP1^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$BROM^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$COLE^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$REFMED^BDMD412(P,BD,EDATE)
I X Q 2
Q 1
;
REFMEDE(P,BD,EDATE) ;EP - diet and exercise for audit export
NEW STR,TNAME,X,Y,%DT
S STR="",TNAME=""
S X=$$INSULIN^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$SULF^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$SULFLIKE^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$MET^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$ACAR^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$TROG^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$INCR^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$DPP4^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$AMYLIN^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$GLP1^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$BROM^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$COLE^BDMD412(P,BD,EDATE)
I X]"" Q 2
S X=$$REFMED^BDMD412(P,BD,EDATE)
I X Q 1
Q 2
;
REFMEDLE(P,BD,EDATE) ;EP - ANY REFUSAL?
NEW STR,TNAME,X,Y,%DT
S STR="",TNAME=""
S X=$$STATIN^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$FIBRATE^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$NIACIN^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$BILE^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$EZET^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$FISHOIL^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$LOVAZA^BDMD416(P,BD,EDATE)
I X]"" Q 2
S X=$$REFMEDL^BDMD416(P,BD,EDATE)
I X Q 1
Q 2
;
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^BDMD413(P,R,"DX")
I TYPE="NIDDM" Q 2
I TYPE["TYPE II" Q 2
I TYPE="IDDM" Q 1
I TYPE["2" Q 2
I TYPE["1" Q 1
S TYPE="" NEW X,I,C S X=$$PLDMDXS^BDMD413(P)
F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"") I $E(C,6)=0!($E(C,6)=2) S TYPE=2
I TYPE]"" Q TYPE
F I=1:1 S C=$P(X,";",I) Q:C=""!(TYPE]"") I $E(C,6)=1!($E(C,6)=3) S TYPE=1
I TYPE]"" Q TYPE
S X=$$LASTDMDX^BDMD413(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 epi file
I $G(F)="" S F="E"
NEW DATE,EARLY
S DATE="",EARLY=9999999
I $G(R) S DATE=$$CMSFDX^BDMD413(P,R,"ID")
I DATE S EARLY=DATE
S DATE=$$PLDMDOO^BDMD413(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))
BDMD416 ; IHS/CMI/LAB - 2012 DIABETES AUDIT ; 02 Feb 2012 2:41 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**5**;JUN 14, 2007
+2 ;
+3 ;
TBCODE(P,EDATE,R) ;EP
+1 NEW BDMJ,BDMI,X,BDMR
+2 SET BDMJ=""
+3 ;return computed TB Status Code
+4 SET X=$$TBTX^BDMD412(P)
+5 IF $EXTRACT(X)=1
QUIT 1
+6 IF $EXTRACT(X)
QUIT 2
+7 SET BDMR=$$PPD^BDMD418(P,EDATE)
+8 IF $EXTRACT($PIECE(BDMR,"||",2))=1
Begin DoDot:1
+9 IF $$TBTX^BDMD412(P)["TX COMPLETE"
SET BDMJ=1
QUIT
+10 SET BDMJ=2
+11 QUIT
End DoDot:1
QUIT BDMJ
+12 IF $EXTRACT($PIECE(BDMR,"||",2))=2
SET BDMJ=4
Begin DoDot:1
+13 IF $$DODX(P,R,"I")=""
SET BDMJ=6
QUIT
+14 SET D=$$DODX(P,R,"I")
SET E=$$PPD^BDMD418(P,EDATE,"I")
SET BDMJ=$SELECT(D>E:4,1:3)
+15 QUIT
End DoDot:1
QUIT BDMJ
+16 IF $EXTRACT(BDMR)=4
SET BDMJ=5
+17 IF $EXTRACT(BDMR)=3
SET BDMJ=7
+18 IF $EXTRACT($PIECE(BDMR,"||",2))=3
SET BDMJ=7
+19 IF $EXTRACT($PIECE(BDMR,"||",2))=4
SET BDMJ=5
+20 QUIT BDMJ
+21 ;;
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^BDMD413(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^BDMD413(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^BDMD418(P,EDATE)
+2 QUIT X
XLIPID(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E,G,S,O
+2 SET (S,O,G)=""
SET X=P_"^MEDS [DM AUDIT LIPID LOWERING DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
SET O=1
+4 KILL BDM
+5 SET X=P_"^MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 IF $DATA(BDM(1))
SET S=1
+7 IF S
IF O
QUIT "3 Both"
+8 IF S
QUIT "1 Statin"
+9 IF O
QUIT "2 Other"
+10 ;refusal
+11 SET G=0
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT LIPID LOWERING DRUGS",0))
+13 IF 'T
GOTO LIPIDN
+14 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD417(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 IF G
QUIT "5 Refused or Adverse Rxn"
LIPIDN ;
+1 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT STATIN DRUGS",0))
+2 IF 'T
GOTO LIPIDA
+3 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD417(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+4 IF G
QUIT "5 Refused or Adverse Rxn"
LIPIDA ;
+1 ;check patient allergies file for any with va drug class CV350
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET B=Y
+3 SET X=0
SET G=""
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;entered after discharge date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>B
QUIT
+5 SET C=$ORDER(^PS(50.605,"B","CV350",0))
+6 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+7 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="5 Refused/Adverse Rxn (Allergy Tracking)"
End DoDot:1
+8 IF G]""
QUIT G
+9 QUIT "4 None"
+10 ;
REFMEDL(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 STATIN DRUGS",0))
+3 SET T1=$ORDER(^ATXAX("B","DM AUDIT FIBRATE DRUGS",0))
+4 SET T2=$ORDER(^ATXAX("B","DM AUDIT NIACIN DRUGS",0))
+5 SET T3=$ORDER(^ATXAX("B","DM AUDIT BILE ACID DRUGS",0))
+6 SET T4=$ORDER(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0))
+7 SET T5=$ORDER(^ATXAX("B","DM AUDIT EZETIMIBE DRUGS",0))
+8 SET T6=$ORDER(^ATXAX("B","DM AUDIT FISH OIL DRUGS",0))
+9 SET T7=$ORDER(^ATXAX("B","DM AUDIT LOVAZA DRUGS",0))
+10 SET G=0
+11 NEW %DT
SET X=BDATE
SET %DT="P"
DO ^%DT
SET B=Y
+12 SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+13 SET G=""
SET A=""
+14 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",BDMPD,50,I))
IF I'=+I!(A)
QUIT
Begin DoDot:1
+15 SET A=0
+16 IF T
IF $DATA(^ATXAX(T,21,"B",I))
SET A=1
+17 IF T1
IF $DATA(^ATXAX(T1,21,"B",I))
SET A=1
+18 IF T2
IF $DATA(^ATXAX(T2,21,"B",I))
SET A=1
+19 IF T3
IF $DATA(^ATXAX(T3,21,"B",I))
SET A=1
+20 IF T4
IF $DATA(^ATXAX(T4,21,"B",I))
SET A=1
+21 IF T5
IF $DATA(^ATXAX(T5,21,"B",I))
SET A=1
+22 IF T6
IF $DATA(^ATXAX(T6,21,"B",I))
SET A=1
+23 IF T7
IF $DATA(^ATXAX(T7,21,"B",I))
SET A=1
+24 ;Q:'A
+25 ;S X=0 F S X=$O(^AUPNPREF("AA",BDMPD,50,I,X)) Q:X'=+X!(G) D
+26 ;.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
End DoDot:1
+27 QUIT $SELECT(A:2,1:1)
STATIN(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT STATIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
FIBRATE(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT FIBRATE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
NIACIN(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT NIACIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
BILE(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT BILE ACID DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
EZET(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT EZETIMIBE DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
FISHOIL(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT FISH OIL DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
LOVAZA(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E
+2 SET X=P_"^LAST MEDS [DM AUDIT LOVAZA DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "X"
+4 QUIT ""
+5 ;
ACE(P,BDATE,EDATE) ;EP
+1 NEW X,BDM,E,X,Y,%DT,BD,G
+2 SET X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "1 Yes "_$PIECE(BDM(1),U,3)_" "_$$FMTE^XLFDT($PIECE(BDM(1),U))
+4 ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
+5 NEW D,%DT
KILL %DT
SET X=BDATE
SET %DT="P"
DO ^%DT
SET D=Y
+6 NEW V,I,%
+7 KILL %DT
SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET %=""
+9 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
+10 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
+11 IF %]""
QUIT "1 Yes "_$PIECE(^PSDRUG($PIECE(%,U,2),0),U)_" "_$$FMTE^XLFDT($PIECE(%,U,1))
+12 ;refusals
+13 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+14 IF 'T
QUIT "2 No"
+15 SET (G,X)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD417(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+16 IF G
IF $PIECE(G,U,2)'="N"
QUIT "3 Refused or adverse reaction"
+17 QUIT "2 No"_$SELECT(G:" - Not Medically Indicated",1:"")
+18 ;
SELF(P,BDATE,EDATE) ;EP
+1 NEW T,BDM,E,X,%DT,Y,ED,BD
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET E=$$LASTHF^BDMD419(P,"DIABETES SELF MONITORING",BD,ED,"F")
+5 IF E]""
QUIT $SELECT(E["YES":"Yes",E["NO":"No",E["REFUSED":"Refused",1:"")
+6 SET X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+7 IF $DATA(BDM(1))
QUIT "Yes"
+8 QUIT "No"
SDM(P,BDATE,EDATE) ;EP
+1 NEW T,BDM,E,X,%DT,Y,ED,BD
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET E=$$LASTHF^BDMD419(P,"STAGED DIABETES MANAGEMENT",BD,ED)
+5 IF E
QUIT "Yes"
+6 SET T=$ORDER(^ATXAX("B","DM AUDIT SDM PROVIDERS",0))
+7 IF 'T
QUIT ""
+8 SET %=P_"^ALL DX [SURVEILLANCE DIABETES;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+9 ;check to see if one of the providers was the primary prov
+10 NEW X,V,G,P,P1
SET (G,X)=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BDM(X),U,5)
Begin DoDot:1
+11 SET P=0
FOR
SET P=$ORDER(^AUPNVPRV("AD",V,P))
IF P'=+P!(G)
QUIT
SET P1=$PIECE(^AUPNVPRV(P,0),U)
IF $DATA(^ATXAX(T,21,"B",P1))
SET G=1
+12 QUIT
End DoDot:1
+13 QUIT $SELECT(G:"Yes",1:"No")
+14 ;
ASPIRIN(P,BDATE,EDATE) ;EP
+1 GOTO ASPIRIN^BDMD418
+2 ;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
+1 IF '$GET(P)
QUIT ""
+2 NEW STR,TNAME,X,Y,%DT,HO
+3 SET STR=""
SET TNAME=""
SET HO=""
+4 SET X=$$INSULIN^BDMD412(P,BD,EDATE)
+5 IF X]""
SET STR=STR_2_U
SET HO=1
+6 SET X=$$SULF^BDMD412(P,BD,EDATE)
+7 IF X]""
SET STR=STR_3_U
SET HO=1
+8 SET X=$$SULFLIKE^BDMD412(P,BD,EDATE)
+9 IF X]""
SET STR=STR_4_U
SET HO=1
+10 SET X=$$MET^BDMD412(P,BD,EDATE)
+11 IF X]""
SET STR=STR_5_U
SET HO=1
+12 SET X=$$ACAR^BDMD412(P,BD,EDATE)
+13 IF X]""
SET STR=STR_6_U
SET HO=1
+14 SET X=$$TROG^BDMD412(P,BD,EDATE)
+15 IF X]""
SET STR=STR_7_U
SET HO=1
+16 SET X=$$INCR^BDMD412(P,BD,EDATE)
+17 IF X]""
SET STR=STR_8_U
SET HO=1
+18 SET X=$$DPP4^BDMD412(P,BD,EDATE)
+19 IF X]""
SET STR=STR_9_U
SET HO=1
+20 SET X=$$AMYLIN^BDMD412(P,BD,EDATE)
+21 IF X]""
SET STR=STR_10_U
SET HO=1
+22 SET X=$$GLP1^BDMD412(P,BD,EDATE)
+23 IF X]""
SET STR=STR_11_U
SET HO=1
+24 SET X=$$BROM^BDMD412(P,BD,EDATE)
+25 IF X]""
SET STR=STR_12_U
SET HO=1
+26 SET X=$$COLE^BDMD412(P,BD,EDATE)
+27 IF X]""
SET STR=STR_13_U
SET HO=1
+28 IF HO
QUIT STR
+29 SET X=$$REFMED^BDMD412(P,BD,EDATE)
+30 IF X
QUIT "R"
+31 QUIT 1
+32 ;
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^BDMD412(P,BD,EDATE)
+4 IF X]""
QUIT 2
+5 SET X=$$SULF^BDMD412(P,BD,EDATE)
+6 IF X]""
QUIT 2
+7 SET X=$$SULFLIKE^BDMD412(P,BD,EDATE)
+8 IF X]""
QUIT 2
+9 SET X=$$MET^BDMD412(P,BD,EDATE)
+10 IF X]""
QUIT 2
+11 SET X=$$ACAR^BDMD412(P,BD,EDATE)
+12 IF X]""
QUIT 2
+13 SET X=$$TROG^BDMD412(P,BD,EDATE)
+14 IF X]""
QUIT 2
+15 SET X=$$INCR^BDMD412(P,BD,EDATE)
+16 IF X]""
QUIT 2
+17 SET X=$$DPP4^BDMD412(P,BD,EDATE)
+18 IF X]""
QUIT 2
+19 SET X=$$AMYLIN^BDMD412(P,BD,EDATE)
+20 IF X]""
QUIT 2
+21 SET X=$$GLP1^BDMD412(P,BD,EDATE)
+22 IF X]""
QUIT 2
+23 SET X=$$BROM^BDMD412(P,BD,EDATE)
+24 IF X]""
QUIT 2
+25 SET X=$$COLE^BDMD412(P,BD,EDATE)
+26 IF X]""
QUIT 2
+27 SET X=$$REFMED^BDMD412(P,BD,EDATE)
+28 IF X
QUIT 2
+29 QUIT 1
+30 ;
REFMEDE(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^BDMD412(P,BD,EDATE)
+4 IF X]""
QUIT 2
+5 SET X=$$SULF^BDMD412(P,BD,EDATE)
+6 IF X]""
QUIT 2
+7 SET X=$$SULFLIKE^BDMD412(P,BD,EDATE)
+8 IF X]""
QUIT 2
+9 SET X=$$MET^BDMD412(P,BD,EDATE)
+10 IF X]""
QUIT 2
+11 SET X=$$ACAR^BDMD412(P,BD,EDATE)
+12 IF X]""
QUIT 2
+13 SET X=$$TROG^BDMD412(P,BD,EDATE)
+14 IF X]""
QUIT 2
+15 SET X=$$INCR^BDMD412(P,BD,EDATE)
+16 IF X]""
QUIT 2
+17 SET X=$$DPP4^BDMD412(P,BD,EDATE)
+18 IF X]""
QUIT 2
+19 SET X=$$AMYLIN^BDMD412(P,BD,EDATE)
+20 IF X]""
QUIT 2
+21 SET X=$$GLP1^BDMD412(P,BD,EDATE)
+22 IF X]""
QUIT 2
+23 SET X=$$BROM^BDMD412(P,BD,EDATE)
+24 IF X]""
QUIT 2
+25 SET X=$$COLE^BDMD412(P,BD,EDATE)
+26 IF X]""
QUIT 2
+27 SET X=$$REFMED^BDMD412(P,BD,EDATE)
+28 IF X
QUIT 1
+29 QUIT 2
+30 ;
REFMEDLE(P,BD,EDATE) ;EP - ANY REFUSAL?
+1 NEW STR,TNAME,X,Y,%DT
+2 SET STR=""
SET TNAME=""
+3 SET X=$$STATIN^BDMD416(P,BD,EDATE)
+4 IF X]""
QUIT 2
+5 SET X=$$FIBRATE^BDMD416(P,BD,EDATE)
+6 IF X]""
QUIT 2
+7 SET X=$$NIACIN^BDMD416(P,BD,EDATE)
+8 IF X]""
QUIT 2
+9 SET X=$$BILE^BDMD416(P,BD,EDATE)
+10 IF X]""
QUIT 2
+11 SET X=$$EZET^BDMD416(P,BD,EDATE)
+12 IF X]""
QUIT 2
+13 SET X=$$FISHOIL^BDMD416(P,BD,EDATE)
+14 IF X]""
QUIT 2
+15 SET X=$$LOVAZA^BDMD416(P,BD,EDATE)
+16 IF X]""
QUIT 2
+17 SET X=$$REFMEDL^BDMD416(P,BD,EDATE)
+18 IF X
QUIT 1
+19 QUIT 2
+20 ;
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^BDMD413(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["2"
QUIT 2
+8 IF TYPE["1"
QUIT 1
+9 SET TYPE=""
NEW X,I,C
SET X=$$PLDMDXS^BDMD413(P)
+10 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(TYPE]"")
QUIT
IF $EXTRACT(C,6)=0!($EXTRACT(C,6)=2)
SET TYPE=2
+11 IF TYPE]""
QUIT TYPE
+12 FOR I=1:1
SET C=$PIECE(X,";",I)
IF C=""!(TYPE]"")
QUIT
IF $EXTRACT(C,6)=1!($EXTRACT(C,6)=3)
SET TYPE=1
+13 IF TYPE]""
QUIT TYPE
+14 SET X=$$LASTDMDX^BDMD413(P,EDATE)
+15 IF X[2
QUIT 2
+16 IF X[1
QUIT 1
+17 QUIT ""
+18 ;
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 epi 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^BDMD413(P,R,"ID")
+5 IF DATE
SET EARLY=DATE
+6 SET DATE=$$PLDMDOO^BDMD413(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))
