APCLD996 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
;
TBCODE(P,EDATE,R) ;EP
NEW APCLJ,APCLI
S APCLJ=""
;return computed TB Status Code
S X=$$TBTX^APCLD998(P)
I X]"",X["TX COMPLETE" Q 1
I X]"" Q 2
I $$PPD^APCLD998(P,EDATE)["POS" D Q APCLJ
.I $$TBTX^APCLD998(P)["TX COMPLETE" S APCLJ=1 Q
.S APCLJ=2
.Q
I $$PPD^APCLD998(P,EDATE)["NEG" S APCLJ=4 D Q APCLJ
.I $$DODX(P,R,"I")="" S APCLJ=5 Q
.S D=$$DODX(P,R,"I"),E=$$PPD^APCLD998(P,EDATE,"I") S APCLJ=$S(D>E:4,1:3)
.Q
S APCLJ=6
Q APCLJ
;;
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
5 ;;PPD -, DM dx date unknown
6 ;;PPD Status unknown
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
SYSMEAN(P,BDATE,EDATE) ;EP
NEW X S X=$$BPS^APCLD997(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^APCLD997(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^APCLD998(P,EDATE)
Q X
FLU(P,BDATE,EDATE) ;EP
NEW APCL,X,E
S X=EDATE,%DT="P" D ^%DT S BD=Y
S BD=$$FMADD^XLFDT(BD,-(15*30)),BD=$$FMTE^XLFDT(BD)
S X=P_"^LAST IMM "_$S($$BI:88,1:12)_";DURING "_BD_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes-"_$$FMTE^XLFDT($P(APCL(1),U))
I $$REFUSAL^APCLD997(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:88,1:12),0)),BD,EDATE) Q "Refused"
Q "No"
PNEU(P,EDATE) ;EP
NEW APCL,X,E
S X=P_"^LAST IMM "_$S($$BI:33,1:19)_";DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes - "_$$FMTE^XLFDT($P(APCL(1),U))
I $$REFUSAL^APCLD997(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE) Q "Refused"
Q "No"
TD(P,EDATE) ;EP
NEW APCL,X,E,B,%DT,Y,TDD
S %DT="P",X=EDATE D ^%DT S B=Y
S X=P_"^LAST IMM "_$S($$BI:9,1:"02")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S TDD($P(APCL(1),U))=""
K APCL S X=P_"^LAST IMM "_$S($$BI:1,1:"03")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S TDD($P(APCL(1),U))=""
K APCL S X=P_"^LAST IMM "_$S($$BI:28,1:"34")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S TDD($P(APCL(1),U))=""
K APCL S X=P_"^LAST IMM "_$S($$BI:20,1:"42")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) S TDD($P(APCL(1),U))=""
K APCL S APCL="",X=0 F S X=$O(TDD(X)) Q:X'=+X S APCL=X
I APCL]"" Q "Yes - "_$$FMTE^XLFDT(APCL)
S B=$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))
I $$REFUSAL^APCLD997(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:9,1:"02"),0)),B,EDATE) Q "Refused"
I $$REFUSAL^APCLD997(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:1,1:"03"),0)),B,EDATE) Q "Refused"
I $$REFUSAL^APCLD997(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:28,1:34),0)),B,EDATE) Q "Refused"
I $$REFUSAL^APCLD997(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:20,1:42),0)),B,EDATE) Q "Refused"
Q "No"
;
ACE(P,BDATE,EDATE) ;EP
NEW X,APCL,E,X,Y,%DT,BD
S X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(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),".")
Q $S(%]"":"Yes",1:"No")
;
SELF(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes"
Q "No"
SDM(P,BDATE,EDATE) ;EP
NEW T,APCL,E 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(%,"APCL(")
;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(APCL(X)) Q:X'=+X!(G) S V=$P(APCL(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 APCL,% S %=P_"^LAST ADA [DM AUDIT PERIDONTAL ADA CODES;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes "_$$FMTE^XLFDT($P(APCL(1),U))
K APCL
S %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
NEW X,Y S X=0,Y=0 F S X=$O(APCL(X)) Q:X'=+X!(Y) I $$CLINIC^APCLV($P(APCL(X),U,5),"C")=56 S Y=1
I Y Q "Yes - clinic 56 visit"
Q "No"
;
ASPIRIN(P,BDATE,EDATE) ;EP
NEW X,APCL,E
S X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
I $D(APCL(1)) Q "Yes"
Q "No"
;
TOBACCO(P,EDATE) ;EP
I '$G(P) Q ""
NEW APCLTOB,APCL,X,E
D TOBACCO3
I $D(APCLTOB) Q APCLTOB
D TOBACCO0
I $D(APCLTOB) Q APCLTOB
D TOBACCO1 ;check Problem file for tobacco use
I $D(APCLTOB) Q APCLTOB
D TOBACCO2 ;check POVs for tobacco use
I $D(APCLTOB) Q APCLTOB
Q "4 Not Documented "
TOBACCO0 ;check for tobacco documented in health factors
K APCL S X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
. I $P(APCL(1),U,3)["NON" S APCLTOB="2 Never used" Q
. I $P(APCL(1),U,3)["PREVIOUS" S APCLTOB="3 Past use" Q
. S APCLTOB="1 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 APCLTOB=Y
I Y["NON" S APCLTOB="2 Never used" Q
I Y["PREVIOUS" S APCLTOB="3 Past use" Q
S APCLTOB="1 Current user"
Q
TOBACCO1 ;check problem file for tobacco use
K APCL S X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
. ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB="3 Past use"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 orig line
. I $P($$ICDDX^ICDCODE($P(APCL(1),U,2)),U,2)=305.13 S APCLTOB="3 Past use"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 csv
. S APCLTOB="1 Current user - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(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 APCL S X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") Q:E I $D(APCL(1)) D
. I $P(APCL(1),U,2)=305.13 S APCLTOB="3 Past use"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30) Q
. S APCLTOB="1 Current user"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(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^APCLD998(P,BD,EDATE)
I X]"" S STR=STR_"2"
S X=$$SULF^APCLD998(P,BD,EDATE)
I X]"" S STR=STR_3
S X=$$MET^APCLD998(P,BD,EDATE)
I X]"" S STR=STR_4
S X=$$ACAR^APCLD998(P,BD,EDATE)
I X]"" S STR=STR_5
S X=$$TROG^APCLD998(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^APCLD997(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^APCLD997(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^APCLD997(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^APCLD997(P,R,"ID")
I DATE]"" S EARLY=DATE
S DATE=$$PLDMDOO^APCLD997(P,"I")
I DATE]"",DATE<EARLY S EARLY=DATE
S DATE=$$FRSTDMDX^APCLD997(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))_"/"_$E(D,2,3)
APCLD996 ; IHS/CMI/LAB - 1999 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
+4 ;
TBCODE(P,EDATE,R) ;EP
+1 NEW APCLJ,APCLI
+2 SET APCLJ=""
+3 ;return computed TB Status Code
+4 SET X=$$TBTX^APCLD998(P)
+5 IF X]""
IF X["TX COMPLETE"
QUIT 1
+6 IF X]""
QUIT 2
+7 IF $$PPD^APCLD998(P,EDATE)["POS"
Begin DoDot:1
+8 IF $$TBTX^APCLD998(P)["TX COMPLETE"
SET APCLJ=1
QUIT
+9 SET APCLJ=2
+10 QUIT
End DoDot:1
QUIT APCLJ
+11 IF $$PPD^APCLD998(P,EDATE)["NEG"
SET APCLJ=4
Begin DoDot:1
+12 IF $$DODX(P,R,"I")=""
SET APCLJ=5
QUIT
+13 SET D=$$DODX(P,R,"I")
SET E=$$PPD^APCLD998(P,EDATE,"I")
SET APCLJ=$SELECT(D>E:4,1:3)
+14 QUIT
End DoDot:1
QUIT APCLJ
+15 SET APCLJ=6
+16 QUIT APCLJ
+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
5 ;;PPD -, DM dx date unknown
6 ;;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^APCLD997(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^APCLD997(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^APCLD998(P,EDATE)
+2 QUIT X
FLU(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,E
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET BD=Y
+3 SET BD=$$FMADD^XLFDT(BD,-(15*30))
SET BD=$$FMTE^XLFDT(BD)
+4 SET X=P_"^LAST IMM "_$SELECT($$BI:88,1:12)_";DURING "_BD_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+5 IF $DATA(APCL(1))
QUIT "Yes-"_$$FMTE^XLFDT($PIECE(APCL(1),U))
+6 IF $$REFUSAL^APCLD997(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:88,1:12),0)),BD,EDATE)
QUIT "Refused"
+7 QUIT "No"
PNEU(P,EDATE) ;EP
+1 NEW APCL,X,E
+2 SET X=P_"^LAST IMM "_$SELECT($$BI:33,1:19)_";DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "Yes - "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+4 IF $$REFUSAL^APCLD997(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE)
QUIT "Refused"
+5 QUIT "No"
TD(P,EDATE) ;EP
+1 NEW APCL,X,E,B,%DT,Y,TDD
+2 SET %DT="P"
SET X=EDATE
DO ^%DT
SET B=Y
+3 SET X=P_"^LAST IMM "_$SELECT($$BI:9,1:"02")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+4 IF $DATA(APCL(1))
SET TDD($PIECE(APCL(1),U))=""
+5 KILL APCL
SET X=P_"^LAST IMM "_$SELECT($$BI:1,1:"03")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+6 IF $DATA(APCL(1))
SET TDD($PIECE(APCL(1),U))=""
+7 KILL APCL
SET X=P_"^LAST IMM "_$SELECT($$BI:28,1:"34")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+8 IF $DATA(APCL(1))
SET TDD($PIECE(APCL(1),U))=""
+9 KILL APCL
SET X=P_"^LAST IMM "_$SELECT($$BI:20,1:"42")_";DURING "_$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+10 IF $DATA(APCL(1))
SET TDD($PIECE(APCL(1),U))=""
+11 KILL APCL
SET APCL=""
SET X=0
FOR
SET X=$ORDER(TDD(X))
IF X'=+X
QUIT
SET APCL=X
+12 IF APCL]""
QUIT "Yes - "_$$FMTE^XLFDT(APCL)
+13 SET B=$$FMTE^XLFDT($$FMADD^XLFDT(B,-3653))
+14 IF $$REFUSAL^APCLD997(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:9,1:"02"),0)),B,EDATE)
QUIT "Refused"
+15 IF $$REFUSAL^APCLD997(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:1,1:"03"),0)),B,EDATE)
QUIT "Refused"
+16 IF $$REFUSAL^APCLD997(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:28,1:34),0)),B,EDATE)
QUIT "Refused"
+17 IF $$REFUSAL^APCLD997(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:20,1:42),0)),B,EDATE)
QUIT "Refused"
+18 QUIT "No"
+19 ;
ACE(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E,X,Y,%DT,BD
+2 SET X=P_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(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 QUIT $SELECT(%]"":"Yes",1:"No")
+11 ;
SELF(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^MEDS [DM AUDIT SELF MONITOR DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "Yes"
+4 QUIT "No"
SDM(P,BDATE,EDATE) ;EP
+1 NEW T,APCL,E
SET T=$ORDER(^ATXAX("B","DM AUDIT SDM PROVIDERS",0))
+2 IF 'T
QUIT ""
+3 SET %=P_"^ALL DX [SURVEILLANCE DIABETES;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+4 ;check to see if one of the providers was the primary prov
+5 NEW X,V,G,P,P1
SET (G,X)=0
FOR
SET X=$ORDER(APCL(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(APCL(X),U,5)
Begin DoDot:1
+6 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
+7 QUIT
End DoDot:1
+8 QUIT $SELECT(G:"Yes",1:"No")
PERI(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW APCL,%
SET %=P_"^LAST ADA [DM AUDIT PERIDONTAL ADA CODES;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "Yes "_$$FMTE^XLFDT($PIECE(APCL(1),U))
+4 KILL APCL
+5 SET %=P_"^ALL VISITS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+6 NEW X,Y
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")=56
SET Y=1
+7 IF Y
QUIT "Yes - clinic 56 visit"
+8 QUIT "No"
+9 ;
ASPIRIN(P,BDATE,EDATE) ;EP
+1 NEW X,APCL,E
+2 SET X=P_"^MEDS [DM AUDIT ASPIRIN DRUGS"_";DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+3 IF $DATA(APCL(1))
QUIT "Yes"
+4 QUIT "No"
+5 ;
TOBACCO(P,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW APCLTOB,APCL,X,E
+3 DO TOBACCO3
+4 IF $DATA(APCLTOB)
QUIT APCLTOB
+5 DO TOBACCO0
+6 IF $DATA(APCLTOB)
QUIT APCLTOB
+7 ;check Problem file for tobacco use
DO TOBACCO1
+8 IF $DATA(APCLTOB)
QUIT APCLTOB
+9 ;check POVs for tobacco use
DO TOBACCO2
+10 IF $DATA(APCLTOB)
QUIT APCLTOB
+11 QUIT "4 Not Documented "
TOBACCO0 ;check for tobacco documented in health factors
+1 ;S APCLTOBN=$O(APCLTOB("")),APCLTOB=APCLTOB(APCLTOBN)
KILL APCL
SET X=P_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+2 IF $PIECE(APCL(1),U,3)["NON"
SET APCLTOB="2 Never used"
QUIT
+3 IF $PIECE(APCL(1),U,3)["PREVIOUS"
SET APCLTOB="3 Past use"
QUIT
+4 SET APCLTOB="1 Current user"
+5 QUIT
End DoDot:1
+6 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 APCLTOB=Y
+7 IF Y["NON"
SET APCLTOB="2 Never used"
QUIT
+8 IF Y["PREVIOUS"
SET APCLTOB="3 Past use"
QUIT
+9 SET APCLTOB="1 Current user"
+10 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 KILL APCL
SET X=P_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+2 ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB="3 Past use"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(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(APCL(1),U,2)),U,2)=305.13
SET APCLTOB="3 Past use"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30)
QUIT
+4 SET APCLTOB="1 Current user - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(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 APCL
SET X=P_"^LAST DX [DM AUDIT SMOKING RELATED DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
IF E
QUIT
IF $DATA(APCL(1))
Begin DoDot:1
+5 IF $PIECE(APCL(1),U,2)=305.13
SET APCLTOB="3 Past use"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30)
QUIT
+6 SET APCLTOB="1 Current user"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(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^APCLD998(P,BD,EDATE)
+5 IF X]""
SET STR=STR_"2"
+6 SET X=$$SULF^APCLD998(P,BD,EDATE)
+7 IF X]""
SET STR=STR_3
+8 SET X=$$MET^APCLD998(P,BD,EDATE)
+9 IF X]""
SET STR=STR_4
+10 SET X=$$ACAR^APCLD998(P,BD,EDATE)
+11 IF X]""
SET STR=STR_5
+12 SET X=$$TROG^APCLD998(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^APCLD997(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^APCLD997(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^APCLD997(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^APCLD997(P,R,"ID")
+5 IF DATE]""
SET EARLY=DATE
+6 SET DATE=$$PLDMDOO^APCLD997(P,"I")
+7 IF DATE]""
IF DATE<EARLY
SET EARLY=DATE
+8 SET DATE=$$FRSTDMDX^APCLD997(P,"I")
+9 IF DATE]""
IF DATE<EARLY
SET EARLY=DATE
+10 IF EARLY=9999999
SET EARLY=""
+11 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))_"/"_$EXTRACT(D,2,3)
