BGP0D25.m

BGP0D25 ; IHS/CMI/LAB - measure 6 03 Jun 2010 3:16 PM ; 

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

 ;

IA ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 I BGPACTCL,BGPAGEB>7,BGPAGEB<18 S BGPD1=1  ;8-17

 I BGPACTCL,BGPAGEB>17 S BGPD2=1  ;>17

 I BGPACTCL,BGPAGEB>64 S BGPD3=1  ;65 AND OLDER

 I BGPACTUP,BGPAGEB>7,BGPAGEB<18 S BGPD4=1

 I BGPACTUP,BGPAGEB>17 S BGPD5=1  ;>17 UP

 I BGPACTUP,BGPAGEB>64 S BGPD6=1  ;65 UP

 I BGPACTCL,BGPAGEB>11,BGPAGEB<19 S BGPD9=1

 I BGPDMD2 S BGPD7=1

 I $$IHD^BGP0D721(DFN,BGP365,BGPEDATE),BGPACTCL S BGPIHD=1,BGPD8=1

 I BGPRTYPE=4,BGPAGEB<18,'BGPIHD,'BGPDMD2 S BGPSTOP=1 Q  ;IF THEY ARE UNDER 18 AND NOT IHD AND NOT DM Q

 I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9) S BGPSTOP=1 Q

DEPEP ;EP - called from elder

 S BGPN3=0 S BGPDEP=$$DEP(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEP,U)=1 S BGPN3=1

 S BGPN2=0 S BGPDEPS=$$DEPSCR(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEPS,U)=1 S BGPN2=1

 S BGPN5=0 S BGPDEDU=$$DEPEDU(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEDU,U)=1 S BGPN5=1

 S BGPN6=0 S BGPSUIC=$$DEPSUIC(DFN,BGPBDATE,BGPEDATE) I $P(BGPSUIC,U)=1 S BGPN6=1

 I BGPN2 S BGPN1=1

 I BGPN3 S BGPN1=1

 S BGPREF=""

 S BGPN4=0 I 'BGPN1 S BGPREF=$$DEPREF(DFN,BGPBDATE,BGPEDATE) I $P(BGPREF,U)=1 S BGPN4=1

 I BGPN4 S BGPN1=1

 I BGPN1,'BGPN4 S BGPN7=1

 S BGPN8=0 I BGPN2!(BGPN3)!(BGPN6) S BGPN8=1

 S BGPVALUE=""

 I (BGPD4+BGPD5+BGPD6) S BGPVALUE="UP"

 I (BGPD1+BGPD2+BGPD3) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_"AC"

 I BGPD7 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_"AD"

 I BGPD8 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_"IHD"

 S BGPVALUE=BGPVALUE_"|||"

 I BGPDEP]"" S BGPVALUE=BGPVALUE_$P(BGPDEP,U,2)_":"_$P(BGPDEP,U,3)_":"_$P(BGPDEP,U,4)

 I BGPDEPS]"" S BGPVALUE=BGPVALUE_$P(BGPDEPS,U,2)_":"_$P(BGPDEPS,U,3)

 I BGPREF]"" S BGPVALUE=BGPVALUE_$P(BGPREF,U,2)_":"_$P(BGPREF,U,3)

 I BGPDEDU]"" S BGPVALUE=BGPVALUE_" "_$P(BGPDEDU,U,2)_":"_$P(BGPDEDU,U,3)

 I BGPD5!(BGPD9) S BGPVALUD=$S(BGPD5:"AC >=18",BGPD9:"AC 12-18",1:"")_"|||" D

 .I BGPDEP]"" S BGPVALUD=BGPVALUD_$P(BGPDEP,U,2)_":"_$P(BGPDEP,U,3)_":"_$P(BGPDEP,U,4)

 .I BGPDEPS]"" S BGPVALUD=BGPVALUD_$P(BGPDEPS,U,2)_":"_$P(BGPDEPS,U,3)

 .I BGPSUIC]"" S BGPVALUD=BGPVALUD_$P(BGPSUIC,U,2)_":"_$P(BGPSUIC,U,3)

 K BGPDEP,BGPDEPS,BGPREF,BGPDEDU

 Q

 ;

