Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP2D71

BGP2D71.m

Go to the documentation of this file. 
  1. BGP2D71 ; IHS/CMI/LAB - measure C ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1. IC1 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  ;denominator 1 is active clinical, 6 and older and overweight
  1.  S (BGPOW,BGPOB,BGPBMI)=""
  1.  K BGPALLED,BGPSN,BGPMN,BGPSPEX
  1.  I 'BGPACTUP S BGPSTOP=1 Q
  1.  S BGPBMI=$$BMI^BGP2D6(DFN,BGPEDATE,BGPAGEE)
  1.  S BGPOW=$$OW^BGP2D6(DFN,BGPBMI,BGPAGEE)
  1.  S BGPOB=$$OB^BGP2D6(DFN,BGPBMI,BGPAGEE)
  1.  S BGPOWOB=BGPOW+BGPOB
  1.  I BGPAGEB>5,BGPOWOB,BGPACTCL S BGPD1=1
  1.  I BGPDMD2 S BGPD2=1
  1.  I BGPAGEB>5,BGPOB,BGPACTCL S BGPD3=1
  1.  I BGPD3,BGPAGEB>5,BGPAGEB<12 S BGPD4=1
  1.  I BGPD3,BGPAGEB>11,BGPAGEB<20 S BGPD5=1
  1.  I BGPD3,BGPAGEB>19,BGPAGEB<40 S BGPD6=1
  1.  I BGPD3,BGPAGEB>39,BGPAGEB<60 S BGPD7=1
  1.  I BGPD3,BGPAGEB>59 S BGPD8=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) Q
  1.  S BGPVALUE=""
  1.  S BGPMN=$$MEDNUTRD^BGP2D711(DFN,BGP365,BGPEDATE) I BGPMN]"" S BGPN1=1
  1.  S BGPSN=$$SPECNUTR^BGP2D711(DFN,BGP365,BGPEDATE) I BGPSN]"" S BGPN2=1
  1.  S BGPSPEX=$$SPECEX^BGP2D711(DFN,BGP365,BGPEDATE) I BGPSPEX]"" S BGPN3=1
  1.  S BGPOTH=$$OTHREL^BGP2D711(DFN,BGP365,BGPEDATE) I BGPOTH]"" S BGPN4=1
  1.  I BGPMN]"" S BGPVALUE="MNT: "_$$DATE^BGP2UTL($P(BGPMN,U))_" "_$P(BGPMN,U,2)_$S(BGPMN]"":"; ",1:"")
  1.  I BGPSN]"" S BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP2UTL($P(BGPSN,U))_" "_$P(BGPSN,U,2)_$S(BGPSN]"":"; ",1:"")
  1.  I BGPSPEX]"" S BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP2UTL($P(BGPSPEX,U))_" "_$P(BGPSPEX,U,2)_$S(BGPSPEX]"":"; ",1:"")
  1.  I BGPOTH]"" S BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP2UTL($P(BGPOTH,U))_" "_$P(BGPOTH,U,2)
  1.  S V=$S(BGPD1:"AC-OW",1:"")
  1.  I BGPD3 S V=V_$S(V]"":",",1:"") S V=V_"AC-OB"
  1.  I BGPD2 S V=V_$S(V]"":",",1:"") S V=V_"AD"  ;$S(BGPD2:"AD;",1:"")_$S(BGPD3:"OB",1:"")
  1.  S V=V_"|||"_BGPVALUE
  1.  S BGPVALUE=V
  1.  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
  1.  K ^TMP($J,"A")
  1.  Q
  1. I19 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
  1.  K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
  1.  S (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
  1.  I 'BGPACTUP S BGPSTOP=1 Q  ;must be at least user pop
  1.  I BGPRTYPE=3,'BGPACTCL S BGPSTOP=1 Q   ;for hedis, must be active clinical
  1.  I BGPRTYPE=7 D NEWSTUFF Q
  1.  S BGPTOBP=$$TOBACCO^BGP2D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1),1)
  1.  S BGPSDX=$$DX^BGP2D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  S BGPSCPT=$$CPTSM^BGP2D7(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,-1))
  1.  ;now get last of these
  1.  S %=""
  1.  ;I BGPSDX]"",$P(BGPSDX,U)="V15.82" S %=1
  1.  ;I BGPSDX]"",$P(BGPSDX,U)="305.13" S %=1
  1.  S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
  1.  I BGPSDX]"" S I=$P(BGPSDX,U,3) I $$ICD^ATXCHK(I,T,9) S %=1
  1.  S F=BGPTOBP
  1.  D
  1.  .I $P(F,U,1)["CURRENT"!($P(F,U,1)["CESSATION") S BGPD2=1 Q
  1.  .I $P(F,U,4)["CURRENT"!($P(F,U,4)["CESSATION") S BGPD2=1 Q
  1.  .I (BGPSDX]""&(%="")) S BGPD2=1 Q
  1.  .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
  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 Q
  1.  I 'BGPD2 S BGPSTOP=1 Q  ;last item documented is not a tobacco user
  1.  I BGPD2,BGPACTCL S BGPD1=1
  1.  I BGPD1,BGPAGEB<12 S BGPD3=1
  1.  I BGPD1,BGPAGEB>11,BGPAGEB<18 S BGPD4=1
  1.  I BGPD1,BGPAGEB>17 S BGPD5=1
  1.  I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q  ;hedis must be active clinical
  1.  S BGPTC=$$PED^BGP2D711(DFN,BGP365,BGPEDATE)
  1.  ;N1 is got education (incl Refusals)
  1.  ;N2 is Refusal
  1.  ;N11 is educ and no Refusal
  1.  ;N3 is quit
  1.  ;N6 is quit or educ w/o Refusals
  1.  I $P(BGPTC,U)]"" S BGPN1=1 I $P(BGPTC,U,2)["Ref" S BGPN2=1
  1.  I BGPN1,'BGPN2 S BGPN11=1
  1.  I BGPRTYPE'=3 D
  1.  .S BGPTOB=$$TOBACCO^BGP2D7(DFN,BGP365,BGPEDATE)
  1.  .I BGPTOB'["PREVIOUS" S BGPTOB=""
  1.  .S BGPSDXQ=$$DX^BGP2D7(DFN,BGP365,BGPEDATE)
  1.  .S BGPTQ="" I $P(BGPTOB,U)["PREVIOUS"!(+$P(BGPSDXQ,U)="305.13")!($P(BGPSDXQ,U)="V15.82") S BGPN3=1
  1.  .;I $P(BGPTOB,U)["CURRENT" S BGPN3=0  ;
  1.  I BGPN1!(BGPN3) S BGPN5=1  ;new numerator v8.0 patch 1
  1.  I BGPN11!(BGPN3) S BGPN6=1
  1.  I BGPRTYPE=3 S BGPN4=0,BGPTOM=$$TOMPED(DFN,BGP365,BGPEDATE) I BGPTOM S BGPN4=1
  1. NXT ;
  1.  S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")
  1.  I BGPRTYPE'=7 D
  1.  .S BGPVALUE=BGPVALUE_"|||" D
  1.  ..I BGPRTYPE'=1 S BGPVALUE=BGPVALUE_$S($P(BGPTC,U):"COUNSEL/RX: "_$$DATE^BGP2UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")
  1.  ..I BGPRTYPE=1,BGPN11 S BGPVALUE=BGPVALUE_$S($P(BGPTC,U):"COUNSEL/RX: "_$$DATE^BGP2UTL($P(BGPTC,U))_" "_$P(BGPTC,U,2),1:"")
  1.  .I BGPN3,BGPRTYPE'=3 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") D
  1.  ..S BGPVALUE=BGPVALUE_"QUIT: "_$S(BGPTOB]"":$P(BGPTOB,U,2)_" ",1:$$DATE^BGP2UTL($P(BGPSDXQ,U,2)))_$P(BGPTOB,U)_$S(+BGPSDXQ="305.13":" POV 305.13 ",$P(BGPSDXQ,U)="V15.82":" POV V15.82",1:"")
  1.  .I BGPN4,BGPRTYPE=3 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") D
  1.  ..S BGPVALUE=BGPVALUE_"TO-M "_$$DATE^BGP2UTL($P(BGPTOM,U))
  1.  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
  1.  Q
  1. DNKA(V) ;EP - is this a DNKA visit?
  1.  NEW D,N
  1.  S D=$$PRIMPOV^APCLV(V,"C")
  1.  I D=".0860" Q 1
  1.  S N=$$PRIMPOV^APCLV(V,"N")
  1.  I $E(D)="V",N["DNKA" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPT" Q 1
  1.  Q 0
  1. TOMPED(P,BDATE,EDATE) ;EP
  1.  K BGPALLED
  1.  S BGPLPED=""
  1.  S Y="BGPALLED("
  1.  S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPALLED(1)) S %="" D  I %]"" S BGPLPED=%
  1.  .S (X,D)=0,T="" F  S X=$O(BGPALLED(X)) Q:X'=+X  D
  1.  ..S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
  1.  ..Q:'T
  1.  ..Q:'$D(^AUTTEDT(T,0))
  1.  ..S T=$P(^AUTTEDT(T,0),U,2)
  1.  ..I T'="TO-M" Q
  1.  ..I $P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T
  1.  I BGPLPED]"" Q BGPLPED  ;
  1. TOMREF ; 
  1.  ;EP - now check all Refusals of these education topics
  1.  S G="",X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X=""!(G]"")  D
  1.  .S D=0 F  S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D=""!(G]"")  D
  1.  ..S I=0 F  S I=$O(^AUPNPREF("AA",P,9999999.09,X,D,I)) Q:I'=+I!(G]"")  D
  1.  ...S Z=$P($G(^AUPNPREF(I,0)),U,3)
  1.  ...Q:Z=""
  1.  ...I Z<BDATE Q
  1.  ...I Z>EDATE Q
  1.  ...S Y=$P($G(^AUTTEDT(X,0)),U,2)
  1.  ...I Y'="TO-M" Q
  1.  ...S G=Z_U_"Ref "_Y
  1.  Q G
  1. GETALLHF ;
  1.  K BGPALLH
  1.  S C=$O(^AUTTHF("B","TOBACCO (SMOKING)",0)) ;ien of category passed
  1.  D GETHF1
  1.  ;If it is a current or cessation, use it and quit
  1.  I $P(BGPTOBS,U,2)["CURRENT"!($P(BGPTOBS,U,2)["CESSATION") Q
  1.  S C=$O(^AUTTHF("B","TOBACCO (SMOKELESS - CHEWING/DIP)",0)) ;ien of category passed
  1.  D GETHF1
  1.  ;If it is a current or cessation, use it and quit
  1.  I $P(BGPTOBS,U,2)["CURRENT"!($P(BGPTOBS,U,2)["CESSATION") Q
  1.  S C=$O(^AUTTHF("B","TOBACCO",0)) ;ien of category passed
  1.  D GETHF1
  1.  ;If it is a current or cessation, use it and quit
  1.  I $P(BGPTOBS,U,2)["CURRENT"!($P(BGPTOBS,U,2)["CESSATION") Q
  1.  ;now get lastest of any of the categories
  1.  S D=$O(BGPALLH(0))
  1.  I D S BGPTOBS=BGPALLH(D) Q
  1.  S BGPTOBS=""
  1.  Q
  1. GETHF1 ;
  1.  I '$G(C) S BGPTOBS="" Q
  1.  NEW ED,BD
  1.  K BGPTOBS
  1.  S ED=BGPEDX
  1.  S BD=BGPBDX
  1.  S (H,D)=0 K O
  1.  F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D
  1.  .Q:'$D(^AUPNVHF("AA",DFN,H))
  1.  .S D="" F  S D=$O(^AUPNVHF("AA",DFN,H,D)) Q:D'=+D  D
  1.  ..Q:(9999999-D)>ED  ;after time frame
  1.  ..Q:(9999999-D)<BD  ;before time frame
  1.  ..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["CESSATION" Q
  1.  ..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["CURRENT SMOKE",$P(^AUTTHF(H,0),U)'["CESSATION" Q
  1.  ..S BGPTOBS(D)=$O(^AUPNVHF("AA",DFN,H,D,""))_U_$P(^AUTTHF(H,0),U)
  1.  .Q
  1.  ;NOW if there are multiples , take the USER one, if no USER ONE TAKE THE LATEST ONE
  1.  S BGPTOBS=""
  1.  S (D,H)=$O(BGPTOBS(0)) I 'D S BGPTOBS="" Q
  1.  S Y=0 F  S Y=$O(BGPTOBS(Y)) Q:Y'=+Y  D  Q:BGPTOBS]""
  1.  .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)
  1.  Q:BGPTOBS]""
  1.  S D=BGPTOBS(D)_U_(9999999-D)
  1.  K BGPTOBS
  1.  S BGPTOBS=D,BGPALLH(H)=D
  1.  Q
  1. QUIT(P,BD,ED) ;
  1.  NEW Y,X,G,T
  1.  S Y=$$LASTDX^BGP2UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
  1.  I Y Q 1_U_"QUIT: "_$$DATE^BGP2UTL($P(Y,U,3))_" POV "_$P(Y,U,2)
  1.  S X=0,G="" F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:$P(^AUPNPROB(X,0),U,3)>ED
  1.  .Q:$P(^AUPNPROB(X,0),U,3)<BD
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .S T=$P($$ICDDX^ICDCODE(Y),U,2)
  1.  .I '$$ICD^ATXCHK(Y,$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9) Q
  1.  .S G=1_U_"QUIT: "_$$DATE^BGP2UTL($P(^AUPNPROB(X,0),U,3))_" PL "_$P(^ICD9(Y,0),U)
  1.  I G Q G
  1.  S G=$$LASTHF^BGP2D7(P,"TOBACCO",BD,ED)
  1.  I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
  1.  S G=$$LASTHF^BGP2D7(P,"TOBACCO (SMOKING)",BD,ED)
  1.  I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
  1.  S G=$$LASTHF^BGP2D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
  1.  I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
  1.  Q ""
  1.  ;
  1. GETLAST(P,BD,ED) ;
  1.  NEW BGPLAST
  1.  S G=$$LASTHF^BGP2D7(P,"TOBACCO",BD,ED)
  1.  I G]"" S BGPLAST(9999999-$P(G,U,3))=G
  1.  S G=$$LASTHF^BGP2D7(P,"TOBACCO (SMOKING)",BD,ED)
  1.  I G]"" S BGPLAST(9999999-$P(G,U,3))=G
  1.  S G=$$LASTHF^BGP2D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
  1.  I G]"" S BGPLAST(9999999-$P(G,U,3))=G
  1.  S G=$O(BGPLAST(0))
  1.  I 'G Q ""
  1.  Q BGPLAST(G)
  1. I91 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10)=0
  1.  K BGPTOB,BGPSDX,BGP1320,BGPTC,BGPTQ,BGPTOM,BGPTOBS,BGPTC1,BGPTOBD,BGPQ
  1.  S (BGPTUHF,BGPTUQ,BGPTU,BGPTUC,BGPREM,BGPTOBD,BGPTOBX,BGPTC,BGPTC1,BGPQ)=""
  1.  I 'BGPACTUP S BGPSTOP=1 Q  ;must be at least user pop
  1.  D NEWSTUFF Q
  1.  ;
  1. NEWSTUFF ;new stuff
  1.  ;BGPD6 - is a tobacco user or user in cessation
  1.  ;BGPD7 - active clinical tobacco user or user in cessation
  1.  ;BGPD8 - ditto, less than 12
  1.  ;BGPD9 - ditto, 12-17
  1.  ;BGPD10 - ditto over 17
  1.  K BGPTOBS
  1.  S BGPBDX=BGPBDATE,BGPEDX=BGPEDATE D GETALLHF
  1.  I BGPTOBS]"" D  G:BGPTU SET
  1.  .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
  1.  .I $P(BGPTOBS,U,2)["CURRENT" S BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2)
  1.  .I $P(BGPTOBS,U,2)]"",'BGPTU D
  1.  ..S X=$P(BGPTOBS,U,3)
  1.  ..S Y=$$CPTI^BGP2DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
  1.  ..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT 1034F" Q
  1.  ..S Y=$$CPTI^BGP2DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
  1.  ..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT 1035F"
  1.  ;
  1.  I BGPTOBS="" D  G:Y SET
  1.  .S Y=$$LASTDX^BGP2UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDATE,BGPEDATE)
  1.  .I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
  1.  .S Y=$$CPT^BGP2DU(DFN,BGPBDATE,BGPEDATE,$O(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
  1.  .I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX=$P(Y,U,3) Q
  1.  .;problem list diagnosis
  1.  .S T=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
  1.  .S X=0,G="",Y="" F  S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X  D
  1.  ..Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  ..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
  1.  ..S Z=$P(^AUPNPROB(X,0),U)
  1.  ..Q:'$$ICD^ATXCHK(Z,T,9)
  1.  ..S Y=1,BGPTU=1,BGPTOBD=$P(^AUPNPROB(X,0),U,3),BGPTOBX="PL: "_$P(^ICD9(Z,0),U,1)
  1.  ;
  1.  S BGPBDX=$$DOB^AUPNPAT(DFN),BGPEDX=$$FMADD^XLFDT(BGPBDATE,-1) S BGPTOBS=$$GETLAST(DFN,BGPBDX,BGPEDX)  ;EXPANDED TIME FRAME
  1.  ;
  1.  I BGPTOBS]"" D  G POT
  1.  .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
  1.  .I $P(BGPTOBS,U,1)["CURRENT" S BGPTU=1,BGPTOBD=$P(BGPTOBS,U,3),BGPTOBX=$P(BGPTOBS,U,2)
  1.  .I $P(BGPTOBS,U,1)]"",'BGPTU D
  1.  ..S X=$P(BGPTOBS,U,3)
  1.  ..S Y=$$CPTI^BGP2DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
  1.  ..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1034F" Q
  1.  ..S Y=$$CPTI^BGP2DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
  1.  ..I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX="CPT: 1035F"
  1.  ;
  1.  I BGPTOBS="" D  G:Y POT
  1.  .S Y=$$LASTDX^BGP2UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDX,BGPEDX)
  1.  .I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
  1.  .S Y=$$CPT^BGP2DU(DFN,BGPBDX,BGPEDX,$O(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
  1.  .I Y S BGPTU=1,BGPTOBD=$P(Y,U,2),BGPTOBX=$P(Y,U,3) Q
  1.  .;problem list diagnosis
  1.  .S T=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
  1.  .S X=0,G="",Y="" F  S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X  D
  1.  ..Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  ..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
  1.  ..S Z=$P(^AUPNPROB(X,0),U)
  1.  ..Q:'$$ICD^ATXCHK(Z,T,9)
  1.  ..S Y=1,BGPTU=1,BGPTOBD=$P(^AUPNPROB(X,0),U,3),BGPTOBX="PL: "_$P(^ICD9(Z,0),U,1)
  1.  ;
  1.  I 'BGPTU G SET  ;not a tobacco user
  1. POT ;if potential check for 2 codes
  1.  S X=BGPTOBD
  1.  S Y=$$LASTDX^BGP2UTL1(DFN,"BGP TOBACCO PAST USE DXS",$$FMADD^XLFDT(X,1),BGPBDATE)
  1.  I Y S BGPTU="" G SET
  1.  S X=0,G="",BGPREM="" F  S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X!(BGPREM)  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1.  .Q:$P(^AUPNPROB(X,0),U,3)>BGPBDATE
  1.  .Q:$P(^AUPNPROB(X,0),U,3)<X
  1.  .S Y=$P(^AUPNPROB(X,0),U)
  1.  .S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
  1.  .I $$ICD^ATXCHK(Y,T,9) S BGPREM=1 Q
  1.  .Q
  1.  ;
  1.  I BGPREM S BGPTU=""
  1.  ;BGPTU - tobacco user  BGPTUQ - quit tobacco use BGPTUC - tobacco user in cessation
  1. SET ;
  1.  I 'BGPTU S BGPSTOP=1 D KVARS Q  ;not in this denominator at all
  1.  S BGPD6=1
  1.  I BGPD6,BGPACTCL S BGPD7=1
  1.  I BGPD7,BGPAGEB<12 S BGPD8=1
  1.  I BGPD7,BGPAGEB>11,BGPAGEB<18 S BGPD9=1
  1.  I BGPD7,BGPAGEB>17 S BGPD10=1
  1.  ;get numerator stuff
  1.  ;BGPN6=tobacco cessation counseling  bgpn7 - REFUSED counseling  
  1.  ;I 'BGPTUC S BGPTC1=$$PED^BGP2D711(DFN,BGPBDATE,BGPEDATE,1)
  1.  S BGPTC1=$$PED^BGP2D711(DFN,BGPBDATE,BGPEDATE,1)
  1.  I $P(BGPTC1,U)]"" S BGPN6=1 I $P(BGPTC1,U,2)["Ref" S BGPN7=1
  1.  ;BGPN8 - quit   bgpn9-cessation
  1.  S Y=$$FMADD^XLFDT(BGPTOBD,1)
  1.  I Y<BGPBDATE S Y=BGPBDATE
  1.  S BGPQ=$$QUIT(DFN,Y,BGPEDATE)  ;any quit after BGPTOBD
  1.  I BGPQ S BGPN8=1
  1.  ;I BGPTUQ S BGPN8=1
  1.  I BGPN8,BGPTUQ S BGPN9=1
  1.  I BGPN6!(BGPN8) S BGPN10=1
  1.  ;SET BGPVALUE
  1.  S BGPVALUE=$S(BGPRTYPE=3:"",1:"")_$S(BGPD7:"AC",1:"")_" TOB USER: "_$$DATE^BGP2UTL(BGPTOBD)
  1.  D
  1.  .S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC1,U):"COUNSEL: "_$$DATE^BGP2UTL($P(BGPTC1,U))_" "_$P(BGPTC1,U,2),1:"")
  1.  .I BGPN8,BGPQ S BGPVALUE=BGPVALUE_"; "_$P(BGPQ,U,2) ;_" "_$P(BGPQ,U,3)
  1. KVARS ;
  1.  K BGPQ,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPQ,BGPALLED,BGPTQ,BGPTC
  1.  K BGPTC1,BGPTOB,BGPSDX,BGP1320,BGPTOM,BGPTOBS,BGPTUHF,BGPTU,BGPTUC,BGPTUQ,BGPTOBD,BGPREM
  1.  Q