BGP5D27 ; IHS/CMI/LAB - measure I2 ;
;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
;
;
AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
;
NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG
;CHECK DX 15.1
S BGPG=$$LASTPRC^BGP5UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I BGPG Q 1
S BGPG=$$CPT^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT BILAT FOOT AMP",0)))
I BGPG Q 1
;check cpt codes for bilateral
;loop through all cpt codes up to Edate and if any match quit
S (X,Y,Z,G)=0 K BGPX
S T=$O(^ATXAX("B","BGP FOOT AMP CPTS",0))
I T S %="" D I %]"" Q %
.S Y=0 F S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(%]"") D
..S D=$P($G(^AUPNVCPT(Y,0)),U,3)
..Q:D=""
..S D=$P($P($G(^AUPNVSIT(D,0)),U),".") ;date done
..Q:D=""
..I D>EDATE Q
..S X=$P(^AUPNVCPT(Y,0),U)
..Q:'$$ICD^BGP5UTL2(X,T,1)
..S BGPX(D)=""
..;
..S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
..S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
..Q
.Q
; now check tran codes
I T,$D(^AUPNVTC("AC",P)) S %="" D I %]"" Q %
.S E=0 F S E=$O(^AUPNVTC("AC",P,E)) Q:E'=+E!(%]"") D
..S D=$P($G(^AUPNVTC(E,0)),U,3) Q:'D S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
..Q:'$$ICD^BGP5UTL2($P(^AUPNVTC(E,0),U,7),T,1)
..S Y=$P(^AUPNVTC(E,0),U,7)
..I D>EDATE Q
..S BGPX(D)=""
..S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
..S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
..Q
.Q
;see if 2 on different dates
S %=0,X=0,C=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1
I C>1 Q 1
S T=$O(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
S (F,S)=0 F S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F S C=$P(^AUPNVPRC(F,0),U) D
.S G=0 S:$$ICD^BGP5UTL2(C,T,0) G=1
.Q:G=0
.S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
.I D>EDATE Q
.S BGPX(D)=""
S %=0,X=0,C=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1
I C>1 Q 1
;NOW ADD IN DX CODES
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)
S %=0 F S %=$O(BGPG(%)) Q:%'=+% S D=$P(BGPG(%),U,1),BGPX(D)=""
S %=0,X=0,C=0 F S X=$O(BGPX(X)) Q:X'=+X S C=C+1
I C>1 Q 1
Q 0
DEPSCRBH(P,BDATE,EDATE) ;EP
NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,BGPTC
S BGPDEPS=""
I $G(P)="" Q ""
S BGPTC=$O(^BGPCTRL("B",2015,0))
BH 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
.Q:'$D(^AMHREC(V,0))
.S C=$P(^AMHREC(V,0),U,25)
.Q:'C
.S C=$P($G(^DIC(40.7,C,0)),U,2)
.Q:C=""
.Q:'$D(^BGPCTRL(BGPTC,50,"B",C)) ;not BH clinic
.I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="N") S BGPC=1_U_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
.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_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C 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_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
.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^BGP5UTL2(BGPP,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
..S BGPC=1_U_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
I BGPC]"",$P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC
K BGPG S %=P_"^ALL EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) D
.S E=0 F S E=$O(BGPG(E)) Q:E'=+E S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
..Q:C=""
..Q:'$D(^BGPCTRL(BGPTC,50,"B",C)) ;not BH clinic
..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_"^"_C_U_$$DATE^BGP5UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) D
.S E=0 F S E=$O(BGPG(E)) Q:E'=+E S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
..Q:C=""
..Q:'$D(^BGPCTRL(BGPTC,50,"B",C)) ;not BH clinic
..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_"^"_C_U_$$DATE^BGP5UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
;now add in v measurements
K BGPG
S Y="BGPG("
S X=P_"^ALL MEAS PHQ2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) D
.S E=0 F S E=$O(BGPG(E)) Q:E'=+E S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
..Q:C=""
..Q:'$D(^BGPCTRL(BGPTC,50,"B",C)) ;not BH clinic
..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP5UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
K BGPG
S Y="BGPG("
S X=P_"^ALL MEAS PHQ9;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) D
.S E=0 F S E=$O(BGPG(E)) Q:E'=+E S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
..Q:C=""
..Q:'$D(^BGPCTRL(BGPTC,50,"B",C)) ;not BH clinic
..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP5UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
BHSCRC ;
;go through visits in a date range for this patient, check cpts
NEW BD,ED
S ED=(9999999-EDATE),BD=9999999-BDATE,G=""
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S C=$$CLINIC^APCLV(V,"C")
..Q:C=""
..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^BGP5UTL2($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1) S G=1_U_C_U_$$DATE^BGP5UTL($$VD^APCLV(V))_U_$$VD^APCLV(V)_U_C
...Q
..Q
.Q
I G,$P(BGPDEPS,U,4)<$P(G,U,1) S BGPDEPS=G
Q BGPDEPS
BGP5D27 ; IHS/CMI/LAB - measure I2 ;
+1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
+2 ;
+3 ;
AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
+1 ;
+2 NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG
+3 ;CHECK DX 15.1
+4 SET BGPG=$$LASTPRC^BGP5UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+5 IF BGPG
QUIT 1
+6 SET BGPG=$$CPT^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP CPT BILAT FOOT AMP",0)))
+7 IF BGPG
QUIT 1
+8 ;check cpt codes for bilateral
+9 ;loop through all cpt codes up to Edate and if any match quit
+10 SET (X,Y,Z,G)=0
KILL BGPX
+11 SET T=$ORDER(^ATXAX("B","BGP FOOT AMP CPTS",0))
+12 IF T
SET %=""
Begin DoDot:1
+13 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+14 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+15 IF D=""
QUIT
+16 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+17 IF D=""
QUIT
+18 IF D>EDATE
QUIT
+19 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+20 IF '$$ICD^BGP5UTL2(X,T,1)
QUIT
+21 SET BGPX(D)=""
+22 ;
+23 SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+24 SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
IF %]""
QUIT %
+27 ; now check tran codes
+28 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+29 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+30 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+31 IF '$$ICD^BGP5UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)
QUIT
+32 SET Y=$PIECE(^AUPNVTC(E,0),U,7)
+33 IF D>EDATE
QUIT
+34 SET BGPX(D)=""
+35 SET M=$PIECE(^AUPNVTC(E,0),U,12)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+36 SET M=$PIECE(^AUPNVTC(E,0),U,15)
IF M
SET M=$PIECE($GET(^AUTTCMOD(M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP5UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+37 QUIT
End DoDot:2
+38 QUIT
End DoDot:1
IF %]""
QUIT %
+39 ;see if 2 on different dates
+40 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+41 IF C>1
QUIT 1
+42 SET T=$ORDER(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
+43 SET (F,S)=0
FOR
SET F=$ORDER(^AUPNVPRC("AC",P,F))
IF F'=+F
QUIT
SET C=$PIECE(^AUPNVPRC(F,0),U)
Begin DoDot:1
+44 SET G=0
IF $$ICD^BGP5UTL2(C,T,0)
SET G=1
+45 IF G=0
QUIT
+46 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+47 IF D>EDATE
QUIT
+48 SET BGPX(D)=""
End DoDot:1
+49 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+50 IF C>1
QUIT 1
+51 ;NOW ADD IN DX CODES
+52 KILL BGPG
+53 SET Y="BGPG("
+54 SET X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+55 SET %=0
FOR
SET %=$ORDER(BGPG(%))
IF %'=+%
QUIT
SET D=$PIECE(BGPG(%),U,1)
SET BGPX(D)=""
+56 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+57 IF C>1
QUIT 1
+58 QUIT 0
DEPSCRBH(P,BDATE,EDATE) ;EP
+1 NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,BGPTC
+2 SET BGPDEPS=""
+3 IF $GET(P)=""
QUIT ""
+4 SET BGPTC=$ORDER(^BGPCTRL("B",2015,0))
BH 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
+1 IF '$DATA(^AMHREC(V,0))
QUIT
+2 SET C=$PIECE(^AMHREC(V,0),U,25)
+3 IF 'C
QUIT
+4 SET C=$PIECE($GET(^DIC(40.7,C,0)),U,2)
+5 IF C=""
QUIT
+6 ;not BH clinic
IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+7 IF $PIECE($GET(^AMHREC(V,14)),U,5)="P"!($PIECE($GET(^AMHREC(V,14)),U,5)="N")
SET BGPC=1_U_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
+8 IF BGPC
QUIT
+9 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
+10 IF 'BGPP
QUIT
+11 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+12 IF BGPP=14.1
SET BGPC=1_U_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
QUIT
End DoDot:2
+13 IF BGPC
QUIT
+14 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
+15 IF 'BGPP
QUIT
+16 SET BGPP=$PIECE($GET(^AUTTMSR(BGPP,0)),U)
+17 IF BGPP="PHQ2"!(BGPP="PHQ9")
SET BGPC=1_U_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
End DoDot:2
+18 IF BGPC
QUIT
+19 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
+20 IF 'BGPP
QUIT
+21 IF '$$ICD^BGP5UTL2(BGPP,$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
QUIT
+22 SET BGPC=1_U_C_U_$$DATE^BGP5UTL(9999999-D)_U_(9999999-D)_U_C
End DoDot:2
End DoDot:1
+23 IF BGPC]""
IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPC,U,4)
SET BGPDEPS=BGPC
+24 KILL BGPG
SET %=P_"^ALL EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+25 IF $DATA(BGPG(1))
Begin DoDot:1
+26 SET E=0
FOR
SET E=$ORDER(BGPG(E))
IF E'=+E
QUIT
SET V=$PIECE(BGPG(E),U,5)
SET C=$$CLINIC^APCLV(V,"C")
Begin DoDot:2
+27 IF C=""
QUIT
+28 ;not BH clinic
IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+29 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(E),U)
SET BGPDEPS=1_"^"_C_U_$$DATE^BGP5UTL($PIECE(BGPG(E),U))_U_$PIECE(BGPG(E),U)_U_C
End DoDot:2
End DoDot:1
+30 KILL BGPG
+31 SET Y="BGPG("
+32 SET X=P_"^ALL DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+33 IF $DATA(BGPG(1))
Begin DoDot:1
+34 SET E=0
FOR
SET E=$ORDER(BGPG(E))
IF E'=+E
QUIT
SET V=$PIECE(BGPG(E),U,5)
SET C=$$CLINIC^APCLV(V,"C")
Begin DoDot:2
+35 IF C=""
QUIT
+36 ;not BH clinic
IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+37 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(E),U)
SET BGPDEPS=1_"^"_C_U_$$DATE^BGP5UTL($PIECE(BGPG(E),U))_U_$PIECE(BGPG(E),U)_U_C
End DoDot:2
End DoDot:1
+38 ;now add in v measurements
+39 KILL BGPG
+40 SET Y="BGPG("
+41 SET X=P_"^ALL MEAS PHQ2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+42 IF $DATA(BGPG(1))
Begin DoDot:1
+43 SET E=0
FOR
SET E=$ORDER(BGPG(E))
IF E'=+E
QUIT
SET V=$PIECE(BGPG(E),U,5)
SET C=$$CLINIC^APCLV(V,"C")
Begin DoDot:2
+44 IF C=""
QUIT
+45 ;not BH clinic
IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+46 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(E),U)
SET BGPDEPS=1_C_U_$$DATE^BGP5UTL($PIECE(BGPG(E),U))_U_$PIECE(BGPG(E),U)_U_C
End DoDot:2
End DoDot:1
+47 KILL BGPG
+48 SET Y="BGPG("
+49 SET X=P_"^ALL MEAS PHQ9;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+50 IF $DATA(BGPG(1))
Begin DoDot:1
+51 SET E=0
FOR
SET E=$ORDER(BGPG(E))
IF E'=+E
QUIT
SET V=$PIECE(BGPG(E),U,5)
SET C=$$CLINIC^APCLV(V,"C")
Begin DoDot:2
+52 IF C=""
QUIT
+53 ;not BH clinic
IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+54 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(E),U)
SET BGPDEPS=1_C_U_$$DATE^BGP5UTL($PIECE(BGPG(E),U))_U_$PIECE(BGPG(E),U)_U_C
End DoDot:2
End DoDot:1
BHSCRC ;
+1 ;go through visits in a date range for this patient, check cpts
+2 NEW BD,ED
+3 SET ED=(9999999-EDATE)
SET BD=9999999-BDATE
SET G=""
+4 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+5 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+8 SET C=$$CLINIC^APCLV(V,"C")
+9 IF C=""
QUIT
+10 IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+12 IF $$ICD^BGP5UTL2($PIECE(^AUPNVCPT(X,0),U),$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
SET G=1_U_C_U_$$DATE^BGP5UTL($$VD^APCLV(V))_U_$$VD^APCLV(V)_U_C
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
+16 IF G
IF $PIECE(BGPDEPS,U,4)<$PIECE(G,U,1)
SET BGPDEPS=G
+17 QUIT BGPDEPS
