BGP8D27 ; IHS/CMI/LAB - measure I2 ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
;
NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG,BGPRL,T1,M,F,C,R,T2
;
;v18 PATCH 1 problem list
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT BIL",EDATE)
I X Q 1
S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
I BGPG Q 1
S BGPG=$$CPT^BGP8DU(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,BGPRL
S T=$O(^ATXAX("B","BGP FOOT AMP CPTS",0))
S T1=$O(^ATXAX("B","BGP CPT FOOT AMP UNKNOWN SIDE",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)
..I $$ICD^BGP8UTL2(X,T,1) D
...S BGPX(D)=""
...;
...I ^DD(9000010.18,.08,0)["AUTTCMOD" 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^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
...I ^DD(9000010.18,.09,0)["AUTTCMOD" 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^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
...I ^DD(9000010.18,.08,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
...I ^DD(9000010.18,.09,0)["DIC(81.3" S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
..Q:'$$ICD^BGP8UTL2(X,T1,1)
..S BGPRL(D,"UNK")=""
..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),".")
..I D>EDATE Q
..I $$ICD^BGP8UTL2($P(^AUPNVTC(E,0),U,7),T,1) D
...S Y=$P(^AUPNVTC(E,0),U,7)
...S BGPX(D)=""
...I '$D(^DIC(81.3,0)) 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^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
...I '$D(^DIC(81.3,0)) 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^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
...I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
...I $D(^DIC(81.3,0)) S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^DIC(81.3,M,0)),U) I M=50 S %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
..Q:'$$ICD^BGP8UTL2(X,T1,1)
..S BGPRL(D,"UNK")=""
.Q
;NEW STUFF FOR PATCH 1 VERSION 18
;A RIGHT AND A LEFT OR 2 DIFFERENT DATES
;GET ALL RIGHTS AND LEFTS BY DX/PROC
K BGPRLU
;PROBLEM LIST
S X=$$PLTAXND^BGP8DU(P,"BGP RIGHT FOOT AMP DXS",EDATE)
I X S BGPRL($P(X,U,3),"RT")=""
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT RIGHT",EDATE)
I X S BGPRL($P(X,U,3),"RT")=""
S X=$$PLTAXND^BGP8DU(P,"BGP LEFT FOOT AMP DXS",EDATE)
I X S BGPRL($P(X,U,3),"LT")=""
S X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT LEFT",EDATE)
I X S BGPRL($P(X,U,3),"LT")=""
;IF THERE IS A RIGHT AND A LEFT STOP NOW
S G="",D=0,R="",L="" F S D=$O(BGPRL(D)) Q:D'=+D D
.I $D(BGPRL(D,"RT")) S R=D
.I $D(BGPRL(D,"LT")) S L=D
I R,L Q 1 ;HAS RIGHT AND LEFT
S T=$O(^ATXAX("B","BGP RIGHT FOOT AMP PROCS",0))
S T1=$O(^ATXAX("B","BGP LEFT FOOT AMP PROCS",0))
S T2=$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=""
.I $$ICD^BGP8UTL2(C,T,0) S G="RT"
.I $$ICD^BGP8UTL2(C,T1,0) S G="LT"
.I $$ICD^BGP8UTL2(C,T2,0) S G="UNK"
.Q:G=""
.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 BGPRL(D,G)=""
;IF THERE IS A RIGHT AND A LEFT STOP NOW
S G="",D=0,R="",L="" F S D=$O(BGPRL(D)) Q:D'=+D D
.I $D(BGPRL(D,"RT")) S R=D
.I $D(BGPRL(D,"LT")) S L=D
I R,L Q 1 ;HAS RIGHT AND LEFT
;NOW GET RT DXS
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP RIGHT 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),BGPRL(D,"RT")=""
;NOW GET LEFT DXS
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP LEFT 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),BGPRL(D,"LT")=""
;IF THERE IS A RIGHT AND A LEFT STOP NOW
S G="",D=0,R="",L="" F S D=$O(BGPRL(D)) Q:D'=+D D
.I $D(BGPRL(D,"RT")) S R=D
.I $D(BGPRL(D,"LT")) S L=D
I R,L Q 1 ;HAS RIGHT AND LEFT
;GET ALL UNKNOWNS, ALREADY HAVE PROCS AND CPTS
;ADD DXS
;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),BGPRL(D,"UNK")=""
;
;kill off all unknowns on the same day as a right or left
S D=0 F S D=$O(BGPRL(D)) Q:D="" I $D(BGPRL(D,"RT")) K BGPRL(D,"UNK")
S D=0 F S D=$O(BGRPL(D)) Q:D="" I $D(BGPRL(D,"LT")) K BGPRL(D,"UNK")
;is there
S G=0 S D=0 F S D=$O(BGPRL(D)) Q:D=""!(G) D
.Q:'$D(BGPRL(D,"UNK"))
.S X=0 F S X=$O(BGPRL(X)) Q:X'=+X D
..Q:X=D
..S G=1
Q G
;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^BGP8UTL2(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",2018,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^BGP8UTL(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^BGP8UTL(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")!(BGPP="PHQT") S BGPC=1_U_C_U_$$DATE^BGP8UTL(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^BGP8UTL2(BGPP,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
..S BGPC=1_U_C_U_$$DATE^BGP8UTL(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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
K BGPG
S Y="BGPG("
S X=P_"^ALL MEAS PHQT;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^BGP8UTL($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^BGP8UTL2($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1) S G=1_U_C_U_$$DATE^BGP8UTL($$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
BGP8D27 ; IHS/CMI/LAB - measure I2 ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
+1 ;
+2 NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG,BGPRL,T1,M,F,C,R,T2
+3 ;
+4 ;v18 PATCH 1 problem list
+5 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT BIL",EDATE)
+6 IF X
QUIT 1
+7 SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
+8 IF BGPG
QUIT 1
+9 SET BGPG=$$CPT^BGP8DU(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP CPT BILAT FOOT AMP",0)))
+10 IF BGPG
QUIT 1
+11 ;check cpt codes for bilateral
+12 ;loop through all cpt codes up to Edate and if any match quit
+13 SET (X,Y,Z,G)=0
KILL BGPX,BGPRL
+14 SET T=$ORDER(^ATXAX("B","BGP FOOT AMP CPTS",0))
+15 SET T1=$ORDER(^ATXAX("B","BGP CPT FOOT AMP UNKNOWN SIDE",0))
+16 IF T
SET %=""
Begin DoDot:1
+17 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AC",P,Y))
IF Y'=+Y!(%]"")
QUIT
Begin DoDot:2
+18 SET D=$PIECE($GET(^AUPNVCPT(Y,0)),U,3)
+19 IF D=""
QUIT
+20 ;date done
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+21 IF D=""
QUIT
+22 IF D>EDATE
QUIT
+23 SET X=$PIECE(^AUPNVCPT(Y,0),U)
+24 IF $$ICD^BGP8UTL2(X,T,1)
Begin DoDot:3
+25 SET BGPX(D)=""
+26 ;
+27 IF ^DD(9000010.18,.08,0)["AUTTCMOD"
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^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+28 IF ^DD(9000010.18,.09,0)["AUTTCMOD"
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^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+29 IF ^DD(9000010.18,.08,0)["DIC(81.3"
SET M=$PIECE(^AUPNVCPT(Y,0),U,8)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
+30 IF ^DD(9000010.18,.09,0)["DIC(81.3"
SET M=$PIECE(^AUPNVCPT(Y,0),U,9)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(X,0),U,1)
End DoDot:3
+31 IF '$$ICD^BGP8UTL2(X,T1,1)
QUIT
+32 SET BGPRL(D,"UNK")=""
+33 QUIT
End DoDot:2
+34 QUIT
End DoDot:1
IF %]""
QUIT %
+35 ; now check tran codes
+36 IF T
IF $DATA(^AUPNVTC("AC",P))
SET %=""
Begin DoDot:1
+37 SET E=0
FOR
SET E=$ORDER(^AUPNVTC("AC",P,E))
IF E'=+E!(%]"")
QUIT
Begin DoDot:2
+38 SET D=$PIECE($GET(^AUPNVTC(E,0)),U,3)
IF 'D
QUIT
SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+39 IF D>EDATE
QUIT
+40 IF $$ICD^BGP8UTL2($PIECE(^AUPNVTC(E,0),U,7),T,1)
Begin DoDot:3
+41 SET Y=$PIECE(^AUPNVTC(E,0),U,7)
+42 SET BGPX(D)=""
+43 IF '$DATA(^DIC(81.3,0))
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^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+44 IF '$DATA(^DIC(81.3,0))
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^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+45 IF $DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,12)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
+46 IF $DATA(^DIC(81.3,0))
SET M=$PIECE(^AUPNVTC(E,0),U,15)
IF M
SET M=$PIECE($GET(^DIC(81.3,M,0)),U)
IF M=50
SET %=1_U_$$DATE^BGP8UTL(D)_" FOOT AMP "_$PIECE(^ICPT(Y,0),U,1)
End DoDot:3
+47 IF '$$ICD^BGP8UTL2(X,T1,1)
QUIT
+48 SET BGPRL(D,"UNK")=""
End DoDot:2
+49 QUIT
End DoDot:1
IF %]""
QUIT %
+50 ;NEW STUFF FOR PATCH 1 VERSION 18
+51 ;A RIGHT AND A LEFT OR 2 DIFFERENT DATES
+52 ;GET ALL RIGHTS AND LEFTS BY DX/PROC
+53 KILL BGPRLU
+54 ;PROBLEM LIST
+55 SET X=$$PLTAXND^BGP8DU(P,"BGP RIGHT FOOT AMP DXS",EDATE)
+56 IF X
SET BGPRL($PIECE(X,U,3),"RT")=""
+57 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT RIGHT",EDATE)
+58 IF X
SET BGPRL($PIECE(X,U,3),"RT")=""
+59 SET X=$$PLTAXND^BGP8DU(P,"BGP LEFT FOOT AMP DXS",EDATE)
+60 IF X
SET BGPRL($PIECE(X,U,3),"LT")=""
+61 SET X=$$IPLSNOND^BGP8DU(P,"PXRM BGP ABSENCE OF FOOT LEFT",EDATE)
+62 IF X
SET BGPRL($PIECE(X,U,3),"LT")=""
+63 ;IF THERE IS A RIGHT AND A LEFT STOP NOW
+64 SET G=""
SET D=0
SET R=""
SET L=""
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+65 IF $DATA(BGPRL(D,"RT"))
SET R=D
+66 IF $DATA(BGPRL(D,"LT"))
SET L=D
End DoDot:1
+67 ;HAS RIGHT AND LEFT
IF R
IF L
QUIT 1
+68 SET T=$ORDER(^ATXAX("B","BGP RIGHT FOOT AMP PROCS",0))
+69 SET T1=$ORDER(^ATXAX("B","BGP LEFT FOOT AMP PROCS",0))
+70 SET T2=$ORDER(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
+71 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
+72 SET G=""
+73 IF $$ICD^BGP8UTL2(C,T,0)
SET G="RT"
+74 IF $$ICD^BGP8UTL2(C,T1,0)
SET G="LT"
+75 IF $$ICD^BGP8UTL2(C,T2,0)
SET G="UNK"
+76 IF G=""
QUIT
+77 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+78 IF D>EDATE
QUIT
+79 SET BGPRL(D,G)=""
End DoDot:1
+80 ;IF THERE IS A RIGHT AND A LEFT STOP NOW
+81 SET G=""
SET D=0
SET R=""
SET L=""
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+82 IF $DATA(BGPRL(D,"RT"))
SET R=D
+83 IF $DATA(BGPRL(D,"LT"))
SET L=D
End DoDot:1
+84 ;HAS RIGHT AND LEFT
IF R
IF L
QUIT 1
+85 ;NOW GET RT DXS
+86 KILL BGPG
+87 SET Y="BGPG("
+88 SET X=P_"^ALL DX [BGP RIGHT FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+89 SET %=0
FOR
SET %=$ORDER(BGPG(%))
IF %'=+%
QUIT
SET D=$PIECE(BGPG(%),U,1)
SET BGPRL(D,"RT")=""
+90 ;NOW GET LEFT DXS
+91 KILL BGPG
+92 SET Y="BGPG("
+93 SET X=P_"^ALL DX [BGP LEFT FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+94 SET %=0
FOR
SET %=$ORDER(BGPG(%))
IF %'=+%
QUIT
SET D=$PIECE(BGPG(%),U,1)
SET BGPRL(D,"LT")=""
+95 ;IF THERE IS A RIGHT AND A LEFT STOP NOW
+96 SET G=""
SET D=0
SET R=""
SET L=""
FOR
SET D=$ORDER(BGPRL(D))
IF D'=+D
QUIT
Begin DoDot:1
+97 IF $DATA(BGPRL(D,"RT"))
SET R=D
+98 IF $DATA(BGPRL(D,"LT"))
SET L=D
End DoDot:1
+99 ;HAS RIGHT AND LEFT
IF R
IF L
QUIT 1
+100 ;GET ALL UNKNOWNS, ALREADY HAVE PROCS AND CPTS
+101 ;ADD DXS
+102 ;NOW ADD IN DX CODES
+103 KILL BGPG
+104 SET Y="BGPG("
+105 SET X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+106 SET %=0
FOR
SET %=$ORDER(BGPG(%))
IF %'=+%
QUIT
SET D=$PIECE(BGPG(%),U,1)
SET BGPRL(D,"UNK")=""
+107 ;
+108 ;kill off all unknowns on the same day as a right or left
+109 SET D=0
FOR
SET D=$ORDER(BGPRL(D))
IF D=""
QUIT
IF $DATA(BGPRL(D,"RT"))
KILL BGPRL(D,"UNK")
+110 SET D=0
FOR
SET D=$ORDER(BGRPL(D))
IF D=""
QUIT
IF $DATA(BGPRL(D,"LT"))
KILL BGPRL(D,"UNK")
+111 ;is there
+112 SET G=0
SET D=0
FOR
SET D=$ORDER(BGPRL(D))
IF D=""!(G)
QUIT
Begin DoDot:1
+113 IF '$DATA(BGPRL(D,"UNK"))
QUIT
+114 SET X=0
FOR
SET X=$ORDER(BGPRL(X))
IF X'=+X
QUIT
Begin DoDot:2
+115 IF X=D
QUIT
+116 SET G=1
End DoDot:2
End DoDot:1
+117 QUIT G
+118 ;see if 2 on different dates
+119 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+120 IF C>1
QUIT 1
+121 SET T=$ORDER(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
+122 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
+123 SET G=0
IF $$ICD^BGP8UTL2(C,T,0)
SET G=1
+124 IF G=0
QUIT
+125 SET D=$PIECE(^AUPNVPRC(F,0),U,6)
IF D=""
SET D=$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVPRC(F,0),U,3),0),U),".")
+126 IF D>EDATE
QUIT
+127 SET BGPX(D)=""
End DoDot:1
+128 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+129 IF C>1
QUIT 1
+130 ;NOW ADD IN DX CODES
+131 KILL BGPG
+132 SET Y="BGPG("
+133 SET X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+134 SET %=0
FOR
SET %=$ORDER(BGPG(%))
IF %'=+%
QUIT
SET D=$PIECE(BGPG(%),U,1)
SET BGPX(D)=""
+135 SET %=0
SET X=0
SET C=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET C=C+1
+136 IF C>1
QUIT 1
+137 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",2018,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^BGP8UTL(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^BGP8UTL(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")!(BGPP="PHQT")
SET BGPC=1_U_C_U_$$DATE^BGP8UTL(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^BGP8UTL2(BGPP,$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
QUIT
+22 SET BGPC=1_U_C_U_$$DATE^BGP8UTL(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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($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^BGP8UTL($PIECE(BGPG(E),U))_U_$PIECE(BGPG(E),U)_U_C
End DoDot:2
End DoDot:1
+55 KILL BGPG
+56 SET Y="BGPG("
+57 SET X=P_"^ALL MEAS PHQT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+58 IF $DATA(BGPG(1))
Begin DoDot:1
+59 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
+60 IF C=""
QUIT
+61 ;not BH clinic
IF '$DATA(^BGPCTRL(BGPTC,50,"B",C))
QUIT
+62 IF $PIECE(BGPDEPS,U,4)<$PIECE(BGPG(E),U)
SET BGPDEPS=1_C_U_$$DATE^BGP8UTL($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^BGP8UTL2($PIECE(^AUPNVCPT(X,0),U),$ORDER(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
SET G=1_U_C_U_$$DATE^BGP8UTL($$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
