APCHS9B6 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 8/28/2007 code set versioning in TOBACCO1
;
DENTAL(P,APCHSED) ;EP
NEW APCHY,DENTDATE
K APCHY,DENTDATE
NEW % S %=P_"^LAST EXAM DENTAL",E=$$START1^APCLDF(%,"APCHY(")
S %=$P($G(APCHY(1)),U) I %]"" S DENTDATE=%
I %]"",%>APCHSED Q "Yes "_$$FMTE^XLFDT(%)_" (Dental Exam 30 recorded)"
K APCHY S %=P_"^LAST ADA [APCH DM ADA EXAMS",E=$$START1^APCLDF(%,"APCHY(")
S %=$P($G(APCHY(1)),U) I %]"",%>APCHSED Q "Yes "_$$FMTE^XLFDT(%)_" (Dental ADA exam code recorded)"
K APCHY,APCHV,^TMP($J,"DENTAL VISITS")
S APCHY="^TMP($J,""DENTAL VISITS"",",%=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,APCHY)
;reorder by date of visit/reverse order
S %=0 F S %=$O(^TMP($J,"DENTAL VISITS",%)) Q:%'=+% S APCHV(9999999-$P(^TMP($J,"DENTAL VISITS",%),U),$P(^TMP($J,"DENTAL VISITS",%),U,5))=""
K ^TMP($J,"DENTAL VISITS")
N PROV,D,V,G S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$PRIMPROV^APCLV(V,"D") I PROV=52,$$ADA(V),'$$DNKA^APCHS9B4(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Dentist)"
S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$CLINIC^APCLV(V,"C") I (PROV=56!(PROV=99)),$$ADA(V),'$$DNKA^APCHS9B4(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Dental Clinic Visit)"
S G=$$REFDF^APCHS9B3(P,9999999.15,$O(^AUTTEXAM("B","DENTAL EXAM",0)),$G(DENTDATE))
I G]"" Q G
S (D,V)=0,G="" F S D=$O(APCHV(D)) Q:D'=+D!(G) S V=0 F S V=$O(APCHV(D,V)) Q:V'=+V!(G) S PROV=$$CLINIC^APCLV(V,"C") I (PROV=56!(PROV=99)),$D(^AUPNVDEN("AD",V)),'$$ADA(V),'$$DNKA^APCHS9B4(V) S G=9999999-D
I G]"" Q "Patient Declined service (ada 9991) on "_$$FMTE^XLFDT(G)
Q "No "_$S($D(DENTDATE):$$FMTE^XLFDT(DENTDATE),1:"")
;
TOBACCO ;EP
K APCHTOB
;D TOBACCO3
;I $D(APCHTOB) Q
D TOBACCO0
I $D(APCHTOB) Q
D TOBACCO3
I $D(APCHTOB) Q
D TOBACCO1 ;check Problem file for tobacco use
I $D(APCHTOB) Q
D TOBACCO2 ;check POVs for tobacco use
I $D(APCHTOB) Q
S APCHTOB="UNDOCUMENTED",APCHTOB="UNDOCUMENTED"
Q
TOBACCO0 ;check for tobacco documented in health factors
S X=$$LASTHF^APCHSMU(APCHSDFN,"TOBACCO","B") I X]"" S APCHTOB=X
Q
TOBACCO3 ;lookup in health status
S C=$O(^AUTTHF("B","TOBACCO",0)) ;ien of category passed
I '$G(C) Q
NEW H,D,O S H=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
. Q:'$D(^AUPNHF("AA",APCHSDFN,H))
. S D=$O(^AUPNHF("AA",APCHSDFN,H,""))
. Q:'D
. S O(D)=$O(^AUPNHF("AA",APCHSDFN,H,D,""))
. Q
S D=$O(O(0))
I D="" Q
S APCHTOB=$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))
Q
TOBACCO1 ;check problem file for tobacco use
K APCH S APCHX=APCHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E I $D(APCH(1)) D
. ;I $P(^ICD9($P(APCH(1),U,2),0),U,1)=305.13 S APCHTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q cmi/anch/maw 8/27/2007 orig line
. I $P($$ICDDX^ICDEX($P(APCH(1),U,2),,,"I"),U,2)=305.13 S APCHTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 8/27/2007 code set versioning
. S APCHTOB="YES, USES TOBACCO - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30)
.Q
Q
TOBACCO2 ;check pov file for TOBACCO USE DOC
K APCH S APCHX=APCHSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS" S E=$$START1^APCLDF(APCHX,"APCH(") Q:E I $D(APCH(1)) D
. I $P(APCH(1),U,2)=305.13 S APCHTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30) Q
. S APCHTOB="YES, USES TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30)
.Q
Q
;
CHEST(P) ;EP - get date of last chest xray from V RAD or V CPT
;FIX ALL RAD LOOKUPS TO LOOP THROUGH GLOBAL
I $G(P)="" Q ""
NEW X,Y,Z,G,LCHEST,T,D
S LCHEST=""
S (X,Y,V)=0 F S X=$O(^AUPNVRAD("AC",P,X)) Q:X'=+X D
.S V=$P(^AUPNVRAD(X,0),U,3),V=$P($P($G(^AUPNVSIT(V,0)),U),".")
.S Y=$P(^AUPNVRAD(X,0),U),Y=$P($G(^RAMIS(71,Y,0)),U,9)
.I Y>71009&(Y<71036),V>LCHEST S LCHEST=V Q
S T=71009 F S T=$O(^ICPT("B",T)) Q:T>71035 S X=0 F S X=$O(^ICPT("B",T,X)) Q:X'=+X D
.S D=$O(^AUPNVCPT("AA",P,X,0)) I D S D=9999999-D
.I D,D>LCHEST S LCHEST=D
K APCHY S %=P_"^LAST PROCEDURE 87.44",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)),$P(APCHY(1),U)>LCHEST S LCHEST=$P(APCHY(1),U)
K APCHY S %=P_"^LAST PROCEDURE 87.39",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)),$P(APCHY(1),U)>LCHEST S LCHEST=$P(APCHY(1),U)
Q $S(LCHEST]"":$$FMTE^XLFDT(LCHEST),1:"")
ADA(V) ;any ada other than 9991
I '$G(V) Q ""
NEW X,Y,Z,G
S G="",X=0 F S X=$O(^AUPNVDEN("AD",V,X)) Q:X'=+X!(G) S Y=$P($G(^AUPNVDEN(X,0)),U) I Y,$D(^AUTTADA(Y,0)),$P(^AUTTADA(Y,0),U)'=9991 S G=1
Q G
APCHS9B6 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
+1 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 8/28/2007 code set versioning in TOBACCO1
+4 ;
DENTAL(P,APCHSED) ;EP
+1 NEW APCHY,DENTDATE
+2 KILL APCHY,DENTDATE
+3 NEW %
SET %=P_"^LAST EXAM DENTAL"
SET E=$$START1^APCLDF(%,"APCHY(")
+4 SET %=$PIECE($GET(APCHY(1)),U)
IF %]""
SET DENTDATE=%
+5 IF %]""
IF %>APCHSED
QUIT "Yes "_$$FMTE^XLFDT(%)_" (Dental Exam 30 recorded)"
+6 KILL APCHY
SET %=P_"^LAST ADA [APCH DM ADA EXAMS"
SET E=$$START1^APCLDF(%,"APCHY(")
+7 SET %=$PIECE($GET(APCHY(1)),U)
IF %]""
IF %>APCHSED
QUIT "Yes "_$$FMTE^XLFDT(%)_" (Dental ADA exam code recorded)"
+8 KILL APCHY,APCHV,^TMP($JOB,"DENTAL VISITS")
+9 SET APCHY="^TMP($J,""DENTAL VISITS"","
SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,APCHY)
+10 ;reorder by date of visit/reverse order
+11 SET %=0
FOR
SET %=$ORDER(^TMP($JOB,"DENTAL VISITS",%))
IF %'=+%
QUIT
SET APCHV(9999999-$PIECE(^TMP($JOB,"DENTAL VISITS",%),U),$PIECE(^TMP($JOB,"DENTAL VISITS",%),U,5))=""
+12 KILL ^TMP($JOB,"DENTAL VISITS")
+13 NEW PROV,D,V,G
SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$PRIMPROV^APCLV(V,"D")
IF PROV=52
IF $$ADA(V)
IF '$$DNKA^APCHS9B4(V)
SET G=9999999-D
+14 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Visit to Dentist)"
+15 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$CLINIC^APCLV(V,"C")
IF (PROV=56!(PROV=99))
IF $$ADA(V)
IF '$$DNKA^APCHS9B4(V)
SET G=9999999-D
+16 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Dental Clinic Visit)"
+17 SET G=$$REFDF^APCHS9B3(P,9999999.15,$ORDER(^AUTTEXAM("B","DENTAL EXAM",0)),$GET(DENTDATE))
+18 IF G]""
QUIT G
+19 SET (D,V)=0
SET G=""
FOR
SET D=$ORDER(APCHV(D))
IF D'=+D!(G)
QUIT
SET V=0
FOR
SET V=$ORDER(APCHV(D,V))
IF V'=+V!(G)
QUIT
SET PROV=$$CLINIC^APCLV(V,"C")
IF (PROV=56!(PROV=99))
IF $DATA(^AUPNVDEN("AD",V))
IF '$$ADA(V)
IF '$$DNKA^APCHS9B4(V)
SET G=9999999-D
+20 IF G]""
QUIT "Patient Declined service (ada 9991) on "_$$FMTE^XLFDT(G)
+21 QUIT "No "_$SELECT($DATA(DENTDATE):$$FMTE^XLFDT(DENTDATE),1:"")
+22 ;
TOBACCO ;EP
+1 KILL APCHTOB
+2 ;D TOBACCO3
+3 ;I $D(APCHTOB) Q
+4 DO TOBACCO0
+5 IF $DATA(APCHTOB)
QUIT
+6 DO TOBACCO3
+7 IF $DATA(APCHTOB)
QUIT
+8 ;check Problem file for tobacco use
DO TOBACCO1
+9 IF $DATA(APCHTOB)
QUIT
+10 ;check POVs for tobacco use
DO TOBACCO2
+11 IF $DATA(APCHTOB)
QUIT
+12 SET APCHTOB="UNDOCUMENTED"
SET APCHTOB="UNDOCUMENTED"
+13 QUIT
TOBACCO0 ;check for tobacco documented in health factors
+1 SET X=$$LASTHF^APCHSMU(APCHSDFN,"TOBACCO","B")
IF X]""
SET APCHTOB=X
+2 QUIT
TOBACCO3 ;lookup in health status
+1 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO",0))
+2 IF '$GET(C)
QUIT
+3 NEW H,D,O
SET H=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNHF("AA",APCHSDFN,H))
QUIT
+6 SET D=$ORDER(^AUPNHF("AA",APCHSDFN,H,""))
+7 IF 'D
QUIT
+8 SET O(D)=$ORDER(^AUPNHF("AA",APCHSDFN,H,D,""))
+9 QUIT
End DoDot:1
+10 SET D=$ORDER(O(0))
+11 IF D=""
QUIT
+12 SET APCHTOB=$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))
+13 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 KILL APCH
SET APCHX=APCHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(APCHX,"APCH(")
IF E
QUIT
IF $DATA(APCH(1))
Begin DoDot:1
+2 ;I $P(^ICD9($P(APCH(1),U,2),0),U,1)=305.13 S APCHTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q cmi/anch/maw 8/27/2007 orig line
+3 ;cmi/anch/maw 8/27/2007 code set versioning
IF $PIECE($$ICDDX^ICDEX($PIECE(APCH(1),U,2),,,"I"),U,2)=305.13
SET APCHTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)
QUIT
+4 SET APCHTOB="YES, USES TOBACCO - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(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 KILL APCH
SET APCHX=APCHSDFN_"^LAST DX [DM AUDIT SMOKING RELATED DXS"
SET E=$$START1^APCLDF(APCHX,"APCH(")
IF E
QUIT
IF $DATA(APCH(1))
Begin DoDot:1
+2 IF $PIECE(APCH(1),U,2)=305.13
SET APCHTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)
QUIT
+3 SET APCHTOB="YES, USES TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
CHEST(P) ;EP - get date of last chest xray from V RAD or V CPT
+1 ;FIX ALL RAD LOOKUPS TO LOOP THROUGH GLOBAL
+2 IF $GET(P)=""
QUIT ""
+3 NEW X,Y,Z,G,LCHEST,T,D
+4 SET LCHEST=""
+5 SET (X,Y,V)=0
FOR
SET X=$ORDER(^AUPNVRAD("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET V=$PIECE(^AUPNVRAD(X,0),U,3)
SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+7 SET Y=$PIECE(^AUPNVRAD(X,0),U)
SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
+8 IF Y>71009&(Y<71036)
IF V>LCHEST
SET LCHEST=V
QUIT
End DoDot:1
+9 SET T=71009
FOR
SET T=$ORDER(^ICPT("B",T))
IF T>71035
QUIT
SET X=0
FOR
SET X=$ORDER(^ICPT("B",T,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET D=$ORDER(^AUPNVCPT("AA",P,X,0))
IF D
SET D=9999999-D
+11 IF D
IF D>LCHEST
SET LCHEST=D
End DoDot:1
+12 KILL APCHY
SET %=P_"^LAST PROCEDURE 87.44"
SET E=$$START1^APCLDF(%,"APCHY(")
+13 IF $DATA(APCHY(1))
IF $PIECE(APCHY(1),U)>LCHEST
SET LCHEST=$PIECE(APCHY(1),U)
+14 KILL APCHY
SET %=P_"^LAST PROCEDURE 87.39"
SET E=$$START1^APCLDF(%,"APCHY(")
+15 IF $DATA(APCHY(1))
IF $PIECE(APCHY(1),U)>LCHEST
SET LCHEST=$PIECE(APCHY(1),U)
+16 QUIT $SELECT(LCHEST]"":$$FMTE^XLFDT(LCHEST),1:"")
ADA(V) ;any ada other than 9991
+1 IF '$GET(V)
QUIT ""
+2 NEW X,Y,Z,G
+3 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNVDEN("AD",V,X))
IF X'=+X!(G)
QUIT
SET Y=$PIECE($GET(^AUPNVDEN(X,0)),U)
IF Y
IF $DATA(^AUTTADA(Y,0))
IF $PIECE(^AUTTADA(Y,0),U)'=9991
SET G=1
+4 QUIT G