DEP(P,BDATE,EDATE) ;EP

 I $G(P)="" Q ""

 NEW BGPG,BGPDEP,BGPV,Y,X,E,D,V,BGPC,BGPP

 K BGPG,BGPDEP

 S BGPV=""

 S Y="BGPG("

 S X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(2)) S BGPDEP((9999999-$P(BGPG(1),U)))="",BGPDEP((9999999-$P(BGPG(2),U)))="" Q 1_U_"2 dxs PCC"_U_$$DATE^BGP0UTL($P(BGPG(2),U))_U_$$DATE^BGP0UTL($P(BGPG(1),U))

 S BGPC=0 I $D(BGPG(1)) S BGPC=1,BGPV=$P(BGPG(1),U,5),BGPDEP((9999999-$P(BGPG(1),U)))=""

 ;

 S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC>1)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC>1)  D

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC>1)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'BGPP

 ..I $P(^AMHREC(V,0),U,16)]"",BGPV]"",$P(^AMHREC(V,0),U,16)=BGPV Q  ;same visit found in pcc

 ..I $D(BGPDEP(D)) Q  ;already got a dx on this date

 ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 ..I BGPP=14 S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP=15 S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I $E(BGPP,1,3)=296 S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP=291.89 S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP=292.84 S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP="293.83" S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP="301.13" S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP=300.4 S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..I BGPP="311." S BGPC=BGPC+1,BGPDEP(D)="" Q

 ..Q

 S X=$O(BGPDEP(0)),Y=$O(BGPDEP(X))

 I BGPC>1 Q 1_"^2 dx PCC/BH"_U_$$FMTE^XLFDT((9999999-X))_U_$$FMTE^XLFDT((9999999-Y))

 Q ""

DEPSUIC(P,BDATE,EDATE) ;EP

 I $G(P)="" Q ""

 NEW BGPV,Y,X,BGPP,BGPC,E,D,V

 S BGPV=""

 S Y="BGPG("

 S X=P_"^LAST DX V62.84;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) Q 1_U_"V62.84"_U_$$DATE^BGP0UTL($P(BGPG(1),U))

 ;

 S BGPC=""

 S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC>1)  D

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC>1)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'BGPP

 ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 ..I BGPP=39 S BGPC=1_U_"BH 39"_U_$$DATE^BGP0UTL((9999999-$P(D,".")))

 ..Q

 Q BGPC

DEPSCR(P,BDATE,EDATE) ;EP

 NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,T

 S BGPDEPS=""

 I $G(P)="" Q ""

 K BGPG S %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) S BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"Ex 36"

 K BGPG

 S Y="BGPG("

 S X=P_"^LAST DX V79.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)),$P(BGPDEPS,U,4)<$P(BGPG(1),U) S BGPDEPS=1_U_"V79.0 DEP SCRN"_U_$$DATE^BGP0UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"POV V79.0"

 ;now add in v measurements

 S BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")

 I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP0UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)

 S BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")

 I $P(BGPDEPS,U,4)<$P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP0UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)

BHSCR ;

 S D=0,BGPC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'BGPP

 ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 ..I BGPP=14.1 S BGPC=1_U_"BH 14.1"_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-X) Q

 .Q:BGPC

 .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRMSR(X,0)),U) D

 ..Q:'BGPP

 ..S BGPP=$P($G(^AUTTMSR(BGPP,0)),U)

 ..I BGPP="PHQ2"!(BGPP="PHQ9") S BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-D)

 .I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="N") S BGPC=1_"BH Dep Exam"_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-D)

 I BGPC]"",$P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC

 ;add in measurements

 ;ANMC

 S T=$O(^AUTTHF("B","PRIME MD SCORE",0))

 I T="" Q BGPDEPS

 S BGPC="" S D=0 F  S D=$O(^AUPNVHF("AA",P,T,D)) Q:D'=+D!(BGPC]"")  D

 .S Y=9999999-D

 .Q:Y<BDATE

 .Q:Y>EDATE

 .S BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-D)

 .Q

 I $P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC

 Q BGPDEPS

