BGP0D71 ; IHS/CMI/LAB - measure C ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
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^BGP0D6(DFN,BGPEDATE,BGPAGEE)
S BGPOW=$$OW^BGP0D6(DFN,BGPBMI,BGPAGEE)
S BGPOB=$$OB^BGP0D6(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 BGPMN=$$MEDNUTRD^BGP0D711(DFN,BGP365,BGPEDATE) I BGPMN]"" S BGPN1=1
S BGPSN=$$SPECNUTR^BGP0D711(DFN,BGP365,BGPEDATE) I BGPSN]"" S BGPN2=1
S BGPSPEX=$$SPECEX^BGP0D711(DFN,BGP365,BGPEDATE) I BGPSPEX]"" S BGPN3=1
S BGPOTH=$$OTHREL^BGP0D711(DFN,BGP365,BGPEDATE) I BGPOTH]"" S BGPN4=1
S BGPVALUE=$$DATE^BGP0UTL($P(BGPMN,U))_" "_$P(BGPMN,U,2)_$S(BGPMN]"":";",1:"")
S BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($P(BGPSN,U))_" "_$P(BGPSN,U,2)_$S(BGPSN]"":";",1:"")
S BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($P(BGPSPEX,U))_" "_$P(BGPSPEX,U,2)_$S(BGPSPEX]"":";",1:"")
S BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($P(BGPOTH,U))_" "_$P(BGPOTH,U,2)
S V=$S(BGPD1:"OW;",1:"")_$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^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGPSDX=$$DX^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
;S BGP1320=$$DENT^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
S BGPSCPT=$$CPTSM^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
;now get last of these
;S D=$P(BGPTOBP,U,3),V="HF "_$P(BGPTOBP,U,1)
;I $P(BGPSDX,U,2)>D S D=$P(BGPSDX,U,2),V="DX "_$P(BGPSDX,U,1)
;I $P(BGP1320,U,2)>D S D=$P(BGP1320,U,2),V="DENTAL 1320"
;I $P(BGPSCPT,U,2)>D S D=$P(BGPSCPT,U,2),V="CPT "_$P(BGPSCPT,U,1)
;I V["HF ",$P(BGPTOBP,U,1)["CURRENT"!(BGPTOBP["CESSATION") S BGPD2=1
;I V["DX ",(BGPSDX]""&(+BGPSDX'="305.13")&(BGPSDX'="V15.82")) S BGPD2=1
;I V["DENTAL " S BGPD2=1
;I V["CPT ",$P(BGPSCPT,U)["1034F"!($P(BGPSCPT,U)["1035F") S BGPD2=1
S %=""
I BGPSDX]"",$P(BGPSDX,U)="V15.82" S %=1
I BGPSDX]"",$P(BGPSDX,U)="305.13" S %=1
S F=$P(BGPTOBP,U,1)
I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(F["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPD2=1
I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPD2=1
;I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(BGPTOBP["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)="G0376") S BGPD2=1
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^BGP0D711(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^BGP0D7(DFN,BGP365,BGPEDATE)
.I BGPTOB'["PREVIOUS" S BGPTOB=""
.S BGPSDXQ=$$DX^BGP0D7(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_"|||"_$S($P(BGPTC,U):"COUNSELING: "_$$DATE^BGP0UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")
.I BGPN3,BGPRTYPE'=3 S BGPVALUE=BGPVALUE_";QUIT: "_$P(BGPTOB,U)_" "_$P(BGPTOB,U,2)_$S(+BGPSDXQ="305.13":" DX: 305.13 "_$$DATE^BGP0UTL($P(BGPSDXQ,U,2)),$P(BGPSDXQ,U)="V15.82":" DX: V15.82 "_$$DATE^BGP0UTL($P(BGPSDXQ,U,2)),1:"")
.I BGPN4,BGPRTYPE=3 S BGPVALUE=BGPVALUE_";TO-M "_$$DATE^BGP0UTL($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 ;
S C=$O(^AUTTHF("B","TOBACCO",0)) ;ien of category passed
I '$G(C) Q
NEW ED,BD
S ED=$$FMADD^XLFDT(BGPBDATE,180)
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)<BGPBDX ;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 on the same day, take the cessation one, if no cessation one, take the current smoker on
S D=$O(BGPTOBS(0)) I 'D S BGPTOBS="" Q
S D=BGPTOBS(D)_U_(9999999-D)
K BGPTOBS
S BGPTOBS=D
Q
QUIT(P,BD,ED) ;
NEW Y,X,G,T
S Y=$$LASTDXI^BGP0UTL1(P,"305.13",BD,ED)
I Y Q 1_U_"QUIT: POV 305.13 "_$$DATE^BGP0UTL($P(Y,U,3))
S Y=$$LASTDXI^BGP0UTL1(P,"V15.82",BD,ED)
I Y Q 1_U_"QUIT: POV V15.82 "_$$DATE^BGP0UTL($P(Y,U,3))
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 T'="V15.82",T'="305.13" Q
.S G=1_U_"QUIT: PL "_$P(^ICD9(Y,0),U)_" "_$$DATE^BGP0UTL($P(^AUPNPROB(X,0),U,3))
I G Q G
S G=$$LASTHF^BGP0D7(P,"TOBACCO",BD,ED)
I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: HF: "_$P(G,U,1)_U_" "_$P(G,U,2)
Q ""
;
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=$$FMADD^XLFDT(BGPBDATE,-180) D GETALLHF
I BGPTOBS]"" D G 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^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1034F"))
..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1034F" Q
..S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1035F"))
..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1035F"
;expand the time range
S BGPBDX=$$DOB^AUPNPAT(DFN) D GETALLHF
;
I BGPTOBS="" D G SET
.S Y=$$LASTDX^BGP0UTL1(DFN,"BGP TOBACCO USER DXS",$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$CPT^BGP0DU(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180),$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
;
I $P(BGPTOBS,U,2)["CURRENT" D S:'BGPREM BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2) S:$P(BGPTOBS,U,2)["CESSATION" BGPTUC=1,BGPTUQ=1 G SET
.S X=$P(BGPTOBS,U,3)
.S Y=$$LASTDXI^BGP0UTL1(DFN,"305.13",$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180))
.I Y S BGPREM=1 Q
.S Y=$$LASTDXI^BGP0UTL1(DFN,"V15.82",$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180))
.I Y S BGPREM=1 Q
.S BGPBDX=$$FMADD^XLFDT(BGPBDATE,-180),BGPEDX=$$FMADD^XLFDT(BGPBDATE,180)
.S T=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
.S X=0,G="" 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)>BGPEDX
..Q:$P(^AUPNPROB(X,0),U,3)<BGPBDX
..S Y=$P(^AUPNPROB(X,0),U)
..Q:'$$ICD^ATXCHK(Y,T,9)
..S BGPREM=1
.Q
;
S X=$P(BGPTOBS,U,3)
S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1034F"))
I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1034F" G SET
S Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1035F"))
I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1035F"
;
;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^BGP0D711(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE,1)
I $P(BGPTC1,U)]"" S BGPN6=1 I $P(BGPTC1,U,2)["ref" S BGPN7=1
;BGPN8 - quit bgpn9-cessation
S BGPQ=$$QUIT(DFN,$$FMADD^XLFDT(BGPTOBD,1),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^BGP0UTL(BGPTOBD)
D
.S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC1,U):";COUNSELING: "_$$DATE^BGP0UTL($P(BGPTC1,U))_" "_$P(BGPTC1,U,2),1:"")
.I BGPN8,BGPQ S BGPVALUE=BGPVALUE_";"_$P(BGPQ,U,2)_" "_$P(BGPQ,U,3)
.I BGPN8,'BGPQ S BGPVALUE=BGPVALUE_";QUIT - CESSATION"
KVARS ;
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
BGP0D71 ; IHS/CMI/LAB - measure C ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+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^BGP0D6(DFN,BGPEDATE,BGPAGEE)
+7 SET BGPOW=$$OW^BGP0D6(DFN,BGPBMI,BGPAGEE)
+8 SET BGPOB=$$OB^BGP0D6(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 BGPMN=$$MEDNUTRD^BGP0D711(DFN,BGP365,BGPEDATE)
IF BGPMN]""
SET BGPN1=1
+20 SET BGPSN=$$SPECNUTR^BGP0D711(DFN,BGP365,BGPEDATE)
IF BGPSN]""
SET BGPN2=1
+21 SET BGPSPEX=$$SPECEX^BGP0D711(DFN,BGP365,BGPEDATE)
IF BGPSPEX]""
SET BGPN3=1
+22 SET BGPOTH=$$OTHREL^BGP0D711(DFN,BGP365,BGPEDATE)
IF BGPOTH]""
SET BGPN4=1
+23 SET BGPVALUE=$$DATE^BGP0UTL($PIECE(BGPMN,U))_" "_$PIECE(BGPMN,U,2)_$SELECT(BGPMN]"":";",1:"")
+24 SET BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($PIECE(BGPSN,U))_" "_$PIECE(BGPSN,U,2)_$SELECT(BGPSN]"":";",1:"")
+25 SET BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($PIECE(BGPSPEX,U))_" "_$PIECE(BGPSPEX,U,2)_$SELECT(BGPSPEX]"":";",1:"")
+26 SET BGPVALUE=BGPVALUE_$$DATE^BGP0UTL($PIECE(BGPOTH,U))_" "_$PIECE(BGPOTH,U,2)
+27 SET V=$SELECT(BGPD1:"OW;",1:"")_$SELECT(BGPD2:"AD;",1:"")_$SELECT(BGPD3:"OB",1:"")
+28 SET V=V_"|||"_BGPVALUE
+29 SET BGPVALUE=V
+30 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
+31 KILL ^TMP($JOB,"A")
+32 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^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+8 SET BGPSDX=$$DX^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+9 ;S BGP1320=$$DENT^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+10 SET BGPSCPT=$$CPTSM^BGP0D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
+11 ;now get last of these
+12 ;S D=$P(BGPTOBP,U,3),V="HF "_$P(BGPTOBP,U,1)
+13 ;I $P(BGPSDX,U,2)>D S D=$P(BGPSDX,U,2),V="DX "_$P(BGPSDX,U,1)
+14 ;I $P(BGP1320,U,2)>D S D=$P(BGP1320,U,2),V="DENTAL 1320"
+15 ;I $P(BGPSCPT,U,2)>D S D=$P(BGPSCPT,U,2),V="CPT "_$P(BGPSCPT,U,1)
+16 ;I V["HF ",$P(BGPTOBP,U,1)["CURRENT"!(BGPTOBP["CESSATION") S BGPD2=1
+17 ;I V["DX ",(BGPSDX]""&(+BGPSDX'="305.13")&(BGPSDX'="V15.82")) S BGPD2=1
+18 ;I V["DENTAL " S BGPD2=1
+19 ;I V["CPT ",$P(BGPSCPT,U)["1034F"!($P(BGPSCPT,U)["1035F") S BGPD2=1
+20 SET %=""
+21 IF BGPSDX]""
IF $PIECE(BGPSDX,U)="V15.82"
SET %=1
+22 IF BGPSDX]""
IF $PIECE(BGPSDX,U)="305.13"
SET %=1
+23 SET F=$PIECE(BGPTOBP,U,1)
+24 IF $PIECE(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(F["CESSATION")!($PIECE(BGPSCPT,U)="1034F")!($PIECE(BGPSCPT,U)="1035F")!($PIECE(BGPSCPT,U)="G0376")!($PIECE(BGPSCPT,U)="G0375")!($PIECE(BGPSCPT,U)=99407)
SET BGPD2=1
+25 IF $PIECE(BGPSCPT,U)=99406!($PIECE(BGPSCPT,U)="G8455")!($PIECE(BGPSCPT,U)="G8456")!($PIECE(BGPSCPT,U)="G8402")!($PIECE(BGPSCPT,U)="G8453")
SET BGPD2=1
+26 ;I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(BGPTOBP["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)=99406)!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)="G0376") S BGPD2=1
+27 ;last item documented is not a tobacco user
IF 'BGPD2
SET BGPSTOP=1
QUIT
+28 IF BGPD2
IF BGPACTCL
SET BGPD1=1
+29 IF BGPD1
IF BGPAGEB<12
SET BGPD3=1
+30 IF BGPD1
IF BGPAGEB>11
IF BGPAGEB<18
SET BGPD4=1
+31 IF BGPD1
IF BGPAGEB>17
SET BGPD5=1
+32 ;hedis must be active clinical
IF BGPRTYPE=3
IF 'BGPD1
SET BGPSTOP=1
QUIT
+33 SET BGPTC=$$PED^BGP0D711(DFN,BGP365,BGPEDATE)
+34 ;N1 is got education (incl refusals)
+35 ;N2 is refusal
+36 ;N11 is educ and no refusal
+37 ;N3 is quit
+38 ;N6 is quit or educ w/o refusals
+39 IF $PIECE(BGPTC,U)]""
SET BGPN1=1
IF $PIECE(BGPTC,U,2)["ref"
SET BGPN2=1
+40 IF BGPN1
IF 'BGPN2
SET BGPN11=1
+41 IF BGPRTYPE'=3
Begin DoDot:1
+42 SET BGPTOB=$$TOBACCO^BGP0D7(DFN,BGP365,BGPEDATE)
+43 IF BGPTOB'["PREVIOUS"
SET BGPTOB=""
+44 SET BGPSDXQ=$$DX^BGP0D7(DFN,BGP365,BGPEDATE)
+45 SET BGPTQ=""
IF $PIECE(BGPTOB,U)["PREVIOUS"!(+$PIECE(BGPSDXQ,U)="305.13")!($PIECE(BGPSDXQ,U)="V15.82")
SET BGPN3=1
+46 ;I $P(BGPTOB,U)["CURRENT" S BGPN3=0 ;
End DoDot:1
+47 ;new numerator v8.0 patch 1
IF BGPN1!(BGPN3)
SET BGPN5=1
+48 IF BGPN11!(BGPN3)
SET BGPN6=1
+49 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_"|||"_$SELECT($PIECE(BGPTC,U):"COUNSELING: "_$$DATE^BGP0UTL($PIECE(BGPTC,U))_" "_$PIECE(BGPTC,U,2),1:"")
+4 IF BGPN3
IF BGPRTYPE'=3
SET BGPVALUE=BGPVALUE_";QUIT: "_$PIECE(BGPTOB,U)_" "_$PIECE(BGPTOB,U,2)_$SELECT(+BGPSDXQ="305.13":" DX: 305.13 "_$$DATE^BGP0UTL($PIECE(BGPSDXQ,U,2)),$PIECE(BGPSDXQ,U)="V15.82":" DX: V15.82 "_$$DATE^BGP0UTL($PIECE(BGPSDXQ,U,2)),1
:"")
+5 IF BGPN4
IF BGPRTYPE=3
SET BGPVALUE=BGPVALUE_";TO-M "_$$DATE^BGP0UTL($PIECE(BGPTOM,U))
End DoDot:1
+6 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
+7 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 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO",0))
+2 IF '$GET(C)
QUIT
+3 NEW ED,BD
+4 SET ED=$$FMADD^XLFDT(BGPBDATE,180)
+5 SET (H,D)=0
KILL O
+6 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVHF("AA",DFN,H))
QUIT
+8 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",DFN,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+9 ;after time frame
IF (9999999-D)>ED
QUIT
+10 ;before time frame
IF (9999999-D)<BGPBDX
QUIT
+11 IF $DATA(BGPTOBS(D))
IF $PIECE(BGPTOBS(D),U,2)["CESSATION"
QUIT
+12 IF $DATA(BGPTOBS(D))
IF $PIECE(BGPTOBS(D),U,2)["CURRENT SMOKE"
IF $PIECE(^AUTTHF(H,0),U)'["CESSATION"
QUIT
+13 SET BGPTOBS(D)=$ORDER(^AUPNVHF("AA",DFN,H,D,""))_U_$PIECE(^AUTTHF(H,0),U)
End DoDot:2
+14 QUIT
End DoDot:1
+15 ;NOW if there are multiples on the same day, take the cessation one, if no cessation one, take the current smoker on
+16 SET D=$ORDER(BGPTOBS(0))
IF 'D
SET BGPTOBS=""
QUIT
+17 SET D=BGPTOBS(D)_U_(9999999-D)
+18 KILL BGPTOBS
+19 SET BGPTOBS=D
+20 QUIT
QUIT(P,BD,ED) ;
+1 NEW Y,X,G,T
+2 SET Y=$$LASTDXI^BGP0UTL1(P,"305.13",BD,ED)
+3 IF Y
QUIT 1_U_"QUIT: POV 305.13 "_$$DATE^BGP0UTL($PIECE(Y,U,3))
+4 SET Y=$$LASTDXI^BGP0UTL1(P,"V15.82",BD,ED)
+5 IF Y
QUIT 1_U_"QUIT: POV V15.82 "_$$DATE^BGP0UTL($PIECE(Y,U,3))
+6 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)>ED
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,3)<BD
QUIT
+10 SET Y=$PIECE(^AUPNPROB(X,0),U)
+11 SET T=$PIECE($$ICDDX^ICDCODE(Y),U,2)
+12 IF T'="V15.82"
IF T'="305.13"
QUIT
+13 SET G=1_U_"QUIT: PL "_$PIECE(^ICD9(Y,0),U)_" "_$$DATE^BGP0UTL($PIECE(^AUPNPROB(X,0),U,3))
End DoDot:1
+14 IF G
QUIT G
+15 SET G=$$LASTHF^BGP0D7(P,"TOBACCO",BD,ED)
+16 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: HF: "_$PIECE(G,U,1)_U_" "_$PIECE(G,U,2)
+17 QUIT ""
+18 ;
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=$$FMADD^XLFDT(BGPBDATE,-180)
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^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1034F"))
+14 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1034F"
QUIT
+15 SET Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$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
GOTO SET
+17 ;expand the time range
+18 SET BGPBDX=$$DOB^AUPNPAT(DFN)
DO GETALLHF
+19 ;
+20 IF BGPTOBS=""
Begin DoDot:1
+21 SET Y=$$LASTDX^BGP0UTL1(DFN,"BGP TOBACCO USER DXS",$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
+22 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+23 SET Y=$$CPT^BGP0DU(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180),$ORDER(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
+24 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX=$PIECE(Y,U,3)
QUIT
End DoDot:1
GOTO SET
+25 ;
+26 IF $PIECE(BGPTOBS,U,2)["CURRENT"
Begin DoDot:1
+27 SET X=$PIECE(BGPTOBS,U,3)
+28 SET Y=$$LASTDXI^BGP0UTL1(DFN,"305.13",$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180))
+29 IF Y
SET BGPREM=1
QUIT
+30 SET Y=$$LASTDXI^BGP0UTL1(DFN,"V15.82",$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180))
+31 IF Y
SET BGPREM=1
QUIT
+32 SET BGPBDX=$$FMADD^XLFDT(BGPBDATE,-180)
SET BGPEDX=$$FMADD^XLFDT(BGPBDATE,180)
+33 SET T=$ORDER(^ATXAX("B","BGP TOBACCO USER DXS",0))
+34 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X!(BGPREM)
QUIT
Begin DoDot:2
+35 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+36 IF $PIECE(^AUPNPROB(X,0),U,3)>BGPEDX
QUIT
+37 IF $PIECE(^AUPNPROB(X,0),U,3)<BGPBDX
QUIT
+38 SET Y=$PIECE(^AUPNPROB(X,0),U)
+39 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+40 SET BGPREM=1
End DoDot:2
+41 QUIT
End DoDot:1
IF 'BGPREM
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
IF $PIECE(BGPTOBS,U,2)["CESSATION"
SET BGPTUC=1
SET BGPTUQ=1
GOTO SET
+42 ;
+43 SET X=$PIECE(BGPTOBS,U,3)
+44 SET Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1034F"))
+45 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1034F"
GOTO SET
+46 SET Y=$$CPTI^BGP0DU(DFN,$$FMADD^XLFDT(X,1),$$FMADD^XLFDT(BGPBDATE,180),+$$CODEN^ICPTCOD("1035F"))
+47 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1035F"
+48 ;
+49 ;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 IF 'BGPTUC
SET BGPTC1=$$PED^BGP0D711(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE,1)
+10 IF $PIECE(BGPTC1,U)]""
SET BGPN6=1
IF $PIECE(BGPTC1,U,2)["ref"
SET BGPN7=1
+11 ;BGPN8 - quit bgpn9-cessation
+12 ;any quit after BGPTOBD
SET BGPQ=$$QUIT(DFN,$$FMADD^XLFDT(BGPTOBD,1),BGPEDATE)
+13 IF BGPQ
SET BGPN8=1
+14 IF BGPTUQ
SET BGPN8=1
+15 IF BGPN8
IF BGPTUQ
SET BGPN9=1
+16 IF BGPN6!(BGPN8)
SET BGPN10=1
+17 ;SET BGPVALUE
+18 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",1:"")_$SELECT(BGPD7:";AC",1:"")_" TOB USER: "_$$DATE^BGP0UTL(BGPTOBD)
+19 Begin DoDot:1
+20 SET BGPVALUE=BGPVALUE_"|||"_$SELECT($PIECE(BGPTC1,U):";COUNSELING: "_$$DATE^BGP0UTL($PIECE(BGPTC1,U))_" "_$PIECE(BGPTC1,U,2),1:"")
+21 IF BGPN8
IF BGPQ
SET BGPVALUE=BGPVALUE_";"_$PIECE(BGPQ,U,2)_" "_$PIECE(BGPQ,U,3)
+22 IF BGPN8
IF 'BGPQ
SET BGPVALUE=BGPVALUE_";QUIT - CESSATION"
End DoDot:1
KVARS ;
+1 KILL BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
+2 KILL BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
+3 QUIT
