BGP9D711 ; IHS/CMI/LAB - measure C 30 Jun 2008 12:14 PM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
SPECNUTR(P,BDATE,EDATE) ;EP
K BGPALLED,BGPG
K BGPG S X=P_"^LAST DX V65.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U)_U_"V65.3 SN"
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")!($P(T,"-")="V65.3") S %=$P(BGPALLED(X),U)_U_T_" SN" Q
Q %
;
SPECEX(P,BDATE,EDATE) ;EP
K BGPG S X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) Q $P(BGPG(1),U)_U_"V65.41 EX"
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"!($P(T,"-")="V65.41") S %=$P(BGPALLED(X),U)_U_T_" EX" Q
Q %
OTHREL(P,BDATE,EDATE) ;EP
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)="LA"!($P(T,"-",1)="OBS")!($P(T,"-",1)="278.00")!($P(T,"-",1)="278.01") S %=$P(BGPALLED(X),U)_U_T_" OTH" Q
Q %
MEDNUTR(P,BDATE,EDATE) ;EP
K ^TMP($J),BGPG,BGPC
S E=+$$CODEN^ICPTCOD(97802),%=$$CPTI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802 MN"
S E=+$$CODEN^ICPTCOD(97803),%=$$CPTI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)-"^97803 MN"
S E=+$$CODEN^ICPTCOD(97804),%=$$CPTI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804 MN"
S E=+$$CODEN^ICPTCOD("G0270"),%=$$CPTI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270 MN"
S E=+$$CODEN^ICPTCOD("G0271"),%=$$CPTI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271 MN"
;TRAN CODES
S E=+$$CODEN^ICPTCOD(97802),%=$$TRANI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802 MN TRAN"
S E=+$$CODEN^ICPTCOD(97803),%=$$TRANI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)-"^97803 MN TRAN"
S E=+$$CODEN^ICPTCOD(97804),%=$$TRANI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804 MN TRAN"
S E=+$$CODEN^ICPTCOD("G0270"),%=$$TRANI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270 MN TRAN"
S E=+$$CODEN^ICPTCOD("G0271"),%=$$TRANI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271 MN TRAN"
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) 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)
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 $G(BGPRTYPE)=3,T="TO-M" 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
..I $P(T,"-",1)["305.1"!($P(T,"-")="649.00")!($P(T,"-")="649.01")!($P(T,"-")="649.02")!($P(T,"-")="649.03")!($P(T,"-")="649.04")!($P(T,"-")="V15.82"),$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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G,$P(BGPLPED,U)<$P(G,U,2) S BGPLPED=$P(G,U,2)_U_"TRAN 4001F"
;now check meds - new in 8.0
K BGPMEDS1
D GETMEDS^BGP9UTL2(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 NDC",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))
.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 C]"",$D(^ATXAX(T1,21,"B",C)) I $P(BGPLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BGPLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
I 'FORE,BGPLPED]"" Q BGPLPED
PEDREF ;
S G=$$REFTOED(P,$S(FORE:$$FMADD^XLFDT(EDATE,-365),1:BDATE),EDATE)
I $P(BGPLPED,U)<$P(G,U,1) Q G
Q BGPLPED
REFTOED(P,BDATE,EDATE) ;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 $G(BGPRTYPE)=3,Y="TO-M" Q
...I $P(Y,"-")="TO"!($P(Y,"-",2)="TO")!($P(Y,"-",2)="SHS") S G=Z_U_"ref "_Y
...;I $P(Y,"-",1)["305.1"!($P(Y,"-")="649.00")!($P(Y,"-")="649.01")!($P(Y,"-")="649.02")!($P(Y,"-")="649.03")!($P(Y,"-")="649.04")!($P(Y,"-")="V15.82") S G=Z_U_"ref "_Y
Q G
BGP9D711 ; IHS/CMI/LAB - measure C 30 Jun 2008 12:14 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
SPECNUTR(P,BDATE,EDATE) ;EP
+1 KILL BGPALLED,BGPG
+2 KILL BGPG
SET X=P_"^LAST DX V65.3;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)_U_"V65.3 SN"
+4 SET Y="BGPALLED("
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPALLED(1))
QUIT ""
+7 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-",2)="N"!($PIECE(T,"-",2)="DT")!($PIECE(T,"-",2)="MNT")!($PIECE(T,"-")="V65.3")
SET %=$PIECE(BGPALLED(X),U)_U_T_" SN"
QUIT
End DoDot:1
+13 QUIT %
+14 ;
SPECEX(P,BDATE,EDATE) ;EP
+1 KILL BGPG
SET X=P_"^LAST DX V65.41;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,"BGPG(")
+2 IF $DATA(BGPG(1))
QUIT $PIECE(BGPG(1),U)_U_"V65.41 EX"
+3 IF '$DATA(BGPALLED(1))
QUIT ""
+4 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+5 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+6 IF 'T
QUIT
+7 IF '$DATA(^AUTTEDT(T,0))
QUIT
+8 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+9 IF $PIECE(T,"-",2)="EX"!($PIECE(T,"-")="V65.41")
SET %=$PIECE(BGPALLED(X),U)_U_T_" EX"
QUIT
End DoDot:1
+10 QUIT %
OTHREL(P,BDATE,EDATE) ;EP
+1 IF '$DATA(BGPALLED(1))
QUIT ""
+2 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+3 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+4 IF 'T
QUIT
+5 IF '$DATA(^AUTTEDT(T,0))
QUIT
+6 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+7 IF $PIECE(T,"-",2)="LA"!($PIECE(T,"-",1)="OBS")!($PIECE(T,"-",1)="278.00")!($PIECE(T,"-",1)="278.01")
SET %=$PIECE(BGPALLED(X),U)_U_T_" OTH"
QUIT
End DoDot:1
+8 QUIT %
MEDNUTR(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB),BGPG,BGPC
+2 SET E=+$$CODEN^ICPTCOD(97802)
SET %=$$CPTI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97802 MN"
+3 SET E=+$$CODEN^ICPTCOD(97803)
SET %=$$CPTI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)-"^97803 MN"
+4 SET E=+$$CODEN^ICPTCOD(97804)
SET %=$$CPTI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97804 MN"
+5 SET E=+$$CODEN^ICPTCOD("G0270")
SET %=$$CPTI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0270 MN"
+6 SET E=+$$CODEN^ICPTCOD("G0271")
SET %=$$CPTI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0271 MN"
+7 ;TRAN CODES
+8 SET E=+$$CODEN^ICPTCOD(97802)
SET %=$$TRANI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97802 MN TRAN"
+9 SET E=+$$CODEN^ICPTCOD(97803)
SET %=$$TRANI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)-"^97803 MN TRAN"
+10 SET E=+$$CODEN^ICPTCOD(97804)
SET %=$$TRANI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^97804 MN TRAN"
+11 SET E=+$$CODEN^ICPTCOD("G0270")
SET %=$$TRANI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0270 MN TRAN"
+12 SET E=+$$CODEN^ICPTCOD("G0271")
SET %=$$TRANI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^G0271 MN TRAN"
+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
SET R=$$PRIMPROV^APCLV($PIECE(BGPG(X),U,5),"D")
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)
+15 IF Y
QUIT D_"^Prv: "_R
+16 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)
+17 IF Y
QUIT D_"^Cl: "_R
+18 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 KILL BGPALLED
+3 SET BGPLPED=""
+4 SET Y="BGPALLED("
+5 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 IF $DATA(BGPALLED(1))
SET %=""
Begin DoDot:1
+7 SET (X,D)=0
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $GET(BGPRTYPE)=3
IF T="TO-M"
QUIT
+13 IF $PIECE(T,"-")="TO"
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+14 IF $PIECE(T,"-",2)="TO"
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+15 IF $PIECE(T,"-",2)="SHS"
IF $PIECE(BGPLPED,U)<$PIECE(BGPALLED(X),U)
SET %=$PIECE(BGPALLED(X),U)_U_T
QUIT
+16 IF $PIECE(T,"-",1)["305.1"!($PIECE(T,"-")="649.00")!($PIECE(T,"-")="649.01")!($PIECE(T,"-")="649.02")!($PIECE(T,"-")="649.03")!($PIECE(T,"-")="649.04")!($PIECE(T,"-")="V15.82")
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=%
+17 KILL ^TMP($JOB,"A")
+18 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+19 ;I '$D(^TMP($J,"A",1)) Q ""
+20 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
+21 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+22 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+23 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+24 SET B=$$CLINIC^APCLV(V,"C")
+25 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
+26 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
+27 QUIT
End DoDot:1
+28 ;I G]"" Q G
+29 SET G=$$CPTI^BGP9DU(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"
+30 SET G=$$TRANI^BGP9DU(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"
+31 SET G=$$CPTI^BGP9DU(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"
+32 SET G=$$TRANI^BGP9DU(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"
+33 SET G=$$CPTI^BGP9DU(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"
+34 SET G=$$CPTI^BGP9DU(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"
+35 SET G=$$CPTI^BGP9DU(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"
+36 SET G=$$TRANI^BGP9DU(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"
+37 SET G=$$TRANI^BGP9DU(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"
+38 SET G=$$TRANI^BGP9DU(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"
+39 SET G=$$CPTI^BGP9DU(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"
+40 SET G=$$TRANI^BGP9DU(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"
+41 ;now check meds - new in 8.0
+42 KILL BGPMEDS1
+43 DO GETMEDS^BGP9UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+44 ;I '$D(BGPMEDS1) G PEDREF
+45 SET T=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+46 SET T1=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
+47 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
+48 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+49 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+50 IF 'Z
QUIT
+51 SET N=$PIECE($GET(^PSDRUG(Z,0)),U)
+52 IF $DATA(^ATXAX(T,21,"B",Z))!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY")
Begin DoDot:2
+53 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
+54 SET C=$PIECE($GET(^PSDRUG(Z,2)),U,4)
+55 IF C]""
IF $DATA(^ATXAX(T1,21,"B",C))
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
+56 IF 'FORE
IF BGPLPED]""
QUIT BGPLPED
PEDREF ;
+1 SET G=$$REFTOED(P,$SELECT(FORE:$$FMADD^XLFDT(EDATE,-365),1:BDATE),EDATE)
+2 IF $PIECE(BGPLPED,U)<$PIECE(G,U,1)
QUIT G
+3 QUIT BGPLPED
REFTOED(P,BDATE,EDATE) ;EP - now check all refusals of these education topics
+1 SET G=""
SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))
IF X=""!(G]"")
QUIT
Begin DoDot:1
+2 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))
IF D=""!(G]"")
QUIT
Begin DoDot:2
+3 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D,I))
IF I'=+I!(G]"")
QUIT
Begin DoDot:3
+4 SET Z=$PIECE($GET(^AUPNPREF(I,0)),U,3)
+5 IF Z=""
QUIT
+6 IF Z<BDATE
QUIT
+7 IF Z>EDATE
QUIT
+8 SET Y=$PIECE($GET(^AUTTEDT(X,0)),U,2)
+9 IF $GET(BGPRTYPE)=3
IF Y="TO-M"
QUIT
+10 IF $PIECE(Y,"-")="TO"!($PIECE(Y,"-",2)="TO")!($PIECE(Y,"-",2)="SHS")
SET G=Z_U_"ref "_Y
+11 ;I $P(Y,"-",1)["305.1"!($P(Y,"-")="649.00")!($P(Y,"-")="649.01")!($P(Y,"-")="649.02")!($P(Y,"-")="649.03")!($P(Y,"-")="649.04")!($P(Y,"-")="V15.82") S G=Z_U_"ref "_Y
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT G
