APCLD812.m

APCLD812 ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ;cmi/anch/maw 9/12/2008 code set versioning in DEPDX

 ;

SETN ;

 S N="" NEW A,G S (A,G)=0 F  S A=$O(APCL(A)) Q:A'=+A!(G)  I $P(^AUPNVLAB(+$P(APCL(A),U,4),0),U,4)]"" S G=A

 S N=$S(G:G,1:1)

 Q

TBTX(P) ;EP

 I '$G(P) Q ""

 NEW APCL,E,X

 K APCL

 S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"APCL(")

 I E Q ""

 I $D(APCL(1)) Q $P(APCL(1),U,3)_U_$S($P(APCL(1),U,3)["TX COMPLETE":"1 Yes",$P(APCL(1),U,3)["TX INCOMPLETE"!($P(APCL(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")

 N T,Y S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))

 I 'T Q ""

 N G S G="",X=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G]"")  I $D(^ATXAX(T,21,"B",X)) S G=$P(^AUTTHF(X,0),U)

 I G]"" Q G_U_$S(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")

 Q ""

CPT(P,BDATE,EDATE,T,F) ;EP return ien of CPT entry if patient had this CPT

 NEW X

 I '$G(P) Q ""

 I '$G(T) Q ""

 I '$G(F) S F=1

 I $G(EDATE)="" Q ""

 I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)

 ;go through visits in a date range for this patient, check cpts

 NEW D,BD,ED,X,Y,D,G,V

 S ED=9999999-EDATE,BD=9999999-BDATE,G=0

 F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..Q:'$D(^AUPNVCPT("AD",V))

 ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G)  D

 ...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X

 ...Q

 ..Q

 .Q

 I 'G Q ""

 I F=1 Q $S(G:1,1:"")

 I F=2 Q G

 I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")

 I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))

 Q ""

RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry in date range

 I '$G(P) Q ""

 I '$G(T) Q ""

 I '$G(F) S F=1

 I $G(EDATE)="" Q ""

 I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)

 ;go through visits in a date range for this patient, check cpts

 NEW D,BD,ED,X,Y,D,G,V

 S ED=9999999-EDATE,BD=9999999-BDATE,G=0

 F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D

 .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  D

 ..Q:'$D(^AUPNVSIT(V,0))

 ..Q:'$D(^AUPNVRAD("AD",V))

 ..S X=0 F  S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G)  D

 ...Q:'$D(^AUPNVRAD(X,0))

 ...S Y=$P(^AUPNVRAD(X,0),U) Q:'Y  Q:'$D(^RAMIS(71,Y,0))

 ...S Y=$P($G(^RAMIS(71,Y,0)),U,9) Q:'Y

 ...Q:'$$ICD^ATXCHK(Y,T,1)

 ...S G=X

 ...Q

 ..Q

 .Q

 I 'G Q ""

 I F=1 Q $S(G:1,1:"")

 I F=2 Q G

 I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")

 I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))

 Q ""

EKG(P,EDATE,F) ;EP

 I $G(F)="" S F="E"

 S %DT="P",X=EDATE D ^%DT S ED=Y

 NEW APCL,X,%,E,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")

 I $D(APCL) S LEKG=$P(APCL(1),U)

 K APCL S %=P_"^LAST PROCEDURE 89.51;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL("),E=$$START1^APCLDF(%,"APCL(")

 I $D(APCL(1)) D

 .Q:LEKG>$P(APCL(1),U)

 .S LEKG=$P(APCL(1),U)

 K APCL S %=P_"^LAST PROCEDURE 89.52;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL("),E=$$START1^APCLDF(%,"APCL(")

 I $D(APCL(1)) D

 .Q:LEKG>$P(APCL(1),U)

 .S LEKG=$P(APCL(1),U)

 K APCL S %=P_"^LAST PROCEDURE 89.53;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_EDATE,E=$$START1^APCLDF(%,"APCL("),E=$$START1^APCLDF(%,"APCL(")

 I $D(APCL(1)) D

 .Q:LEKG>$P(APCL(1),U)

 .S LEKG=$P(APCL(1),U)

 ;check CPT codes in year prior to date range

 S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))

 K APCL I T S APCL(1)=$$CPT^APCLD812(P,$$DOB^AUPNPAT(P),ED,T,3) D

 .I APCL(1)="" K APCL Q

 .Q:LEKG>$P(APCL(1),U)

 .S LEKG=$P(APCL(1),U)

 K APCL I T S APCL(1)=$$RAD^APCLD812(P,$$DOB^AUPNPAT(P),ED,T,3) D

 .I APCL(1)="" K APCL Q

 .Q:LEKG>$P(APCL(1),U)

 .S LEKG=$P(APCL(1),U)

 Q $S(F="E":$$FMTE^XLFDT(LEKG),1:LEKG)

 ;

