BGP4D25.m

BGP4D25 ; IHS/CMI/LAB - measure 6 03 Jun 2014 3:16 PM ;

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 ;

IA ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=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 $$CHD^BGP4D729(DFN,BGP365,BGPEDATE),BGPACTCL S BGPIHD=1,BGPD8=1

 I BGPACTCB,BGPAGEB>17 S BGPD10=1  ;>17

 I BGPACTCB,BGPAGEB>11,BGPAGEB<19 S BGPD11=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+BGPD10+BGPD11) S BGPSTOP=1 Q

DEPEP ;EP - called from elder

 S BGPVALUE=""

 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

 S BGPN10=0 S BGPDEPSD=$$DEPSCRD(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEPSD,U)=1 S BGPN10=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

 I BGPN10!(BGPN3)!(BGPN6) S BGPN10=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:"")_"CHD"

 S BGPVALUE=BGPVALUE_"|||"

 I BGPDEPS]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";SCREEN: ",1:"SCREEN: ") S BGPVALUE=BGPVALUE_$P(BGPDEPS,U,3)_" "_$P(BGPDEPS,U,5)

 I BGPDEP]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";DX: ",1:"DX: ") S BGPVALUE=BGPVALUE_$P(BGPDEP,U,2)

 I BGPDEDU]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":";PT ED: ",1:"PT ED: ") S BGPVALUE=BGPVALUE_$P(BGPDEDU,U,3)_" "_$P(BGPDEDU,U,2)

 I BGPRTYPE'=1,BGPREF]"" S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_$P(BGPREF,U,3)_" "_$P(BGPREF,U,2)

 ;I BGPD5!(BGPD9) S BGPVALUD=$S(BGPD5:"AC",BGPD9:"AC",1:"")

 I BGPD10!(BGPD11) S BGPVALUD=$G(BGPVALUD)_$S($G(BGPVALUD)]"":",AC+BH",1:"AC+BH")

 I $G(BGPVALUD)]"" S BGPVALUD=BGPVALUD_"|||" D

 .I BGPDEPSD]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; SCREEN: ",1:"SCREEN: ") S BGPVALUD=BGPVALUD_$P(BGPDEPSD,U,3)_" "_$P(BGPDEPSD,U,5)

 .I BGPDEP]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ") S BGPVALUD=BGPVALUD_$P(BGPDEP,U,2)

 .I BGPSUIC]"" S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; SUIC DX: ",1:"SUIC DX: ") S BGPVALUD=BGPVALUD_$P(BGPSUIC,U,3)_" "_$P(BGPSUIC,U,2)

 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_$$DATE^BGP4UTL($P(BGPG(2),U))_" POV "_$P(BGPG(2),U,2)_" + "_$$DATE^BGP4UTL($P(BGPG(1),U))_" POV "_$P(BGPG(1),U,2)_U_U_$P(BGPG(1),U,1)

 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)=BGPP Q

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

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

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

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

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

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

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

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

 ..Q

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

 I BGPC>1 Q 1_"^"_$$FMTE^XLFDT((9999999-X))_" BH POV "_BGPDEP(X)_" + "_$$FMTE^XLFDT((9999999-Y))_" BH POV "_BGPDEP(Y)_U_U_(9999999-Y)

 Q ""

