BGP8D711 ; IHS/CMI/LAB - measure C 30 Jun 2010 12:14 PM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
SPECNUTR(P,BDATE,EDATE) ;EP
NEW BGPALLED,BGPG,X,T,D,%
K BGPALLED,BGPG
K BGPG S X=P_"^LAST DX [BGP DIETARY SURVEILLANCE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U)_U_$P(BGPG(1),U,2)
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)) Q ""
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 $P(T,"-",2)="N"!($P(T,"-",2)="DT")!($P(T,"-",2)="MNT") S %=$P(BGPALLED(X),U)_U_T_" SN" Q
.S S=$P(T,"-",1)
.S S=$$ICDDX^BGP8UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($P(S,U,1),$O(^ATXAX("B","BGP DIETARY SURVEILLANCE DXS",0)),9) S %=$P(BGPALLED(X),U)_U_T_" SN" Q
.I $P(T,"-",1)="97802"!($P(T,"-",1)="97803")!($P(T,"-",1)="97804")!($P(T,"-")="G0270")!($P(T,"-")="G0271") S %=$P(BGPALLED(X),U)_U_T Q
I %]"" Q %
;NOW CHECK FOR PATIENT GOAL OF NUTRITION
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",P,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.S G=0
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y!(G) D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z,$$VAL^XBDIQ1(9001002.4,Z,.01)="NUTRITION" S G=1
.Q:'G ; not nutrition
.S G=0
.I $P(^AUPNGOAL(X,0),U,11)="ME" S G=1
.I $P(^AUPNGOAL(X,0),U,11)="A" S G=1
.I $P(^AUPNGOAL(X,0),U,11)="MA" S G=1
.Q:'G
.;DURING REPORT PERIOD (CREATE OR MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,3),".")
.I D'<BDATE,D'>EDATE S G=1
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BDATE,D'>EDATE S G=1
.Q:'G
.S %=$P(^AUPNGOAL(X,0),U,5)
.I %="" S %=$P(^AUPNGOAL(X,0),U,3)
.S %=%_U_"Goal Nutrition"
Q %
;
SPECEX(P,BDATE,EDATE) ;EP
NEW BGPG,BGPALLED,X,T,%,D
K BGPALLED
S X=P_"^LAST DX [BGP EXERCISE COUNSELING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U)_U_$P(BGPG(1),U,2)
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)) Q ""
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 $P(T,"-",2)="EX" S %=$P(BGPALLED(X),U)_U_T Q
.S S=$P(T,"-",1)
.S S=$$ICDDX^BGP8UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($P(S,U,1),$O(^ATXAX("B","BGP EXERCISE COUNSELING DXS",0)),9) S %=$P(BGPALLED(X),U)_U_T Q
I %]"" Q %
;NOW CHECK FOR PATIENT GOAL OF PHYSICAL ACTIVITY
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",P,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.S G=0
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y!(G) D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..I Z,$$VAL^XBDIQ1(9001002.4,Z,.01)="PHYSICAL ACTIVITY" S G=1
.Q:'G ; not nutrition
.S G=0
.I $P(^AUPNGOAL(X,0),U,11)="ME" S G=1
.I $P(^AUPNGOAL(X,0),U,11)="A" S G=1
.I $P(^AUPNGOAL(X,0),U,11)="MA" S G=1
.Q:'G
.;DURING REPORT PERIOD (CREATE OR MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,3),".")
.I D'<BDATE,D'>EDATE S G=1
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BDATE,D'>EDATE S G=1
.Q:'G
.S %=$P(^AUPNGOAL(X,0),U,5)
.I %="" S %=$P(^AUPNGOAL(X,0),U,3)
.S %=%_U_"Goal Physical Activity"
Q %
OTHREL(P,BDATE,EDATE) ;EP
NEW BGPALLED,SN,Y,X,E,D,T,S,%
K BGPALLED
S Y="BGPALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S SN=$O(^BGPSNOMR("B","OTHER NUTRITION PATIENT ED",0))
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 $P(T,"-",2)="LA"!($P(T,"-",1)="OBS") S %=$P(BGPALLED(X),U)_U_T Q
.S S=$P(T,"-",1)
.S S=$$ICDDX^BGP8UTL2(S)
.I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($P(S,U,1),$O(^ATXAX("B","BGP OTHER REL WT EDUC DXS",0)),9) S %=$P(BGPALLED(X),U)_U_T Q
.I S="S9449"!(S="S9451")!(S="S9452")!(S="S9470") S %=$P(BGPALLED(X),U)_U_T Q
.I $P(T,"-",1)]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-",1))) S %=$P(BGPALLED(X),U)_U_T Q
I % Q %
;NOW CHECK V CPT
S %=$$CPT^BGP8DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP OTHER REL EDUC CPTS",0)),5)
Q %
MEDNUTRD(P,BDATE,EDATE) ;EP
K ^TMP($J)
NEW E,%,X,Y,D,Z,W,BGPG,BGPC
K BGPG,BGPC
S E=+$$CODEN^ICPTCOD(97802),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802"
S E=+$$CODEN^ICPTCOD(97803),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97803"
S E=+$$CODEN^ICPTCOD(97804),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804"
S E=+$$CODEN^ICPTCOD("G0270"),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270"
S E=+$$CODEN^ICPTCOD("G0271"),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271"
;TRAN CODES
S E=+$$CODEN^ICPTCOD(97802),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802"
S E=+$$CODEN^ICPTCOD(97803),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)-"^97803"
S E=+$$CODEN^ICPTCOD(97804),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804"
S E=+$$CODEN^ICPTCOD("G0270"),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270"
S E=+$$CODEN^ICPTCOD("G0271"),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271"
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
S (X,Y,D)="" F S X=$O(BGPG(X)) Q:X'=+X!(Y) D
.S Z=0 F S Z=$O(^AUPNVPRV("AD",$P(BGPG(X),U,5),Z)) Q:Z'=+Z!(Y) D
..S W=$P($G(^AUPNVPRV(Z,0)),U,1)
..Q:W=""
..S R=$$VALI^XBDIQ1(200,W,53.5)
..I R="" Q
..S R=$P($G(^DIC(7,R,9999999)),U,1)
..I R="07"!(R=29),'$$DNKA($P(BGPG(X),U,5)) S Y=1,D=$P(BGPG(X),U)
I Y Q D_"^Prv "_R
S (X,Y,D)="" F S X=$O(BGPG(X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(BGPG(X),U,5),"C") I (R=67!(R=36)),'$$DNKA($P(BGPG(X),U,5)) S Y=1,D=$P(BGPG(X),U)
I Y Q D_"^Cl "_R
Q ""
MEDNUTR(P,BDATE,EDATE) ;EP
K ^TMP($J),BGPG,BGPC
S E=+$$CODEN^ICPTCOD(97802),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802"
S E=+$$CODEN^ICPTCOD(97803),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97803"
S E=+$$CODEN^ICPTCOD(97804),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804"
S E=+$$CODEN^ICPTCOD("G0270"),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270"
S E=+$$CODEN^ICPTCOD("G0271"),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271"
;TRAN CODES
S E=+$$CODEN^ICPTCOD(97802),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802"
S E=+$$CODEN^ICPTCOD(97803),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)-"^97803"
S E=+$$CODEN^ICPTCOD(97804),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804"
S E=+$$CODEN^ICPTCOD("G0270"),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270"
S E=+$$CODEN^ICPTCOD("G0271"),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271"
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
S (X,Y,D)="" F S X=$O(BGPG(X)) Q:X'=+X!(Y) D
.S Z=0 F S Z=$O(^AUPNVPRV("AD",$P(BGPG(X),U,5),Z)) Q:Z'=+Z!(Y) D
..S W=$P($G(^AUPNVPRV(Z,0)),U,1)
..Q:W=""
..S R=$$VALI^XBDIQ1(200,W,53.5)
..I R="" Q
..S R=$P($G(^DIC(7,R,9999999)),U,1)
..I R="07"!(R=29)!(R=97)!(R=99),'$$DNKA($P(BGPG(X),U,5)) S Y=1,D=$P(BGPG(X),U)
;S R=$$PRIMPROV^APCLV($P(BGPG(X),U,5),"D") I (R="07"!(R=29))!(R=97)!(R=99),'$$DNKA($P(BGPG(X),U,5)) S Y=1,D=$P(BGPG(X),U)
I Y Q D_"^Prv "_R
S (X,Y,D)="" F S X=$O(BGPG(X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(BGPG(X),U,5),"C") I (R=67!(R=36)),'$$DNKA($P(BGPG(X),U,5)) S Y=1,D=$P(BGPG(X),U)
I Y Q D_"^Cl "_R
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
PED(P,BDATE,EDATE,FORE) ;EP
S FORE=$G(FORE)
NEW BGPALLED,X,Y,%,T,G,A,B,E,Z,BGPLPED,SN
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 SN=$O(^BGPSNOMR("B","TOBACCO CESSATION PATIENT ED",0))
.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 $G(BGPRTYPE)=3,T="TO-M" Q
..I $P(T,"-")]"",$D(^BGPSNOMR(SN,11,"B",$P(T,"-"))) S %=$P(BGPALLED(X),U)_U_T Q
..;$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP QUIT TOBACCO",S))
..I $P(T,"-")]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP TOBACCO TOPICS",$P(T,"-"))),$P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-")="TO",$P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",2)="TO",$P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",2)="SHS",$P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T Q
..S S=$P(T,"-",1)
..S S=$$ICDDX^BGP8UTL2(S)
..I $P(S,U,1)'="-1",$$ICD^BGP8UTL2($P(S,U,1),$O(^ATXAX("B","BGP TOBACCO DXS",0)),9) S %=$P(BGPALLED(X),U)_U_T Q
..I $P(T,"-",1)="D1320"!($P(T,"-")="99406")!($P(T,"-")="99407")!($P(T,"-")="G0375")!($P(T,"-")="G0376")!($P(T,"-")="4000F")!($P(T,"-")="G8402")!($P(T,"-")="G8453"),$P(BGPLPED,U)<$P(BGPALLED(X),U) S %=$P(BGPALLED(X),U)_U_T Q
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
;I '$D(^TMP($J,"A",1)) Q ""
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S B=$$CLINIC^APCLV(V,"C")
.I B=94,$P(BGPLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BGPLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"Cl 94" Q
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320,$P(BGPLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BGPLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"ADA 1320" Q
.Q
;I G]"" Q G
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT D1320"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN D1320"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406)) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT 99406"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406)) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN 99406"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407)) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT 99407"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407)) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN 99407"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT G0375"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT G0376"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT 4000F"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN G0375"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN G0376"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN 4000F"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CESSATION MED - CPT 4001F"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN 4001F"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT G8402"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN G8402"
S G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"CPT G8453"
S G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN G8453"
;now check meds - new in 8.0
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
;I '$D(BGPMEDS1) G PEDREF
S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION VAPI",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK" ;new in v11.0
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.Q:'Z
.S N=$P($G(^PSDRUG(Z,0)),U)
.I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
..I $P(BGPLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BGPLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
.S C=$P($G(^PSDRUG(Z,2)),U,4)
.I $$VAPI^BGP8D81(Z,T1) I $P(BGPLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BGPLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
Q BGPLPED
BGP8D711 ; IHS/CMI/LAB - measure C 30 Jun 2010 12:14 PM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
SPECNUTR(P,BDATE,EDATE) ;EP
+1 NEW BGPALLED,BGPG,X,T,D,%
+2 KILL BGPALLED,BGPG
+3 KILL BGPG
SET X=P_"^LAST DX [BGP DIETARY SURVEILLANCE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)_U_$PIECE(BGPG(1),U,2)
+5 SET Y="BGPALLED("
+6 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;I '$D(BGPALLED(1)) Q ""
+8 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+9 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+10 IF 'T
QUIT
+11 IF '$DATA(^AUTTEDT(T,0))
QUIT
+12 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+13 IF $PIECE(T,"-",2)="N"!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")
SET %=$PIECE(BGPALLED(X),U)_U_T_" SN"
QUIT
+14 SET S=$PIECE(T,"-",1)
+15 SET S=$$ICDDX^BGP8UTL2(S)
+16 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP DIETARY SURVEILLANCE DXS",0)),9)
SET %=$PIECE(BGPALLED(X),U)_U_T_" SN"
QUIT
+17 IF $PIECE(T,"-",1)="97802"!($PIECE(T,"-",1)="97803")!($PIECE(T,"-",1)="97804")!($PIECE(T,"-")="G0270")!($PIECE(T,"-")="G0271")
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:1
+18 IF %]""
QUIT %
+19 ;NOW CHECK FOR PATIENT GOAL OF NUTRITION
+20 SET X=0
SET %=""
+21 FOR
SET X=$ORDER(^AUPNGOAL("AC",P,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+22 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+23 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+24 SET G=0
+25 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+26 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+27 IF Z
IF $$VAL^XBDIQ1(9001002.4,Z,.01)="NUTRITION"
SET G=1
End DoDot:2
+28 ; not nutrition
IF 'G
QUIT
+29 SET G=0
+30 IF $PIECE(^AUPNGOAL(X,0),U,11)="ME"
SET G=1
+31 IF $PIECE(^AUPNGOAL(X,0),U,11)="A"
SET G=1
+32 IF $PIECE(^AUPNGOAL(X,0),U,11)="MA"
SET G=1
+33 IF 'G
QUIT
+34 ;DURING REPORT PERIOD (CREATE OR MODIFIED DATE)
+35 SET G=0
+36 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,3),".")
+37 IF D'<BDATE
IF D'>EDATE
SET G=1
+38 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+39 IF D'<BDATE
IF D'>EDATE
SET G=1
+40 IF 'G
QUIT
+41 SET %=$PIECE(^AUPNGOAL(X,0),U,5)
+42 IF %=""
SET %=$PIECE(^AUPNGOAL(X,0),U,3)
+43 SET %=%_U_"Goal Nutrition"
End DoDot:1
+44 QUIT %
+45 ;
SPECEX(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPALLED,X,T,%,D
+2 KILL BGPALLED
+3 SET X=P_"^LAST DX [BGP EXERCISE COUNSELING DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)_U_$PIECE(BGPG(1),U,2)
+5 SET Y="BGPALLED("
+6 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 ;I '$D(BGPALLED(1)) Q ""
+8 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+9 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+10 IF 'T
QUIT
+11 IF '$DATA(^AUTTEDT(T,0))
QUIT
+12 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+13 IF $PIECE(T,"-",2)="EX"
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+14 SET S=$PIECE(T,"-",1)
+15 SET S=$$ICDDX^BGP8UTL2(S)
+16 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP EXERCISE COUNSELING DXS",0)),9)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:1
+17 IF %]""
QUIT %
+18 ;NOW CHECK FOR PATIENT GOAL OF PHYSICAL ACTIVITY
+19 SET X=0
SET %=""
+20 FOR
SET X=$ORDER(^AUPNGOAL("AC",P,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+21 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+22 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+23 SET G=0
+24 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+25 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+26 IF Z
IF $$VAL^XBDIQ1(9001002.4,Z,.01)="PHYSICAL ACTIVITY"
SET G=1
End DoDot:2
+27 ; not nutrition
IF 'G
QUIT
+28 SET G=0
+29 IF $PIECE(^AUPNGOAL(X,0),U,11)="ME"
SET G=1
+30 IF $PIECE(^AUPNGOAL(X,0),U,11)="A"
SET G=1
+31 IF $PIECE(^AUPNGOAL(X,0),U,11)="MA"
SET G=1
+32 IF 'G
QUIT
+33 ;DURING REPORT PERIOD (CREATE OR MODIFIED DATE)
+34 SET G=0
+35 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,3),".")
+36 IF D'<BDATE
IF D'>EDATE
SET G=1
+37 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+38 IF D'<BDATE
IF D'>EDATE
SET G=1
+39 IF 'G
QUIT
+40 SET %=$PIECE(^AUPNGOAL(X,0),U,5)
+41 IF %=""
SET %=$PIECE(^AUPNGOAL(X,0),U,3)
+42 SET %=%_U_"Goal Physical Activity"
End DoDot:1
+43 QUIT %
OTHREL(P,BDATE,EDATE) ;EP
+1 NEW BGPALLED,SN,Y,X,E,D,T,S,%
+2 KILL BGPALLED
+3 SET Y="BGPALLED("
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET SN=$ORDER(^BGPSNOMR("B","OTHER NUTRITION PATIENT ED",0))
+6 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+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 $PIECE(T,"-",2)="LA"!($PIECE(T,"-",1)="OBS")
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+12 SET S=$PIECE(T,"-",1)
+13 SET S=$$ICDDX^BGP8UTL2(S)
+14 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP OTHER REL WT EDUC DXS",0)),9)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+15 IF S="S9449"!(S="S9451")!(S="S9452")!(S="S9470")
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+16 IF $PIECE(T,"-",1)]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-",1)))
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:1
+17 IF %
QUIT %
+18 ;NOW CHECK V CPT
+19 SET %=$$CPT^BGP8DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP OTHER REL EDUC CPTS",0)),5)
+20 QUIT %
MEDNUTRD(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB)
+2 NEW E,%,X,Y,D,Z,W,BGPG,BGPC
+3 KILL BGPG,BGPC
+4 SET E=+$$CODEN^ICPTCOD(97802)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97802"
+5 SET E=+$$CODEN^ICPTCOD(97803)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97803"
+6 SET E=+$$CODEN^ICPTCOD(97804)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97804"
+7 SET E=+$$CODEN^ICPTCOD("G0270")
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0270"
+8 SET E=+$$CODEN^ICPTCOD("G0271")
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0271"
+9 ;TRAN CODES
+10 SET E=+$$CODEN^ICPTCOD(97802)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97802"
+11 SET E=+$$CODEN^ICPTCOD(97803)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)-"^97803"
+12 SET E=+$$CODEN^ICPTCOD(97804)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97804"
+13 SET E=+$$CODEN^ICPTCOD("G0270")
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0270"
+14 SET E=+$$CODEN^ICPTCOD("G0271")
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0271"
+15 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+16 SET (X,Y,D)=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+17 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRV("AD",$PIECE(BGPG(X),U,5),Z))
IF Z'=+Z!(Y)
QUIT
Begin DoDot:2
+18 SET W=$PIECE($GET(^AUPNVPRV(Z,0)),U,1)
+19 IF W=""
QUIT
+20 SET R=$$VALI^XBDIQ1(200,W,53.5)
+21 IF R=""
QUIT
+22 SET R=$PIECE($GET(^DIC(7,R,9999999)),U,1)
+23 IF R="07"!(R=29)
IF '$$DNKA($PIECE(BGPG(X),U,5))
SET Y=1
SET D=$PIECE(BGPG(X),U)
End DoDot:2
End DoDot:1
+24 IF Y
QUIT D_"^Prv "_R
+25 SET (X,Y,D)=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(BGPG(X),U,5),"C")
IF (R=67!(R=36))
IF '$$DNKA($PIECE(BGPG(X),U,5))
SET Y=1
SET D=$PIECE(BGPG(X),U)
+26 IF Y
QUIT D_"^Cl "_R
+27 QUIT ""
MEDNUTR(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB),BGPG,BGPC
+2 SET E=+$$CODEN^ICPTCOD(97802)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97802"
+3 SET E=+$$CODEN^ICPTCOD(97803)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97803"
+4 SET E=+$$CODEN^ICPTCOD(97804)
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97804"
+5 SET E=+$$CODEN^ICPTCOD("G0270")
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0270"
+6 SET E=+$$CODEN^ICPTCOD("G0271")
SET %=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0271"
+7 ;TRAN CODES
+8 SET E=+$$CODEN^ICPTCOD(97802)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97802"
+9 SET E=+$$CODEN^ICPTCOD(97803)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)-"^97803"
+10 SET E=+$$CODEN^ICPTCOD(97804)
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97804"
+11 SET E=+$$CODEN^ICPTCOD("G0270")
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0270"
+12 SET E=+$$CODEN^ICPTCOD("G0271")
SET %=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0271"
+13 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+14 SET (X,Y,D)=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+15 SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRV("AD",$PIECE(BGPG(X),U,5),Z))
IF Z'=+Z!(Y)
QUIT
Begin DoDot:2
+16 SET W=$PIECE($GET(^AUPNVPRV(Z,0)),U,1)
+17 IF W=""
QUIT
+18 SET R=$$VALI^XBDIQ1(200,W,53.5)
+19 IF R=""
QUIT
+20 SET R=$PIECE($GET(^DIC(7,R,9999999)),U,1)
+21 IF R="07"!(R=29)!(R=97)!(R=99)
IF '$$DNKA($PIECE(BGPG(X),U,5))
SET Y=1
SET D=$PIECE(BGPG(X),U)
End DoDot:2
End DoDot:1
+22 ;S R=$$PRIMPROV^APCLV($P(BGPG(X),U,5),"D") I (R="07"!(R=29))!(R=97)!(R=99),'$$DNKA($P(BGPG(X),U,5)) S Y=1,D=$P(BGPG(X),U)
+23 IF Y
QUIT D_"^Prv "_R
+24 SET (X,Y,D)=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(BGPG(X),U,5),"C")
IF (R=67!(R=36))
IF '$$DNKA($PIECE(BGPG(X),U,5))
SET Y=1
SET D=$PIECE(BGPG(X),U)
+25 IF Y
QUIT D_"^Cl "_R
+26 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
PED(P,BDATE,EDATE,FORE) ;EP
+1 SET FORE=$GET(FORE)
+2 NEW BGPALLED,X,Y,%,T,G,A,B,E,Z,BGPLPED,SN
+3 KILL BGPALLED
+4 SET BGPLPED=""
+5 SET Y="BGPALLED("
+6 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPALLED(1))
SET %=""
Begin DoDot:1
+8 SET SN=$ORDER(^BGPSNOMR("B","TOBACCO CESSATION PATIENT ED",0))
+9 SET (X,D)=0
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:2
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF $GET(BGPRTYPE)=3
IF T="TO-M"
QUIT
+15 IF $PIECE(T,"-")]""
IF $DATA(^BGPSNOMR(SN,11,"B",$PIECE(T,"-")))
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+16 ;$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP QUIT TOBACCO",S))
+17 IF $PIECE(T,"-")]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP TOBACCO TOPICS",$PIECE(T,"-")))
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+18 IF $PIECE(T,"-")="TO"
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+19 IF $PIECE(T,"-",2)="TO"
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+20 IF $PIECE(T,"-",2)="SHS"
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+21 SET S=$PIECE(T,"-",1)
+22 SET S=$$ICDDX^BGP8UTL2(S)
+23 IF $PIECE(S,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP TOBACCO DXS",0)),9)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+24 IF $PIECE(T,"-",1)="D1320"!($PIECE(T,"-")="99406")!($PIECE(T,"-")="99407")!($PIECE(T,"-")="G0375")!($PIECE(T,"-")="G0376")!($PIECE(T,"-")="4000F")!($PIECE(T,"-")="G8402")!($PIECE(T,"-")="G8453")
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
End DoDot:2
End DoDot:1
IF %]""
SET BGPLPED=%
+25 KILL ^TMP($JOB,"A")
+26 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+27 ;I '$D(^TMP($J,"A",1)) Q ""
+28 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+29 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+30 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+31 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+32 SET B=$$CLINIC^APCLV(V,"C")
+33 IF B=94
IF $PIECE(BGPLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BGPLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"Cl 94"
QUIT
+34 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
IF $PIECE(BGPLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BGPLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"ADA 1320"
QUIT
+35 QUIT
End DoDot:1
+36 ;I G]"" Q G
+37 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT D1320"
+38 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN D1320"
+39 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT 99406"
+40 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN 99406"
+41 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT 99407"
+42 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN 99407"
+43 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT G0375"
+44 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT G0376"
+45 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT 4000F"
+46 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN G0375"
+47 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN G0376"
+48 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN 4000F"
+49 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CESSATION MED - CPT 4001F"
+50 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN 4001F"
+51 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT G8402"
+52 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN G8402"
+53 SET G=$$CPTI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"CPT G8453"
+54 SET G=$$TRANI^BGP8DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453"))
IF G
IF $PIECE(BGPLPED,U)<$PIECE(G,U,2)
SET BGPLPED=$PIECE(G,U,2)_U_"TRAN G8453"
+55 ;now check meds - new in 8.0
+56 KILL BGPMEDS1
+57 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+58 ;I '$D(BGPMEDS1) G PEDREF
+59 SET T=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+60 SET T1=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION VAPI",0))
+61 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+62 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+63 ;new in v11.0
IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+64 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+65 IF 'Z
QUIT
+66 SET N=$PIECE($GET(^PSDRUG(Z,0)),U)
+67 IF $DATA(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY")
Begin DoDot:2
+68 IF $PIECE(BGPLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BGPLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:2
+69 SET C=$PIECE($GET(^PSDRUG(Z,2)),U,4)
+70 IF $$VAPI^BGP8D81(Z,T1)
IF $PIECE(BGPLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BGPLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:1
+71 QUIT BGPLPED