REFMED(P,BDATE,EDATE) ;EP

 S T=$O(^ATXAX("B","DM AUDIT INSULIN DRUGS",0))

 S T1=$O(^ATXAX("B","DM AUDIT SULFONYLUREA DRUGS",0))

 S T2=$O(^ATXAX("B","DM AUDIT METFORMIN DRUGS",0))

 S T3=$O(^ATXAX("B","DM AUDIT ACARBOSE DRUGS",0))

 S T4=$O(^ATXAX("B","DM AUDIT GLITAZONE DRUGS",0))

 S T5=$O(^ATXAX("B","DM AUDIT INCRETIN MIMETIC",0))  ;cmi/maw 12/18/2007 DM2008

 S T6=$O(^ATXAX("B","DM AUDIT DPP4 INHIBITOR DRUGS",0))  ;cmi/maw 12/18/2007 DM2008

 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=""

 S I=0 F  S I=$O(^AUPNPREF("AA",APCLPD,50,I)) Q:I'=+I!(G)  D

 .S A=0

 .I $D(^ATXAX(T,21,"B",I)) S A=1

 .I $D(^ATXAX(T1,21,"B",I)) S A=1

 .I $D(^ATXAX(T2,21,"B",I)) S A=1

 .I $D(^ATXAX(T3,21,"B",I)) S A=1

 .I $D(^ATXAX(T4,21,"B",I)) S A=1

 .I $D(^ATXAX(T5,21,"B",I)) S A=1  ;cmi/maw 12/18/2008 DM2008

 .I $D(^ATXAX(T6,21,"B",I)) S A=1  ;cmi/maw 12/18/2008 DM2008

 .Q:'A

 .S X=0 F  S X=$O(^AUPNPREF("AA",APCLPD,50,I,X)) Q:X'=+X!(G)  D

 ..S Y=0 F  S Y=$O(^AUPNPREF("AA",APCLPD,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 G

INSULIN(P,BDATE,EDATE) ;EP

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

 ;

SULF(P,BDATE,EDATE) ;EP

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT SULFONYLUREA DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

MET(P,BDATE,EDATE) ;EP

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT METFORMIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

 ;

ACAR(P,BDATE,EDATE) ;EP

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT ACARBOSE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

 ;

TROG(P,BDATE,EDATE) ;EP

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT GLITAZONE DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

INCR(P,BDATE,EDATE) ;EP  cmi/maw 12/18/2007 DM2008

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT INCRETIN MIMETIC"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

 ;

DPP4(P,BDATE,EDATE) ;EP  cmi/maw 12/18/2008 DM2008

 NEW X,APCL,E

 S X=P_"^LAST MEDS [DM AUDIT DPP4 INHIBITOR DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")

 I $D(APCL(1)) Q "X"

 Q ""

TXNAME(V) ;EP

 I $G(V)="" Q ""

 S V=$$TXNAMES(V)

 Q $E(V,1,16)

TXNAMES(Y) ;

 I Y=9 Q "REFUSED"

 I Y=1 Q "DIET"

 I Y=2 Q "INSULIN"

 I Y=3 Q "SULFONYLUREA"

 I Y=4 Q "METFORMIN (GLUCOPHAGE)"

 I Y=5 Q "ACARBOSE OR MIGLITOL"

 I Y=6 Q "GLITAZONE"

 I Y=7 Q "INCRETIN MIMETIC"

 I Y=8 Q "DPP4"

 I Y=9 Q "UNKNOWN/REFUSED"

 I Y=23 Q "INSULIN+S'UREA"

 I Y=24 Q "INSULIN+MET"

 I Y=25 Q "INSULIN+ACAR"

 I Y=26 Q "INSULIN+GLITAZONE"

 I Y=27 Q "INSULIN+INCR"

 I Y=28 Q "INSULIN+DPP4"

 I Y=34 Q "S'UREA+MET"

 I Y=35 Q "S'UREA+ACAR"

 I Y=36 Q "S'UREA+GLITAZONE"

 I Y=37 Q "S'UREA+INCR"

 I Y=38 Q "S'UREA+DPP4"

 I Y=45 Q "MET+ACAR"

 I Y=46 Q "MET+GLITAZONE"

 I Y=47 Q "MET+INCR"

 I Y=48 Q "MET+DPP4"

 I Y=56 Q "ACAR+GLITAZONE"

 I Y=57 Q "ACAR+INCR"

 I Y=58 Q "ACAR+DPP4"

 I Y=67 Q "GLITAZONE+INCR"

 I Y=68 Q "GLITAZONE+DPP4"

 I Y=78 Q "INCR+DPP4"

 I Y=234 Q "INS+S'UREA+MET"

 I Y=235 Q "INS+S'UREA+ACAR"

 I Y=236 Q "INS+S'UREA+GLIT"

 I Y=237 Q "INS+S'UREA+INCR"

 I Y=238 Q "INS+S'UREA+DPP4"

 I Y=245 Q "INS+MET+ACAR"

 I Y=246 Q "INS+MET+GLITAZONE"

 I Y=247 Q "INS+MET+INCR"

 I Y=248 Q "INS+MET+DPP4"

 I Y=256 Q "INS+ACAR+GLITAZONE"

 I Y=257 Q "INS+ACAR+INCR"

 I Y=258 Q "INS+ACAR+DPP4"

 I Y=267 Q "INS+GLIT+INCR"

 I Y=268 Q "INS+GLIT+DPP4"

 I Y=278 Q "INS+INCR+DPP4"

 I Y=345 Q "S'UREA+MET+ACAR"

 I Y=346 Q "S'UREA+MET+GLIT"

 I Y=347 Q "S'UREA+MET+INCR"

 I Y=348 Q "S'UREA+MET+DPP4"

 I Y=356 Q "S'UREA+ACAR+GLIT"

 I Y=357 Q "S'UREA+ACAR+INCR"

 I Y=358 Q "S'UREA+ACAR+DPP4"

 I Y=456 Q "MET+ACAR+GLIT"

 I Y=457 Q "MET+ACAR+INCR"

 I Y=458 Q "MET+ACAR+DPP4"

 I Y=567 Q "ACAR+GLIT+INCR"

 I Y=568 Q "ACAR+GLIT+DPP4"

 I Y=578 Q "GLIT+INCR+DPP4"

 Q ""

 ;

DEPDX(P,BDATE,EDATE) ;EP

 NEW APCL,X

 K APCL

 S (G,X,I)=""

 ;is depression on the problem list?

 S T=$O(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))

 S X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G]"")  D

 .S I=$P($G(^AUPNPROB(X,0)),U)

 .Q:'$$ICD^ATXCHK(I,T,9)

 .;S G="Yes - Problem List "_$P(^ICD9(I,0),U)  ;cmi/anch/maw orig line

 .S G="Yes - Problem List "_$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q

 I G]"" Q G

 S (G,X,I)=""

 ;is depression on the BH problem list?

 S T=$O(^ATXAX("B","DM AUDIT DEPRESSIVE DISORDERS",0))

 S X=0 F  S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G]"")  D

 .S I=$P($G(^AMHPPROB(X,0)),U)

 .S I=$P($G(^AMHPROB(I,0)),U,5)

 .Q:I=""

 .S I=+$$CODEN^ICDCODE(I,80)

 .Q:I=""

 .Q:'$$ICD^ATXCHK(I,T,9)

 .;S G="Yes - BH Problem List "_$P(^ICD9(I,0),U)  ;cmi/anch/maw orig line

 .S G="Yes - BH Problem List "_$P($$ICDDX^ICDCODE(I),U,2)  ;cmi/anch/maw 9/12/2007 csv

 .Q

 I G]"" Q G

 ;now check for 2 dxs in past year

 S Y="APCL(",APCLV=""

 S X=P_"^LAST 2 DX [DM AUDIT DEPRESSIVE DISORDERS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 I $D(APCL(2)) Q "Yes 2 dxs in PCC"

 S APCL=0 I $D(APCL(1)) S APCL=1

 ;S X=BDATE,%DT="P" D ^%DT S BD=Y

 ;S X=EDATE,%DT="P" D ^%DT S ED=Y

 ;go through BH record file and find up to 2 visits in date range

 S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(APCL>1)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCL>1)  D

 .Q:'$D(^AMHREC(V,0))

 .I $P(^AMHREC(V,0),U,16)]"",APCLV]"",$P(^AMHREC(V,0),U,16)=APCLV Q

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(APCL>1)  S APCLP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'APCLP

 ..S APCLP=$P($G(^AMHPROB(APCLP,0)),U)

 ..I APCLP=14 S APCL=APCL+1 Q

 ..I APCLP=15 S APCL=APCL+1 Q

 ..I APCLP=18 S APCL=APCL+1 Q

 ..I APCLP=24 S APCL=APCL+1 Q

 ..I $E(APCLP,1,3)=296 S APCL=APCL+1 Q

 ..I $E(APCLP,1,3)=300 S APCL=APCL+1 Q

 ..I $E(APCLP,1,3)=309 S APCL=APCL+1 Q

 ..I APCLP="301.13" S APCL=APCL+1 Q

 ..I APCLP=308.3 S APCL=APCL+1 Q

 ..I APCLP="311." S APCL=APCL+1 Q

 ..Q

 I APCL>1 Q "Yes 2 dx PCC/BH"

 Q "No"

