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"
+6 KILL BGPG
+7 SET Y="BGPG("
+8 SET X=P_"^LAST DX V79.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 IF $DATA(BGPG(1))
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(1),U)
SET BGPDEPS=1_U_"V79.0 DEP SCRN"_U_$$DATE^BGP0UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"POV V79.0"
+10 ;now add in v measurements
+11 SET BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
+12 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP0UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+13 SET BGPC=$$LASTITEM^BGP0DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
+14 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP0UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
BHSCR ;
+1 SET D=0
SET BGPC=""
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)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)
Begin DoDot:2
+3 IF 'BGPP
QUIT
+4 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+5 IF BGPP=14.1
SET BGPC=1_U_"BH 14.1"_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-X)
QUIT
End DoDot:2
+6 IF BGPC
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+8 IF 'BGPP
QUIT
+9 SET BGPP=$PIECE($GET(^AUTTMSR(BGPP,0)),U)
+10 IF BGPP="PHQ2"!(BGPP="PHQ9")
SET BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-D)
End DoDot:2
+11 IF $PIECE($GET(^AMHREC(V,14)),U,5)="P"!($PIECE($GET(^AMHREC(V,14)),U,5)="N")
SET BGPC=1_"BH Dep Exam"_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-D)
End DoDot:1
+12 IF BGPC]""
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+13 ;add in measurements
+14 ;ANMC
+15 SET T=$ORDER(^AUTTHF("B","PRIME MD SCORE",0))
+16 IF T=""
QUIT BGPDEPS
+17 SET BGPC=""
SET D=0
FOR
SET D=$ORDER(^AUPNVHF("AA",P,T,D))
IF D'=+D!(BGPC]"")
QUIT
Begin DoDot:1
+18 SET Y=9999999-D
+19 IF Y<BDATE
QUIT
+20 IF Y>EDATE
QUIT
+21 SET BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP0UTL(9999999-D)_U_(9999999-D)
+22 QUIT
End DoDot:1
+23 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+24 QUIT BGPDEPS
DEPREF(P,BDATE,EDATE) ;EP
+1 NEW G
+2 SET G=$$REFUSAL^BGP0UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^ref DEP SCRN^"_$$DATE^BGP0UTL($PIECE(G,U,2))_U_$PIECE(G,U,2)
+4 QUIT ""
DEPEDU(P,BDATE,EDATE) ;EP
+1 NEW BGPG,Y,X,E,D,T,BGPDEPE,V,BGPC,G,I,Z
+2 KILL BGPG
+3 SET Y="BGPG("
SET BGPDEPE=""
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG(1))
GOTO DEPMH
+6 SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(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,"-",1)="DEP"!($PIECE(T,"-",1)="BH")!($PIECE(T,"-",1)="SB")!($PIECE(T,"-",1)="PDEP")
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+12 IF $PIECE(T,"-",1)["296.2"!($PIECE(T,"-",1["296.3"))
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+13 IF $PIECE(T,"-",1)["995.5"!($PIECE(T,"-",1)="995.80")!($PIECE(T,"-",1)="995.81")!($PIECE(T,"-")="995.82")!($PIECE(T,"-")="995.83")!($PIECE(T,"-")="995.84")!($PIECE(T,"-")="995.85")
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
Begin DoDot:2
+14 SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
+15 ;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
+16 ;.S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
+17 ;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
+18 ;.S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
+19 IF $PIECE(T,"-",1)="300.9"!($PIECE(T,"-")="684.44")
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
Begin DoDot:2
+20 SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
+21 IF +$EXTRACT($PIECE(T,"-",1),1,3)>289
IF +$EXTRACT($PIECE(T,"-",1),1,3)<320
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
Begin DoDot:2
+22 SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
End DoDot:1
DEPMH ;
+1 SET BGPC=""
SET T=""
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)
QUIT
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET T=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+3 IF 'T
QUIT
+4 IF '$DATA(^AUTTEDT(T,0))
QUIT
+5 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+6 IF $PIECE(T,"-",1)="DEP"!($PIECE(T,"-",1)="BH")!($PIECE(T,"-",1)="SB")!($PIECE(T,"-",1)="PDEP")
SET BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
+7 IF $PIECE(T,"-",1)["296.2"!($PIECE(T,"-",1["296.3"))
SET BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
+8 IF $PIECE(T,"-",1)["995.5"!($PIECE(T,"-",1)="995.80")!($PIECE(T,"-",1)="995.81")!($PIECE(T,"-")="995.82")!($PIECE(T,"-")="995.83")!($PIECE(T,"-")="995.84")!($PIECE(T,"-")="995.85")
Begin DoDot:3
+9 SET BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
End DoDot:3
+10 ;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
+11 ;.S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
+12 ;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
+13 ;.S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
+14 IF $PIECE(T,"-",1)="300.9"!($PIECE(T,"-",1)="684.44")
Begin DoDot:3
+15 SET BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
End DoDot:3
+16 IF +$EXTRACT($PIECE(T,"-",1),1,3)>289
IF +$EXTRACT($PIECE(T,"-",1),1,3)<320
Begin DoDot:3
+17 SET BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP0UTL((9999999-D))_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPE=BGPC
+19 IF BGPDEPE
QUIT BGPDEPE
EDUREF ;
+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 $PIECE(Y,"-")="DEP"!($PIECE(Y,"-",1)="BH")!($PIECE(Y,"-",1)="SB")!($PIECE(Y,"-",1)="PDEP")
SET G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)
+10 ;I $P(Y,"-",1)["296.2"!($P(Y,"-",1["296.3")) S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)
+11 ;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)
+12 ;I $P(Y,"-",1)["300.9"!($P(Y,"-",1["684.44")) S G=1_U_"ref "_Y_U_$$DATE^BGP0UTL(Z)
+13 ;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)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT G
