BDMD916 ; IHS/CMI/LAB - 2009 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;cmi/anch/maw 9/12/2007 code set versioning in TOBACCO1,ASAPOV
;
TBCODE(P,EDATE,R) ;EP
NEW BDMJ,BDMI,X,BDMR
S BDMJ=""
;return computed TB Status Code
S X=$$TBTX^BDMD912(P)
I $E(X)=1 Q 1
I $E(X) Q 2
S BDMR=$$PPD^BDMD918(P,EDATE)
I $E(BDMR)=1 D Q BDMJ
.I $$TBTX^BDMD912(P)["TX COMPLETE" S BDMJ=1 Q
.S BDMJ=2
.Q
I $E(BDMR)=2 S BDMJ=4 D Q BDMJ
.I $$DODX(P,R,"I")="" S BDMJ=6 Q
.S D=$$DODX(P,R,"I"),E=$$PPD^BDMD918(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
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^BDMD913(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C'=3 Q ""
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/")+C
Q C\3
Q ""
DIAMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^BDMD913(P,BDATE,EDATE,"I")
I X="" Q ""
NEW Y,C S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C'=3 Q ""
S C=0 F Y=1:1:3 S C=$P($P(X,";",Y),"/",2)+C
Q C\3
PPDDATE(P,EDATE) ;EP
NEW X S X=$$LASTNP^BDMD918(P,EDATE)
Q X
LIPID(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^BDMD917(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^BDMD917(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"
;
;
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^BDMD917(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^BDMD919(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^BDMD919(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
NEW X,BDM,E,A,N,G
S (A,B,G,N)=""
S X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S A=1
K BDM S X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) S N=1
I A!(N) Q "1 Aspirin/Antiplatelet Rx"
;refusal oR NMI
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I 'T G ANTI
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD917(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "3 Refused"
I G Q "2 None - Not Medically Indicated"
ANTI ;
NEW T S T=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
I 'T G AR
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD917(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G Q "3 Refused or adverse rxn"
AR ;NOW CHECK FOR ADVERSE REACTION/ALLERGY
S X=EDATE,%DT="P" D ^%DT S E=Y
D ASAALLEG(P,E,.BDMSAAL) ;return text of aspirin allergy if found
I $D(BDMSAAL(1)) Q "3 Refused or adverse rxn "_BDMSAAL(1)_" (Allergy Tracking)"
Q "2 None"
;
;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
I '$G(P) Q ""
NEW STR,TNAME,X,Y,%DT
S STR="",TNAME=""
S X=$$INSULIN^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_2
S X=$$SULF^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_3
S X=$$MET^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_4
S X=$$ACAR^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_5
S X=$$TROG^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_6
S X=$$INCR^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_7
S X=$$DPP4^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_8
S X=$$AMYLIN^BDMD912(P,BD,EDATE)
I X]"" S STR=STR_9
I STR]"" Q STR
S X=$$REFMED^BDMD912(P,BD,EDATE)
I X Q STR_"R"
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^BDMD913(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^BDMD913(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^BDMD913(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^BDMD913(P,R,"ID")
I DATE S EARLY=DATE
S DATE=$$PLDMDOO^BDMD913(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))
;;
ASAALLEG(P,BDMD,BDMY) ;does patient have an aspirin allergy
;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
NEW ED,BD,BDMG,BDMC,X,Y,Z,N
;BDMD is discharge date
S BDMC=0 K BDMY
;S ED=$$FMADD^XLFDT(BDMD,-365)
ASAPOV ;
K BDMG S Y="BDMG(",X=P_"^ALL DX [BDM ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD) 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["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="POV: "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_"] "_N
.;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 orig line
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 csv
.Q
K BDMG S Y="BDMG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD) 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["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="POV: "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_"] "_N
.Q
;now check problem list for these codes
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
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($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>BDMD ;added after discharge date
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S BDMC=BDMC+1,BDMY(BDMC)="PROBLEM LIST: "_$$FMTE^XLFDT($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
;now check allergy tracking
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),".")>BDMD ;entered after AUDIT date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["ASPIRIN" S BDMC=BDMC+1,BDMY(BDMC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($P(^GMR(120.8,X,0),U,4))_" "_N Q
.S C=$O(^PS(50.605,"B","CN103",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.S C=$O(^PS(50.605,"B","BL100",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.S C=$O(^PS(50.605,"B","BL110",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.S C=$O(^PS(50.605,"B","BL117",0))
.I C,$D(^GMR(120.8,X,3,"B",C)) S G="Refused/Adverse Rxn" Q
.Q
Q
BDMD916 ; IHS/CMI/LAB - 2009 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning in TOBACCO1,ASAPOV
+4 ;
TBCODE(P,EDATE,R) ;EP
+1 NEW BDMJ,BDMI,X,BDMR
+2 SET BDMJ=""
+3 ;return computed TB Status Code
+4 SET X=$$TBTX^BDMD912(P)
+5 IF $EXTRACT(X)=1
QUIT 1
+6 IF $EXTRACT(X)
QUIT 2
+7 SET BDMR=$$PPD^BDMD918(P,EDATE)
+8 IF $EXTRACT(BDMR)=1
Begin DoDot:1
+9 IF $$TBTX^BDMD912(P)["TX COMPLETE"
SET BDMJ=1
QUIT
+10 SET BDMJ=2
+11 QUIT
End DoDot:1
QUIT BDMJ
+12 IF $EXTRACT(BDMR)=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^BDMD918(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=5
+18 QUIT BDMJ
+19 ;;
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^BDMD913(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C'=3
QUIT ""
+5 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/")+C
+6 QUIT C\3
+7 QUIT ""
DIAMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^BDMD913(P,BDATE,EDATE,"I")
+2 IF X=""
QUIT ""
+3 NEW Y,C
SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+4 IF C'=3
QUIT ""
+5 SET C=0
FOR Y=1:1:3
SET C=$PIECE($PIECE(X,";",Y),"/",2)+C
+6 QUIT C\3
PPDDATE(P,EDATE) ;EP
+1 NEW X
SET X=$$LASTNP^BDMD918(P,EDATE)
+2 QUIT X
LIPID(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^BDMD917(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^BDMD917(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 ;
+11 ;
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^BDMD917(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^BDMD919(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^BDMD919(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 NEW X,BDM,E,A,N,G
+2 SET (A,B,G,N)=""
+3 SET X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+4 IF $DATA(BDM(1))
SET A=1
+5 KILL BDM
SET X=P_"^MEDS [DM AUDIT ANTI-PLATELET DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 IF $DATA(BDM(1))
SET N=1
+7 IF A!(N)
QUIT "1 Aspirin/Antiplatelet Rx"
+8 ;refusal oR NMI
+9 SET G=0
+10 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+11 IF 'T
GOTO ANTI
+12 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD917(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+13 IF G
IF $PIECE(G,U,2)'="N"
QUIT "3 Refused"
+14 IF G
QUIT "2 None - Not Medically Indicated"
ANTI ;
+1 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+2 IF 'T
GOTO AR
+3 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD917(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+4 IF G
QUIT "3 Refused or adverse rxn"
AR ;NOW CHECK FOR ADVERSE REACTION/ALLERGY
+1 SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+2 ;return text of aspirin allergy if found
DO ASAALLEG(P,E,.BDMSAAL)
+3 IF $DATA(BDMSAAL(1))
QUIT "3 Refused or adverse rxn "_BDMSAAL(1)_" (Allergy Tracking)"
+4 QUIT "2 None"
+5 ;
+6 ;
THERAPY(P,BD,EDATE) ;EP - therapy code for epi
+1 IF '$GET(P)
QUIT ""
+2 NEW STR,TNAME,X,Y,%DT
+3 SET STR=""
SET TNAME=""
+4 SET X=$$INSULIN^BDMD912(P,BD,EDATE)
+5 IF X]""
SET STR=STR_2
+6 SET X=$$SULF^BDMD912(P,BD,EDATE)
+7 IF X]""
SET STR=STR_3
+8 SET X=$$MET^BDMD912(P,BD,EDATE)
+9 IF X]""
SET STR=STR_4
+10 SET X=$$ACAR^BDMD912(P,BD,EDATE)
+11 IF X]""
SET STR=STR_5
+12 SET X=$$TROG^BDMD912(P,BD,EDATE)
+13 IF X]""
SET STR=STR_6
+14 SET X=$$INCR^BDMD912(P,BD,EDATE)
+15 IF X]""
SET STR=STR_7
+16 SET X=$$DPP4^BDMD912(P,BD,EDATE)
+17 IF X]""
SET STR=STR_8
+18 SET X=$$AMYLIN^BDMD912(P,BD,EDATE)
+19 IF X]""
SET STR=STR_9
+20 IF STR]""
QUIT STR
+21 SET X=$$REFMED^BDMD912(P,BD,EDATE)
+22 IF X
QUIT STR_"R"
+23 QUIT 1
+24 ;
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^BDMD913(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^BDMD913(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^BDMD913(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^BDMD913(P,R,"ID")
+5 IF DATE
SET EARLY=DATE
+6 SET DATE=$$PLDMDOO^BDMD913(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))
+3 ;;
ASAALLEG(P,BDMD,BDMY) ;does patient have an aspirin allergy
+1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
+2 NEW ED,BD,BDMG,BDMC,X,Y,Z,N
+3 ;BDMD is discharge date
+4 SET BDMC=0
KILL BDMY
+5 ;S ED=$$FMADD^XLFDT(BDMD,-365)
ASAPOV ;
+1 KILL BDMG
SET Y="BDMG("
SET X=P_"^ALL DX [BDM ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BDMG(X),U,4)
Begin DoDot:1
+3 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+4 IF N["ASPIRIN"!(N["ASA")
SET BDMC=BDMC+1
SET BDMY(BDMC)="POV: "_$$FMTE^XLFDT($PIECE(BDMG(X),U))_" ["_$PIECE(BDMG(X),U,2)_"] "_N
+5 ;S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($G(^ICD9(Z,0)),U)="E935.3" S BDMC=BDMC+1,BDMY(BDMC)="POV "_$$FMTE^XLFDT($P(BDMG(X),U))_" ["_$P(BDMG(X),U,2)_" + E935.3] "_N ;cmi/anch/maw 9/12/2007 orig line
+6 ;cmi/anch/maw 9/12/2007 csv
SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E935.3"
SET BDMC=BDMC+1
SET BDMY(BDMC)="POV "_$$FMTE^XLFDT($PIECE(BDMG(X),U))_" ["_$PIECE(BDMG(X),U,2)_" + E935.3] "_N
+7 QUIT
End DoDot:1
+8 KILL BDMG
SET Y="BDMG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BDMD)
SET E=$$START1^APCLDF(X,Y)
+9 SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BDMG(X),U,4)
Begin DoDot:1
+10 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+11 IF N["ASPIRIN"!(N["ASA")
SET BDMC=BDMC+1
SET BDMY(BDMC)="POV: "_$$FMTE^XLFDT($PIECE(BDMG(X),U))_" ["_$PIECE(BDMG(X),U,2)_"] "_N
+12 QUIT
End DoDot:1
+13 ;now check problem list for these codes
+14 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+15 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+16 ;S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($G(^ICD9(I,0)),U) ;cmi/anch/maw 9/12/2007 orig line
+17 ;cmi/anch/maw 9/12/2007 csv
SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+18 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+19 ;added after discharge date
IF $PIECE(^AUPNPROB(X,0),U,8)>BDMD
QUIT
+20 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["ASPIRIN"!(N["ASA")
SET BDMC=BDMC+1
SET BDMY(BDMC)="PROBLEM LIST: "_$$FMTE^XLFDT($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+21 QUIT
End DoDot:1
+22 ;now check allergy tracking
+23 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+24 ;entered after AUDIT date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BDMD
QUIT
+25 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+26 IF N["ASPIRIN"
SET BDMC=BDMC+1
SET BDMY(BDMC)="ALLERGY TRACKING: "_$$FMTE^XLFDT($PIECE(^GMR(120.8,X,0),U,4))_" "_N
QUIT
+27 SET C=$ORDER(^PS(50.605,"B","CN103",0))
+28 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+29 SET C=$ORDER(^PS(50.605,"B","BL100",0))
+30 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+31 SET C=$ORDER(^PS(50.605,"B","BL110",0))
+32 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+33 SET C=$ORDER(^PS(50.605,"B","BL117",0))
+34 IF C
IF $DATA(^GMR(120.8,X,3,"B",C))
SET G="Refused/Adverse Rxn"
QUIT
+35 QUIT
End DoDot:1
+36 QUIT