DEPSCR(P,BDATE,EDATE) ;EP

 NEW X

 I $G(P)="" Q ""

 K APCL

 S Y="APCL("

 S X=P_"^LAST DX V79.0;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) Q "Yes V79.0"_" "_$$DATE^APCLD810($P(APCL(1),U))

 ;check patient education

 S Y="APCL("

 S X=P_"^LAST EXAM 36;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 I $D(APCL(1)) Q "Yes Exam 36-Dep Screen "_$$DATE^APCLD810($P(APCL(1),U))

 S Y="APCL("

 S X=P_"^ALL EDUC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)

 I '$D(APCL(1)) G BHSCR

 S (X,E)=0,%="",T="",D="" F  S X=$O(APCL(X)) Q:X'=+X!(D)  D

 .S T=$P(^AUPNVPED(+$P(APCL(X),U,4),0),U)

 .Q:'T

 .Q:'$D(^AUTTEDT(T,0))

 .S T=$P(^AUTTEDT(T,0),U,2)

 .I $P(T,"-",1)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="GAD")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP") S D="Yes pt ed "_T_" "_$$DATE^APCLD810($P(APCL(X),U))

 K APCL

 I $P(D,U)]"" Q D

BHSCR ;

 S D=0,APCLC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(APCLC]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCLC]"")  D

 .I $P($G(^AMHREC(V,14)),U,5)]"",$P(^AMHREC(V,14),U,5)'="UAS",$P(^AMHREC(V,14),U,5)'="REF" S APCLC="Yes BH Exam 36 "_$$DATE^APCLD810(9999999-D) Q

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(APCLC]"")  S APCLP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'APCLP

 ..S APCLP=$P($G(^AMHPROB(APCLP,0)),U)

 ..I APCLP=14.1 S APCLC="Yes BH 14.1 "_$$DATE^APCLD810(9999999-D) Q

 ..I '$D(^AMHREDU("AD",V)) Q

 ..S Y=0 F  S Y=$O(^AMHREDU("AD",V,Y)) Q:Y'=+Y!(APCLC)  D

 ...S T=$P(^AMHREDU(Y,0),U)

 ...Q:'T

 ...Q:'$D(^AUTTEDT(T,0))

 ...S T=$P(^AUTTEDT(T,0),U,2)

 ...I $P(T,"-",1)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="GAD")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP") S APCLC="Yes BH pt ed "_T_" "_$$DATE^APCLD810(9999999-D)

 ...Q

 I APCLC]"" Q APCLC

 ;refusal

 NEW G S G=$$REFUSAL^APCLD817(P,9999999.15,$O(^AUTTEXAM("B","DEPRESSION SCREENING",0)),BDATE,EDATE)

 I G Q "Refused"

 S D=0,APCLC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(APCLC]"")  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(APCLC]"")  D

 .I $P($G(^AMHREC(V,14)),U,5)]"",($P(^AMHREC(V,14),U,5)="UAS"!($P(^AMHREC(V,14),U,5)'="REF")) S APCLC="Refused BH Exam 36 "_$$DATE^APCLD810(9999999-D) Q

 I APCLC]"" Q APCLC

 Q "No"

LOINC(A,B) ;

 NEW %

 S %=$P($G(^LAB(95.3,A,9999999)),U,2)

 I %]"",$D(^ATXAX(B,21,"B",%)) Q 1

 S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)

 I $D(^ATXAX(B,21,"B",%)) Q 1

 Q ""

