BGP0D711.m

BGP0D711 ; IHS/CMI/LAB - measure C 30 Jun 2009 12:14 PM ;

 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010

 ;

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 %

MEDNUTRD(P,BDATE,EDATE) ;EP

 K ^TMP($J),BGPG,BGPC

 S E=+$$CODEN^ICPTCOD(97802),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802 MN"

 S E=+$$CODEN^ICPTCOD(97803),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97803 MN"

 S E=+$$CODEN^ICPTCOD(97804),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804 MN"

 S E=+$$CODEN^ICPTCOD("G0270"),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270 MN"

 S E=+$$CODEN^ICPTCOD("G0271"),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271 MN"

 ;TRAN CODES

 S E=+$$CODEN^ICPTCOD(97802),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802 MN TRAN"

 S E=+$$CODEN^ICPTCOD(97803),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)-"^97803 MN TRAN"

 S E=+$$CODEN^ICPTCOD(97804),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804 MN TRAN"

 S E=+$$CODEN^ICPTCOD("G0270"),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270 MN TRAN"

 S E=+$$CODEN^ICPTCOD("G0271"),%=$$TRANI^BGP0DU(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)),'$$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^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802 MN"

 S E=+$$CODEN^ICPTCOD(97803),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97803 MN"

 S E=+$$CODEN^ICPTCOD(97804),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804 MN"

 S E=+$$CODEN^ICPTCOD("G0270"),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270 MN"

 S E=+$$CODEN^ICPTCOD("G0271"),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0271 MN"

 ;TRAN CODES

 S E=+$$CODEN^ICPTCOD(97802),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97802 MN TRAN"

 S E=+$$CODEN^ICPTCOD(97803),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)-"^97803 MN TRAN"

 S E=+$$CODEN^ICPTCOD(97804),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^97804 MN TRAN"

 S E=+$$CODEN^ICPTCOD("G0270"),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^G0270 MN TRAN"

 S E=+$$CODEN^ICPTCOD("G0271"),%=$$TRANI^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0DU(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^BGP0UTL2(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 Q BGPLPED  ;if in forecaster mode skip refusals

 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

BGP0D711  ; IHS/CMI/LAB - measure C 30 Jun 2009 12:14 PM ;

 +1       ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010

 +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 %

MEDNUTRD(P,BDATE,EDATE) ;EP

 +1        KILL ^TMP($JOB),BGPG,BGPC

 +2        SET E=+$$CODEN^ICPTCOD(97802)

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97802 MN"

 +3        SET E=+$$CODEN^ICPTCOD(97803)

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97803 MN"

 +4        SET E=+$$CODEN^ICPTCOD(97804)

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97804 MN"

 +5        SET E=+$$CODEN^ICPTCOD("G0270")

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^G0270 MN"

 +6        SET E=+$$CODEN^ICPTCOD("G0271")

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^G0271 MN"

 +7       ;TRAN CODES

 +8        SET E=+$$CODEN^ICPTCOD(97802)

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97802 MN TRAN"

 +9        SET E=+$$CODEN^ICPTCOD(97803)

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)-"^97803 MN TRAN"

 +10       SET E=+$$CODEN^ICPTCOD(97804)

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97804 MN TRAN"

 +11       SET E=+$$CODEN^ICPTCOD("G0270")

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^G0270 MN TRAN"

 +12       SET E=+$$CODEN^ICPTCOD("G0271")

           SET %=$$TRANI^BGP0DU(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))

                   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 ""

MEDNUTR(P,BDATE,EDATE) ;EP

 +1        KILL ^TMP($JOB),BGPG,BGPC

 +2        SET E=+$$CODEN^ICPTCOD(97802)

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97802 MN"

 +3        SET E=+$$CODEN^ICPTCOD(97803)

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97803 MN"

 +4        SET E=+$$CODEN^ICPTCOD(97804)

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97804 MN"

 +5        SET E=+$$CODEN^ICPTCOD("G0270")

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^G0270 MN"

 +6        SET E=+$$CODEN^ICPTCOD("G0271")

           SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^G0271 MN"

 +7       ;TRAN CODES

 +8        SET E=+$$CODEN^ICPTCOD(97802)

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97802 MN TRAN"

 +9        SET E=+$$CODEN^ICPTCOD(97803)

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)-"^97803 MN TRAN"

 +10       SET E=+$$CODEN^ICPTCOD(97804)

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^97804 MN TRAN"

 +11       SET E=+$$CODEN^ICPTCOD("G0270")

           SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)

           IF %]""

               QUIT $PIECE(%,U,2)_"^G0270 MN TRAN"

 +12       SET E=+$$CODEN^ICPTCOD("G0271")

           SET %=$$TRANI^BGP0DU(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