BGP3D71 ; IHS/CMI/LAB - measure C ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;
IC1 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
;denominator 1 is active clinical, 6 and older and overweight
S (BGPOW,BGPOB,BGPBMI)=""
K BGPALLED,BGPSN,BGPMN,BGPSPEX
I 'BGPACTUP S BGPSTOP=1 Q
S BGPBMI=$$BMI^BGP3D6(DFN,BGPEDATE,BGPAGEE)
S BGPOW=$$OW^BGP3D6(DFN,BGPBMI,BGPAGEE)
S BGPOB=$$OB^BGP3D6(DFN,BGPBMI,BGPAGEE)
S BGPOWOB=BGPOW+BGPOB
I BGPAGEB>5,BGPOWOB,BGPACTCL S BGPD1=1
I BGPDMD2 S BGPD2=1
I BGPAGEB>5,BGPOB,BGPACTCL S BGPD3=1
I BGPD3,BGPAGEB>5,BGPAGEB<12 S BGPD4=1
I BGPD3,BGPAGEB>11,BGPAGEB<20 S BGPD5=1
I BGPD3,BGPAGEB>19,BGPAGEB<40 S BGPD6=1
I BGPD3,BGPAGEB>39,BGPAGEB<60 S BGPD7=1
I BGPD3,BGPAGEB>59 S BGPD8=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) Q
S BGPVALUE=""
S BGPMN=$$MEDNUTRD^BGP3D711(DFN,BGP365,BGPEDATE) I BGPMN]"" S BGPN1=1
S BGPSN=$$SPECNUTR^BGP3D711(DFN,BGP365,BGPEDATE) I BGPSN]"" S BGPN2=1
S BGPSPEX=$$SPECEX^BGP3D711(DFN,BGP365,BGPEDATE) I BGPSPEX]"" S BGPN3=1
S BGPOTH=$$OTHREL^BGP3D711(DFN,BGP365,BGPEDATE) I BGPOTH]"" S BGPN4=1
I BGPMN]"" S BGPVALUE="MNT: "_$$DATE^BGP3UTL($P(BGPMN,U))_" "_$P(BGPMN,U,2)_$S(BGPMN]"":"; ",1:"")
I BGPSN]"" S BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP3UTL($P(BGPSN,U))_" "_$P(BGPSN,U,2)_$S(BGPSN]"":"; ",1:"")
I BGPSPEX]"" S BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP3UTL($P(BGPSPEX,U))_" "_$P(BGPSPEX,U,2)_$S(BGPSPEX]"":"; ",1:"")
I BGPOTH]"" S BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP3UTL($P(BGPOTH,U))_" "_$P(BGPOTH,U,2)
S V=$S(BGPD1:"AC-OW",1:"")
I BGPD3 S V=V_$S(V]"":",",1:"") S V=V_"AC-OB"
I BGPD2 S V=V_$S(V]"":",",1:"") S V=V_"AD" ;$S(BGPD2:"AD;",1:"")_$S(BGPD3:"OB",1:"")
S V=V_"|||"_BGPVALUE
S BGPVALUE=V
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALLED,BGPBMI,BGPOW,BGPOB,BGPOWOB,BGPMN,BGPSN,BGPSPEX
K ^TMP($J,"A")
Q
I19 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
S (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
I 'BGPACTUP S BGPSTOP=1 Q ;must be at least user pop
I BGPRTYPE=3,'BGPACTCL S BGPSTOP=1 Q ;for hedis, must be active clinical
I BGPRTYPE=7 D NEWSTUFF Q
S BGPTOBP=$$TOBACCO^BGP3D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1),1)
S BGPSDX=$$DX^BGP3D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGPSCPT=$$CPTSM^BGP3D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
;now get last of these
S %=""
;I BGPSDX]"",$P(BGPSDX,U)="V15.82" S %=1
;I BGPSDX]"",$P(BGPSDX,U)="305.13" S %=1
S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
I BGPSDX]"" S I=$P(BGPSDX,U,3) I $$ICD^ATXCHK(I,T,9) S %=1
S F=BGPTOBP
D
.I $P(F,U,1)["CURRENT"!($P(F,U,1)["CESSATION") S BGPD2=1 Q
.I $P(F,U,4)["CURRENT"!($P(F,U,4)["CESSATION") S BGPD2=1 Q
.I (BGPSDX]""&(%="")) S BGPD2=1 Q
.I ($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPD2=1 Q
.I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPD2=1 Q
I 'BGPD2 S BGPSTOP=1 Q ;last item documented is not a tobacco user
I BGPD2,BGPACTCL S BGPD1=1
I BGPD1,BGPAGEB<12 S BGPD3=1
I BGPD1,BGPAGEB>11,BGPAGEB<18 S BGPD4=1
I BGPD1,BGPAGEB>17 S BGPD5=1
I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q ;hedis must be active clinical
S BGPTC=$$PED^BGP3D711(DFN,BGP365,BGPEDATE)
;N1 is got education (incl Refusals)
;N2 is Refusal
;N11 is educ and no Refusal
;N3 is quit
;N6 is quit or educ w/o Refusals
I $P(BGPTC,U)]"" S BGPN1=1 I $P(BGPTC,U,2)["Ref" S BGPN2=1
I BGPN1,'BGPN2 S BGPN11=1
I BGPRTYPE'=3 D
.S BGPTOB=$$TOBACCO^BGP3D7(DFN,BGP365,BGPEDATE)
.I BGPTOB'["PREVIOUS" S BGPTOB=""
.S BGPSDXQ=$$DX^BGP3D7(DFN,BGP365,BGPEDATE)
.S BGPTQ="" I $P(BGPTOB,U)["PREVIOUS"!(+$P(BGPSDXQ,U)="305.13")!($P(BGPSDXQ,U)="V15.82") S BGPN3=1
.;I $P(BGPTOB,U)["CURRENT" S BGPN3=0 ;
I BGPN1!(BGPN3) S BGPN5=1 ;new numerator v8.0 patch 1
I BGPN11!(BGPN3) S BGPN6=1
I BGPRTYPE=3 S BGPN4=0,BGPTOM=$$TOMPED(DFN,BGP365,BGPEDATE) I BGPTOM S BGPN4=1
NXT ;
S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")
I BGPRTYPE'=7 D
.S BGPVALUE=BGPVALUE_"|||" D
..I BGPRTYPE'=1 S BGPVALUE=BGPVALUE_$S($P(BGPTC,U):"COUNSEL/RX: "_$$DATE^BGP3UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")
..I BGPRTYPE=1,BGPN11 S BGPVALUE=BGPVALUE_$S($P(BGPTC,U):"COUNSEL/RX: "_$$DATE^BGP3UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")
.I BGPN3,BGPRTYPE'=3 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") D
..S BGPVALUE=BGPVALUE_"QUIT: "_$S(BGPTOB]"":$P(BGPTOB,U,2)_" ",1:$$DATE^BGP3UTL($P(BGPSDXQ,U,2)))_$P(BGPTOB,U)_$S(+BGPSDXQ="305.13":" POV 305.13 ",$P(BGPSDXQ,U)="V15.82":" POV V15.82",1:"")
.I BGPN4,BGPRTYPE=3 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") D
..S BGPVALUE=BGPVALUE_"TO-M "_$$DATE^BGP3UTL($P(BGPTOM,U))
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC,BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD
Q
DNKA(V) ;EP - is this a DNKA visit?
NEW D,N
S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
TOMPED(P,BDATE,EDATE) ;EP
K BGPALLED
S BGPLPED=""
S Y="BGPALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPALLED(1)) S %="" D I %]"" S BGPLPED=%
.S (X,D)=0,T="" F S X=$O(BGPALLED(X)) Q:X'=+X D
..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I T'="TO-M" Q
..I $P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T
I BGPLPED]"" Q BGPLPED ;
TOMREF ;
;EP - now check all Refusals of these education topics
S G="",X=0 F S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"") D
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"") D
..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"") D
...S Z=$P($G(^AUPNPREF(I,0)),U,3)
...Q:Z=""
...I Z<BDATE Q
...I Z>EDATE Q
...S Y=$P($G(^AUTTEDT(X,0)),U,2)
...I Y'="TO-M" Q
...S G=Z_U_"Ref "_Y
Q G
GETALLHF ;
K BGPALLH
S C=$O(^AUTTHF("B","TOBACCO (SMOKING)",0)) ;ien of category passed
D GETHF1
;If it is a current or cessation, use it and quit
I $P(BGPTOBS,U,2)["CURRENT"!($P(BGPTOBS,U,2)["CESSATION") Q
S C=$O(^AUTTHF("B","TOBACCO (SMOKELESS - CHEWING/DIP)",0)) ;ien of category passed
D GETHF1
;If it is a current or cessation, use it and quit
I $P(BGPTOBS,U,2)["CURRENT"!($P(BGPTOBS,U,2)["CESSATION") Q
S C=$O(^AUTTHF("B","TOBACCO",0)) ;ien of category passed
D GETHF1
;If it is a current or cessation, use it and quit
I $P(BGPTOBS,U,2)["CURRENT"!($P(BGPTOBS,U,2)["CESSATION") Q
;now get lastest of any of the categories
S D=$O(BGPALLH(0))
I D S BGPTOBS=BGPALLH(D) Q
S BGPTOBS=""
Q
GETHF1 ;
I '$G(C) S BGPTOBS="" Q
NEW ED,BD
K BGPTOBS
S ED=BGPEDX
S BD=BGPBDX
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",DFN,H))
.S D="" F S D=$O(^AUPNVHF("AA",DFN,H,D)) Q:D'=+D D
..Q:(9999999-D)>ED ;after time frame
..Q:(9999999-D)<BD ;before time frame
..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["CESSATION" Q
..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["CURRENT SMOKE",$P(^AUTTHF(H,0),U)'["CESSATION" Q
..S BGPTOBS(D)=$O(^AUPNVHF("AA",DFN,H,D,""))_U_$P(^AUTTHF(H,0),U)
.Q
;NOW if there are multiples , take the USER one, if no USER ONE TAKE THE LATEST ONE
S BGPTOBS=""
S (D,H)=$O(BGPTOBS(0)) I 'D S BGPTOBS="" Q
S Y=0 F S Y=$O(BGPTOBS(Y)) Q:Y'=+Y D Q:BGPTOBS]""
.I $P(BGPTOBS(Y),U,2)["CESSATION"!($P(BGPTOBS(Y),U,2)["CURRENT") S BGPTOBS=BGPTOBS(Y)_U_(9999999-Y),BGPALLH(Y)=BGPTOBS(Y)_U_(9999999-Y)
Q:BGPTOBS]""
S D=BGPTOBS(D)_U_(9999999-D)
K BGPTOBS
S BGPTOBS=D,BGPALLH(H)=D
Q
QUIT(P,BD,ED) ;
NEW Y,X,G,T
S Y=$$LASTDX^BGP3UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
I Y Q 1_U_"QUIT: "_$$DATE^BGP3UTL($P(Y,U,3))_" POV "_$P(Y,U,2)
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:$P(^AUPNPROB(X,0),U,3)>ED
.Q:$P(^AUPNPROB(X,0),U,3)<BD
.S Y=$P(^AUPNPROB(X,0),U)
.S T=$P($$ICDDX^ICDCODE(Y),U,2)
.I '$$ICD^ATXCHK(Y,$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9) Q
.S G=1_U_"QUIT: "_$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,3))_" PL "_$P(^ICD9(Y,0),U)
I G Q G
S G=$$LASTHF^BGP3D7(P,"TOBACCO",BD,ED)
I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
S G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKING)",BD,ED)
I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
S G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
Q ""
;
GETLAST(P,BD,ED) ;
NEW BGPLAST
S G=$$LASTHF^BGP3D7(P,"TOBACCO",BD,ED)
I G]"" S BGPLAST(9999999-$P(G,U,3))=G
S G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKING)",BD,ED)
I G]"" S BGPLAST(9999999-$P(G,U,3))=G
S G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
I G]"" S BGPLAST(9999999-$P(G,U,3))=G
S G=$O(BGPLAST(0))
I 'G Q ""
Q BGPLAST(G)
I91 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
S (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
I 'BGPACTUP S BGPSTOP=1 Q ;must be at least user pop
D NEWSTUFF Q
;
NEWSTUFF ;new stuff
;BGPD6 - is a tobacco user or user in cessation
;BGPD7 - active clinical tobacco user or user in cessation
;BGPD8 - ditto, less than 12
;BGPD9 - ditto, 12-17
;BGPD10 - ditto over 17
K BGPTOBS
S BGPBDX=BGPBDATE,BGPEDX=BGPEDATE D GETALLHF
I BGPTOBS]"" D G:BGPTU SET
.I $P(BGPTOBS,U,2)["CESSATION" S BGPTUC=1,BGPTUQ=1,BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2) ;cessation and quit
.I $P(BGPTOBS,U,2)["CURRENT" S BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2)
.I $P(BGPTOBS,U,2)]"",'BGPTU D
..S X=$P(BGPTOBS,U,3)
..S Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT 1034F" Q
..S Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT 1035F"
;
I BGPTOBS="" D G:Y SET
.S Y=$$LASTDX^BGP3UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDATE,BGPEDATE)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$CPT^BGP3DU(DFN,BGPBDATE,BGPEDATE,$O(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX=$P(Y,U,3) Q
.;problem list diagnosis
.S T=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
.S X=0,G="",Y="" F S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X D
..Q:$P(^AUPNPROB(X,0),U,12)'="A"
..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
..S Z=$P(^AUPNPROB(X,0),U)
..Q:'$$ICD^ATXCHK(Z,T,9)
..S Y=1,BGPTU=1,BGPTOBD=$P(^AUPNPROB(X,0),U,3),BGPTOBX="PL: "_$P(^ICD9(Z,0),U,1)
;
S BGPBDX=$$DOB^AUPNPAT(DFN),BGPEDX=$$FMADD^XLFDT(BGPBDATE,-1) S BGPTOBS=$$GETLAST(DFN,BGPBDX,BGPEDX) ;EXPANDED TIME FRAME
;
I BGPTOBS]"" D G POT
.I $P(BGPTOBS,U,1)["CESSATION" S BGPTUC=1,BGPTUQ=1,BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2) ;cessation and quit
.I $P(BGPTOBS,U,1)["CURRENT" S BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2)
.I $P(BGPTOBS,U,1)]"",'BGPTU D
..S X=$P(BGPTOBS,U,3)
..S Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1034F" Q
..S Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1035F"
;
I BGPTOBS="" D G:Y POT
.S Y=$$LASTDX^BGP3UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDX,BGPEDX)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$CPT^BGP3DU(DFN,BGPBDX,BGPEDX,$O(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX=$P(Y,U,3) Q
.;problem list diagnosis
.S T=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
.S X=0,G="",Y="" F S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X D
..Q:$P(^AUPNPROB(X,0),U,12)'="A"
..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
..S Z=$P(^AUPNPROB(X,0),U)
..Q:'$$ICD^ATXCHK(Z,T,9)
..S Y=1,BGPTU=1,BGPTOBD=$P(^AUPNPROB(X,0),U,3),BGPTOBX="PL: "_$P(^ICD9(Z,0),U,1)
;
I 'BGPTU G SET ;not a tobacco user
POT ;if potential check for 2 codes
S X=BGPTOBD
S Y=$$LASTDX^BGP3UTL1(DFN,"BGP TOBACCO PAST USE DXS",$$FMADD^XLFDT(X,1),BGPBDATE)
I Y S BGPTU="" G SET
S X=0,G="",BGPREM="" F S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X!(BGPREM) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:$P(^AUPNPROB(X,0),U,3)>BGPBDATE
.Q:$P(^AUPNPROB(X,0),U,3)<X
.S Y=$P(^AUPNPROB(X,0),U)
.S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
.I $$ICD^ATXCHK(Y,T,9) S BGPREM=1 Q
.Q
;
I BGPREM S BGPTU=""
;BGPTU - tobacco user BGPTUQ - quit tobacco use BGPTUC - tobacco user in cessation
SET ;
I 'BGPTU S BGPSTOP=1 D KVARS Q ;not in this denominator at all
S BGPD6=1
I BGPD6,BGPACTCL S BGPD7=1
I BGPD7,BGPAGEB<12 S BGPD8=1
I BGPD7,BGPAGEB>11,BGPAGEB<18 S BGPD9=1
I BGPD7,BGPAGEB>17 S BGPD10=1
;get numerator stuff
;BGPN6=tobacco cessation counseling bgpn7 - REFUSED counseling
;I 'BGPTUC S BGPTC1=$$PED^BGP3D711(DFN,BGPBDATE,BGPEDATE,1)
S BGPTC1=$$PED^BGP3D711(DFN,BGPBDATE,BGPEDATE,1)
I $P(BGPTC1,U)]"" S BGPN6=1 I $P(BGPTC1,U,2)["Ref" S BGPN7=1
;BGPN8 - quit bgpn9-cessation
S Y=$$FMADD^XLFDT(BGPTOBD,1)
I Y<BGPBDATE S Y=BGPBDATE
S BGPQ=$$QUIT(DFN,Y,BGPEDATE) ;any quit after BGPTOBD
I BGPQ S BGPN8=1
;I BGPTUQ S BGPN8=1
I BGPN8,BGPTUQ S BGPN9=1
I BGPN6!(BGPN8) S BGPN10=1
;SET BGPVALUE
S BGPVALUE=$S(BGPRTYPE=3:"",1:"")_$S(BGPD7:"AC",1:"")_" TOB USER: "_$$DATE^BGP3UTL(BGPTOBD)
D
.S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC1,U):"COUNSEL: "_$$DATE^BGP3UTL($P(BGPTC1,U))_" "_$P(BGPTC1,U,2),1:"")
.I BGPN8,BGPQ S BGPVALUE=BGPVALUE_"; "_$P(BGPQ,U,2) ;_" "_$P(BGPQ,U,3)
KVARS ;
Q:$G(BGPINFO)
K BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
K BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
Q
BGP3D71 ; IHS/CMI/LAB - measure C ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;
IC1 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 ;denominator 1 is active clinical, 6 and older and overweight
+3 SET (BGPOW,BGPOB,BGPBMI)=""
+4 KILL BGPALLED,BGPSN,BGPMN,BGPSPEX
+5 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+6 SET BGPBMI=$$BMI^BGP3D6(DFN,BGPEDATE,BGPAGEE)
+7 SET BGPOW=$$OW^BGP3D6(DFN,BGPBMI,BGPAGEE)
+8 SET BGPOB=$$OB^BGP3D6(DFN,BGPBMI,BGPAGEE)
+9 SET BGPOWOB=BGPOW+BGPOB
+10 IF BGPAGEB>5
IF BGPOWOB
IF BGPACTCL
SET BGPD1=1
+11 IF BGPDMD2
SET BGPD2=1
+12 IF BGPAGEB>5
IF BGPOB
IF BGPACTCL
SET BGPD3=1
+13 IF BGPD3
IF BGPAGEB>5
IF BGPAGEB<12
SET BGPD4=1
+14 IF BGPD3
IF BGPAGEB>11
IF BGPAGEB<20
SET BGPD5=1
+15 IF BGPD3
IF BGPAGEB>19
IF BGPAGEB<40
SET BGPD6=1
+16 IF BGPD3
IF BGPAGEB>39
IF BGPAGEB<60
SET BGPD7=1
+17 IF BGPD3
IF BGPAGEB>59
SET BGPD8=1
+18 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8)
QUIT
+19 SET BGPVALUE=""
+20 SET BGPMN=$$MEDNUTRD^BGP3D711(DFN,BGP365,BGPEDATE)
IF BGPMN]""
SET BGPN1=1
+21 SET BGPSN=$$SPECNUTR^BGP3D711(DFN,BGP365,BGPEDATE)
IF BGPSN]""
SET BGPN2=1
+22 SET BGPSPEX=$$SPECEX^BGP3D711(DFN,BGP365,BGPEDATE)
IF BGPSPEX]""
SET BGPN3=1
+23 SET BGPOTH=$$OTHREL^BGP3D711(DFN,BGP365,BGPEDATE)
IF BGPOTH]""
SET BGPN4=1
+24 IF BGPMN]""
SET BGPVALUE="MNT: "_$$DATE^BGP3UTL($PIECE(BGPMN,U))_" "_$PIECE(BGPMN,U,2)_$SELECT(BGPMN]"":"; ",1:"")
+25 IF BGPSN]""
SET BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP3UTL($PIECE(BGPSN,U))_" "_$PIECE(BGPSN,U,2)_$SELECT(BGPSN]"":"; ",1:"")
+26 IF BGPSPEX]""
SET BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP3UTL($PIECE(BGPSPEX,U))_" "_$PIECE(BGPSPEX,U,2)_$SELECT(BGPSPEX]"":"; ",1:"")
+27 IF BGPOTH]""
SET BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP3UTL($PIECE(BGPOTH,U))_" "_$PIECE(BGPOTH,U,2)
+28 SET V=$SELECT(BGPD1:"AC-OW",1:"")
+29 IF BGPD3
SET V=V_$SELECT(V]"":",",1:"")
SET V=V_"AC-OB"
+30 ;$S(BGPD2:"AD;",1:"")_$S(BGPD3:"OB",1:"")
IF BGPD2
SET V=V_$SELECT(V]"":",",1:"")
SET V=V_"AD"
+31 SET V=V_"|||"_BGPVALUE
+32 SET BGPVALUE=V
+33 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALLED,BGPBMI,BGPOW,BGPOB,BGPOWOB,BGPMN,BGPSN,BGPSPEX
+34 KILL ^TMP($JOB,"A")
+35 QUIT
I19 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
+2 KILL BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
+3 SET (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
+4 ;must be at least user pop
IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+5 ;for hedis, must be active clinical
IF BGPRTYPE=3
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+6 IF BGPRTYPE=7
DO NEWSTUFF
QUIT
+7 SET BGPTOBP=$$TOBACCO^BGP3D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1),1)
+8 SET BGPSDX=$$DX^BGP3D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+9 SET BGPSCPT=$$CPTSM^BGP3D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+10 ;now get last of these
+11 SET %=""
+12 ;I BGPSDX]"",$P(BGPSDX,U)="V15.82" S %=1
+13 ;I BGPSDX]"",$P(BGPSDX,U)="305.13" S %=1
+14 SET T=$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
+15 IF BGPSDX]""
SET I=$PIECE(BGPSDX,U,3)
IF $$ICD^ATXCHK(I,T,9)
SET %=1
+16 SET F=BGPTOBP
+17 Begin DoDot:1
+18 IF $PIECE(F,U,1)["CURRENT"!($PIECE(F,U,1)["CESSATION")
SET BGPD2=1
QUIT
+19 IF $PIECE(F,U,4)["CURRENT"!($PIECE(F,U,4)["CESSATION")
SET BGPD2=1
QUIT
+20 IF (BGPSDX]""&(%=""))
SET BGPD2=1
QUIT
+21 IF ($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)
SET BGPD2=1
QUIT
+22 IF $PIECE(BGPSCPT,U)=99406!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8456")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
SET BGPD2=1
QUIT
End DoDot:1
+23 ;last item documented is not a tobacco user
IF 'BGPD2
SET BGPSTOP=1
QUIT
+24 IF BGPD2
IF BGPACTCL
SET BGPD1=1
+25 IF BGPD1
IF BGPAGEB<12
SET BGPD3=1
+26 IF BGPD1
IF BGPAGEB>11
IF BGPAGEB<18
SET BGPD4=1
+27 IF BGPD1
IF BGPAGEB>17
SET BGPD5=1
+28 ;hedis must be active clinical
IF BGPRTYPE=3
IF 'BGPD1
SET BGPSTOP=1
QUIT
+29 SET BGPTC=$$PED^BGP3D711(DFN,BGP365,BGPEDATE)
+30 ;N1 is got education (incl Refusals)
+31 ;N2 is Refusal
+32 ;N11 is educ and no Refusal
+33 ;N3 is quit
+34 ;N6 is quit or educ w/o Refusals
+35 IF $PIECE(BGPTC,U)]""
SET BGPN1=1
IF $PIECE(BGPTC,U,2)["Ref"
SET BGPN2=1
+36 IF BGPN1
IF 'BGPN2
SET BGPN11=1
+37 IF BGPRTYPE'=3
Begin DoDot:1
+38 SET BGPTOB=$$TOBACCO^BGP3D7(DFN,BGP365,BGPEDATE)
+39 IF BGPTOB'["PREVIOUS"
SET BGPTOB=""
+40 SET BGPSDXQ=$$DX^BGP3D7(DFN,BGP365,BGPEDATE)
+41 SET BGPTQ=""
IF $PIECE(BGPTOB,U)["PREVIOUS"!(+$PIECE(BGPSDXQ,U)="305.13")!($PIECE(BGPSDXQ,U)="V15.82")
SET BGPN3=1
+42 ;I $P(BGPTOB,U)["CURRENT" S BGPN3=0 ;
End DoDot:1
+43 ;new numerator v8.0 patch 1
IF BGPN1!(BGPN3)
SET BGPN5=1
+44 IF BGPN11!(BGPN3)
SET BGPN6=1
+45 IF BGPRTYPE=3
SET BGPN4=0
SET BGPTOM=$$TOMPED(DFN,BGP365,BGPEDATE)
IF BGPTOM
SET BGPN4=1
NXT ;
+1 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")
+2 IF BGPRTYPE'=7
Begin DoDot:1
+3 SET BGPVALUE=BGPVALUE_"|||"
Begin DoDot:2
+4 IF BGPRTYPE'=1
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPTC,U):"COUNSEL/RX: "_$$DATE^BGP3UTL($PIECE(BGPTC,U))_" "_$PIECE(BGPTC,U,2),1:"")
+5 IF BGPRTYPE=1
IF BGPN11
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPTC,U):"COUNSEL/RX: "_$$DATE^BGP3UTL($PIECE(BGPTC,U))_" "_$PIECE(BGPTC,U,2),1:"")
End DoDot:2
+6 IF BGPN3
IF BGPRTYPE'=3
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
Begin DoDot:2
+7 SET BGPVALUE=BGPVALUE_"QUIT: "_$SELECT(BGPTOB]"":$PIECE(BGPTOB,U,2)_" ",1:$$DATE^BGP3UTL($PIECE(BGPSDXQ,U,2)))_$PIECE(BGPTOB,U)_$SELECT(+BGPSDXQ="305.13":" POV 305.13 ",$PIECE(BGPSDXQ,U)="V15.82":" POV V15.82",1:"")
End DoDot:2
+8 IF BGPN4
IF BGPRTYPE=3
SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")
Begin DoDot:2
+9 SET BGPVALUE=BGPVALUE_"TO-M "_$$DATE^BGP3UTL($PIECE(BGPTOM,U))
End DoDot:2
End DoDot:1
+10 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC,BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD
+11 QUIT
DNKA(V) ;EP - is this a DNKA visit?
+1 NEW D,N
+2 SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
TOMPED(P,BDATE,EDATE) ;EP
+1 KILL BGPALLED
+2 SET BGPLPED=""
+3 SET Y="BGPALLED("
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(BGPALLED(1))
SET %=""
Begin DoDot:1
+6 SET (X,D)=0
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:2
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+8 IF 'T
QUIT
+9 IF '$DATA(^AUTTEDT(T,0))
QUIT
+10 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+11 IF T'="TO-M"
QUIT
+12 IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
End DoDot:2
End DoDot:1
IF %]""
SET BGPLPED=%
+13 ;
IF BGPLPED]""
QUIT BGPLPED
TOMREF ;
+1 ;EP - now check all Refusals of these education topics
+2 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
IF X=""!(G]"")
QUIT
Begin DoDot:1
+3 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
IF D=""!(G]"")
QUIT
Begin DoDot:2
+4 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D,I))
IF I'=+I!(G]"")
QUIT
Begin DoDot:3
+5 SET Z=$PIECE($GET(^AUPNPREF(I,0)),U,3)
+6 IF Z=""
QUIT
+7 IF Z<BDATE
QUIT
+8 IF Z>EDATE
QUIT
+9 SET Y=$PIECE($GET(^AUTTEDT(X,0)),U,2)
+10 IF Y'="TO-M"
QUIT
+11 SET G=Z_U_"Ref "_Y
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT G
GETALLHF ;
+1 KILL BGPALLH
+2 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO (SMOKING)",0))
+3 DO GETHF1
+4 ;If it is a current or cessation, use it and quit
+5 IF $PIECE(BGPTOBS,U,2)["CURRENT"!($PIECE(BGPTOBS,U,2)["CESSATION")
QUIT
+6 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO (SMOKELESS - CHEWING/DIP)",0))
+7 DO GETHF1
+8 ;If it is a current or cessation, use it and quit
+9 IF $PIECE(BGPTOBS,U,2)["CURRENT"!($PIECE(BGPTOBS,U,2)["CESSATION")
QUIT
+10 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO",0))
+11 DO GETHF1
+12 ;If it is a current or cessation, use it and quit
+13 IF $PIECE(BGPTOBS,U,2)["CURRENT"!($PIECE(BGPTOBS,U,2)["CESSATION")
QUIT
+14 ;now get lastest of any of the categories
+15 SET D=$ORDER(BGPALLH(0))
+16 IF D
SET BGPTOBS=BGPALLH(D)
QUIT
+17 SET BGPTOBS=""
+18 QUIT
GETHF1 ;
+1 IF '$GET(C)
SET BGPTOBS=""
QUIT
+2 NEW ED,BD
+3 KILL BGPTOBS
+4 SET ED=BGPEDX
+5 SET BD=BGPBDX
+6 SET (H,D)=0
KILL O
+7 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+8 IF '$DATA(^AUPNVHF("AA",DFN,H))
QUIT
+9 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",DFN,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+10 ;after time frame
IF (9999999-D)>ED
QUIT
+11 ;before time frame
IF (9999999-D)<BD
QUIT
+12 IF $DATA(BGPTOBS(D))
IF $PIECE(BGPTOBS(D),U,2)["CESSATION"
QUIT
+13 IF $DATA(BGPTOBS(D))
IF $PIECE(BGPTOBS(D),U,2)["CURRENT SMOKE"
IF $PIECE(^AUTTHF(H,0),U)'["CESSATION"
QUIT
+14 SET BGPTOBS(D)=$ORDER(^AUPNVHF("AA",DFN,H,D,""))_U_$PIECE(^AUTTHF(H,0),U)
End DoDot:2
+15 QUIT
End DoDot:1
+16 ;NOW if there are multiples , take the USER one, if no USER ONE TAKE THE LATEST ONE
+17 SET BGPTOBS=""
+18 SET (D,H)=$ORDER(BGPTOBS(0))
IF 'D
SET BGPTOBS=""
QUIT
+19 SET Y=0
FOR
SET Y=$ORDER(BGPTOBS(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+20 IF $PIECE(BGPTOBS(Y),U,2)["CESSATION"!($PIECE(BGPTOBS(Y),U,2)["CURRENT")
SET BGPTOBS=BGPTOBS(Y)_U_(9999999-Y)
SET BGPALLH(Y)=BGPTOBS(Y)_U_(9999999-Y)
End DoDot:1
IF BGPTOBS]""
QUIT
+21 IF BGPTOBS]""
QUIT
+22 SET D=BGPTOBS(D)_U_(9999999-D)
+23 KILL BGPTOBS
+24 SET BGPTOBS=D
SET BGPALLH(H)=D
+25 QUIT
QUIT(P,BD,ED) ;
+1 NEW Y,X,G,T
+2 SET Y=$$LASTDX^BGP3UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
+3 IF Y
QUIT 1_U_"QUIT: "_$$DATE^BGP3UTL($PIECE(Y,U,3))_" POV "_$PIECE(Y,U,2)
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,3)>ED
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,3)<BD
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 SET T=$PIECE($$ICDDX^ICDCODE(Y),U,2)
+10 IF '$$ICD^ATXCHK(Y,$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9)
QUIT
+11 SET G=1_U_"QUIT: "_$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,3))_" PL "_$PIECE(^ICD9(Y,0),U)
End DoDot:1
+12 IF G
QUIT G
+13 SET G=$$LASTHF^BGP3D7(P,"TOBACCO",BD,ED)
+14 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+15 SET G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKING)",BD,ED)
+16 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+17 SET G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
+18 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+19 QUIT ""
+20 ;
GETLAST(P,BD,ED) ;
+1 NEW BGPLAST
+2 SET G=$$LASTHF^BGP3D7(P,"TOBACCO",BD,ED)
+3 IF G]""
SET BGPLAST(9999999-$PIECE(G,U,3))=G
+4 SET G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKING)",BD,ED)
+5 IF G]""
SET BGPLAST(9999999-$PIECE(G,U,3))=G
+6 SET G=$$LASTHF^BGP3D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
+7 IF G]""
SET BGPLAST(9999999-$PIECE(G,U,3))=G
+8 SET G=$ORDER(BGPLAST(0))
+9 IF 'G
QUIT ""
+10 QUIT BGPLAST(G)
I91 ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
+2 KILL BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
+3 SET (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
+4 ;must be at least user pop
IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+5 DO NEWSTUFF
QUIT
+6 ;
NEWSTUFF ;new stuff
+1 ;BGPD6 - is a tobacco user or user in cessation
+2 ;BGPD7 - active clinical tobacco user or user in cessation
+3 ;BGPD8 - ditto, less than 12
+4 ;BGPD9 - ditto, 12-17
+5 ;BGPD10 - ditto over 17
+6 KILL BGPTOBS
+7 SET BGPBDX=BGPBDATE
SET BGPEDX=BGPEDATE
DO GETALLHF
+8 IF BGPTOBS]""
Begin DoDot:1
+9 ;cessation and quit
IF $PIECE(BGPTOBS,U,2)["CESSATION"
SET BGPTUC=1
SET BGPTUQ=1
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+10 IF $PIECE(BGPTOBS,U,2)["CURRENT"
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+11 IF $PIECE(BGPTOBS,U,2)]""
IF 'BGPTU
Begin DoDot:2
+12 SET X=$PIECE(BGPTOBS,U,3)
+13 SET Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
+14 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT 1034F"
QUIT
+15 SET Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
+16 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT 1035F"
End DoDot:2
End DoDot:1
IF BGPTU
GOTO SET
+17 ;
+18 IF BGPTOBS=""
Begin DoDot:1
+19 SET Y=$$LASTDX^BGP3UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDATE,BGPEDATE)
+20 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+21 SET Y=$$CPT^BGP3DU(DFN,BGPBDATE,BGPEDATE,$ORDER(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
+22 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX=$PIECE(Y,U,3)
QUIT
+23 ;problem list diagnosis
+24 SET T=$ORDER(^ATXAX("B","BGP TOBACCO USER DXS",0))
+25 SET X=0
SET G=""
SET Y=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:2
+26 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+27 IF $PIECE(^AUPNPROB(X,0),U,3)>BGPEDX
QUIT
+28 SET Z=$PIECE(^AUPNPROB(X,0),U)
+29 IF '$$ICD^ATXCHK(Z,T,9)
QUIT
+30 SET Y=1
SET BGPTU=1
SET BGPTOBD=$PIECE(^AUPNPROB(X,0),U,3)
SET BGPTOBX="PL: "_$PIECE(^ICD9(Z,0),U,1)
End DoDot:2
End DoDot:1
IF Y
GOTO SET
+31 ;
+32 ;EXPANDED TIME FRAME
SET BGPBDX=$$DOB^AUPNPAT(DFN)
SET BGPEDX=$$FMADD^XLFDT(BGPBDATE,-1)
SET BGPTOBS=$$GETLAST(DFN,BGPBDX,BGPEDX)
+33 ;
+34 IF BGPTOBS]""
Begin DoDot:1
+35 ;cessation and quit
IF $PIECE(BGPTOBS,U,1)["CESSATION"
SET BGPTUC=1
SET BGPTUQ=1
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+36 IF $PIECE(BGPTOBS,U,1)["CURRENT"
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+37 IF $PIECE(BGPTOBS,U,1)]""
IF 'BGPTU
Begin DoDot:2
+38 SET X=$PIECE(BGPTOBS,U,3)
+39 SET Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
+40 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1034F"
QUIT
+41 SET Y=$$CPTI^BGP3DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
+42 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1035F"
End DoDot:2
End DoDot:1
GOTO POT
+43 ;
+44 IF BGPTOBS=""
Begin DoDot:1
+45 SET Y=$$LASTDX^BGP3UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDX,BGPEDX)
+46 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+47 SET Y=$$CPT^BGP3DU(DFN,BGPBDX,BGPEDX,$ORDER(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
+48 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX=$PIECE(Y,U,3)
QUIT
+49 ;problem list diagnosis
+50 SET T=$ORDER(^ATXAX("B","BGP TOBACCO USER DXS",0))
+51 SET X=0
SET G=""
SET Y=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:2
+52 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+53 IF $PIECE(^AUPNPROB(X,0),U,3)>BGPEDX
QUIT
+54 SET Z=$PIECE(^AUPNPROB(X,0),U)
+55 IF '$$ICD^ATXCHK(Z,T,9)
QUIT
+56 SET Y=1
SET BGPTU=1
SET BGPTOBD=$PIECE(^AUPNPROB(X,0),U,3)
SET BGPTOBX="PL: "_$PIECE(^ICD9(Z,0),U,1)
End DoDot:2
End DoDot:1
IF Y
GOTO POT
+57 ;
+58 ;not a tobacco user
IF 'BGPTU
GOTO SET
POT ;if potential check for 2 codes
+1 SET X=BGPTOBD
+2 SET Y=$$LASTDX^BGP3UTL1(DFN,"BGP TOBACCO PAST USE DXS",$$FMADD^XLFDT(X,1),BGPBDATE)
+3 IF Y
SET BGPTU=""
GOTO SET
+4 SET X=0
SET G=""
SET BGPREM=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X!(BGPREM)
QUIT
Begin DoDot:1
+5 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,3)>BGPBDATE
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,3)<X
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 SET T=$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
+10 IF $$ICD^ATXCHK(Y,T,9)
SET BGPREM=1
QUIT
+11 QUIT
End DoDot:1
+12 ;
+13 IF BGPREM
SET BGPTU=""
+14 ;BGPTU - tobacco user BGPTUQ - quit tobacco use BGPTUC - tobacco user in cessation
SET ;
+1 ;not in this denominator at all
IF 'BGPTU
SET BGPSTOP=1
DO KVARS
QUIT
+2 SET BGPD6=1
+3 IF BGPD6
IF BGPACTCL
SET BGPD7=1
+4 IF BGPD7
IF BGPAGEB<12
SET BGPD8=1
+5 IF BGPD7
IF BGPAGEB>11
IF BGPAGEB<18
SET BGPD9=1
+6 IF BGPD7
IF BGPAGEB>17
SET BGPD10=1
+7 ;get numerator stuff
+8 ;BGPN6=tobacco cessation counseling bgpn7 - REFUSED counseling
+9 ;I 'BGPTUC S BGPTC1=$$PED^BGP3D711(DFN,BGPBDATE,BGPEDATE,1)
+10 SET BGPTC1=$$PED^BGP3D711(DFN,BGPBDATE,BGPEDATE,1)
+11 IF $PIECE(BGPTC1,U)]""
SET BGPN6=1
IF $PIECE(BGPTC1,U,2)["Ref"
SET BGPN7=1
+12 ;BGPN8 - quit bgpn9-cessation
+13 SET Y=$$FMADD^XLFDT(BGPTOBD,1)
+14 IF Y<BGPBDATE
SET Y=BGPBDATE
+15 ;any quit after BGPTOBD
SET BGPQ=$$QUIT(DFN,Y,BGPEDATE)
+16 IF BGPQ
SET BGPN8=1
+17 ;I BGPTUQ S BGPN8=1
+18 IF BGPN8
IF BGPTUQ
SET BGPN9=1
+19 IF BGPN6!(BGPN8)
SET BGPN10=1
+20 ;SET BGPVALUE
+21 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",1:"")_$SELECT(BGPD7:"AC",1:"")_" TOB USER: "_$$DATE^BGP3UTL(BGPTOBD)
+22 Begin DoDot:1
+23 SET BGPVALUE=BGPVALUE_"|||"_$SELECT($PIECE(BGPTC1,U):"COUNSEL: "_$$DATE^BGP3UTL($PIECE(BGPTC1,U))_" "_$PIECE(BGPTC1,U,2),1:"")
+24 ;_" "_$P(BGPQ,U,3)
IF BGPN8
IF BGPQ
SET BGPVALUE=BGPVALUE_"; "_$PIECE(BGPQ,U,2)
End DoDot:1
KVARS ;
+1 IF $GET(BGPINFO)
QUIT
+2 KILL BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
+3 KILL BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
+4 QUIT
