BGP4D71.m

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)