APCLD812  ; IHS/CMI/LAB - 2008 DIABETES AUDIT ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;cmi/anch/maw 9/12/2008 code set versioning in DEPDX

 +4       ;

SETN      ;

 +1        SET N=""

           NEW A,G

           SET (A,G)=0

           FOR 

               SET A=$ORDER(APCL(A))

               IF A'=+A!(G)

                   QUIT 

               IF $PIECE(^AUPNVLAB(+$PIECE(APCL(A),U,4),0),U,4)]""

                   SET G=A

 +2        SET N=$SELECT(G:G,1:1)

 +3        QUIT 

TBTX(P)   ;EP

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW APCL,E,X

 +3        KILL APCL

 +4        SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"

           SET E=$$START1^APCLDF(X,"APCL(")

 +5        IF E

               QUIT ""

 +6        IF $DATA(APCL(1))

               QUIT $PIECE(APCL(1),U,3)_U_$SELECT($PIECE(APCL(1),U,3)["TX COMPLETE":"1 Yes",$PIECE(APCL(1),U,3)["TX INCOMPLETE"!($PIECE(APCL(1),U,3)["TX UNTREATED"):"2 No",1:"4 Unknown")

 +7        NEW T,Y

           SET T=$ORDER(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))

 +8        IF 'T

               QUIT ""

 +9        NEW G

           SET G=""

           SET X=0

           FOR 

               SET X=$ORDER(^AUPNHF("AA",P,X))

               IF X'=+X!(G]"")

                   QUIT 

               IF $DATA(^ATXAX(T,21,"B",X))

                   SET G=$PIECE(^AUTTHF(X,0),U)

 +10       IF G]""

               QUIT G_U_$SELECT(G["TX COMPLETE":"1 Yes",G["TX INCOMPLETE"!(G["TX UNTREATED"):"2 No",1:"4 Unknown")

 +11       QUIT ""

CPT(P,BDATE,EDATE,T,F) ;EP return ien of CPT entry if patient had this CPT

 +1        NEW X

 +2        IF '$GET(P)

               QUIT ""

 +3        IF '$GET(T)

               QUIT ""

 +4        IF '$GET(F)

               SET F=1

 +5        IF $GET(EDATE)=""

               QUIT ""

 +6        IF $GET(BDATE)=""

               SET BDATE=$$FMADD^XLFDT(EDATE,-365)

 +7       ;go through visits in a date range for this patient, check cpts

 +8        NEW D,BD,ED,X,Y,D,G,V

 +9        SET ED=9999999-EDATE

           SET BD=9999999-BDATE

           SET G=0

 +10       FOR 

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)!(G)

                   QUIT 

               Begin DoDot:1

 +11               SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V!(G)

                           QUIT 

                       Begin DoDot:2

 +12                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT 

 +13                       IF '$DATA(^AUPNVCPT("AD",V))

                               QUIT 

 +14                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVCPT("AD",V,X))

                               IF X'=+X!(G)

                                   QUIT 

                               Begin DoDot:3

 +15                               IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),T,1)

                                       SET G=X

 +16                               QUIT 

                               End DoDot:3

 +17                       QUIT 

                       End DoDot:2

 +18               QUIT 

               End DoDot:1

 +19       IF 'G

               QUIT ""

 +20       IF F=1

               QUIT $SELECT(G:1,1:"")

 +21       IF F=2

               QUIT G

 +22       IF F=3

               SET V=$PIECE(^AUPNVCPT(G,0),U,3)

               IF V

                   QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")

 +23       IF F=4

               SET V=$PIECE(^AUPNVCPT(G,0),U,3)

               IF V

                   QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))

 +24       QUIT ""

RAD(P,BDATE,EDATE,T,F) ;EP return if a v rad entry in date range

 +1        IF '$GET(P)

               QUIT ""

 +2        IF '$GET(T)

               QUIT ""

 +3        IF '$GET(F)

               SET F=1

 +4        IF $GET(EDATE)=""

               QUIT ""

 +5        IF $GET(BDATE)=""

               SET BDATE=$$FMADD^XLFDT(EDATE,-365)

 +6       ;go through visits in a date range for this patient, check cpts

 +7        NEW D,BD,ED,X,Y,D,G,V

 +8        SET ED=9999999-EDATE

           SET BD=9999999-BDATE

           SET G=0

 +9        FOR 

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)!(G)

                   QUIT 

               Begin DoDot:1

 +10               SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V!(G)

                           QUIT 

                       Begin DoDot:2

 +11                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT 

 +12                       IF '$DATA(^AUPNVRAD("AD",V))

                               QUIT 

 +13                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVRAD("AD",V,X))

                               IF X'=+X!(G)

                                   QUIT 

                               Begin DoDot:3

 +14                               IF '$DATA(^AUPNVRAD(X,0))

                                       QUIT 

 +15                               SET Y=$PIECE(^AUPNVRAD(X,0),U)