- 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 ""
