BDMD316 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
;
TBCODE(P,EDATE,R) ;EP
NEW BDMJ,BDMI
S BDMJ=""
;return computed TB Status Code
S X=$$TBTX^BDMD312(P)
I X]"",X["TX COMPLETE" Q 1
I X]"" Q 2
I $$PPD^BDMD318(P,EDATE)["POS" D Q BDMJ
.I $$TBTX^BDMD312(P)["TX COMPLETE" S BDMJ=1 Q
.S BDMJ=2
.Q
I $$PPD^BDMD318(P,EDATE)["NEG" S BDMJ=4 D Q BDMJ
.I $$DODX(P,R,"I")="" S BDMJ=4 Q
.S D=$$DODX(P,R,"I"),E=$$PPD^BDMD318(P,EDATE,"I") S BDMJ=$S(D>E:4,1:3)
.Q
S BDMJ=5
Q BDMJ
;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated/treatment incomplete or unknown treatment
3 ;;PPD -, up-to-date (placed after dm dx)
4 ;;PPD -, before DM dx or date unknown
5 ;;PPD Status unknown
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^BDMD313(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^BDMD313(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^BDMD318(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 "Both"
I S Q "Statin"
I O Q "Other"
;refusal of NMI
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT LIPID LOWERING DRUGS",0))
I 'T Q "None"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD317(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "None - Not Medically Indicated"
NEW T S T=$O(^ATXAX("B","DM AUDIT STATIN DRUGS",0))
I 'T Q "None"
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD317(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "None - Not Medically Indicated"
;
Q "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 "Yes"
;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,%
S %=""
S I=0 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),".")
I %]"" Q "Yes"
;refusals
NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'T Q "No"
S (G,X)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD317(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
Q "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^BDMD319(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^BDMD319(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")
PERI(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
NEW BDM,% S %=P_"^LAST ADA [DM AUDIT PERIDONTAL ADA CODES;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) Q "Yes "_$$FMTE^XLFDT($P(BDM(1),U))
K BDM
S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
NEW X,Y S X=0,Y=0 F S X=$O(BDM(X)) Q:X'=+X!(Y) I $$CLINIC^APCLV($P(BDM(X),U,5),"C")=56 S Y=1
I Y Q "Yes - clinic 56 visit"
Q "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=2 Q "Both"
I A Q "Aspirin"
I N Q "Other"
;refusal of NMI
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I 'T Q "None"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD317(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "None - Not Medically Indicated"
NEW T S T=$O(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
I 'T Q "None"
S (X,G)=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) S G=$$REFUSAL^BDMD317(P,50,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "None - Not Medically Indicated"
;
Q "None"
;
TOBACCO(P,EDATE) ;EP
I '$G(P) Q ""
NEW BDMTOB,BDM,X,E
D TOBACCO0
I $D(BDMTOB) Q BDMTOB
D TOBACCO3
I $D(BDMTOB) Q BDMTOB
D TOBACCO1 ;check Problem file for tobacco use
I $D(BDMTOB) Q BDMTOB
D TOBACCO2 ;check POVs for tobacco use
I $D(BDMTOB) Q BDMTOB
Q "3 Not Documented "
TOBACCO0 ;check for tobacco documented in health factors
K BDM S X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S E=$$START1^APCLDF(X,"BDM(") Q:E I $D(BDM(1)) D ;S BDMTOBN=$O(BDMTOB("")),BDMTOB=BDMTOB(BDMTOBN)
. I $P(BDM(1),U,3)["CURRENT" S BDMTOB="1 Current User" Q
. S BDMTOB="2 Not a Current User "
.Q
Q
TOBACCO3 ;lookup in health status
S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
Q:'%
S (X,Y)=0 F S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(Y) I $D(^ATXAX(%,21,"B",X)) S Y=X
Q:'Y
S Y=$P(^AUTTHF(Y,0),U)
S BDMTOB=Y
I Y["CURRENT" S BDMTOB="1 Current User" Q
S BDMTOB="2 Not a Current User"
Q
TOBACCO1 ;check problem file for tobacco use
K BDM S X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(X,"BDM(") Q:E I $D(BDM(1)) D
. ;I $P(^ICD9($P(BDM(1),U,2),0),U,1)=305.13 S BDMTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(BDM(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 orig line
. I $P($$ICDDX^ICDCODE($P(BDM(1),U,2)),U,2)=305.13 S BDMTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(BDM(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 csv
. S BDMTOB="1 Current user - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(BDM(1),U,4),0),U,5),0),U),1,30)
.Q
Q
TOBACCO2 ;check pov file for TOBACCO USE DOC
NEW D,%DT
S %DT="P",X=EDATE D ^%DT S D=Y
NEW BDATE S BDATE=$$FMADD^XLFDT(D,-365),BDATE=$$FMTE^XLFDT(BDATE)
K BDM S X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(") Q:E I $D(BDM(1)) D
. I $P(BDM(1),U,2)=305.13 S BDMTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(BDM(1),U,4),0),U,4),0),U),1,30) Q
. S BDMTOB="1 Current user"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(BDM(1),U,4),0),U,4),0),U),1,30)
.Q
Q
;
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^BDMD312(P,BD,EDATE)
I X]"" S STR=STR_"2"
S X=$$SULF^BDMD312(P,BD,EDATE)
I X]"" S STR=STR_3
S X=$$MET^BDMD312(P,BD,EDATE)
I X]"" S STR=STR_4
S X=$$ACAR^BDMD312(P,BD,EDATE)
I X]"" S STR=STR_5
S X=$$TROG^BDMD312(P,BD,EDATE)
I X]"" S STR=STR_"6"
I STR]"" Q STR
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^BDMD313(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^BDMD313(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^BDMD313(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>EDATE Q ""
Q ($$FMDIFF^XLFDT(EDATE,Y,1)\365)
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^BDMD313(P,R,"ID")
I DATE]"" S EARLY=DATE
S DATE=$$PLDMDOO^BDMD313(P,"I")
I DATE]"",DATE<EARLY S EARLY=DATE
I EARLY=9999999 S EARLY=""
Q $S(F="I":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":"15",1:$E(D,6,7))_"/"_(1700+$E(D,1,3))
;
;;
BDMD316 ; IHS/CMI/LAB - 2003 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
+4 ;
TBCODE(P,EDATE,R) ;EP
+1 NEW BDMJ,BDMI
+2 SET BDMJ=""
+3 ;return computed TB Status Code
+4 SET X=$$TBTX^BDMD312(P)
+5 IF X]""
IF X["TX COMPLETE"
QUIT 1
+6 IF X]""
QUIT 2
+7 IF $$PPD^BDMD318(P,EDATE)["POS"
Begin DoDot:1
+8 IF $$TBTX^BDMD312(P)["TX COMPLETE"
SET BDMJ=1
QUIT
+9 SET BDMJ=2
+10 QUIT
End DoDot:1
QUIT BDMJ
+11 IF $$PPD^BDMD318(P,EDATE)["NEG"
SET BDMJ=4
Begin DoDot:1
+12 IF $$DODX(P,R,"I")=""
SET BDMJ=4
QUIT
+13 SET D=$$DODX(P,R,"I")
SET E=$$PPD^BDMD318(P,EDATE,"I")
SET BDMJ=$SELECT(D>E:4,1:3)
+14 QUIT
End DoDot:1
QUIT BDMJ
+15 SET BDMJ=5
+16 QUIT BDMJ
+17 ;;
1 ;;PPD +, treatment complete
2 ;;PPD +, not treated/treatment incomplete or unknown treatment
3 ;;PPD -, up-to-date (placed after dm dx)
4 ;;PPD -, before DM dx or date unknown
5 ;;PPD Status unknown
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
+1 NEW X
SET X=$$BPS^BDMD313(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^BDMD313(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^BDMD318(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 "Both"
+8 IF S
QUIT "Statin"
+9 IF O
QUIT "Other"
+10 ;refusal of NMI
+11 SET G=0
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT LIPID LOWERING DRUGS",0))
+13 IF 'T
QUIT "None"
+14 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD317(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+16 IF G
QUIT "None - Not Medically Indicated"
+17 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT STATIN DRUGS",0))
+18 IF 'T
QUIT "None"
+19 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD317(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+20 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+21 IF G
QUIT "None - Not Medically Indicated"
+22 ;
+23 QUIT "None"
+24 ;
+25 ;
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 "Yes"
+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 SET %=""
+8 SET I=0
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),".")
End DoDot:1
+10 IF %]""
QUIT "Yes"
+11 ;refusals
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+13 IF 'T
QUIT "No"
+14 SET (G,X)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD317(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+16 QUIT "No"_$SELECT(G:" - Not Medically Indicated",1:"")
+17 ;
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^BDMD319(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^BDMD319(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")
PERI(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BDM,%
SET %=P_"^LAST ADA [DM AUDIT PERIDONTAL ADA CODES;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(BDM(1),U))
+4 KILL BDM
+5 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+6 NEW X,Y
SET X=0
SET Y=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(Y)
QUIT
IF $$CLINIC^APCLV($PIECE(BDM(X),U,5),"C")=56
SET Y=1
+7 IF Y
QUIT "Yes - clinic 56 visit"
+8 QUIT "No"
+9 ;
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=2
QUIT "Both"
+8 IF A
QUIT "Aspirin"
+9 IF N
QUIT "Other"
+10 ;refusal of NMI
+11 SET G=0
+12 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+13 IF 'T
QUIT "None"
+14 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD317(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+15 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+16 IF G
QUIT "None - Not Medically Indicated"
+17 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ANTI-PLATELET DRUGS",0))
+18 IF 'T
QUIT "None"
+19 SET (X,G)=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
SET G=$$REFUSAL^BDMD317(P,50,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
+20 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+21 IF G
QUIT "None - Not Medically Indicated"
+22 ;
+23 QUIT "None"
+24 ;
TOBACCO(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BDMTOB,BDM,X,E
+3 DO TOBACCO0
+4 IF $DATA(BDMTOB)
QUIT BDMTOB
+5 DO TOBACCO3
+6 IF $DATA(BDMTOB)
QUIT BDMTOB
+7 ;check Problem file for tobacco use
DO TOBACCO1
+8 IF $DATA(BDMTOB)
QUIT BDMTOB
+9 ;check POVs for tobacco use
DO TOBACCO2
+10 IF $DATA(BDMTOB)
QUIT BDMTOB
+11 QUIT "3 Not Documented "
TOBACCO0 ;check for tobacco documented in health factors
+1 ;S BDMTOBN=$O(BDMTOB("")),BDMTOB=BDMTOB(BDMTOBN)
KILL BDM
SET X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"
SET E=$$START1^APCLDF(X,"BDM(")
IF E
QUIT
IF $DATA(BDM(1))
Begin DoDot:1
+2 IF $PIECE(BDM(1),U,3)["CURRENT"
SET BDMTOB="1 Current User"
QUIT
+3 SET BDMTOB="2 Not a Current User "
+4 QUIT
End DoDot:1
+5 QUIT
TOBACCO3 ;lookup in health status
+1 SET %=$ORDER(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))
+2 IF '%
QUIT
+3 SET (X,Y)=0
FOR
SET X=$ORDER(^AUPNHF("AA",P,X))
IF X'=+X!(Y)
QUIT
IF $DATA(^ATXAX(%,21,"B",X))
SET Y=X
+4 IF 'Y
QUIT
+5 SET Y=$PIECE(^AUTTHF(Y,0),U)
+6 SET BDMTOB=Y
+7 IF Y["CURRENT"
SET BDMTOB="1 Current User"
QUIT
+8 SET BDMTOB="2 Not a Current User"
+9 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 KILL BDM
SET X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(X,"BDM(")
IF E
QUIT
IF $DATA(BDM(1))
Begin DoDot:1
+2 ;I $P(^ICD9($P(BDM(1),U,2),0),U,1)=305.13 S BDMTOB="2 Not a Current User"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(BDM(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 orig line
+3 ;cmi/anch/maw 9/10/2007 csv
IF $PIECE($$ICDDX^ICDCODE($PIECE(BDM(1),U,2)),U,2)=305.13
SET BDMTOB="2 Not a Current User"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(BDM(1),U,4),0),U,5),0),U),1,30)
QUIT
+4 SET BDMTOB="1 Current user - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(BDM(1),U,4),0),U,5),0),U),1,30)
+5 QUIT
End DoDot:1
+6 QUIT
TOBACCO2 ;check pov file for TOBACCO USE DOC
+1 NEW D,%DT
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET D=Y
+3 NEW BDATE
SET BDATE=$$FMADD^XLFDT(D,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
+4 KILL BDM
SET X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
IF E
QUIT
IF $DATA(BDM(1))
Begin DoDot:1
+5 IF $PIECE(BDM(1),U,2)=305.13
SET BDMTOB="2 Not a Current User"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(BDM(1),U,4),0),U,4),0),U),1,30)
QUIT
+6 SET BDMTOB="1 Current user"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(BDM(1),U,4),0),U,4),0),U),1,30)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
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^BDMD312(P,BD,EDATE)
+5 IF X]""
SET STR=STR_"2"
+6 SET X=$$SULF^BDMD312(P,BD,EDATE)
+7 IF X]""
SET STR=STR_3
+8 SET X=$$MET^BDMD312(P,BD,EDATE)
+9 IF X]""
SET STR=STR_4
+10 SET X=$$ACAR^BDMD312(P,BD,EDATE)
+11 IF X]""
SET STR=STR_5
+12 SET X=$$TROG^BDMD312(P,BD,EDATE)
+13 IF X]""
SET STR=STR_"6"
+14 IF STR]""
QUIT STR
+15 QUIT 1
+16 ;
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^BDMD313(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^BDMD313(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^BDMD313(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>EDATE
QUIT ""
+5 QUIT ($$FMDIFF^XLFDT(EDATE,Y,1)\365)
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^BDMD313(P,R,"ID")
+5 IF DATE]""
SET EARLY=DATE
+6 SET DATE=$$PLDMDOO^BDMD313(P,"I")
+7 IF DATE]""
IF DATE<EARLY
SET EARLY=DATE
+8 IF EARLY=9999999
SET EARLY=""
+9 QUIT $SELECT(F="I":EARLY,1:$$D(EARLY))
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":"15",1:$EXTRACT(D,6,7))_"/"_(1700+$EXTRACT(D,1,3))
+3 ;
+4 ;;
