BGP8D71 ; IHS/CMI/LAB - measure C ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
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^BGP8D6(DFN,BGPEDATE,BGPAGEE)
S BGPOW=$$OW^BGP8D6(DFN,BGPBMI,BGPAGEE)
S BGPOB=$$OB^BGP8D6(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^BGP8D711(DFN,BGP365,BGPEDATE) I BGPMN]"" S BGPN1=1
S BGPSN=$$SPECNUTR^BGP8D711(DFN,BGP365,BGPEDATE) I BGPSN]"" S BGPN2=1
S BGPSPEX=$$SPECEX^BGP8D711(DFN,BGP365,BGPEDATE) I BGPSPEX]"" S BGPN3=1
S BGPOTH=$$OTHREL^BGP8D711(DFN,BGP365,BGPEDATE) I BGPOTH]"" S BGPN4=1
I BGPMN]"" S BGPVALUE="MNT: "_$$DATE^BGP8UTL($P(BGPMN,U))_" "_$P(BGPMN,U,2)_$S(BGPMN]"":"; ",1:"")
I BGPSN]"" S BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP8UTL($P(BGPSN,U))_" "_$P(BGPSN,U,2)_$S(BGPSN]"":"; ",1:"")
I BGPSPEX]"" S BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP8UTL($P(BGPSPEX,U))_" "_$P(BGPSPEX,U,2)_$S(BGPSPEX]"":"; ",1:"")
I BGPOTH]"" S BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP8UTL($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
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 ;EP
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")!($P(BGPTOBS,U,2)["HEAVY")!($P(BGPTOBS,U,2)["LIGHT") 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","ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)",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 ",$P(^AUTTHF(H,0),U)'["CESSATION" Q
..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["LIGHT",$P(^AUTTHF(H,0),U)'["CESSATION" Q
..I $D(BGPTOBS(D)),$P(BGPTOBS(D),U,2)["HEAVY",$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")!($P(BGPTOBS(Y),U,2)["LIGHT")!($P(BGPTOBS(Y),U,2)["HEAVY") 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^BGP8UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
I Y Q 1_U_"QUIT: "_$$DATE^BGP8UTL($P(Y,U,3))_" POV "_$P(Y,U,2)
S Y=$$PLTAXID^BGP8DU(DFN,"BGP TOBACCO PAST USE DXS",BD,ED)
I Y Q 1_U_"QUIT: "_$$DATE^BGP8UTL($P(Y,U,3))_" "_$P(Y,U,2)
S Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP QUIT TOBACCO",BD,ED)
I Y Q 1_U_"QUIT: "_$$DATE^BGP8UTL($P(Y,U,3))_" "_$P(Y,U,2)
;S G=$$LASTHF^BGP8D7(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^BGP8D7(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^BGP8D7(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)
S G=$$LASTHF^BGP8D7(P,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)",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) ;EP
NEW BGPLAST,S,C,T,E
S S=$$LASTHF^BGP8D7(P,"TOBACCO (SMOKING)",BD,ED)
I S]"" S BGPLAST(9999999-$P(S,U,3))=S I $P(S,U,1)["CESSATION"!($P(S,U,1)["CURRENT")!($P(S,U,1)["LIGHT")!($P(S,U,1)["HEAVY") Q S
S C=$$LASTHF^BGP8D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
I C]"" S BGPLAST(9999999-$P(C,U,3))=C I $P(C,U,1)["CESSATION"!($P(C,U,1)["CURRENT") Q C
S E=$$LASTHF^BGP8D7(P,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)",BD,ED)
I E]"" S BGPLAST(9999999-$P(C,U,3))=E I $P(E,U,1)["CESSATION"!($P(C,U,1)["CURRENT") Q E
S T=$O(BGPLAST(0))
I 'T Q ""
Q BGPLAST(T)
;
I91 ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=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
NEW BGPGD
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"!($P(BGPTOBS,U,2)["HEAVY TOBACCO SMOKER")!($P(BGPTOBS,U,2)["LIGHT TOBACCO SMOKER") 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^BGP8DU(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^BGP8DU(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^BGP8UTL1(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=$$PLTAXID^BGP8DU(DFN,"BGP TOBACCO USER DXS",,BGPEDATE)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP CURRENT TOBACCO",,BGPEDATE)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$CPT^BGP8DU(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
;
;
S BGPTOBS=""
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"!($P(BGPTOBS,U,1)="LIGHT TOBACCO SMOKER")!($P(BGPTOBS,U,1)="HEAVY TOBACCO SMOKER") 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^BGP8DU(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^BGP8DU(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^BGP8UTL1(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=$$PLTAXID^BGP8DU(DFN,"BGP TOBACCO USER DXS",,BGPEDATE)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP CURRENT TOBACCO",,BGPEDATE)
.I Y S BGPTU=1,BGPTOBD=$P(Y,U,3),BGPTOBX=$P(Y,U,2) Q
.S Y=$$CPT^BGP8DU(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
;
;
I 'BGPTU G SET ;not a tobacco user
POT ;if potential check for 2 codes
S X=BGPTOBD
S Y=$$LASTDX^BGP8UTL1(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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.;IF ANY OF THE 3 DATES ARE BEFORE REPORT PERIOD & AFTER X USE IT
.S BGPGD=""
.F J=13,3,8 D I 'BGPGD Q ;NO GOOD DATES Q:$P(^AUPNPROB(X,0),U,3)>BGPBDATE
..S D=$P(^AUPNPROB(X,0),U,J) I D]"",D<BGPBDATE,D>$$FMADD^XLFDT(BGPTOBD,1) S BGPGD=1 ;Q:$P(^AUPNPROB(X,0),U,3)<$$FMADD^XLFDT(BGPTOBD,1)
.S Y=$P(^AUPNPROB(X,0),U)
.S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
.I $$ICD^BGP8UTL2(Y,T,9) S BGPREM=1 Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP QUIT TOBACCO",S)) S BGPREM=1 Q
.Q
;CHECK SNOMED
;S Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP QUIT TOBACCO",$$FMADD^XLFDT(BGPTOBD,1),BGPBDATE) I Y S BGPREM=1 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
I BGPD6,BGPAGEB<12 S BGPD11=1
I BGPD6,BGPAGEB>11,BGPAGEB<18 S BGPD12=1
I BGPD6,BGPAGEB>17 S BGPD13=1
;get numerator stuff
;BGPN6=tobacco cessation counseling bgpn7 - REFUSED counseling
;I 'BGPTUC S BGPTC1=$$PED^BGP8D711(DFN,BGPBDATE,BGPEDATE,1)
S BGPTC1=$$PED^BGP8D711(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="UP"_$S(BGPD7:",AC",1:"")_" TOB USER: "_$$DATE^BGP8UTL(BGPTOBD)
D
.S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC1,U):"COUNSEL: "_$$DATE^BGP8UTL($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
BGP8D71 ; IHS/CMI/LAB - measure C ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+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^BGP8D6(DFN,BGPEDATE,BGPAGEE)
+7 SET BGPOW=$$OW^BGP8D6(DFN,BGPBMI,BGPAGEE)
+8 SET BGPOB=$$OB^BGP8D6(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^BGP8D711(DFN,BGP365,BGPEDATE)
IF BGPMN]""
SET BGPN1=1
+21 SET BGPSN=$$SPECNUTR^BGP8D711(DFN,BGP365,BGPEDATE)
IF BGPSN]""
SET BGPN2=1
+22 SET BGPSPEX=$$SPECEX^BGP8D711(DFN,BGP365,BGPEDATE)
IF BGPSPEX]""
SET BGPN3=1
+23 SET BGPOTH=$$OTHREL^BGP8D711(DFN,BGP365,BGPEDATE)
IF BGPOTH]""
SET BGPN4=1
+24 IF BGPMN]""
SET BGPVALUE="MNT: "_$$DATE^BGP8UTL($PIECE(BGPMN,U))_" "_$PIECE(BGPMN,U,2)_$SELECT(BGPMN]"":"; ",1:"")
+25 IF BGPSN]""
SET BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP8UTL($PIECE(BGPSN,U))_" "_$PIECE(BGPSN,U,2)_$SELECT(BGPSN]"":"; ",1:"")
+26 IF BGPSPEX]""
SET BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP8UTL($PIECE(BGPSPEX,U))_" "_$PIECE(BGPSPEX,U,2)_$SELECT(BGPSPEX]"":"; ",1:"")
+27 IF BGPOTH]""
SET BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP8UTL($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
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 ;EP
+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")!($PIECE(BGPTOBS,U,2)["HEAVY")!($PIECE(BGPTOBS,U,2)["LIGHT")
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","ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)",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 ;ien of category passed
SET C=$ORDER(^AUTTHF("B","TOBACCO",0))
+15 DO GETHF1
+16 ;If it is a current or cessation, use it and quit
+17 IF $PIECE(BGPTOBS,U,2)["CURRENT"!($PIECE(BGPTOBS,U,2)["CESSATION")
QUIT
+18 ;now get lastest of any of the categories
+19 SET D=$ORDER(BGPALLH(0))
+20 IF D
SET BGPTOBS=BGPALLH(D)
QUIT
+21 SET BGPTOBS=""
+22 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 "
IF $PIECE(^AUTTHF(H,0),U)'["CESSATION"
QUIT
+14 IF $DATA(BGPTOBS(D))
IF $PIECE(BGPTOBS(D),U,2)["LIGHT"
IF $PIECE(^AUTTHF(H,0),U)'["CESSATION"
QUIT
+15 IF $DATA(BGPTOBS(D))
IF $PIECE(BGPTOBS(D),U,2)["HEAVY"
IF $PIECE(^AUTTHF(H,0),U)'["CESSATION"
QUIT
+16 SET BGPTOBS(D)=$ORDER(^AUPNVHF("AA",DFN,H,D,""))_U_$PIECE(^AUTTHF(H,0),U)
End DoDot:2
+17 QUIT
End DoDot:1
+18 ;NOW if there are multiples , take the USER one, if no USER ONE TAKE THE LATEST ONE
+19 SET BGPTOBS=""
+20 SET (D,H)=$ORDER(BGPTOBS(0))
IF 'D
SET BGPTOBS=""
QUIT
+21 SET Y=0
FOR
SET Y=$ORDER(BGPTOBS(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+22 IF $PIECE(BGPTOBS(Y),U,2)["CESSATION"!($PIECE(BGPTOBS(Y),U,2)["CURRENT")!($PIECE(BGPTOBS(Y),U,2)["LIGHT")!($PIECE(BGPTOBS(Y),U,2)["HEAVY")
SET BGPTOBS=BGPTOBS(Y)_U_(9999999-Y)
SET BGPALLH(Y)=BGPTOBS(Y)_U_(9999999-Y)
End DoDot:1
IF BGPTOBS]""
QUIT
+23 IF BGPTOBS]""
QUIT
+24 SET D=BGPTOBS(D)_U_(9999999-D)
+25 KILL BGPTOBS
+26 SET BGPTOBS=D
SET BGPALLH(H)=D
+27 QUIT
QUIT(P,BD,ED) ;
+1 NEW Y,X,G,T
+2 SET Y=$$LASTDX^BGP8UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
+3 IF Y
QUIT 1_U_"QUIT: "_$$DATE^BGP8UTL($PIECE(Y,U,3))_" POV "_$PIECE(Y,U,2)
+4 SET Y=$$PLTAXID^BGP8DU(DFN,"BGP TOBACCO PAST USE DXS",BD,ED)
+5 IF Y
QUIT 1_U_"QUIT: "_$$DATE^BGP8UTL($PIECE(Y,U,3))_" "_$PIECE(Y,U,2)
+6 SET Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP QUIT TOBACCO",BD,ED)
+7 IF Y
QUIT 1_U_"QUIT: "_$$DATE^BGP8UTL($PIECE(Y,U,3))_" "_$PIECE(Y,U,2)
+8 ;S G=$$LASTHF^BGP8D7(P,"TOBACCO",BD,ED)
+9 ;I $P(G,U)["PREVIOUS" Q 1_U_"QUIT: "_$P(G,U,2)_" HF: "_$P(G,U,1)
+10 SET G=$$LASTHF^BGP8D7(P,"TOBACCO (SMOKING)",BD,ED)
+11 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+12 SET G=$$LASTHF^BGP8D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
+13 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+14 SET G=$$LASTHF^BGP8D7(P,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)",BD,ED)
+15 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+16 QUIT ""
+17 ;
GETLAST(P,BD,ED) ;EP
+1 NEW BGPLAST,S,C,T,E
+2 SET S=$$LASTHF^BGP8D7(P,"TOBACCO (SMOKING)",BD,ED)
+3 IF S]""
SET BGPLAST(9999999-$PIECE(S,U,3))=S
IF $PIECE(S,U,1)["CESSATION"!($PIECE(S,U,1)["CURRENT")!($PIECE(S,U,1)["LIGHT")!($PIECE(S,U,1)["HEAVY")
QUIT S
+4 SET C=$$LASTHF^BGP8D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
+5 IF C]""
SET BGPLAST(9999999-$PIECE(C,U,3))=C
IF $PIECE(C,U,1)["CESSATION"!($PIECE(C,U,1)["CURRENT")
QUIT C
+6 SET E=$$LASTHF^BGP8D7(P,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)",BD,ED)
+7 IF E]""
SET BGPLAST(9999999-$PIECE(C,U,3))=E
IF $PIECE(E,U,1)["CESSATION"!($PIECE(C,U,1)["CURRENT")
QUIT E
+8 SET T=$ORDER(BGPLAST(0))
+9 IF 'T
QUIT ""
+10 QUIT BGPLAST(T)
+11 ;
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,BGPD11,BGPD12,BGPD13)=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 NEW BGPGD
+8 SET BGPBDX=BGPBDATE
SET BGPEDX=BGPEDATE
DO GETALLHF
+9 IF BGPTOBS]""
Begin DoDot:1
+10 ;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)
+11 IF $PIECE(BGPTOBS,U,2)["CURRENT"!($PIECE(BGPTOBS,U,2)["HEAVY TOBACCO SMOKER")!($PIECE(BGPTOBS,U,2)["LIGHT TOBACCO SMOKER")
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+12 IF $PIECE(BGPTOBS,U,2)]""
IF 'BGPTU
Begin DoDot:2
+13 SET X=$PIECE(BGPTOBS,U,3)
+14 SET Y=$$CPTI^BGP8DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
+15 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT 1034F"
QUIT
+16 SET Y=$$CPTI^BGP8DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
+17 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
+18 ;
+19 IF BGPTOBS=""
Begin DoDot:1
+20 SET Y=$$LASTDX^BGP8UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDATE,BGPEDATE)
+21 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+22 SET Y=$$PLTAXID^BGP8DU(DFN,"BGP TOBACCO USER DXS",,BGPEDATE)
+23 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+24 SET Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP CURRENT TOBACCO",,BGPEDATE)
+25 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+26 SET Y=$$CPT^BGP8DU(DFN,BGPBDATE,BGPEDATE,$ORDER(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
+27 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX=$PIECE(Y,U,3)
QUIT
End DoDot:1
IF Y
GOTO SET
+28 ;
+29 ;
+30 SET BGPTOBS=""
+31 ;EXPANDED TIME FRAME
SET BGPBDX=$$DOB^AUPNPAT(DFN)
SET BGPEDX=$$FMADD^XLFDT(BGPBDATE,-1)
SET BGPTOBS=$$GETLAST(DFN,BGPBDX,BGPEDX)
+32 ;
+33 IF BGPTOBS]""
Begin DoDot:1
+34 ;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)
+35 IF $PIECE(BGPTOBS,U,1)["CURRENT"!($PIECE(BGPTOBS,U,1)="LIGHT TOBACCO SMOKER")!($PIECE(BGPTOBS,U,1)="HEAVY TOBACCO SMOKER")
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+36 IF $PIECE(BGPTOBS,U,1)]""
IF 'BGPTU
Begin DoDot:2
+37 SET X=$PIECE(BGPTOBS,U,3)
+38 SET Y=$$CPTI^BGP8DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
+39 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1034F"
QUIT
+40 SET Y=$$CPTI^BGP8DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
+41 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1035F"
End DoDot:2
End DoDot:1
GOTO POT
+42 ;
+43 IF BGPTOBS=""
Begin DoDot:1
+44 SET Y=$$LASTDX^BGP8UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDX,BGPEDX)
+45 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+46 SET Y=$$PLTAXID^BGP8DU(DFN,"BGP TOBACCO USER DXS",,BGPEDATE)
+47 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+48 SET Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP CURRENT TOBACCO",,BGPEDATE)
+49 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+50 SET Y=$$CPT^BGP8DU(DFN,BGPBDX,BGPEDX,$ORDER(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
+51 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX=$PIECE(Y,U,3)
QUIT
End DoDot:1
IF Y
GOTO POT
+52 ;
+53 ;
+54 ;not a tobacco user
IF 'BGPTU
GOTO SET
POT ;if potential check for 2 codes
+1 SET X=BGPTOBD
+2 SET Y=$$LASTDX^BGP8UTL1(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)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 ;IF ANY OF THE 3 DATES ARE BEFORE REPORT PERIOD & AFTER X USE IT
+8 SET BGPGD=""
+9 ;NO GOOD DATES Q:$P(^AUPNPROB(X,0),U,3)>BGPBDATE
FOR J=13,3,8
Begin DoDot:2
+10 ;Q:$P(^AUPNPROB(X,0),U,3)<$$FMADD^XLFDT(BGPTOBD,1)
SET D=$PIECE(^AUPNPROB(X,0),U,J)
IF D]""
IF D<BGPBDATE
IF D>$$FMADD^XLFDT(BGPTOBD,1)
SET BGPGD=1
End DoDot:2
IF 'BGPGD
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 SET T=$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
+13 IF $$ICD^BGP8UTL2(Y,T,9)
SET BGPREM=1
QUIT
+14 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+15 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP QUIT TOBACCO",S))
SET BGPREM=1
QUIT
+16 QUIT
End DoDot:1
+17 ;CHECK SNOMED
+18 ;S Y=$$IPLSNOID^BGP8DU(DFN,"PXRM BGP QUIT TOBACCO",$$FMADD^XLFDT(BGPTOBD,1),BGPBDATE) I Y S BGPREM=1 Q
+19 ;
+20 IF BGPREM
SET BGPTU=""
+21 ;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 IF BGPD6
IF BGPAGEB<12
SET BGPD11=1
+8 IF BGPD6
IF BGPAGEB>11
IF BGPAGEB<18
SET BGPD12=1
+9 IF BGPD6
IF BGPAGEB>17
SET BGPD13=1
+10 ;get numerator stuff
+11 ;BGPN6=tobacco cessation counseling bgpn7 - REFUSED counseling
+12 ;I 'BGPTUC S BGPTC1=$$PED^BGP8D711(DFN,BGPBDATE,BGPEDATE,1)
+13 SET BGPTC1=$$PED^BGP8D711(DFN,BGPBDATE,BGPEDATE,1)
+14 IF $PIECE(BGPTC1,U)]""
SET BGPN6=1
IF $PIECE(BGPTC1,U,2)["Ref"
SET BGPN7=1
+15 ;BGPN8 - quit bgpn9-cessation
+16 SET Y=$$FMADD^XLFDT(BGPTOBD,1)
+17 IF Y<BGPBDATE
SET Y=BGPBDATE
+18 ;any quit after BGPTOBD
SET BGPQ=$$QUIT(DFN,Y,BGPEDATE)
+19 IF BGPQ
SET BGPN8=1
+20 ;I BGPTUQ S BGPN8=1
+21 IF BGPN8
IF BGPTUQ
SET BGPN9=1
+22 IF BGPN6!(BGPN8)
SET BGPN10=1
+23 ;SET BGPVALUE
+24 SET BGPVALUE="UP"_$SELECT(BGPD7:",AC",1:"")_" TOB USER: "_$$DATE^BGP8UTL(BGPTOBD)
+25 Begin DoDot:1
+26 SET BGPVALUE=BGPVALUE_"|||"_$SELECT($PIECE(BGPTC1,U):"COUNSEL: "_$$DATE^BGP8UTL($PIECE(BGPTC1,U))_" "_$PIECE(BGPTC1,U,2),1:"")
+27 ;_" "_$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
