BHSDM6 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;04-Aug-2011 14:33;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6**;March 17, 2006;Build 5
;===================================================================
;Taken from APCHS9B6
;VA version of IHS components for supplemental summaries
; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 02/20/04 1:53 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**8,11,12**;JUN 24, 1997
;Patch 1 updates up to IHS patch 14
;Patch 2 code set versioning
;Patch 6 updated for tobacco changes
;===================================================================
DENTAL(P,APCHSED) ;EP
NEW BHSY,DENTDATE,E
K BHSY,DENTDATE
NEW % S %=P_"^LAST EXAM DENTAL",E=$$START1^APCLDF(%,"BHSY(")
S %=$P($G(BHSY(1)),U) I %]"" S DENTDATE=%
I %]"",%>APCHSED Q "Yes "_$$FMTE^XLFDT(%)_" (Dental Exam 30 recorded)"
K BHSY S %=P_"^LAST ADA [APCH DM ADA EXAMS",E=$$START1^APCLDF(%,"BHSY(")
S %=$P($G(BHSY(1)),U) I %]"",%>APCHSED Q "Yes "_$$FMTE^XLFDT(%)_" (Dental ADA exam code recorded)"
K BHSY,APCHV,^TMP($J,"DENTAL VISITS")
S BHSY="^TMP($J,""DENTAL VISITS"",",%=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT),E=$$START1^APCLDF(%,BHSY)
;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^BHSDM4(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^BHSDM4(V) S G=9999999-D
I G]"" Q "Maybe "_$$FMTE^XLFDT(G)_" (Dental Clinic Visit)"
S G=$$REFDF^BHSDM3(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^BHSDM4(V) S G=9999999-D
I G]"" Q "Patient Refused service (ada 9991) on "_$$FMTE^XLFDT(G)
Q "No "_$S($D(DENTDATE):$$FMTE^XLFDT(DENTDATE),1:"")
;
TOBACCO ;EP
K BHDTOB
;D TOBACCO3
;I $D(BHDTOB) Q
D TOBACCO0
I $D(BHDTOB) Q
D TOBACCO3
I $D(BHDTOB) Q
D TOBACCO1 ;check Problem file for tobacco use
I $D(BHDTOB) Q
D TOBACCO2 ;check POVs for tobacco use
I $D(BHDTOB) Q
S BHDTOB="UNDOCUMENTED",BHDTOB="UNDOCUMENTED"
Q
TOBACCO0 ;check for tobacco documented in health factors
;S X=$$LASTHF^BHSMU(BHSDFN,"TOBACCO","B") I X]"" S BHDTOB=X
NEW CTGN,HF,HFDT,LIST,RESULT,X,BTIU,BHST,CTG
I '$G(DFN) Q ""
F BHST=1:1 D Q:CTG=""
.S CTG=$P($T(TOBU+BHST),";;",2)
.Q:CTG=""
.S CTGN=$O(^AUTTHF("B",CTG,0)) I 'CTGN Q ;ien of category passed
.;
.S HF=0
.F S HF=$O(^AUTTHF("AC",CTGN,HF)) Q:'+HF D ;find health factors in category
..Q:'$D(^AUPNVHF("AA",DFN,HF)) ;quit if patient doesn't have health factor
..S HFDT=$O(^AUPNVHF("AA",DFN,HF,"")) Q:'HFDT ;get visit date for health factor
..S LIST(HFDT)=$O(^AUPNVHF("AA",DFN,HF,HFDT,"")) ;store iens by date
;
I '$O(LIST(0)) Q
S HFDT=$O(LIST(0)) ;find latest date (inverse dates)
S RESULT=$$GET1^DIQ(9000010.23,LIST(HFDT),.01)
S BHDTOB=RESULT_" "_$$FMTE^XLFDT(9999999-HFDT)
Q
TOBU ;;
;;TOBACCO (EXPOSURE)
;;TOBACCO (SMOKELESS - CHEWING/DIP)
;;TOBACCO (SMOKING)
;
Q
TOBACCO3 ;lookup in health status
N C
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",BHSDFN,H))
. S D=$O(^AUPNHF("AA",BHSDFN,H,""))
. Q:'D
. S O(D)=$O(^AUPNHF("AA",BHSDFN,H,D,""))
. Q
S D=$O(O(0))
I D="" Q
S BHDTOB=$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))
Q
TOBACCO1 ;check problem file for tobacco use
K APCH,APCHX
S APCHX=BHSDFN_"^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 BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q
. I $$ICDDX^ICDCODE($P(APCH(1),U,2),U,2)=305.13 S BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q ;code set versioning cmi/anch/maw 8/27/2007 code set versioning
. S BHDTOB="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=BHSDFN_"^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 BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCH(1),U,4),0),U,4),0),U),1,30) Q
. S BHDTOB="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>71019&(Y<71040),V>LCHEST S LCHEST=V Q
S T=71019 F S T=$O(^ICPT("B",T)) Q:T>71039 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 BHSY S %=P_"^LAST PROCEDURE 87.44",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)),$P(BHSY(1),U)>LCHEST S LCHEST=$P(BHSY(1),U)
K BHSY S %=P_"^LAST PROCEDURE 87.39",E=$$START1^APCLDF(%,"BHSY(")
I $D(BHSY(1)),$P(BHSY(1),U)>LCHEST S LCHEST=$P(BHSY(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
BHSDM6 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;04-Aug-2011 14:33;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,6**;March 17, 2006;Build 5
+2 ;===================================================================
+3 ;Taken from APCHS9B6
+4 ;VA version of IHS components for supplemental summaries
+5 ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 02/20/04 1:53 PM ]
+6 ;;2.0;IHS RPMS/PCC Health Summary;**8,11,12**;JUN 24, 1997
+7 ;Patch 1 updates up to IHS patch 14
+8 ;Patch 2 code set versioning
+9 ;Patch 6 updated for tobacco changes
+10 ;===================================================================
DENTAL(P,APCHSED) ;EP
+1 NEW BHSY,DENTDATE,E
+2 KILL BHSY,DENTDATE
+3 NEW %
SET %=P_"^LAST EXAM DENTAL"
SET E=$$START1^APCLDF(%,"BHSY(")
+4 SET %=$PIECE($GET(BHSY(1)),U)
IF %]""
SET DENTDATE=%
+5 IF %]""
IF %>APCHSED
QUIT "Yes "_$$FMTE^XLFDT(%)_" (Dental Exam 30 recorded)"
+6 KILL BHSY
SET %=P_"^LAST ADA [APCH DM ADA EXAMS"
SET E=$$START1^APCLDF(%,"BHSY(")
+7 SET %=$PIECE($GET(BHSY(1)),U)
IF %]""
IF %>APCHSED
QUIT "Yes "_$$FMTE^XLFDT(%)_" (Dental ADA exam code recorded)"
+8 KILL BHSY,APCHV,^TMP($JOB,"DENTAL VISITS")
+9 SET BHSY="^TMP($J,""DENTAL VISITS"","
SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(APCHSED)_"-"_$$FMTE^XLFDT(DT)
SET E=$$START1^APCLDF(%,BHSY)
+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^BHSDM4(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^BHSDM4(V)
SET G=9999999-D
+16 IF G]""
QUIT "Maybe "_$$FMTE^XLFDT(G)_" (Dental Clinic Visit)"
+17 SET G=$$REFDF^BHSDM3(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^BHSDM4(V)
SET G=9999999-D
+20 IF G]""
QUIT "Patient Refused service (ada 9991) on "_$$FMTE^XLFDT(G)
+21 QUIT "No "_$SELECT($DATA(DENTDATE):$$FMTE^XLFDT(DENTDATE),1:"")
+22 ;
TOBACCO ;EP
+1 KILL BHDTOB
+2 ;D TOBACCO3
+3 ;I $D(BHDTOB) Q
+4 DO TOBACCO0
+5 IF $DATA(BHDTOB)
QUIT
+6 DO TOBACCO3
+7 IF $DATA(BHDTOB)
QUIT
+8 ;check Problem file for tobacco use
DO TOBACCO1
+9 IF $DATA(BHDTOB)
QUIT
+10 ;check POVs for tobacco use
DO TOBACCO2
+11 IF $DATA(BHDTOB)
QUIT
+12 SET BHDTOB="UNDOCUMENTED"
SET BHDTOB="UNDOCUMENTED"
+13 QUIT
TOBACCO0 ;check for tobacco documented in health factors
+1 ;S X=$$LASTHF^BHSMU(BHSDFN,"TOBACCO","B") I X]"" S BHDTOB=X
+2 NEW CTGN,HF,HFDT,LIST,RESULT,X,BTIU,BHST,CTG
+3 IF '$GET(DFN)
QUIT ""
+4 FOR BHST=1:1
Begin DoDot:1
+5 SET CTG=$PIECE($TEXT(TOBU+BHST),";;",2)
+6 IF CTG=""
QUIT
+7 ;ien of category passed
SET CTGN=$ORDER(^AUTTHF("B",CTG,0))
IF 'CTGN
QUIT
+8 ;
+9 SET HF=0
+10 ;find health factors in category
FOR
SET HF=$ORDER(^AUTTHF("AC",CTGN,HF))
IF '+HF
QUIT
Begin DoDot:2
+11 ;quit if patient doesn't have health factor
IF '$DATA(^AUPNVHF("AA",DFN,HF))
QUIT
+12 ;get visit date for health factor
SET HFDT=$ORDER(^AUPNVHF("AA",DFN,HF,""))
IF 'HFDT
QUIT
+13 ;store iens by date
SET LIST(HFDT)=$ORDER(^AUPNVHF("AA",DFN,HF,HFDT,""))
End DoDot:2
End DoDot:1
IF CTG=""
QUIT
+14 ;
+15 IF '$ORDER(LIST(0))
QUIT
+16 ;find latest date (inverse dates)
SET HFDT=$ORDER(LIST(0))
+17 SET RESULT=$$GET1^DIQ(9000010.23,LIST(HFDT),.01)
+18 SET BHDTOB=RESULT_" "_$$FMTE^XLFDT(9999999-HFDT)
+19 QUIT
TOBU ;;
+1 ;;TOBACCO (EXPOSURE)
+2 ;;TOBACCO (SMOKELESS - CHEWING/DIP)
+3 ;;TOBACCO (SMOKING)
+4 ;
+5 QUIT
TOBACCO3 ;lookup in health status
+1 NEW C
+2 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO",0))
+3 IF '$GET(C)
QUIT
+4 NEW H,D,O
SET H=0
KILL O
+5 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNHF("AA",BHSDFN,H))
QUIT
+7 SET D=$ORDER(^AUPNHF("AA",BHSDFN,H,""))
+8 IF 'D
QUIT
+9 SET O(D)=$ORDER(^AUPNHF("AA",BHSDFN,H,D,""))
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(O(0))
+12 IF D=""
QUIT
+13 SET BHDTOB=$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$FMTE^XLFDT((9999999-D))
+14 QUIT
TOBACCO1 ;check problem file for tobacco use
+1 KILL APCH,APCHX
+2 SET APCHX=BHSDFN_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
SET E=$$START1^APCLDF(APCHX,"APCH(")
IF E
QUIT
IF $DATA(APCH(1))
Begin DoDot:1
+3 ;I $P(^ICD9($P(APCH(1),U,2),0),U,1)=305.13 S BHDTOB="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCH(1),U,4),0),U,5),0),U),1,30) Q
+4 ;code set versioning cmi/anch/maw 8/27/2007 code set versioning
IF $$ICDDX^ICDCODE($PIECE(APCH(1),U,2),U,2)=305.13
SET BHDTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)
QUIT
+5 SET BHDTOB="YES, USES TOBACCO - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCH(1),U,4),0),U,5),0),U),1,30)
+6 QUIT
End DoDot:1
+7 QUIT
TOBACCO2 ;check pov file for TOBACCO USE DOC
+1 KILL APCH
SET APCHX=BHSDFN_"^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 BHDTOB="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCH(1),U,4),0),U,4),0),U),1,30)
QUIT
+3 SET BHDTOB="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>71019&(Y<71040)
IF V>LCHEST
SET LCHEST=V
QUIT
End DoDot:1
+9 SET T=71019
FOR
SET T=$ORDER(^ICPT("B",T))
IF T>71039
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 BHSY
SET %=P_"^LAST PROCEDURE 87.44"
SET E=$$START1^APCLDF(%,"BHSY(")
+13 IF $DATA(BHSY(1))
IF $PIECE(BHSY(1),U)>LCHEST
SET LCHEST=$PIECE(BHSY(1),U)
+14 KILL BHSY
SET %=P_"^LAST PROCEDURE 87.39"
SET E=$$START1^APCLDF(%,"BHSY(")
+15 IF $DATA(BHSY(1))
IF $PIECE(BHSY(1),U)>LCHEST
SET LCHEST=$PIECE(BHSY(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