DEPREF(P,BDATE,EDATE) ;EP

 NEW G

 S G=$$REFUSAL^BGP0UTL1(P,9999999.15,$O(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)

 I $P(G,U)=1 Q 1_"^ref DEP SCRN^"_$$DATE^BGP0UTL($P(G,U,2))_U_$P(G,U,2)

 Q ""

DEPEDU(P,BDATE,EDATE) ;EP

 NEW BGPG,Y,X,E,D,T,BGPDEPE,V,BGPC,G,I,Z

 K BGPG

 S Y="BGPG(",BGPDEPE=""

 S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I '$D(BGPG(1)) G DEPMH

 S (X,D,E)=0,%="",T="" F  S X=$O(BGPG(X)) Q:X'=+X  D

 .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)

 .Q:'T

 .Q:'$D(^AUTTEDT(T,0))

 .S T=$P(^AUTTEDT(T,0),U,2)

 .I $P(T,"-",1)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP"),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .I $P(T,"-",1)["296.2"!($P(T,"-",1["296.3")),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .I $P(T,"-",1)["995.5"!($P(T,"-",1)="995.80")!($P(T,"-",1)="995.81")!($P(T,"-")="995.82")!($P(T,"-")="995.83")!($P(T,"-")="995.84")!($P(T,"-")="995.85"),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) D

 ..S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .;I $P(T,"-",1)["V40."!($P(T,"-",1)="V60.0")!($P(T,"-",1)="V61.11")!($P(T,"-")="V61.21")!($P(T,"-")["V62.")!($P(T,"-")="V67.3")!($P(T,"-")["V69."),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) D

 .;.S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .;I $P(T,"-",1)="V79.2"!($P(T,"-",1)="V79.3")!($P(T,"-",1)="V79.4")!($P(T,"-")="V79.5")!($P(T,"-")="V79.6")!($P(T,"-")="V79.7")!($P(T,"-")="V79.8")!($P(T,"-")="V79.9"),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) D

 .;.S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .I $P(T,"-",1)="300.9"!($P(T,"-")="684.44"),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) D

 ..S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .I +$E($P(T,"-",1),1,3)>289,+$E($P(T,"-",1),1,3)<320,$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) D

 ..S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

