- 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
