BDMD217 ; IHS/CMI/LAB - 2001 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;cmi/anch/maw 9/10/2007 code set versioning in PLDMDXS
;
DIETEDUC(P,BDATE,EDATE) ;EP
NEW D,BD,ED,X,Y,%DT,D,G,BDMVRD,V,BDM,RD,NRD
S (RD,NRD)=""
S X=BDATE,%DT="P" D ^%DT S BD=Y
S X=EDATE,%DT="P" D ^%DT S ED=Y
S D=9999999-ED,(RD,NRD)="" ;is this right???
F S D=$O(^AUPNVSIT("AA",P,D)) Q:D=""!(D>(9999999-BD)) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..Q:$P(^AUPNVSIT(V,0),U,11)
..Q:'$P(^AUPNVSIT(V,0),U,9)
..Q:'$D(^AUPNVPOV("AD",V))
..Q:'$D(^AUPNVPRV("AD",V))
..Q:$$DNKA(V)
..I $$PRIMPROV^APCLV(V,"D")=29 S BDMVRD(V)="" Q
..I $$PRIMPROV^APCLV(V,"D")="07" S BDMVRD(V)="" Q
..I $$PRIMPROV^APCLV(V,"D")="34" S BDMVRD(V)="" Q
..Q
.Q
I $D(BDMVRD) S RD=1 ;a RD visit so a hit
K BDM
S X=P_"^EDUC [DM AUDIT DIET EDUC TOPICS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
NEW BDMDED S X=0 F S X=$O(BDM(X)) Q:X'=+X S BDMDED($P(BDM(X),U,5))=$$PC(+$P(BDM(X),U,4))
S X=0 F S X=$O(BDMDED(X)) Q:X'=+X D
.I BDMDED(X)="07"!(BDMDED(X)=29)!(BDMDED(X)=34) S RD=1 Q
.I '$D(BDMVRD(X)) S NRD=1 ;a topic with this is not an provider documented, no RD visit
S G=0
I RD!(NRD) Q $S(RD+NRD=2:"Yes (RD & Non RD)",RD:"Yes (RD)",1:"Yes (Non RD)")
NEW T S T=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
I 'T Q "None"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) I $$REFUSAL(P,9999999.09,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE) S G=1
I G Q "Refused"
Q "None"
PC(V) ;return provider discipline of educ provider
I 'V Q ""
NEW X S X=$P(^AUPNVPED(V,0),U,5)
I 'X Q ""
;IHS/CMI/LAB patch 11 01/11/2002
I $P(^DD(9000010.16,.05,0),U,2)[200 Q $$PROVCLSC^XBFUNC1(X)
NEW A S A=$P(^DIC(6,X,0),U,4)
I 'A Q ""
Q $P($G(^DIC(7,A,9999999)),U)
EXEDUC(P,BDATE,EDATE) ;EP
NEW BDM,X,E,%,G
S X=P_"^EDUC [DM AUDIT EXERCISE EDUC TOPICS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "Yes"
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
I 'T Q "No"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) I $$REFUSAL(P,9999999.09,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE) S G=1
Q $S(G:"Refused",1:"No")
OTHEDUC(P,BDATE,EDATE) ;EP
NEW BDM,X,E,%
S X=P_"^EDUC [DM AUDIT OTHER EDUC TOPICS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
I $D(BDM(1)) Q "Yes"
S G=0
NEW T S T=$O(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
I 'T Q "No"
S X=0 F S X=$O(^ATXAX(T,21,X)) Q:X'=+X!(G) I $$REFUSAL(P,9999999.09,$P(^ATXAX(T,21,X,0),U),BDATE,EDATE) S G=1
Q $S(G:"Refused",1:"No")
DFE(P,BDATE,EDATE) ;EP
NEW BDM,%,E K BDM S %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) Q "Yes-Diabetic Foot Exam-"_$$FMTE^XLFDT($P(BDM(1),U))
;now check any clinic 65
K BDM
S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
NEW X,Y,R S (X,Y)=0 F S X=$O(BDM(X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(BDM(X),U,5),"D") I (R=33!(R=25)!(R=84)),'$$DNKA($P(BDM(X),U,5)) S Y=1
I Y Q "Yes - Podiatrist Visit"
S X=0,Y=0 F S X=$O(BDM(X)) Q:X'=+X!(Y) I $$CLINIC^APCLV($P(BDM(X),U,5),"C")=65,'$$DNKA($P(BDM(X),U,5)) S Y=1
I Y Q "Yes - Podiatry Clinic visit"
NEW G S G=$$REFUSAL(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),BDATE,EDATE)
I G Q "Refused"
Q "No"
DNKA(V) ;is this a DNKA visit?
I '$G(V) Q ""
NEW D,N S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
REFR(V) ;
I '$G(V) Q ""
NEW D,N S D=$$PRIMPOV^APCLV(V,"C")
I D="367.89"!(D="367.9")!($E(D,1,5)=372.0)!($E(D,1,5)=372.1) Q 1
Q 0
REFUSAL(P,F,I,B,E) ;EP
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G=1
Q G
EYE(P,BDATE,EDATE) ;EP
NEW BDM,%,E K BDM S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) Q "Yes-Diabetic Eye Exam-"_$$FMTE^XLFDT($P(BDM(1),U))
K BDM NEW BD,ED,T
S X=BDATE,%DT="P" D ^%DT S BD=Y
S X=EDATE,%DT="P" D ^%DT S ED=Y
S T=$O(^ICPT("B",92250,0)),T1=$O(^ICPT("B",92012,0))
I T,$D(^AUPNVCPT("AA",P,T)) S %="" D I %]"" Q %
.S E=0 F S E=$O(^AUPNVCPT("AA",P,T,E)) Q:E'=+E!(%]"") D
..S D=9999999-E ;date done
..I D>ED Q
..I D<BD Q
..S %="Yes-Fundus Photography-"_$$FMTE^XLFDT(D)
..Q
.Q
I T1,$D(^AUPNVCPT("AA",P,T1)) S %="" D I %]"" Q %
.S E=0 F S E=$O(^AUPNVCPT("AA",P,T1,E)) Q:E'=+E!(%]"") D
..S D=9999999-E ;date done
..I D>ED Q
..I D<BD Q
..S %="Yes-Eye Exam/Est Pat-"_$$FMTE^XLFDT(D)
..Q
.Q
S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
NEW X,Y,R S (X,Y)=0 F S X=$O(BDM(X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(BDM(X),U,5),"D") I (R=24!(R=79)!(R="08")),'$$DNKA($P(BDM(X),U,5)),'$$REFR($P(BDM(X),U,5)) S Y=1
I Y Q "Yes - Optometrist/Opthamalogist Visit"
S X=0,Y=0 F S X=$O(BDM(X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(BDM(X),U,5),"C") I (R=17!(R=18)!(R=64)!(R="A2")),'$$DNKA($P(BDM(X),U,5)),'$$REFR($P(BDM(X),U,5)) S Y=1
I Y Q "Yes - Optometry/Opthamology Clinic visit"
NEW G S G=$$REFUSAL(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
I G Q "Refused"
Q "No"
DENTAL(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
NEW BDM,%,E
K BDM
S %=P_"^LAST EXAM DENTAL;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
S %=$P($G(BDM(1)),U)
I %]"" Q "Yes-Dental Exam-"_$$FMTE^XLFDT(%)
K BDM
S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BDM(")
NEW X,Y S X=0,Y="" F S X=$O(BDM(X)) Q:X'=+X!(Y]"") I $$CLINIC^APCLV($P(BDM(X),U,5),"C")=56!($$CLINIC^APCLV($P(BDM(X),U,5),"C")="99"),'$$DNKA($P(BDM(X),U,5)) S Y=$$FMTE^XLFDT($P(BDM(X),U))
I Y]"" Q "Yes-Dental Clinic visit-"_Y
NEW X,Y S X=0,Y="" F S X=$O(BDM(X)) Q:X'=+X!(Y]"") I $$PRIMPROV^APCLV($P(BDM(X),U,5),"D")=52,'$$DNKA($P(BDM(X),U,5)) S Y=$$FMTE^XLFDT($P(BDM(X),U))
I Y]"" Q "Yes-Dentist Visit-"_$$FMTE^XLFDT(Y)
NEW G S G=$$REFUSAL(P,9999999.15,$O(^AUTTEXAM("B","DENTAL EXAM",0)),BDATE,EDATE)
I G Q "Refused"
Q "No"
BPS(P,BDATE,EDATE,F) ;EP ;
I $G(F)="" S F="E"
NEW X,BDM,E,BDML,BDMLL,BDMV
S BDMLL=0,BDMV=""
K BDM
S X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(")
S BDML=0 F S BDML=$O(BDM(BDML)) Q:BDML'=+BDML!(BDMLL=3) S BDMBP=$P($G(BDM(BDML)),U,2) D
.Q:$$CLINIC^APCLV($P(BDM(BDML),U,5),"C")=30
.S BDMLL=BDMLL+1
.I F="E" S $P(BDMV,";",BDMLL)=BDMBP_" "_$$FMTE^XLFDT($P(BDM(BDML),U))
.I F="I" S $P(BDMV,";",BDMLL)=$P(BDMBP," ")
Q BDMV
HTNDX(P,EDATE) ;EP - is HTN on problem list
I '$G(P) Q ""
I '$D(^DPT(P)) Q ""
NEW %,BDM,E
K BDM
S %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES" S E=$$START1^APCLDF(%,"BDM(")
I $D(BDM(1)) Q "Yes"
K BDM
S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"BDM(") I $D(BDM(3)) Q "Yes"
Q "No"
LASTHT(P,EDATE,F) ;EP - return last ht and date
I 'P Q ""
I $G(F)="" S F="E"
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW %,BDMARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)
I H="" Q H
S H=$J(H,4,1)
I F="I" Q H
Q H_" inches "_$$FMTE^XLFDT($P(BDMARRY(1),U))
LASTWT(P,EDATE,F) ;EP - return last wt
I 'P Q ""
I $G(F)="" S F="E"
NEW %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX
NEW BDMV221 S BDMV221=$O(^ICD9("BA","V22.1 ",""))
K BDM S BDMW="" S BDMX=P_"^LAST 24 MEAS WT;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE S E=$$START1^APCLDF(BDMX,"BDM(")
S BDMN=0 F S BDMN=$O(BDM(BDMN)) Q:BDMN'=+BDMN!(BDMW]"") D
. S BDMZ=$P(BDM(BDMN),U,5)
. I '$D(^AUPNVPOV("AD",BDMZ)) S BDMW=$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U)) Q
. S BDMD=0 F S BDMD=$O(^AUPNVPOV("AD",BDMZ,BDMD)) Q:'BDMD!(BDMW]"") D
.. I $P(^AUPNVPOV(BDMD,0),U)'=BDMV221 S BDMW=$P(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($P(BDM(BDMN),U))
..Q
Q $S(F="E":BDMW,1:+BDMW)
CMSFDX(P,R,T) ;EP - return date/dx of dm in register
I '$G(P) Q ""
I '$G(R) Q ""
I $G(T)="" Q ""
NEW D1,Y,X,D,G S (G,X)=0,(D,Y)="" F S X=$O(^ACM(44,"C",P,X)) Q:X'=+X!(G) I $P(^ACM(44,X,0),U,4)=R D
.S D=$P($G(^ACM(44,X,"SV")),U,2),D1=D,D=$$FMTE^XLFDT(D)
.S Y=$$VAL^XBDIQ1(9002244,X,.01)
Q $S(T="D":$G(D),T="DX":$G(Y),T="ID":$G(D1),1:"")
;
PLDMDOO(P,F) ;EP
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P(^AUPNPROB(X,0),U)
.I $$ICD^ATXCHK(I,T,9) D
..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
..Q
.Q
S D=$O(D(0)) Q $S(F="E":$$FMTE^XLFDT(D),1:$O(D(0)))
PLDMDXS(P) ;EP - get all DM dxs from problem list
I '$G(P) Q ""
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q "<diabetes taxonomy missing>"
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P(^AUPNPROB(X,0),U)
.;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U) ;cmi/anch/maw 9/10/2007 orig line
.I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/10/2007 csv
.Q
Q D
;
FRSTDMDX(P,F) ;EP return date of first dm dx
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW X,E,BDM,Y
S Y="BDM("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BDM(1)),U)
Q $S(F="E":$$FMTE^XLFDT(Y),1:Y)
LASTDMDX(P,D) ;EP - last pcc dm dx
I '$G(P) Q ""
NEW X,E,BDM,Y
S Y="BDM("
S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
I $D(BDM(1)) Q "Type 2"
K BDM S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
I $D(BDM(1)) Q "Type 1"
Q ""
;
BDMD217 ; IHS/CMI/LAB - 2001 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in PLDMDXS
+4 ;
DIETEDUC(P,BDATE,EDATE) ;EP
+1 NEW D,BD,ED,X,Y,%DT,D,G,BDMVRD,V,BDM,RD,NRD
+2 SET (RD,NRD)=""
+3 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+4 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+5 ;is this right???
SET D=9999999-ED
SET (RD,NRD)=""
+6 FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D=""!(D>(9999999-BD))
QUIT
Begin DoDot:1
+7 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+12 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+13 IF $$DNKA(V)
QUIT
+14 IF $$PRIMPROV^APCLV(V,"D")=29
SET BDMVRD(V)=""
QUIT
+15 IF $$PRIMPROV^APCLV(V,"D")="07"
SET BDMVRD(V)=""
QUIT
+16 IF $$PRIMPROV^APCLV(V,"D")="34"
SET BDMVRD(V)=""
QUIT
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 ;a RD visit so a hit
IF $DATA(BDMVRD)
SET RD=1
+20 KILL BDM
+21 SET X=P_"^EDUC [DM AUDIT DIET EDUC TOPICS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+22 NEW BDMDED
SET X=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X
QUIT
SET BDMDED($PIECE(BDM(X),U,5))=$$PC(+$PIECE(BDM(X),U,4))
+23 SET X=0
FOR
SET X=$ORDER(BDMDED(X))
IF X'=+X
QUIT
Begin DoDot:1
+24 IF BDMDED(X)="07"!(BDMDED(X)=29)!(BDMDED(X)=34)
SET RD=1
QUIT
+25 ;a topic with this is not an provider documented, no RD visit
IF '$DATA(BDMVRD(X))
SET NRD=1
End DoDot:1
+26 SET G=0
+27 IF RD!(NRD)
QUIT $SELECT(RD+NRD=2:"Yes (RD & Non RD)",RD:"Yes (RD)",1:"Yes (Non RD)")
+28 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
+29 IF 'T
QUIT "None"
+30 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL(P,9999999.09,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
SET G=1
+31 IF G
QUIT "Refused"
+32 QUIT "None"
PC(V) ;return provider discipline of educ provider
+1 IF 'V
QUIT ""
+2 NEW X
SET X=$PIECE(^AUPNVPED(V,0),U,5)
+3 IF 'X
QUIT ""
+4 ;IHS/CMI/LAB patch 11 01/11/2002
+5 IF $PIECE(^DD(9000010.16,.05,0),U,2)[200
QUIT $$PROVCLSC^XBFUNC1(X)
+6 NEW A
SET A=$PIECE(^DIC(6,X,0),U,4)
+7 IF 'A
QUIT ""
+8 QUIT $PIECE($GET(^DIC(7,A,9999999)),U)
EXEDUC(P,BDATE,EDATE) ;EP
+1 NEW BDM,X,E,%,G
+2 SET X=P_"^EDUC [DM AUDIT EXERCISE EDUC TOPICS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "Yes"
+4 SET G=0
+5 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
+6 IF 'T
QUIT "No"
+7 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL(P,9999999.09,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
SET G=1
+8 QUIT $SELECT(G:"Refused",1:"No")
OTHEDUC(P,BDATE,EDATE) ;EP
+1 NEW BDM,X,E,%
+2 SET X=P_"^EDUC [DM AUDIT OTHER EDUC TOPICS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+3 IF $DATA(BDM(1))
QUIT "Yes"
+4 SET G=0
+5 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
+6 IF 'T
QUIT "No"
+7 SET X=0
FOR
SET X=$ORDER(^ATXAX(T,21,X))
IF X'=+X!(G)
QUIT
IF $$REFUSAL(P,9999999.09,$PIECE(^ATXAX(T,21,X,0),U),BDATE,EDATE)
SET G=1
+8 QUIT $SELECT(G:"Refused",1:"No")
DFE(P,BDATE,EDATE) ;EP
+1 NEW BDM,%,E
KILL BDM
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+2 IF $DATA(BDM(1))
QUIT "Yes-Diabetic Foot Exam-"_$$FMTE^XLFDT($PIECE(BDM(1),U))
+3 ;now check any clinic 65
+4 KILL BDM
+5 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+6 NEW X,Y,R
SET (X,Y)=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(Y)
QUIT
SET R=$$PRIMPROV^APCLV($PIECE(BDM(X),U,5),"D")
IF (R=33!(R=25)!(R=84))
IF '$$DNKA($PIECE(BDM(X),U,5))
SET Y=1
+7 IF Y
QUIT "Yes - Podiatrist Visit"
+8 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")=65
IF '$$DNKA($PIECE(BDM(X),U,5))
SET Y=1
+9 IF Y
QUIT "Yes - Podiatry Clinic visit"
+10 NEW G
SET G=$$REFUSAL(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),BDATE,EDATE)
+11 IF G
QUIT "Refused"
+12 QUIT "No"
DNKA(V) ;is this a DNKA visit?
+1 IF '$GET(V)
QUIT ""
+2 NEW D,N
SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
REFR(V) ;
+1 IF '$GET(V)
QUIT ""
+2 NEW D,N
SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D="367.89"!(D="367.9")!($EXTRACT(D,1,5)=372.0)!($EXTRACT(D,1,5)=372.1)
QUIT 1
+4 QUIT 0
REFUSAL(P,F,I,B,E) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G=1
+9 QUIT G
EYE(P,BDATE,EDATE) ;EP
+1 NEW BDM,%,E
KILL BDM
SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+2 IF $DATA(BDM(1))
QUIT "Yes-Diabetic Eye Exam-"_$$FMTE^XLFDT($PIECE(BDM(1),U))
+3 KILL BDM
NEW BD,ED,T
+4 SET X=BDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+5 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+6 SET T=$ORDER(^ICPT("B",92250,0))
SET T1=$ORDER(^ICPT("B",92012,0))
+7 IF T
IF $DATA(^AUPNVCPT("AA",P,T))
SET %=""
Begin DoDot:1
+8 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AA",P,T,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+9 ;date done
SET D=9999999-E
+10 IF D>ED
QUIT
+11 IF D<BD
QUIT
+12 SET %="Yes-Fundus Photography-"_$$FMTE^XLFDT(D)
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
IF %]""
QUIT %
+15 IF T1
IF $DATA(^AUPNVCPT("AA",P,T1))
SET %=""
Begin DoDot:1
+16 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AA",P,T1,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+17 ;date done
SET D=9999999-E
+18 IF D>ED
QUIT
+19 IF D<BD
QUIT
+20 SET %="Yes-Eye Exam/Est Pat-"_$$FMTE^XLFDT(D)
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
IF %]""
QUIT %
+23 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+24 NEW X,Y,R
SET (X,Y)=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(Y)
QUIT
SET R=$$PRIMPROV^APCLV($PIECE(BDM(X),U,5),"D")
IF (R=24!(R=79)!(R="08"))
IF '$$DNKA($PIECE(BDM(X),U,5))
IF '$$REFR($PIECE(BDM(X),U,5))
SET Y=1
+25 IF Y
QUIT "Yes - Optometrist/Opthamalogist Visit"
+26 SET X=0
SET Y=0
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(BDM(X),U,5),"C")
IF (R=17!(R=18)!(R=64)!(R="A2"))
IF '$$DNKA($PIECE(BDM(X),U,5))
IF '$$REFR($PIECE(BDM(X),U,5))
SET Y=1
+27 IF Y
QUIT "Yes - Optometry/Opthamology Clinic visit"
+28 NEW G
SET G=$$REFUSAL(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC EYE EXAM",0)),BDATE,EDATE)
+29 IF G
QUIT "Refused"
+30 QUIT "No"
DENTAL(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BDM,%,E
+3 KILL BDM
+4 SET %=P_"^LAST EXAM DENTAL;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+5 SET %=$PIECE($GET(BDM(1)),U)
+6 IF %]""
QUIT "Yes-Dental Exam-"_$$FMTE^XLFDT(%)
+7 KILL BDM
+8 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BDM(")
+9 NEW X,Y
SET X=0
SET Y=""
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(Y]"")
QUIT
IF $$CLINIC^APCLV($PIECE(BDM(X),U,5),"C")=56!($$CLINIC^APCLV($PIECE(BDM(X),U,5),"C")="99")
IF '$$DNKA($PIECE(BDM(X),U,5))
SET Y=$$FMTE^XLFDT($PIECE(BDM(X),U))
+10 IF Y]""
QUIT "Yes-Dental Clinic visit-"_Y
+11 NEW X,Y
SET X=0
SET Y=""
FOR
SET X=$ORDER(BDM(X))
IF X'=+X!(Y]"")
QUIT
IF $$PRIMPROV^APCLV($PIECE(BDM(X),U,5),"D")=52
IF '$$DNKA($PIECE(BDM(X),U,5))
SET Y=$$FMTE^XLFDT($PIECE(BDM(X),U))
+12 IF Y]""
QUIT "Yes-Dentist Visit-"_$$FMTE^XLFDT(Y)
+13 NEW G
SET G=$$REFUSAL(P,9999999.15,$ORDER(^AUTTEXAM("B","DENTAL EXAM",0)),BDATE,EDATE)
+14 IF G
QUIT "Refused"
+15 QUIT "No"
BPS(P,BDATE,EDATE,F) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 NEW X,BDM,E,BDML,BDMLL,BDMV
+3 SET BDMLL=0
SET BDMV=""
+4 KILL BDM
+5 SET X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
+6 SET BDML=0
FOR
SET BDML=$ORDER(BDM(BDML))
IF BDML'=+BDML!(BDMLL=3)
QUIT
SET BDMBP=$PIECE($GET(BDM(BDML)),U,2)
Begin DoDot:1
+7 IF $$CLINIC^APCLV($PIECE(BDM(BDML),U,5),"C")=30
QUIT
+8 SET BDMLL=BDMLL+1
+9 IF F="E"
SET $PIECE(BDMV,";",BDMLL)=BDMBP_" "_$$FMTE^XLFDT($PIECE(BDM(BDML),U))
+10 IF F="I"
SET $PIECE(BDMV,";",BDMLL)=$PIECE(BDMBP," ")
End DoDot:1
+11 QUIT BDMV
HTNDX(P,EDATE) ;EP - is HTN on problem list
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P))
QUIT ""
+3 NEW %,BDM,E
+4 KILL BDM
+5 SET %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES"
SET E=$$START1^APCLDF(%,"BDM(")
+6 IF $DATA(BDM(1))
QUIT "Yes"
+7 KILL BDM
+8 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"BDM(")
IF $DATA(BDM(3))
QUIT "Yes"
+9 QUIT "No"
LASTHT(P,EDATE,F) ;EP - return last ht and date
+1 IF 'P
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+4 NEW %,BDMARRY,H,E
+5 SET %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"BDMARRY(")
SET H=$PIECE($GET(BDMARRY(1)),U,2)
+6 IF H=""
QUIT H
+7 SET H=$JUSTIFY(H,4,1)
+8 IF F="I"
QUIT H
+9 QUIT H_" inches "_$$FMTE^XLFDT($PIECE(BDMARRY(1),U))
LASTWT(P,EDATE,F) ;EP - return last wt
+1 IF 'P
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW %,BDMARRY,E,BDMW,X,BDMN,BDM,BDMD,BDMZ,BDMX
+4 NEW BDMV221
SET BDMV221=$ORDER(^ICD9("BA","V22.1 ",""))
+5 KILL BDM
SET BDMW=""
SET BDMX=P_"^LAST 24 MEAS WT;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
SET E=$$START1^APCLDF(BDMX,"BDM(")
+6 SET BDMN=0
FOR
SET BDMN=$ORDER(BDM(BDMN))
IF BDMN'=+BDMN!(BDMW]"")
QUIT
Begin DoDot:1
+7 SET BDMZ=$PIECE(BDM(BDMN),U,5)
+8 IF '$DATA(^AUPNVPOV("AD",BDMZ))
SET BDMW=$PIECE(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(BDM(BDMN),U))
QUIT
+9 SET BDMD=0
FOR
SET BDMD=$ORDER(^AUPNVPOV("AD",BDMZ,BDMD))
IF 'BDMD!(BDMW]"")
QUIT
Begin DoDot:2
+10 IF $PIECE(^AUPNVPOV(BDMD,0),U)'=BDMV221
SET BDMW=$PIECE(BDM(BDMN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(BDM(BDMN),U))
+11 QUIT
End DoDot:2
End DoDot:1
+12 QUIT $SELECT(F="E":BDMW,1:+BDMW)
CMSFDX(P,R,T) ;EP - return date/dx of dm in register
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(R)
QUIT ""
+3 IF $GET(T)=""
QUIT ""
+4 NEW D1,Y,X,D,G
SET (G,X)=0
SET (D,Y)=""
FOR
SET X=$ORDER(^ACM(44,"C",P,X))
IF X'=+X!(G)
QUIT
IF $PIECE(^ACM(44,X,0),U,4)=R
Begin DoDot:1
+5 SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)
SET D1=D
SET D=$$FMTE^XLFDT(D)
+6 SET Y=$$VAL^XBDIQ1(9002244,X,.01)
End DoDot:1
+7 QUIT $SELECT(T="D":$GET(D),T="DX":$GET(Y),T="ID":$GET(D1),1:"")
+8 ;
PLDMDOO(P,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+4 IF 'T
QUIT ""
+5 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET I=$PIECE(^AUPNPROB(X,0),U)
+7 IF $$ICD^ATXCHK(I,T,9)
Begin DoDot:2
+8 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(D(0))
QUIT $SELECT(F="E":$$FMTE^XLFDT(D),1:$ORDER(D(0)))
PLDMDXS(P) ;EP - get all DM dxs from problem list
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+3 IF 'T
QUIT "<diabetes taxonomy missing>"
+4 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET I=$PIECE(^AUPNPROB(X,0),U)
+6 ;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U) ;cmi/anch/maw 9/10/2007 orig line
+7 ;cmi/anch/maw 9/10/2007 csv
IF $$ICD^ATXCHK(I,T,9)
IF D]""
SET D=D_";"
SET D=D_$PIECE($$ICDDX^ICDCODE(I),U,2)
+8 QUIT
End DoDot:1
+9 QUIT D
+10 ;
FRSTDMDX(P,F) ;EP return date of first dm dx
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW X,E,BDM,Y
+4 SET Y="BDM("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
SET Y=$PIECE($GET(BDM(1)),U)
+6 QUIT $SELECT(F="E":$$FMTE^XLFDT(Y),1:Y)
LASTDMDX(P,D) ;EP - last pcc dm dx
+1 IF '$GET(P)
QUIT ""
+2 NEW X,E,BDM,Y
+3 SET Y="BDM("
+4 SET X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BDM(1))
QUIT "Type 2"
+6 KILL BDM
SET X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BDM(1))
QUIT "Type 1"
+8 QUIT ""
+9 ;