DEPMH ;

 S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(BGPC)  S T=$P($G(^AMHREDU(X,0)),U) D

 ..Q:'T

 ..Q:'$D(^AUTTEDT(T,0))

 ..S T=$P(^AUTTEDT(T,0),U,2)

 ..I $P(T,"-",1)="DEP"!($P(T,"-",1)="BH")!($P(T,"-",1)="SB")!($P(T,"-",1)="PDEP") S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 ..I $P(T,"-",1)["296.2"!($P(T,"-",1["296.3")) S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 ..I $P(T,"-",1)["995.5"!($P(T,"-",1)="995.80")!($P(T,"-",1)="995.81")!($P(T,"-")="995.82")!($P(T,"-")="995.83")!($P(T,"-")="995.84")!($P(T,"-")="995.85") D

 ...S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 ..;I $P(T,"-",1)["V40."!($P(T,"-",1)="V60.0")!($P(T,"-",1)="V61.11")!($P(T,"-")="V61.21")!($P(T,"-")["V62.")!($P(T,"-")="V67.3")!($P(T,"-")["V69.") D

 ..;.S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 ..;I $P(T,"-",1)="V79.2"!($P(T,"-",1)="V79.3")!($P(T,"-",1)="V79.4")!($P(T,"-")="V79.5")!($P(T,"-")="V79.6")!($P(T,"-")="V79.7")!($P(T,"-")="V79.8")!($P(T,"-")="V79.9") D

 ..;.S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 ..I $P(T,"-",1)="300.9"!($P(T,"-",1)="684.44") D

 ...S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 ..I +$E($P(T,"-",1),1,3)>289,+$E($P(T,"-",1),1,3)<320 D

 ...S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)

 I $P(BGPDEPE,U,4)<$P(BGPC,U,4) S BGPDEPE=BGPC

 I BGPDEPE Q BGPDEPE

EDUREF ;

 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 $P(Y,"-")="DEP"!($P(Y,"-",1)="BH")!($P(Y,"-",1)="SB")!($P(Y,"-",1)="PDEP") S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)

 ...;I $P(Y,"-",1)["296.2"!($P(Y,"-",1["296.3")) S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)

 ...;I $P(Y,"-",1)["995.5"!($P(Y,"-",1)="995.80")!($P(Y,"-",1)="995.81")!($P(Y,"-")="995.82")!($P(Y,"-")="995.83")!($P(Y,"-")="995.84")!($P(Y,"-")="995.85") S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)

 ...;I $P(Y,"-",1)["300.9"!($P(Y,"-",1["684.44")) S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)

 ...;I +$E($P(Y,"-",1),1,3)>289,+$E($P(Y,"-",1),1,3)<320 S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)

 Q G

BGP0D25   ; IHS/CMI/LAB - measure 6 03 Jun 2010 3:16 PM ; 

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

 +2       ;

IA        ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 +2       ;8-17

           IF BGPACTCL

               IF BGPAGEB>7

                   IF BGPAGEB<18

                       SET BGPD1=1

 +3       ;>17

           IF BGPACTCL

               IF BGPAGEB>17

                   SET BGPD2=1

 +4       ;65 AND OLDER

           IF BGPACTCL

               IF BGPAGEB>64

                   SET BGPD3=1

 +5        IF BGPACTUP

               IF BGPAGEB>7

                   IF BGPAGEB<18

                       SET BGPD4=1

 +6       ;>17 UP

           IF BGPACTUP

               IF BGPAGEB>17

                   SET BGPD5=1

 +7       ;65 UP

           IF BGPACTUP

               IF BGPAGEB>64

                   SET BGPD6=1

 +8        IF BGPACTCL

               IF BGPAGEB>11

                   IF BGPAGEB<19

                       SET BGPD9=1

 +9        IF BGPDMD2

               SET BGPD7=1

 +10       IF $$IHD^BGP0D721(DFN,BGP365,BGPEDATE)

               IF BGPACTCL

                   SET BGPIHD=1

                   SET BGPD8=1

 +11      ;IF THEY ARE UNDER 18 AND NOT IHD AND NOT DM Q

           IF BGPRTYPE=4

               IF BGPAGEB<18

                   IF 'BGPIHD

                       IF 'BGPDMD2

                           SET BGPSTOP=1

                           QUIT 

 +12       IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9)

               SET BGPSTOP=1

               QUIT 

DEPEP     ;EP - called from elder

 +1        SET BGPN3=0

           SET BGPDEP=$$DEP(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDEP,U)=1

               SET BGPN3=1

 +2        SET BGPN2=0

           SET BGPDEPS=$$DEPSCR(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDEPS,U)=1

               SET BGPN2=1

 +3        SET BGPN5=0

           SET BGPDEDU=$$DEPEDU(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDEDU,U)=1

               SET BGPN5=1

 +4        SET BGPN6=0

           SET BGPSUIC=$$DEPSUIC(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPSUIC,U)=1

               SET BGPN6=1

 +5        IF BGPN2

               SET BGPN1=1

 +6        IF BGPN3

               SET BGPN1=1

 +7        SET BGPREF=""

 +8        SET BGPN4=0

           IF 'BGPN1

               SET BGPREF=$$DEPREF(DFN,BGPBDATE,BGPEDATE)

               IF $PIECE(BGPREF,U)=1

                   SET BGPN4=1

 +9        IF BGPN4

               SET BGPN1=1

 +10       IF BGPN1

               IF 'BGPN4

                   SET BGPN7=1

 +11       SET BGPN8=0

           IF BGPN2!(BGPN3)!(BGPN6)

               SET BGPN8=1

 +12       SET BGPVALUE=""

 +13       IF (BGPD4+BGPD5+BGPD6)

               SET BGPVALUE="UP"

 +14       IF (BGPD1+BGPD2+BGPD3)

               SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_"AC"

 +15       IF BGPD7

               SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_"AD"

 +16       IF BGPD8

               SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_"IHD"

 +17       SET BGPVALUE=BGPVALUE_"|||"

 +18       IF BGPDEP]""

               SET BGPVALUE=BGPVALUE_$PIECE(BGPDEP,U,2)_":"_$PIECE(BGPDEP,U,3)_":"_$PIECE(BGPDEP,U,4)

 +19       IF BGPDEPS]""

               SET BGPVALUE=BGPVALUE_$PIECE(BGPDEPS,U,2)_":"_$PIECE(BGPDEPS,U,3)

 +20       IF BGPREF]""

               SET BGPVALUE=BGPVALUE_$PIECE(BGPREF,U,2)_":"_$PIECE(BGPREF,U,3)

 +21       IF BGPDEDU]""

               SET BGPVALUE=BGPVALUE_" "_$PIECE(BGPDEDU,U,2)_":"_$PIECE(BGPDEDU,U,3)

 +22       IF BGPD5!(BGPD9)

               SET BGPVALUD=$SELECT(BGPD5:"AC >=18",BGPD9:"AC 12-18",1:"")_"|||"

               Begin DoDot:1

 +23               IF BGPDEP]""

                       SET BGPVALUD=BGPVALUD_$PIECE(BGPDEP,U,2)_":"_$PIECE(BGPDEP,U,3)_":"_$PIECE(BGPDEP,U,4)

 +24               IF BGPDEPS]""

                       SET BGPVALUD=BGPVALUD_$PIECE(BGPDEPS,U,2)_":"_$PIECE(BGPDEPS,U,3)

 +25               IF BGPSUIC]""

                       SET BGPVALUD=BGPVALUD_$PIECE(BGPSUIC,U,2)_":"_$PIECE(BGPSUIC,U,3)

               End DoDot:1

 +26       KILL BGPDEP,BGPDEPS,BGPREF,BGPDEDU

 +27       QUIT 

 +28      ;

