BGP9D25 ; IHS/CMI/LAB - measure 6 ; 03 Jun 2009 3:16 PM
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
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 BGPDMD2 S BGPD7=1
I $$IHD^BGP9D721(DFN,BGP365,BGPEDATE),BGPACTCL S BGPIHD=1,BGPD8=1
I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) S BGPSTOP=1 Q
DEPEP ;EP - called from elder
S BGPN3=0 S BGPDEP=$$DEP(DFN,BGP365,BGPEDATE) I $P(BGPDEP,U)=1 S BGPN3=1
S BGPN2=0 S BGPDEPS=$$DEPSCR(DFN,BGP365,BGPEDATE) I $P(BGPDEPS,U)=1 S BGPN2=1
S BGPN5=0 S BGPDEDU=$$DEPEDU(DFN,BGP365,BGPEDATE) I $P(BGPDEDU,U)=1 S BGPN5=1
I BGPN2 S BGPN1=1
I BGPN3 S BGPN1=1
S BGPREF=""
S BGPN4=0 I 'BGPN1 S BGPREF=$$DEPREF(DFN,BGP365,BGPEDATE) I $P(BGPREF,U)=1 S BGPN4=1
I BGPN4 S BGPN1=1
I BGPN1,'BGPN4 S BGPN7=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)
K BGPDEP,BGPDEPS,BGPREF,BGPDEDU
Q
;
DEP(P,BDATE,EDATE) ;EP
I $G(P)="" Q ""
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^BGP9UTL($P(BGPG(2),U))_U_$$DATE^BGP9UTL($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 ""
DEPSCR(P,BDATE,EDATE) ;EP
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^BGP9UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)
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^BGP9UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)
;now add in v measurements
S BGPC=$$LASTITEM^BGP9DU(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^BGP9UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)
S BGPC=$$LASTITEM^BGP9DU(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^BGP9UTL($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^BGP9UTL(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^BGP9UTL(9999999-D)_U_(9999999-X)
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^BGP9UTL(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
S G=$$REFUSAL^BGP9UTL1(P,9999999.15,$O(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^ref DEP SCRN^"_$$DATE^BGP9UTL($P(G,U,2))_U_$P(G,U,2)
Q ""
DEPEDU(P,BDATE,EDATE) ;EP
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^BGP9UTL($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^BGP9UTL($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^BGP9UTL($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^BGP9UTL($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^BGP9UTL($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^BGP9UTL($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^BGP9UTL($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^BGP9UTL((9999999-D))_U_(9999999-D)
..I $P(T,"-",1)["296.2"!($P(T,"-",1["296.3")) S BGPC=1_U_"EDUC: "_T_U_$$DATE^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL(Z)
...;I $P(Y,"-",1)["296.2"!($P(Y,"-",1["296.3")) S G=1_U_"ref "_Y_U_$$DATE^BGP9UTL(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^BGP9UTL(Z)
...;I $P(Y,"-",1)["300.9"!($P(Y,"-",1["684.44")) S G=1_U_"ref "_Y_U_$$DATE^BGP9UTL(Z)
...;I +$E($P(Y,"-",1),1,3)>289,+$E($P(Y,"-",1),1,3)<320 S G=1_U_"ref "_Y_U_$$DATE^BGP9UTL(Z)
Q G
BGP9D25 ; IHS/CMI/LAB - measure 6 ; 03 Jun 2009 3:16 PM
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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 BGPDMD2
SET BGPD7=1
+9 IF $$IHD^BGP9D721(DFN,BGP365,BGPEDATE)
IF BGPACTCL
SET BGPIHD=1
SET BGPD8=1
+10 IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8)
SET BGPSTOP=1
QUIT
DEPEP ;EP - called from elder
+1 SET BGPN3=0
SET BGPDEP=$$DEP(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDEP,U)=1
SET BGPN3=1
+2 SET BGPN2=0
SET BGPDEPS=$$DEPSCR(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDEPS,U)=1
SET BGPN2=1
+3 SET BGPN5=0
SET BGPDEDU=$$DEPEDU(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDEDU,U)=1
SET BGPN5=1
+4 IF BGPN2
SET BGPN1=1
+5 IF BGPN3
SET BGPN1=1
+6 SET BGPREF=""
+7 SET BGPN4=0
IF 'BGPN1
SET BGPREF=$$DEPREF(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPREF,U)=1
SET BGPN4=1
+8 IF BGPN4
SET BGPN1=1
+9 IF BGPN1
IF 'BGPN4
SET BGPN7=1
+10 SET BGPVALUE=""
+11 IF (BGPD4+BGPD5+BGPD6)
SET BGPVALUE="UP"
+12 IF (BGPD1+BGPD2+BGPD3)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_"AC"
+13 IF BGPD7
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_"AD"
+14 IF BGPD8
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_"IHD"
+15 SET BGPVALUE=BGPVALUE_"|||"
+16 IF BGPDEP]""
SET BGPVALUE=BGPVALUE_$PIECE(BGPDEP,U,2)_":"_$PIECE(BGPDEP,U,3)_":"_$PIECE(BGPDEP,U,4)
+17 IF BGPDEPS]""
SET BGPVALUE=BGPVALUE_$PIECE(BGPDEPS,U,2)_":"_$PIECE(BGPDEPS,U,3)
+18 IF BGPREF]""
SET BGPVALUE=BGPVALUE_$PIECE(BGPREF,U,2)_":"_$PIECE(BGPREF,U,3)
+19 IF BGPDEDU]""
SET BGPVALUE=BGPVALUE_" "_$PIECE(BGPDEDU,U,2)_":"_$PIECE(BGPDEDU,U,3)
+20 KILL BGPDEP,BGPDEPS,BGPREF,BGPDEDU
+21 QUIT
+22 ;
DEP(P,BDATE,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 KILL BGPG,BGPDEP
+3 SET BGPV=""
+4 SET Y="BGPG("
+5 SET X=P_"^LAST 2 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 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^BGP9UTL($PIECE(BGPG(2),U))_U_$$DATE^BGP9UTL($PIECE(BGPG(1),U))
+7 SET BGPC=0
IF $DATA(BGPG(1))
SET BGPC=1
SET BGPV=$PIECE(BGPG(1),U,5)
SET BGPDEP((9999999-$PIECE(BGPG(1),U)))=""
+8 ;
+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>1)
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 ;same visit found in pcc
IF $PIECE(^AMHREC(V,0),U,16)]""
IF BGPV]""
IF $PIECE(^AMHREC(V,0),U,16)=BGPV
QUIT
+13 ;already got a dx on this date
IF $DATA(BGPDEP(D))
QUIT
+14 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+15 IF BGPP=14
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+16 IF BGPP=15
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+17 IF $EXTRACT(BGPP,1,3)=296
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+18 IF BGPP=291.89
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+19 IF BGPP=292.84
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+20 IF BGPP="293.83"
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+21 IF BGPP="301.13"
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+22 IF BGPP=300.4
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+23 IF BGPP="311."
SET BGPC=BGPC+1
SET BGPDEP(D)=""
QUIT
+24 QUIT
End DoDot:2
End DoDot:1
+25 SET X=$ORDER(BGPDEP(0))
SET Y=$ORDER(BGPDEP(X))
+26 IF BGPC>1
QUIT 1_"^2 dx PCC/BH"_U_$$FMTE^XLFDT((9999999-X))_U_$$FMTE^XLFDT((9999999-Y))
+27 QUIT ""
DEPSCR(P,BDATE,EDATE) ;EP
+1 SET BGPDEPS=""
+2 IF $GET(P)=""
QUIT ""
+3 KILL BGPG
SET %=P_"^LAST EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPDEPS=1_"^DEP SCRN^"_$$DATE^BGP9UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)
+5 KILL BGPG
+6 SET Y="BGPG("
+7 SET X=P_"^LAST DX V79.0;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+8 IF $DATA(BGPG(1))
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(1),U)
SET BGPDEPS=1_U_"V79.0 DEP SCRN"_U_$$DATE^BGP9UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)
+9 ;now add in v measurements
+10 SET BGPC=$$LASTITEM^BGP9DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
+11 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas: "_$PIECE(BGPC,U,3)_U_$$DATE^BGP9UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)
+12 SET BGPC=$$LASTITEM^BGP9DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
+13 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas: "_$PIECE(BGPC,U,3)_U_$$DATE^BGP9UTL($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^BGP9UTL(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^BGP9UTL(9999999-D)_U_(9999999-X)
End DoDot:2
End DoDot:1
+11 IF BGPC]""
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+12 ;add in measurements
+13 ;ANMC
+14 SET T=$ORDER(^AUTTHF("B","PRIME MD SCORE",0))
+15 IF T=""
QUIT BGPDEPS
+16 SET BGPC=""
SET D=0
FOR
SET D=$ORDER(^AUPNVHF("AA",P,T,D))
IF D'=+D!(BGPC]"")
QUIT
Begin DoDot:1
+17 SET Y=9999999-D
+18 IF Y<BDATE
QUIT
+19 IF Y>EDATE
QUIT
+20 SET BGPC=1_U_"PRIME MD SCORE HEALTH FACTOR"_U_$$DATE^BGP9UTL(9999999-D)_U_(9999999-D)
+21 QUIT
End DoDot:1
+22 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+23 QUIT BGPDEPS
DEPREF(P,BDATE,EDATE) ;EP
+1 SET G=$$REFUSAL^BGP9UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",36,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+2 IF $PIECE(G,U)=1
QUIT 1_"^ref DEP SCRN^"_$$DATE^BGP9UTL($PIECE(G,U,2))_U_$PIECE(G,U,2)
+3 QUIT ""
DEPEDU(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
SET BGPDEPE=""
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG(1))
GOTO DEPMH
+5 SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 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^BGP9UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+11 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^BGP9UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
+12 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
+13 SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
+14 ;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
+15 ;.S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP9UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
+16 ;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
+17 ;.S BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP9UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)
+18 IF $PIECE(T,"-",1)="300.9"!($PIECE(T,"-")="684.44")
IF $PIECE(BGPDEPE,U,4)<$PIECE(BGPG(X),U,1)
Begin DoDot:2
+19 SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_U_$PIECE(BGPG(X),U)
End DoDot:2
+20 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
+21 SET BGPDEPE=1_U_"EDUC: "_T_U_$$DATE^BGP9UTL($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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL((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^BGP9UTL(Z)
+10 ;I $P(Y,"-",1)["296.2"!($P(Y,"-",1["296.3")) S G=1_U_"ref "_Y_U_$$DATE^BGP9UTL(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^BGP9UTL(Z)
+12 ;I $P(Y,"-",1)["300.9"!($P(Y,"-",1["684.44")) S G=1_U_"ref "_Y_U_$$DATE^BGP9UTL(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^BGP9UTL(Z)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT G