DEPSUIC(P,BDATE,EDATE) ;EP

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

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

 S BGPV=""

 S Y="BGPG("

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

 I $D(BGPG(1)) Q 1_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP4UTL($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 POV 39"_U_$$DATE^BGP4UTL((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^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"Ex 36"

 K BGPG

 S Y="BGPG("

 S X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;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_"POV "_$P(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"POV "_$P(BGPG(1),U,2)

 ;CPT CODE ADDED IN 11.1

 S Y=$$CPTI^BGP4DU(DFN,BDATE,EDATE,+$$CODEN^ICPTCOD("1220F"))

 I Y,$P(BGPDEPS,U,4)<$P(Y,U,2) S BGPDEPS=1_U_"CPT 1220F"_U_$$DATE^BGP4UTL($P(Y,U,2))_U_$P(Y,U,2)_U_"CPT 1220F"

 ;now add in v measurements

 S BGPC=$$LASTITEM^BGP4DU(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^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)

 S BGPC=$$LASTITEM^BGP4DU(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^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)

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^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1" 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^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP

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

 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^BGP4UTL(9999999-D)_U_(9999999-D)_U_"PRIME MD SCORE"

 .Q

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

 Q BGPDEPS

DEPSCRD(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^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"Ex 36"

 K BGPG

 S Y="BGPG("

 S X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;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_"POV "_$P(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP4UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"POV "_$P(BGPG(1),U,2)

 ;CPT CODE ADDED IN 11.1

 S Y=$$CPTI^BGP4DU(DFN,BDATE,EDATE,+$$CODEN^ICPTCOD("1220F"))

 I Y,$P(BGPDEPS,U,4)<$P(Y,U,2) S BGPDEPS=1_U_"CPT 1220F"_U_$$DATE^BGP4UTL($P(Y,U,2))_U_$P(Y,U,2)_U_"CPT 1220F"

 ;now add in v measurements

 S BGPC=$$LASTITEM^BGP4DU(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^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)

 S BGPC=$$LASTITEM^BGP4DU(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^BGP4UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3)

 S BGPC=$$LASTITEM^BGP4DU(P,BDATE,EDATE,"MEASUREMENT","PHQT")

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

BHSCRD ;

 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^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1" 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")!(BGPP="PHQT") S BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP4UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP

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

 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^BGP4UTL(9999999-D)_U_(9999999-D)_U_"PRIME MD SCORE"

 .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^BGP4UTL1(P,9999999.15,$O(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)

 I $P(G,U)=1 Q 1_"^Refused Ex 36^"_$$DATE^BGP4UTL($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,S

 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_""_T_U_$$DATE^BGP4UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .S S=$P(T,"-",1)

 .S S=$$ICDDX^BGP4UTL2(S)

 .I $P(S,U,1)'="-1",$$ICD^BGP4UTL2($P(S,U,1),$O(^ATXAX("B","BGP DEP SCREEN EDUC DXS",0)),9),$P(BGPDEPE,U,4)<$P(BGPG(X),U,1) S BGPDEPE=1_U_""_T_U_$$DATE^BGP4UTL($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)

 ..S S=$P(T,"-",1)

 ..S S=$$ICDDX^BGP4UTL2(S)

 ..I $P(S,U,1)'="-1",$$ICD^BGP4UTL2($P(S,U,1),$O(^ATXAX("B","BGP DEP SCREEN EDUC DXS",0)),9) D

 ...S BGPC=1_U_T_U_$$DATE^BGP4UTL((9999999-D))_U_(9999999-D)

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

 Q BGPDEPE

BGP4D25   ; IHS/CMI/LAB - measure 6 03 Jun 2014 3:16 PM ;

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +2       ;

IA        ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=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 $$CHD^BGP4D729(DFN,BGP365,BGPEDATE)

               IF BGPACTCL

                   SET BGPIHD=1

                   SET BGPD8=1

 +11      ;>17

           IF BGPACTCB

               IF BGPAGEB>17

                   SET BGPD10=1

 +12       IF BGPACTCB

               IF BGPAGEB>11

                   IF BGPAGEB<19

                       SET BGPD11=1

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

 +14       IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11)

               SET BGPSTOP=1

               QUIT 

DEPEP     ;EP - called from elder

 +1        SET BGPVALUE=""

 +2        SET BGPN3=0

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

           IF $PIECE(BGPDEP,U)=1

               SET BGPN3=1

 +3        SET BGPN2=0

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

           IF $PIECE(BGPDEPS,U)=1

               SET BGPN2=1

 +4        SET BGPN5=0

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

           IF $PIECE(BGPDEDU,U)=1

               SET BGPN5=1

 +5        SET BGPN6=0

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

           IF $PIECE(BGPSUIC,U)=1

               SET BGPN6=1

 +6        SET BGPN10=0

           SET BGPDEPSD=$$DEPSCRD(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDEPSD,U)=1

               SET BGPN10=1

 +7        IF BGPN2

               SET BGPN1=1

 +8        IF BGPN3

               SET BGPN1=1

 +9        SET BGPREF=""

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

 +11       IF BGPN4

               SET BGPN1=1

 +12       IF BGPN1

               IF 'BGPN4

                   SET BGPN7=1

 +13       SET BGPN8=0

           IF BGPN2!(BGPN3)!(BGPN6)

               SET BGPN8=1

 +14       IF BGPN10!(BGPN3)!(BGPN6)

               SET BGPN10=1

 +15       SET BGPVALUE=""

 +16       IF (BGPD4+BGPD5+BGPD6)

               SET BGPVALUE="UP"

 +17       IF (BGPD1+BGPD2+BGPD3)

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

 +18       IF BGPD7

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

 +19       IF BGPD8

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

 +20       SET BGPVALUE=BGPVALUE_"|||"

 +21       IF BGPDEPS]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";SCREEN: ",1:"SCREEN: ")

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

 +22       IF BGPDEP]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";DX: ",1:"DX: ")

               SET BGPVALUE=BGPVALUE_$PIECE(BGPDEP,U,2)

 +23       IF BGPDEDU]""

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":";PT ED: ",1:"PT ED: ")

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

 +24       IF BGPRTYPE'=1

               IF BGPREF]""

                   SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")

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

 +25      ;I BGPD5!(BGPD9) S BGPVALUD=$S(BGPD5:"AC",BGPD9:"AC",1:"")

 +26       IF BGPD10!(BGPD11)

               SET BGPVALUD=$GET(BGPVALUD)_$SELECT($GET(BGPVALUD)]"":",AC+BH",1:"AC+BH")

 +27       IF $GET(BGPVALUD)]""

               SET BGPVALUD=BGPVALUD_"|||"

               Begin DoDot:1

 +28               IF BGPDEPSD]""

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; SCREEN: ",1:"SCREEN: ")

                       SET BGPVALUD=BGPVALUD_$PIECE(BGPDEPSD,U,3)_" "_$PIECE(BGPDEPSD,U,5)

 +29               IF BGPDEP]""

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")

                       SET BGPVALUD=BGPVALUD_$PIECE(BGPDEP,U,2)

 +30               IF BGPSUIC]""

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; SUIC DX: ",1:"SUIC DX: ")

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

               End DoDot:1

 +31       KILL BGPDEP,BGPDEPS,BGPREF,BGPDEDU

 +32       QUIT 

 +33      ;

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_$$DATE^BGP4UTL($PIECE(BGPG(2),U))_" POV "_$PIECE(BGPG(2),U,2)_" + "_$$DATE^BGP4UTL($PIECE(BGPG(1),U))_" POV "_$PIECE(BGPG(1),U,2)_U_U_$PIECE(BGPG(1),U,1)

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