DEP(P,BDATE,EDATE) ;EP

 +1        IF $GET(P)=""

               QUIT ""

 +2        NEW BGPG,BGPDEP,BGPV,Y,X,E,D,V,BGPC,BGPP

 +3        KILL BGPG,BGPDEP

 +4        SET BGPV=""

 +5        SET Y="BGPG("

 +6        SET X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,Y)

 +7        IF $DATA(BGPG(2))

               SET BGPDEP((9999999-$PIECE(BGPG(1),U)))=""

               SET BGPDEP((9999999-$PIECE(BGPG(2),U)))=""

               QUIT 1_U_"2 dxs PCC"_U_$$DATE^BGP0UTL($PIECE(BGPG(2),U))_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))

 +8        SET BGPC=0

           IF $DATA(BGPG(1))

               SET BGPC=1

               SET BGPV=$PIECE(BGPG(1),U,5)

               SET BGPDEP((9999999-$PIECE(BGPG(1),U)))=""

 +9       ;

 +10       SET E=9999999-BDATE

           SET D=9999999-EDATE-1_".99"

           FOR 

               SET D=$ORDER(^AMHREC("AE",P,D))

               IF D'=+D!($PIECE(D,".")>E)!(BGPC>1)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(^AMHREC("AE",P,D,V))

                   IF V'=+V!(BGPC>1)

                       QUIT 

                   Begin DoDot:1

 +11                   SET X=0

                       FOR 

                           SET X=$ORDER(^AMHRPRO("AD",V,X))

                           IF X'=+X!(BGPC>1)

                               QUIT 

                           SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)

                           Begin DoDot:2

 +12                           IF 'BGPP

                                   QUIT 

 +13      ;same visit found in pcc

                               IF $PIECE(^AMHREC(V,0),U,16)]""

                                   IF BGPV]""

                                       IF $PIECE(^AMHREC(V,0),U,16)=BGPV

                                           QUIT 

 +14      ;already got a dx on this date

                               IF $DATA(BGPDEP(D))

                                   QUIT 

 +15                           SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)

 +16                           IF BGPP=14

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +17                           IF BGPP=15

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +18                           IF $EXTRACT(BGPP,1,3)=296

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +19                           IF BGPP=291.89

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +20                           IF BGPP=292.84

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +21                           IF BGPP="293.83"

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +22                           IF BGPP="301.13"

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +23                           IF BGPP=300.4

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +24                           IF BGPP="311."

                                   SET BGPC=BGPC+1

                                   SET BGPDEP(D)=""

                                   QUIT 

 +25                           QUIT 

                           End DoDot:2

                   End DoDot:1

 +26       SET X=$ORDER(BGPDEP(0))

           SET Y=$ORDER(BGPDEP(X))

 +27       IF BGPC>1

               QUIT 1_"^2 dx PCC/BH"_U_$$FMTE^XLFDT((9999999-X))_U_$$FMTE^XLFDT((9999999-Y))

 +28       QUIT ""

DEPSUIC(P,BDATE,EDATE) ;EP

 +1        IF $GET(P)=""

               QUIT ""

 +2        NEW BGPV,Y,X,BGPP,BGPC,E,D,V

 +3        SET BGPV=""

 +4        SET Y="BGPG("

 +5        SET X=P_"^LAST DX V62.84;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,Y)

 +6        IF $DATA(BGPG(1))

               QUIT 1_U_"V62.84"_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))

 +7       ;

 +8        SET BGPC=""

 +9        SET E=9999999-BDATE

           SET D=9999999-EDATE-1_".99"

           FOR 

               SET D=$ORDER(^AMHREC("AE",P,D))

               IF D'=+D!($PIECE(D,".")>E)!(BGPC)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(^AMHREC("AE",P,D,V))

                   IF V'=+V!(BGPC>1)

                       QUIT 

                   Begin DoDot:1

 +10                   SET X=0

                       FOR 

                           SET X=$ORDER(^AMHRPRO("AD",V,X))

                           IF X'=+X!(BGPC>1)

                               QUIT 

                           SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)

                           Begin DoDot:2

 +11                           IF 'BGPP

                                   QUIT 

 +12                           SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)

 +13                           IF BGPP=39

                                   SET BGPC=1_U_"BH 39"_U_$$DATE^BGP0UTL((9999999-$PIECE(D,".")))

 +14                           QUIT 

                           End DoDot:2

                   End DoDot:1

 +15       QUIT BGPC

DEPSCR(P,BDATE,EDATE) ;EP

 +1        NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,T

 +2        SET BGPDEPS=""

 +3        IF $GET(P)=""

               QUIT ""

 +4        KILL BGPG

           SET %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(%,"BGPG(")

 +5        IF $DATA(BGPG(1))

               SET BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"Ex 36"