BGP4D71 ; IHS/CMI/LAB - measure C ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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^BGP4D6(DFN,BGPEDATE,BGPAGEE)
S BGPOW=$$OW^BGP4D6(DFN,BGPBMI,BGPAGEE)
S BGPOB=$$OB^BGP4D6(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^BGP4D711(DFN,BGP365,BGPEDATE) I BGPMN]"" S BGPN1=1
S BGPSN=$$SPECNUTR^BGP4D711(DFN,BGP365,BGPEDATE) I BGPSN]"" S BGPN2=1
S BGPSPEX=$$SPECEX^BGP4D711(DFN,BGP365,BGPEDATE) I BGPSPEX]"" S BGPN3=1
S BGPOTH=$$OTHREL^BGP4D711(DFN,BGP365,BGPEDATE) I BGPOTH]"" S BGPN4=1
I BGPMN]"" S BGPVALUE="MNT: "_$$DATE^BGP4UTL($P(BGPMN,U))_" "_$P(BGPMN,U,2)_$S(BGPMN]"":"; ",1:"")
I BGPSN]"" S BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP4UTL($P(BGPSN,U))_" "_$P(BGPSN,U,2)_$S(BGPSN]"":"; ",1:"")
I BGPSPEX]"" S BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP4UTL($P(BGPSPEX,U))_" "_$P(BGPSPEX,U,2)_$S(BGPSPEX]"":"; ",1:"")
I BGPOTH]"" S BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP4UTL($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 ;
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","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^BGP4UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
I Y Q 1_U_"QUIT: "_$$DATE^BGP4UTL($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)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.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^BGP4UTL2(Y),U,2)
.I '$$ICD^BGP4UTL2(Y,$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9) Q
.S G=1_U_"QUIT: "_$$DATE^BGP4UTL($P(^AUPNPROB(X,0),U,3))_" PL "_$P(^ICD9(Y,0),U)
I G Q G
S G=$$LASTHF^BGP4D7(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^BGP4D7(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^BGP4D7(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^BGP4D7(P,"TOBACCO",BD,ED)
I G]"" S BGPLAST(9999999-$P(G,U,3))=G
S G=$$LASTHF^BGP4D7(P,"TOBACCO (SMOKING)",BD,ED)
I G]"" S BGPLAST(9999999-$P(G,U,3))=G
S G=$$LASTHF^BGP4D7(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"!($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^BGP4DU(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^BGP4DU(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^BGP4UTL1(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^BGP4DU(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)="D"
..Q:$P(^AUPNPROB(X,0),U,12)="I"
..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
..S Z=$P(^AUPNPROB(X,0),U)
..Q:'$$ICD^BGP4UTL2(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^BGP4DU(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^BGP4DU(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^BGP4UTL1(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^BGP4DU(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)="D"
..Q:$P(^AUPNPROB(X,0),U,12)="I"
..Q:$P(^AUPNPROB(X,0),U,3)>BGPEDX
..S Z=$P(^AUPNPROB(X,0),U)
..Q:'$$ICD^BGP4UTL2(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^BGP4UTL1(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"
.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^BGP4UTL2(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^BGP4D711(DFN,BGPBDATE,BGPEDATE,1)
S BGPTC1=$$PED^BGP4D711(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^BGP4UTL(BGPTOBD)
D
.S BGPVALUE=BGPVALUE_"|||"_$S($P(BGPTC1,U):"COUNSEL: "_$$DATE^BGP4UTL($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
BGP4D71 ; IHS/CMI/LAB - measure C ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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^BGP4D6(DFN,BGPEDATE,BGPAGEE)
+7 SET BGPOW=$$OW^BGP4D6(DFN,BGPBMI,BGPAGEE)
+8 SET BGPOB=$$OB^BGP4D6(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^BGP4D711(DFN,BGP365,BGPEDATE)
IF BGPMN]""
SET BGPN1=1
+21 SET BGPSN=$$SPECNUTR^BGP4D711(DFN,BGP365,BGPEDATE)
IF BGPSN]""
SET BGPN2=1
+22 SET BGPSPEX=$$SPECEX^BGP4D711(DFN,BGP365,BGPEDATE)
IF BGPSPEX]""
SET BGPN3=1
+23 SET BGPOTH=$$OTHREL^BGP4D711(DFN,BGP365,BGPEDATE)
IF BGPOTH]""
SET BGPN4=1
+24 IF BGPMN]""
SET BGPVALUE="MNT: "_$$DATE^BGP4UTL($PIECE(BGPMN,U))_" "_$PIECE(BGPMN,U,2)_$SELECT(BGPMN]"":"; ",1:"")
+25 IF BGPSN]""
SET BGPVALUE=BGPVALUE_"NUTR: "_$$DATE^BGP4UTL($PIECE(BGPSN,U))_" "_$PIECE(BGPSN,U,2)_$SELECT(BGPSN]"":"; ",1:"")
+26 IF BGPSPEX]""
SET BGPVALUE=BGPVALUE_"EXER ED: "_$$DATE^BGP4UTL($PIECE(BGPSPEX,U))_" "_$PIECE(BGPSPEX,U,2)_$SELECT(BGPSPEX]"":"; ",1:"")
+27 IF BGPOTH]""
SET BGPVALUE=BGPVALUE_"LIFE: "_$$DATE^BGP4UTL($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 ;
+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","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^BGP4UTL1(P,"BGP TOBACCO PAST USE DXS",BD,ED)
+3 IF Y
QUIT 1_U_"QUIT: "_$$DATE^BGP4UTL($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)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,3)>ED
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)<BD
QUIT
+9 SET Y=$PIECE(^AUPNPROB(X,0),U)
+10 SET T=$PIECE($$ICDDX^BGP4UTL2(Y),U,2)
+11 IF '$$ICD^BGP4UTL2(Y,$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0)),9)
QUIT
+12 SET G=1_U_"QUIT: "_$$DATE^BGP4UTL($PIECE(^AUPNPROB(X,0),U,3))_" PL "_$PIECE(^ICD9(Y,0),U)
End DoDot:1
+13 IF G
QUIT G
+14 SET G=$$LASTHF^BGP4D7(P,"TOBACCO",BD,ED)
+15 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+16 SET G=$$LASTHF^BGP4D7(P,"TOBACCO (SMOKING)",BD,ED)
+17 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+18 SET G=$$LASTHF^BGP4D7(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BD,ED)
+19 IF $PIECE(G,U)["PREVIOUS"
QUIT 1_U_"QUIT: "_$PIECE(G,U,2)_" HF: "_$PIECE(G,U,1)
+20 QUIT ""
+21 ;
GETLAST(P,BD,ED) ;
+1 NEW BGPLAST
+2 SET G=$$LASTHF^BGP4D7(P,"TOBACCO",BD,ED)
+3 IF G]""
SET BGPLAST(9999999-$PIECE(G,U,3))=G
+4 SET G=$$LASTHF^BGP4D7(P,"TOBACCO (SMOKING)",BD,ED)
+5 IF G]""
SET BGPLAST(9999999-$PIECE(G,U,3))=G
+6 SET G=$$LASTHF^BGP4D7(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"!($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)
+11 IF $PIECE(BGPTOBS,U,2)]""
IF 'BGPTU
Begin DoDot:2
+12 SET X=$PIECE(BGPTOBS,U,3)
+13 SET Y=$$CPTI^BGP4DU(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^BGP4DU(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^BGP4UTL1(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^BGP4DU(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)="D"
QUIT
+27 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+28 IF $PIECE(^AUPNPROB(X,0),U,3)>BGPEDX
QUIT
+29 SET Z=$PIECE(^AUPNPROB(X,0),U)
+30 IF '$$ICD^BGP4UTL2(Z,T,9)
QUIT
+31 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
+32 ;
+33 ;EXPANDED TIME FRAME
SET BGPBDX=$$DOB^AUPNPAT(DFN)
SET BGPEDX=$$FMADD^XLFDT(BGPBDATE,-1)
SET BGPTOBS=$$GETLAST(DFN,BGPBDX,BGPEDX)
+34 ;
+35 IF BGPTOBS]""
Begin DoDot:1
+36 ;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)
+37 IF $PIECE(BGPTOBS,U,1)["CURRENT"
SET BGPTU=1
SET BGPTOBD=$PIECE(BGPTOBS,U,3)
SET BGPTOBX=$PIECE(BGPTOBS,U,2)
+38 IF $PIECE(BGPTOBS,U,1)]""
IF 'BGPTU
Begin DoDot:2
+39 SET X=$PIECE(BGPTOBS,U,3)
+40 SET Y=$$CPTI^BGP4DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1034F"))
+41 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1034F"
QUIT
+42 SET Y=$$CPTI^BGP4DU(DFN,$$FMADD^XLFDT(X,1),BGPEDATE,+$$CODEN^ICPTCOD("1035F"))
+43 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX="CPT: 1035F"
End DoDot:2
End DoDot:1
GOTO POT
+44 ;
+45 IF BGPTOBS=""
Begin DoDot:1
+46 SET Y=$$LASTDX^BGP4UTL1(DFN,"BGP TOBACCO USER DXS",BGPBDX,BGPEDX)
+47 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,3)
SET BGPTOBX=$PIECE(Y,U,2)
QUIT
+48 SET Y=$$CPT^BGP4DU(DFN,BGPBDX,BGPEDX,$ORDER(^ATXAX("B","BGP TOBACCO USER CPTS",0)),6)
+49 IF Y
SET BGPTU=1
SET BGPTOBD=$PIECE(Y,U,2)
SET BGPTOBX=$PIECE(Y,U,3)
QUIT
+50 ;problem list diagnosis
+51 SET T=$ORDER(^ATXAX("B","BGP TOBACCO USER DXS",0))
+52 SET X=0
SET G=""
SET Y=""
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:2
+53 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+54 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+55 IF $PIECE(^AUPNPROB(X,0),U,3)>BGPEDX
QUIT
+56 SET Z=$PIECE(^AUPNPROB(X,0),U)
+57 IF '$$ICD^BGP4UTL2(Z,T,9)
QUIT
+58 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
+59 ;
+60 ;not a tobacco user
IF 'BGPTU
GOTO SET
POT ;if potential check for 2 codes
+1 SET X=BGPTOBD
+2 SET Y=$$LASTDX^BGP4UTL1(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 $PIECE(^AUPNPROB(X,0),U,3)>BGPBDATE
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)<X
QUIT
+9 SET Y=$PIECE(^AUPNPROB(X,0),U)
+10 SET T=$ORDER(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
+11 IF $$ICD^BGP4UTL2(Y,T,9)
SET BGPREM=1
QUIT
+12 QUIT
End DoDot:1
+13 ;
+14 IF BGPREM
SET BGPTU=""
+15 ;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^BGP4D711(DFN,BGPBDATE,BGPEDATE,1)
+10 SET BGPTC1=$$PED^BGP4D711(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^BGP4UTL(BGPTOBD)
+22 Begin DoDot:1
+23 SET BGPVALUE=BGPVALUE_"|||"_$SELECT($PIECE(BGPTC1,U):"COUNSEL: "_$$DATE^BGP4UTL($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
