BGP8PC11 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
DEP ;EP
I 'BGPIPCUP S BGPSTOP=1 Q ;must be ipc up
I BGPAGEB<12 S BGPSTOP=1 Q ;must be 12 or older at beginning of time period
S (BGPD1,BGPN1)=0
S BGPDEP="",BGPVALUE=""
S BGPD1=1 ;meet denominator
S BGPDEP=$$DEPSCR(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEP,U)=1 S BGPN1=1 G DEPE
S BGPDEP=$$DEPDX(DFN,BGPBDATE,BGPEDATE) I $P(BGPDEP,U)=1 S BGPN1=1
DEPE ;
S BGPVALUE="IPCUP|||"
I BGPN1 S BGPVALUE=BGPVALUE_"***"_$P(BGPDEP,U,3)_" "_$P(BGPDEP,U,5)
;I BGPN1 W !,DFN," ",BGPVALUE
K BGPDEP,BGPDSE
Q
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^BGP8UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"Ex 36" Q BGPDEPS
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)) S BGPDEPS=1_U_"POV "_$P(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP8UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)_U_"POV "_$P(BGPG(1),U,2) Q BGPDEPS
;
S Y=$$CPT^BGP8DU(DFN,BDATE,EDATE,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),5)
I Y S BGPDEPS=1_U_"CPT "_$P(Y,U,2)_U_$$DATE^BGP8UTL($P(Y,U,1))_U_$P(Y,U,1)_U_"CPT "_$P(Y,U,2)
I BGPDEPS Q BGPDEPS
;now add in v measurements
S BGPC=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
I $P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP8UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3) Q BGPDEPS
S BGPC=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
I $P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP8UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3) Q BGPDEPS
S BGPC=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","PHQT")
I $P(BGPC,U,2) S BGPDEPS=1_U_"Meas "_$P(BGPC,U,3)_U_$$DATE^BGP8UTL($P(BGPC,U,2))_U_$P(BGPC,U,2)_U_"Meas "_$P(BGPC,U,3) Q BGPDEPS
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
.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^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH Exam 36"
.Q:BGPC
.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^BGP8UTL(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^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP
.Q:BGPC
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRPROC(X,0)),U) D
..Q:'BGPP
..Q:'$$ICD^BGP8UTL2(BGPP,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
..S BGPC=1_U_"BH CPT: "_$P(^ICPT(BGPP,0),U,1)_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH CPT "_$P(^ICPT(BGPP,0),U,1)
I BGPC]"" S BGPDEPS=BGPC
Q BGPDEPS
DEPDX(P,BDATE,EDATE) ;EP
I $G(P)="" Q ""
NEW BGPG,BGPDEP,BGPV,Y,X,E,D,V,BGPC,BGPP,I,Z,BGPPC
K BGPG,BGPDEP
S BGPV=""
S Y="BGPG("
S X=P_"^LAST 1 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_U_$$DATE^BGP8UTL($P(BGPG(1),U))_U_U_"POV "_$P(BGPG(1),U,2)
;
S BGPC=0,E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC>0) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC>0) 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 BGPPC=$P($G(^AMHPROB(BGPP,0)),U)
..I BGPPC=14 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..I BGPPC=15 S BGPC=BGPC+1,BGPDEP(D)=BGPP Q
..;GET ICD CODE
..S I=$P(^AMHPROB(BGPP,0),U,17)
..I I="" S I=$P(^AMHPROB(BGPP,0),U,5)
..Q:I=""
..S Z=+$$CODEN^BGP8UTL2(I,80)
..I Z'>0 Q
..I $$ICD^BGP8UTL2(Z,$O(^ATXAX("B","BGP MOOD DISORDERS",0)),9) S BGPC=BGPC+1,BGPDEP(D)=BGPPC Q
..Q
S X=$O(BGPDEP(0))
I BGPC>0 Q 1_"^^"_$$FMTE^XLFDT((9999999-$P(X,".")))_"^^BH POV "_BGPDEP(X)
Q ""
BGP8PC11 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
DEP ;EP
+1 ;must be ipc up
IF 'BGPIPCUP
SET BGPSTOP=1
QUIT
+2 ;must be 12 or older at beginning of time period
IF BGPAGEB<12
SET BGPSTOP=1
QUIT
+3 SET (BGPD1,BGPN1)=0
+4 SET BGPDEP=""
SET BGPVALUE=""
+5 ;meet denominator
SET BGPD1=1
+6 SET BGPDEP=$$DEPSCR(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDEP,U)=1
SET BGPN1=1
GOTO DEPE
+7 SET BGPDEP=$$DEPDX(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPDEP,U)=1
SET BGPN1=1
DEPE ;
+1 SET BGPVALUE="IPCUP|||"
+2 IF BGPN1
SET BGPVALUE=BGPVALUE_"***"_$PIECE(BGPDEP,U,3)_" "_$PIECE(BGPDEP,U,5)
+3 ;I BGPN1 W !,DFN," ",BGPVALUE
+4 KILL BGPDEP,BGPDSE
+5 QUIT
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^BGP8UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"Ex 36"
QUIT BGPDEPS
+6 KILL BGPG
+7 SET Y="BGPG("
+8 SET X=P_"^LAST DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 IF $DATA(BGPG(1))
SET BGPDEPS=1_U_"POV "_$PIECE(BGPG(1),U,2)_" DEP"_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)_U_"POV "_$PIECE(BGPG(1),U,2)
QUIT BGPDEPS
+10 ;
+11 SET Y=$$CPT^BGP8DU(DFN,BDATE,EDATE,$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),5)
+12 IF Y
SET BGPDEPS=1_U_"CPT "_$PIECE(Y,U,2)_U_$$DATE^BGP8UTL($PIECE(Y,U,1))_U_$PIECE(Y,U,1)_U_"CPT "_$PIECE(Y,U,2)
+13 IF BGPDEPS
QUIT BGPDEPS
+14 ;now add in v measurements
+15 SET BGPC=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","PHQ2")
+16 IF $PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP8UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
QUIT BGPDEPS
+17 SET BGPC=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","PHQ9")
+18 IF $PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP8UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
QUIT BGPDEPS
+19 SET BGPC=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","PHQT")
+20 IF $PIECE(BGPC,U,2)
SET BGPDEPS=1_U_"Meas "_$PIECE(BGPC,U,3)_U_$$DATE^BGP8UTL($PIECE(BGPC,U,2))_U_$PIECE(BGPC,U,2)_U_"Meas "_$PIECE(BGPC,U,3)
QUIT BGPDEPS
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 IF $PIECE($GET(^AMHREC(V,14)),U,5)="P"!($PIECE($GET(^AMHREC(V,14)),U,5)="N")
SET BGPC=1_U_"BH Dep Exam"_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH Exam 36"
+3 IF BGPC
QUIT
+4 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
+5 IF 'BGPP
QUIT
+6 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+7 IF BGPP=14.1
SET BGPC=1_U_"BH 14.1"_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH POV 14.1"
QUIT
End DoDot:2
+8 IF BGPC
QUIT
+9 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
+10 IF 'BGPP
QUIT
+11 SET BGPP=$PIECE($GET(^AUTTMSR(BGPP,0)),U)
+12 IF BGPP="PHQ2"!(BGPP="PHQ9")!(BGPP="PHQT")
SET BGPC=1_U_"BH "_BGPP_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH Meas "_BGPP
End DoDot:2
+13 IF BGPC
QUIT
+14 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(BGPC)
QUIT
SET BGPP=$PIECE($GET(^AMHRPROC(X,0)),U)
Begin DoDot:2
+15 IF 'BGPP
QUIT
+16 IF '$$ICD^BGP8UTL2(BGPP,$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
QUIT
+17 SET BGPC=1_U_"BH CPT: "_$PIECE(^ICPT(BGPP,0),U,1)_U_$$DATE^BGP8UTL(9999999-D)_U_(9999999-D)_U_"BH CPT "_$PIECE(^ICPT(BGPP,0),U,1)
End DoDot:2
End DoDot:1
+18 IF BGPC]""
SET BGPDEPS=BGPC
+19 QUIT BGPDEPS
DEPDX(P,BDATE,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW BGPG,BGPDEP,BGPV,Y,X,E,D,V,BGPC,BGPP,I,Z,BGPPC
+3 KILL BGPG,BGPDEP
+4 SET BGPV=""
+5 SET Y="BGPG("
+6 SET X=P_"^LAST 1 DX [BGP MOOD DISORDERS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BGPG(1))
QUIT 1_U_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_U_U_"POV "_$PIECE(BGPG(1),U,2)
+8 ;
+9 SET BGPC=0
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>0)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(BGPC>0)
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 BGPPC=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+13 IF BGPPC=14
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+14 IF BGPPC=15
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPP
QUIT
+15 ;GET ICD CODE
+16 SET I=$PIECE(^AMHPROB(BGPP,0),U,17)
+17 IF I=""
SET I=$PIECE(^AMHPROB(BGPP,0),U,5)
+18 IF I=""
QUIT
+19 SET Z=+$$CODEN^BGP8UTL2(I,80)
+20 IF Z'>0
QUIT
+21 IF $$ICD^BGP8UTL2(Z,$ORDER(^ATXAX("B","BGP MOOD DISORDERS",0)),9)
SET BGPC=BGPC+1
SET BGPDEP(D)=BGPPC
QUIT
+22 QUIT
End DoDot:2
End DoDot:1
+23 SET X=$ORDER(BGPDEP(0))
+24 IF BGPC>0
QUIT 1_"^^"_$$FMTE^XLFDT((9999999-$PIECE(X,".")))_"^^BH POV "_BGPDEP(X)
+25 QUIT ""
