- APCLD217 ; IHS/CMI/LAB - 2001 DIABETES AUDIT ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- ;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,APCLVRD,V,APCL,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 APCLVRD(V)="" Q
- ..I $$PRIMPROV^APCLV(V,"D")="07" S APCLVRD(V)="" Q
- ..I $$PRIMPROV^APCLV(V,"D")="34" S APCLVRD(V)="" Q
- ..Q
- .Q
- I $D(APCLVRD) S RD=1 ;a RD visit so a hit
- K APCL
- S X=P_"^EDUC [DM AUDIT DIET EDUC TOPICS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
- NEW APCLDED S X=0 F S X=$O(APCL(X)) Q:X'=+X S APCLDED($P(APCL(X),U,5))=$$PC(+$P(APCL(X),U,4))
- S X=0 F S X=$O(APCLDED(X)) Q:X'=+X D
- .I APCLDED(X)="07"!(APCLDED(X)=29)!(APCLDED(X)=34) S RD=1 Q
- .I '$D(APCLVRD(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 APCL,X,E,%,G
- S X=P_"^EDUC [DM AUDIT EXERCISE EDUC TOPICS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
- I $D(APCL(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 APCL,X,E,%
- S X=P_"^EDUC [DM AUDIT OTHER EDUC TOPICS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
- I $D(APCL(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 APCL,%,E K APCL S %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
- I $D(APCL(1)) Q "Yes-Diabetic Foot Exam-"_$$FMTE^XLFDT($P(APCL(1),U))
- ;now check any clinic 65
- K APCL
- S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
- NEW X,Y,R S (X,Y)=0 F S X=$O(APCL(X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(APCL(X),U,5),"D") I (R=33!(R=25)!(R=84)),'$$DNKA($P(APCL(X),U,5)) S Y=1
- I Y Q "Yes - Podiatrist Visit"
- S X=0,Y=0 F S X=$O(APCL(X)) Q:X'=+X!(Y) I $$CLINIC^APCLV($P(APCL(X),U,5),"C")=65,'$$DNKA($P(APCL(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 APCL,%,E K APCL S %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
- I $D(APCL(1)) Q "Yes-Diabetic Eye Exam-"_$$FMTE^XLFDT($P(APCL(1),U))
- K APCL 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(%,"APCL(")
- NEW X,Y,R S (X,Y)=0 F S X=$O(APCL(X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(APCL(X),U,5),"D") I (R=24!(R=79)!(R="08")),'$$DNKA($P(APCL(X),U,5)),'$$REFR($P(APCL(X),U,5)) S Y=1
- I Y Q "Yes - Optometrist/Opthamalogist Visit"
- S X=0,Y=0 F S X=$O(APCL(X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(APCL(X),U,5),"C") I (R=17!(R=18)!(R=64)!(R="A2")),'$$DNKA($P(APCL(X),U,5)),'$$REFR($P(APCL(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 APCL,%,E
- K APCL
- S %=P_"^LAST EXAM DENTAL;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
- S %=$P($G(APCL(1)),U)
- I %]"" Q "Yes-Dental Exam-"_$$FMTE^XLFDT(%)
- K APCL
- S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
- NEW X,Y S X=0,Y="" F S X=$O(APCL(X)) Q:X'=+X!(Y]"") I $$CLINIC^APCLV($P(APCL(X),U,5),"C")=56!($$CLINIC^APCLV($P(APCL(X),U,5),"C")="99"),'$$DNKA($P(APCL(X),U,5)) S Y=$$FMTE^XLFDT($P(APCL(X),U))
- I Y]"" Q "Yes-Dental Clinic visit-"_Y
- NEW X,Y S X=0,Y="" F S X=$O(APCL(X)) Q:X'=+X!(Y]"") I $$PRIMPROV^APCLV($P(APCL(X),U,5),"D")=52,'$$DNKA($P(APCL(X),U,5)) S Y=$$FMTE^XLFDT($P(APCL(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,APCL,E,APCLL,APCLLL,APCLV
- S APCLLL=0,APCLV=""
- K APCL
- S X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
- S APCLL=0 F S APCLL=$O(APCL(APCLL)) Q:APCLL'=+APCLL!(APCLLL=3) S APCLBP=$P($G(APCL(APCLL)),U,2) D
- .Q:$$CLINIC^APCLV($P(APCL(APCLL),U,5),"C")=30
- .S APCLLL=APCLLL+1
- .I F="E" S $P(APCLV,";",APCLLL)=APCLBP_" "_$$FMTE^XLFDT($P(APCL(APCLL),U))
- .I F="I" S $P(APCLV,";",APCLLL)=$P(APCLBP," ")
- Q APCLV
- HTNDX(P,EDATE) ;EP - is HTN on problem list
- I '$G(P) Q ""
- I '$D(^DPT(P)) Q ""
- NEW %,APCL,E
- K APCL
- S %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES" S E=$$START1^APCLDF(%,"APCL(")
- I $D(APCL(1)) Q "Yes"
- K APCL
- S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") I $D(APCL(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 %,APCLARRY,H,E
- S %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2)
- I H="" Q H
- S H=$J(H,4,1)
- I F="I" Q H
- Q H_" inches "_$$FMTE^XLFDT($P(APCLARRY(1),U))
- LASTWT(P,EDATE,F) ;EP - return last wt
- I 'P Q ""
- I $G(F)="" S F="E"
- NEW %,APCLARRY,E,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX
- NEW APCLV221 S APCLV221=$O(^ICD9("BA","V22.1 ",""))
- K APCL S APCLW="" S APCLX=P_"^LAST 24 MEAS WT;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE S E=$$START1^APCLDF(APCLX,"APCL(")
- S APCLN=0 F S APCLN=$O(APCL(APCLN)) Q:APCLN'=+APCLN!(APCLW]"") D
- . S APCLZ=$P(APCL(APCLN),U,5)
- . I '$D(^AUPNVPOV("AD",APCLZ)) S APCLW=$P(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($P(APCL(APCLN),U)) Q
- . S APCLD=0 F S APCLD=$O(^AUPNVPOV("AD",APCLZ,APCLD)) Q:'APCLD!(APCLW]"") D
- .. I $P(^AUPNVPOV(APCLD,0),U)'=APCLV221 S APCLW=$P(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($P(APCL(APCLN),U))
- ..Q
- Q $S(F="E":APCLW,1:+APCLW)
- 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,APCL,Y
- S Y="APCL("
- S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(APCL(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,APCL,Y
- S Y="APCL("
- S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
- I $D(APCL(1)) Q "Type 2"
- K APCL S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
- I $D(APCL(1)) Q "Type 1"
- Q ""
- ;
- APCLD217 ; IHS/CMI/LAB - 2001 DIABETES AUDIT ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +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,APCLVRD,V,APCL,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 APCLVRD(V)=""
- QUIT
- +15 IF $$PRIMPROV^APCLV(V,"D")="07"
- SET APCLVRD(V)=""
- QUIT
- +16 IF $$PRIMPROV^APCLV(V,"D")="34"
- SET APCLVRD(V)=""
- QUIT
- +17 QUIT
- End DoDot:2
- +18 QUIT
- End DoDot:1
- +19 ;a RD visit so a hit
- IF $DATA(APCLVRD)
- SET RD=1
- +20 KILL APCL
- +21 SET X=P_"^EDUC [DM AUDIT DIET EDUC TOPICS;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(X,"APCL(")
- +22 NEW APCLDED
- SET X=0
- FOR
- SET X=$ORDER(APCL(X))
- IF X'=+X
- QUIT
- SET APCLDED($PIECE(APCL(X),U,5))=$$PC(+$PIECE(APCL(X),U,4))
- +23 SET X=0
- FOR
- SET X=$ORDER(APCLDED(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +24 IF APCLDED(X)="07"!(APCLDED(X)=29)!(APCLDED(X)=34)
- SET RD=1
- QUIT
- +25 ;a topic with this is not an provider documented, no RD visit
- IF '$DATA(APCLVRD(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 APCL,X,E,%,G
- +2 SET X=P_"^EDUC [DM AUDIT EXERCISE EDUC TOPICS;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(X,"APCL(")
- +3 IF $DATA(APCL(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 APCL,X,E,%
- +2 SET X=P_"^EDUC [DM AUDIT OTHER EDUC TOPICS;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(X,"APCL(")
- +3 IF $DATA(APCL(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 APCL,%,E
- KILL APCL
- SET %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(%,"APCL(")
- +2 IF $DATA(APCL(1))
- QUIT "Yes-Diabetic Foot Exam-"_$$FMTE^XLFDT($PIECE(APCL(1),U))
- +3 ;now check any clinic 65
- +4 KILL APCL
- +5 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(%,"APCL(")
- +6 NEW X,Y,R
- SET (X,Y)=0
- FOR
- SET X=$ORDER(APCL(X))
- IF X'=+X!(Y)
- QUIT
- SET R=$$PRIMPROV^APCLV($PIECE(APCL(X),U,5),"D")
- IF (R=33!(R=25)!(R=84))
- IF '$$DNKA($PIECE(APCL(X),U,5))
- SET Y=1
- +7 IF Y
- QUIT "Yes - Podiatrist Visit"
- +8 SET X=0
- SET Y=0
- FOR
- SET X=$ORDER(APCL(X))
- IF X'=+X!(Y)
- QUIT
- IF $$CLINIC^APCLV($PIECE(APCL(X),U,5),"C")=65
- IF '$$DNKA($PIECE(APCL(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 APCL,%,E
- KILL APCL
- SET %=P_"^LAST EXAM DIABETIC EYE EXAM;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(%,"APCL(")
- +2 IF $DATA(APCL(1))
- QUIT "Yes-Diabetic Eye Exam-"_$$FMTE^XLFDT($PIECE(APCL(1),U))
- +3 KILL APCL
- 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(%,"APCL(")
- +24 NEW X,Y,R
- SET (X,Y)=0
- FOR
- SET X=$ORDER(APCL(X))
- IF X'=+X!(Y)
- QUIT
- SET R=$$PRIMPROV^APCLV($PIECE(APCL(X),U,5),"D")
- IF (R=24!(R=79)!(R="08"))
- IF '$$DNKA($PIECE(APCL(X),U,5))
- IF '$$REFR($PIECE(APCL(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(APCL(X))
- IF X'=+X!(Y)
- QUIT
- SET R=$$CLINIC^APCLV($PIECE(APCL(X),U,5),"C")
- IF (R=17!(R=18)!(R=64)!(R="A2"))
- IF '$$DNKA($PIECE(APCL(X),U,5))
- IF '$$REFR($PIECE(APCL(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 APCL,%,E
- +3 KILL APCL
- +4 SET %=P_"^LAST EXAM DENTAL;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(%,"APCL(")
- +5 SET %=$PIECE($GET(APCL(1)),U)
- +6 IF %]""
- QUIT "Yes-Dental Exam-"_$$FMTE^XLFDT(%)
- +7 KILL APCL
- +8 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(%,"APCL(")
- +9 NEW X,Y
- SET X=0
- SET Y=""
- FOR
- SET X=$ORDER(APCL(X))
- IF X'=+X!(Y]"")
- QUIT
- IF $$CLINIC^APCLV($PIECE(APCL(X),U,5),"C")=56!($$CLINIC^APCLV($PIECE(APCL(X),U,5),"C")="99")
- IF '$$DNKA($PIECE(APCL(X),U,5))
- SET Y=$$FMTE^XLFDT($PIECE(APCL(X),U))
- +10 IF Y]""
- QUIT "Yes-Dental Clinic visit-"_Y
- +11 NEW X,Y
- SET X=0
- SET Y=""
- FOR
- SET X=$ORDER(APCL(X))
- IF X'=+X!(Y]"")
- QUIT
- IF $$PRIMPROV^APCLV($PIECE(APCL(X),U,5),"D")=52
- IF '$$DNKA($PIECE(APCL(X),U,5))
- SET Y=$$FMTE^XLFDT($PIECE(APCL(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,APCL,E,APCLL,APCLLL,APCLV
- +3 SET APCLLL=0
- SET APCLV=""
- +4 KILL APCL
- +5 SET X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE
- SET E=$$START1^APCLDF(X,"APCL(")
- +6 SET APCLL=0
- FOR
- SET APCLL=$ORDER(APCL(APCLL))
- IF APCLL'=+APCLL!(APCLLL=3)
- QUIT
- SET APCLBP=$PIECE($GET(APCL(APCLL)),U,2)
- Begin DoDot:1
- +7 IF $$CLINIC^APCLV($PIECE(APCL(APCLL),U,5),"C")=30
- QUIT
- +8 SET APCLLL=APCLLL+1
- +9 IF F="E"
- SET $PIECE(APCLV,";",APCLLL)=APCLBP_" "_$$FMTE^XLFDT($PIECE(APCL(APCLL),U))
- +10 IF F="I"
- SET $PIECE(APCLV,";",APCLLL)=$PIECE(APCLBP," ")
- End DoDot:1
- +11 QUIT APCLV
- HTNDX(P,EDATE) ;EP - is HTN on problem list
- +1 IF '$GET(P)
- QUIT ""
- +2 IF '$DATA(^DPT(P))
- QUIT ""
- +3 NEW %,APCL,E
- +4 KILL APCL
- +5 SET %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES"
- SET E=$$START1^APCLDF(%,"APCL(")
- +6 IF $DATA(APCL(1))
- QUIT "Yes"
- +7 KILL APCL
- +8 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
- SET E=$$START1^APCLDF(X,"APCL(")
- IF $DATA(APCL(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 %,APCLARRY,H,E
- +5 SET %=P_"^LAST MEAS HT;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
- NEW X
- SET E=$$START1^APCLDF(%,"APCLARRY(")
- SET H=$PIECE($GET(APCLARRY(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(APCLARRY(1),U))
- LASTWT(P,EDATE,F) ;EP - return last wt
- +1 IF 'P
- QUIT ""
- +2 IF $GET(F)=""
- SET F="E"
- +3 NEW %,APCLARRY,E,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX
- +4 NEW APCLV221
- SET APCLV221=$ORDER(^ICD9("BA","V22.1 ",""))
- +5 KILL APCL
- SET APCLW=""
- SET APCLX=P_"^LAST 24 MEAS WT;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE
- SET E=$$START1^APCLDF(APCLX,"APCL(")
- +6 SET APCLN=0
- FOR
- SET APCLN=$ORDER(APCL(APCLN))
- IF APCLN'=+APCLN!(APCLW]"")
- QUIT
- Begin DoDot:1
- +7 SET APCLZ=$PIECE(APCL(APCLN),U,5)
- +8 IF '$DATA(^AUPNVPOV("AD",APCLZ))
- SET APCLW=$PIECE(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(APCL(APCLN),U))
- QUIT
- +9 SET APCLD=0
- FOR
- SET APCLD=$ORDER(^AUPNVPOV("AD",APCLZ,APCLD))
- IF 'APCLD!(APCLW]"")
- QUIT
- Begin DoDot:2
- +10 IF $PIECE(^AUPNVPOV(APCLD,0),U)'=APCLV221
- SET APCLW=$PIECE(APCL(APCLN),U,2)_" lbs "_$$FMTE^XLFDT($PIECE(APCL(APCLN),U))
- +11 QUIT
- End DoDot:2
- End DoDot:1
- +12 QUIT $SELECT(F="E":APCLW,1:+APCLW)
- 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,APCL,Y
- +4 SET Y="APCL("
- +5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
- SET E=$$START1^APCLDF(X,Y)
- SET Y=$PIECE($GET(APCL(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,APCL,Y
- +3 SET Y="APCL("
- +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(APCL(1))
- QUIT "Type 2"
- +6 KILL APCL
- 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(APCL(1))
- QUIT "Type 1"
- +8 QUIT ""
- +9 ;