BGP5D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
;
STI ;EP
D EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
Q
ISTI ;EP
NEW BGPCIN
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN15,BGPN16,BGPN17,BGPN18,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S BGPVALUE="",BGPDENV=""
K BGPYAR,BGPZAR,BGPNUMV
I $T(EN^BKMSTIDS)="" S BGPSTOP=1 Q ;no routine to execute
; BGPTIME=1 ZW
;D EN^XBNEW("STI^BGP5D24","DFN;BGPBDATE;BGPEDATE;BGPYAR;BGPZAR")
D EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
I '$D(BGPZAR) S BGPSTOP=1 Q ;no incidences or diagnoses
I $P($G(BGPZAR(0)),U)=0 S BGPSTOP=1 Q ;no incidences or diagnoses
S (BGPN1,BGPN2)=$P(BGPZAR(0),U,1) ;TOTAL # OF INCIDENCES
S BGPD1=$P(BGPZAR(0),U,2) ;TOTAL # SCREENINGS NEEDED
S BGPN3=$P(BGPZAR(0),U,3) ;TOTAL # OF SCREENINGS DONE
S BGPN4=$P(BGPZAR(0),U,4) ;TOTAL # OF REFUSALS
S BGPN15=$P(BGPZAR(0),U,5) ;NEW GROUPED DEN
S BGPN16=$P(BGPZAR(0),U,6) ;NEW GROUPED NUM
S BGPN17=$P(BGPZAR(0),U,7) ;NEW GROUPED REF
S BGPCIN=0
S X=0 F S X=$O(BGPZAR(X)) Q:X'=+X D
.S BGPCIN=BGPCIN+1
.S:BGPDENV]"" BGPDENV=BGPDENV_"; "
.S BGPNUMV(X)=""
.S I=0,C=0,BGPHXX="" F S I=$O(BGPZAR(X,I)) Q:I="" D
..I $D(BGPZAR(X,I,0)) S C=C+1 S BGPDENV=BGPDENV_$S(C=1:BGPCIN_") ",1:", ")_$P(BGPZAR(X,I,0),U,5)
..I $G(BGPYAR(I,"NUM","HIV"))=1 S BGPHXX=$O(BGPYAR(I,"NUM","HIV",0)) I BGPHXX S J=$P(BGPYAR(I,"NUM","HIV",BGPHXX),U,2) I J'["POV" S BGPHXX=""
..;I BGPHXX S BGPN18=1
.D
..;I $G(BGPZAR(X,"CHL"))]"" S Z=$G(BGPZAR(X,"CHL")) S:$P(Z,U) BGPD2=BGPD2+1 S:$P(Z,U,2) BGPN5=BGPN5+1 S:$P(Z,U,3) BGPN6=BGPN6+1 D
..;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"CHL-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;CHL SCREENINGS NEEDED/DONE
..;I $G(BGPZAR(X,"GC"))]"" S Z=$G(BGPZAR(X,"GC")) S:$P(Z,U) BGPD3=BGPD3+1 S:$P(Z,U,2) BGPN7=BGPN7+1 S:$P(Z,U,3) BGPN8=BGPN8+1 D
..;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"GC-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;GON SCREENINGS NEEDED/DONE
..I $G(BGPZAR(X,"HIV"))]"" S Z=$G(BGPZAR(X,"HIV")) S:$P(Z,U) BGPD4=BGPD4+1 S:$P(Z,U,2) BGPN9=BGPN9+1 S:$P(Z,U,3) BGPN10=BGPN10+1 D
...S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", "
...S H=0,I="" S:'($P(Z,U,1)+$P(Z,U,2)) H=1,I="Contraind Prior DX",BGPN18=1
...S BGPNUMV(X)=BGPNUMV(X)_"HIV-"_$S($P(Z,U,2):"Y",H:I,1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;HIV SCREENINGS NEEDED/DONE
..;I $G(BGPZAR(X,"SYP"))]"" S Z=$G(BGPZAR(X,"SYP")) S:$P(Z,U) BGPD5=BGPD5+1 S:$P(Z,U,2) BGPN11=BGPN11+1 S:$P(Z,U,3) BGPN12=BGPN12+1 D
..;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"SYP-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;SYP SCREENINGS NEEDED/DONE
.;I H]"" S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"Prior HIV DX (Contraind): "_$$DATE^BGP5UTL(H)
.S BGPVALUE="UP"_$S(BGPACTCL:";AC",1:"")_" Visit "_BGPDENV_"|||"
S BGPCIN=0 S X=0 F S X=$O(BGPNUMV(X)) Q:X'=+X S BGPCIN=BGPCIN+1 S BGPVALUE=BGPVALUE_$S(BGPCIN>1:"; ",1:"")_BGPCIN_") "_$S(BGPNUMV(X)="":"N/A",1:BGPNUMV(X))
Q
;
IASB ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S BGPVALUE=""
I 'BGPACTUP S BGPSTOP=1 Q
I BGPAGEB<15 S BGPSTOP=1 Q
I BGPAGEB>34 S BGPSTOP=1 Q
K BGPERV ;will return array of all er visits with injury diagnosis fm date^injury dx^screen^positive^text^bni^bni text
D ERINJ(DFN,BGPBDATE,BGPEDATE,.BGPERV)
I '$G(BGPERV(0)) S BGPSTOP=1 Q ;no injury visits
S BGPD1=BGPERV(0) ;total # of visits
I BGPAGEB>14,BGPAGEB<25 S BGPD2=BGPERV(0)
I BGPAGEB>24,BGPAGEB<35 S BGPD3=BGPERV(0)
S X=0,BGPN1=0 F S X=$O(BGPERV(X)) Q:X'=+X I $P(BGPERV(X),U,4) S BGPN1=BGPN1+1 ;SCREEN ON EVERY VISIT?
S X=0,BGPN2=0 F S X=$O(BGPERV(X)) Q:X'=+X I $P(BGPERV(X),U,5) S BGPN2=BGPN2+1 ;positive on at least one
I BGPN2 S X=0,BGPN3=0 F S X=$O(BGPERV(X)) Q:X'=+X D
.I $P(BGPERV(X),U,5),$P(BGPERV(X),U,7) S BGPN3=BGPN3+1
I BGPN3 S X=0 F S X=$O(BGPERV(X)) Q:X'=+X I $P(BGPERV(X),U,5) S:$P(BGPERV(X),U,10)=1 BGPN4=BGPN4+1 S:$P(BGPERV(X),U,10)=2 BGPN5=BGPN5+1
S BGPVALUE="UP"_$S(BGPACTCB:",AC+BH",1:"")
S V="",X=0,D="" F S X=$O(BGPERV(X)) Q:X'=+X S D=D_$S(D]"":"; ",1:"")_"ER "_X_") "_$$DATE^BGP5UTL($P(BGPERV(X),U,1))_" POV "_$P(BGPERV(X),U,3) D
.;S V=V_$S(V]"":"; ",1:"")
.;S V=V_"ER Visit "_X_") "
.I '$P(BGPERV(X),U,4) S D=D_", SCREEN: None" Q
.S D=D_$S($P(BGPERV(X),U,5):", SCREEN: Pos",1:", SCREEN: Neg/No Res")_" "_$P(BGPERV(X),U,6)
.I '$P(BGPERV(X),U,5) Q
.I '$P(BGPERV(X),U,7) S D=D_", BNI: No" Q
.S D=D_", BNI: "_$S($P(BGPERV(X),U,10)=1:$$DATE^BGP5UTL($P(BGPERV(X),U,8))_" Yes ER",1:" Yes Not ER")_" "_$P(BGPERV(X),U,9)
S BGPVALUE=BGPVALUE_"|||"_D
Q
;
ERINJ(P,BDATE,EDATE,BGPRET) ;
;did patient P have an ER visit with an injury dx?
K ^TMP($J,"A")
K BGPRET
NEW A,G,B,E,D,CNT,T
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP INJURY DIAGNOSES",0))
S E=$O(^ATXAX("B","BGP CAUSE OF INJURY ECODES",0))
S (X,G,CNT)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$P(^AUPNVSIT(V,0),U,7)'="A" ;ambulatory only
.Q:$$CLINIC^APCLV(V,"C")'=30
.Q:"CV"[$P(^AUPNVSIT(V,0),U,3) ;no Contract health
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S D=$P($P(^AUPNVSIT(V,0),U),".")
.;check diagnosis for injury
.S (G,A)=0 F S A=$O(^AUPNVPOV("AD",V,A)) Q:A'=+A!(G) D
..S B=$P($G(^AUPNVPOV(A,0)),U)
..I $$ICD^BGP5UTL2(B,T,9) S CNT=CNT+1,BGPRET(CNT)=D_U_V_U_$P($$ICDDX^BGP5UTL2(B),U,2),G=1,$P(BGPRET(CNT),U,4)=$$ERAS(V),$P(BGPRET(CNT),U,7)=$$BNI(P,V,BGPRET(CNT)) Q
..S B=$P($G(^AUPNVPOV(A,0)),U,9)
..I $$ICD^BGP5UTL2(B,E,9) S CNT=CNT+1,BGPRET(CNT)=D_U_V_U_$P($$ICDDX^BGP5UTL2(B),U,2),G=1,$P(BGPRET(CNT),U,4)=$$ERAS(V),$P(BGPRET(CNT),U,7)=$$BNI(P,V,BGPRET(CNT)) Q
S BGPRET(0)=CNT
Q
;
ERAS(V) ;was there screening on this visit V and was it positive
I $G(V)="" Q ""
NEW X,Y,Z,A,T
S X=0,Z="" F S X=$O(^AUPNVXAM("AD",V,X)) Q:X'=+X!($P(Z,U,2)) I $P(^AUTTEXAM(+$G(^AUPNVXAM(X,0)),0),U,2)=35 D
.S Y=$P(^AUPNVXAM(X,0),U,4)
.S Z=1_U_$S(Y="PO":"1^Ex 35",1:"0^Ex 35")
.Q
I $P(Z,U),$P(Z,U,2) Q Z
;check measurements
S X=0,Z="" F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X!($P(Z,U,2)) D
.Q:$P($G(^AUPNVMSR(X,2)),U,1)
.I $P(^AUTTMSR(+$G(^AUPNVMSR(X,0)),0),U,1)="AUDT" D Q
..S Y=$P(^AUPNVMSR(X,0),U,4)
..S Z=1_U_$S(Y>7.99999:"1^MSR AUDT",1:"0^MSR AUDT")
.I $P(^AUTTMSR(+$G(^AUPNVMSR(X,0)),0),U,1)="AUDC" D
..S Y=$P(^AUPNVMSR(X,0),U,4)
..I $P(^DPT(P,0),U,2)="M" S Z=1_U_$S(Y]""&(Y'<4):"1^MSR AUDC",1:"0^MSR AUDC")
..I $P(^DPT(P,0),U,2)="F" S Z=1_U_$S(Y]""&(Y'<3):"1^MSR AUDC",1:"0^MSR AUDC")
.I $P(^AUTTMSR(+$G(^AUPNVMSR(X,0)),0),U,1)="CRFT" D Q
..S Y=$P(^AUPNVMSR(X,0),U,4)
..S Z=1_U_$S(Y=2!(Y=3)!(Y=4)!(Y=5)!(Y=6):"1^MSR CRFT",1:"0^MSR CRFT")
I $P(Z,U),$P(Z,U,2) Q Z
S X=0 F S X=$O(^AUPNVHF("AD",V,X)) Q:X'=+X!($P(Z,U,2)) I $P(^AUTTHF($P(^AUTTHF(+$G(^AUPNVHF(X,0)),0),U,3),0),U)["ALCOHOL" D
.S Y=$P(^AUTTHF(+$G(^AUPNVHF(X,0)),0),U)
.S A="" I Y["CAGE",Y'[0 S A=1
.S Z=1_U_A_U_Y
I Z]"",$P(Z,U,2) Q Z
;screening CPT
S T=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!($P(Z,U,2)) D
.I $$ICD^BGP5UTL2($P(+$G(^AUPNVCPT(X,0)),U,1),T,1) D
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..S Z=1_U_U_"CPT "_Y
..I Y="G0396"!(Y="G0397")!(Y=99408)!(Y=99409) S $P(Z,U,2)=1
.Q
I Z]"" Q Z
;screening pov
S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!($P(Z,U,2)) I $$ICD^BGP5UTL2(+^AUPNVPOV(X,0),$O(^ATXAX("B","BGP SCREEN FOR ALCOHOLISM DX",0)),9) D
.S Z=1_U_U_"POV "_$$VAL^XBDIQ1(9000010.07,X,.01)
.Q
Q Z
;
BNI(P,V,E) ;
I $P(E,U,4)'=1 Q "" ;not a positive screen
NEW D,X,%
S D=$P($P(^AUPNVSIT(V,0),U),"."),%=""
S X=0 F S X=$O(^AUPNVPED("AD",V,X)) Q:X'=+X!(%]"") S Z=$P(^AUTTEDT(+$G(^AUPNVPED(X,0)),0),U,2) I Z="AOD-BNI"!($P(Z,"-")="99408")!($P(Z,"-")="99409")!($P(Z,"-")="H0050")!($P(Z,"-")="G0397")!($P(Z,"-")="G0396") S %=1_U_D_U_Z_U_1
I %]"" Q %
S T=$O(^ATXAX("B","BGP BNI CPTS",0))
S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(%]"") D
.Q:'$$ICD^BGP5UTL2($P(+$G(^AUPNVCPT(X,0)),U,1),T,1)
.S %=1_U_D_U_"CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_1
I %]"" Q %
S X=$$BNII(P,D)
Q X
BNII(P,BD) ;
NEW Y,BGPG,E,X,T,%,D
S Y=$$CPT^BGP5DU(P,BD,$$FMADD^XLFDT(BD,7),$O(^ATXAX("B","BGP BNI CPTS",0)),6,"CT")
I $P(Y,U) Q 1_U_$P(Y,U,2)_U_"CPT "_$P(Y,U,3)_U_2
K BGPG
S Y="BGPG(",BGPDEP=""
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT($$FMADD^XLFDT(BD,7)) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G BNIMH
S (X,D,E)=0,%="",T="" F S X=$O(BGPG(X)) Q:X'=+X D I %]"" Q
.S V=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U,3)
.Q:'V
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="C"
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="T"
.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 T="AOD-BNI"!($P(T,"-")="99408")!($P(T,"-")="99409")!($P(T,"-")="H0050")!($P(T,"-")="G0397")!($P(T,"-")="G0396") S %=1_U_$P(BGPG(X),U)_U_T_U_2
.Q
I %]"" Q %
BNIMH ;
S T="",%="" S E=9999999-BD,D=9999999-($$FMADD^XLFDT(BD,7))-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(%]"") S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(%]"") D
.S Z=$P(^AMHREC(V,0),U,7) I Z S Z=$P(^AMHTSET(Z,0),U,2) Q:Z=1 Q:Z=10 Q:Z=7
.S X=0,%="" F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(%]"") 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 T="AOD-BNI"!($P(T,"-")="99408")!($P(T,"-")="99409")!($P(T,"-")="H0050")!($P(T,"-")="G0397")!($P(T,"-")="G0396") S %=1_U_(9999999-D)_U_T_U_2 Q
.S T=$O(^ATXAX("B","BGP BNI CPTS",0))
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(%]"") D
..Q:'$$ICD^BGP5UTL2($P(+$G(^AMHRPROC(X,0)),U,1),T,1)
..S %=1_U_(9999999-D)_U_"BH CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01)_U_2 Q
..Q
Q %
IPC ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S BGPVALUE=""
I 'BGPACTCL Q ;not active clinical
S BGPVAL=$$PCV(DFN,BGPBDATE,BGPEDATE) ;return #visits^list string
S BGPN1=$P(BGPVAL,U)
I BGPAGEB<18 S BGPN2=BGPN1
I BGPAGEB>17,BGPAGEB<55 S BGPN3=BGPN1
I BGPAGEB>54 S BGPN4=BGPN1
;I BGPCANCE,BGPN1>1 S BGPN5=1
S BGPVALUE="AC"_"|||"_BGPN1_$S(BGPN1'=1:" visits: ",1:" visit: ")_$P(BGPVAL,U,2)
K BGPVAL
Q
;
PCV(P,BDATE,EDATE) ;EP
;all dxs BGP PALLIATIVE CARE DXS and get unique visits count
NEW BGPG,X,Y,E
K BGPG
S Y="BGPG("
S X=P_"^ALL DX [BGP PALLIATIVE CARE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) Q 0 ;no visits
NEW X,C,R
S R="",C=0
S X=0 F S X=$O(BGPG(X)) Q:X'=+X I '$D(X($P(BGPG(X),U,5))) D
.S X($P(BGPG(X),U,5))=""
.S C=C+1
.S R=R_$S(R="":"",1:", ")_$$DATE^BGP5UTL($P($P(^AUPNVSIT($P(BGPG(X),U,5),0),U),"."))
Q C_U_R
BGP5D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
+1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
+2 ;
STI ;EP
+1 DO EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
+2 QUIT
ISTI ;EP
+1 NEW BGPCIN
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN15,BGPN16,BGPN17,BGPN18,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+3 SET BGPVALUE=""
SET BGPDENV=""
+4 KILL BGPYAR,BGPZAR,BGPNUMV
+5 ;no routine to execute
IF $TEXT(EN^BKMSTIDS)=""
SET BGPSTOP=1
QUIT
+6 ; BGPTIME=1 ZW
+7 ;D EN^XBNEW("STI^BGP5D24","DFN;BGPBDATE;BGPEDATE;BGPYAR;BGPZAR")
+8 DO EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
+9 ;no incidences or diagnoses
IF '$DATA(BGPZAR)
SET BGPSTOP=1
QUIT
+10 ;no incidences or diagnoses
IF $PIECE($GET(BGPZAR(0)),U)=0
SET BGPSTOP=1
QUIT
+11 ;TOTAL # OF INCIDENCES
SET (BGPN1,BGPN2)=$PIECE(BGPZAR(0),U,1)
+12 ;TOTAL # SCREENINGS NEEDED
SET BGPD1=$PIECE(BGPZAR(0),U,2)
+13 ;TOTAL # OF SCREENINGS DONE
SET BGPN3=$PIECE(BGPZAR(0),U,3)
+14 ;TOTAL # OF REFUSALS
SET BGPN4=$PIECE(BGPZAR(0),U,4)
+15 ;NEW GROUPED DEN
SET BGPN15=$PIECE(BGPZAR(0),U,5)
+16 ;NEW GROUPED NUM
SET BGPN16=$PIECE(BGPZAR(0),U,6)
+17 ;NEW GROUPED REF
SET BGPN17=$PIECE(BGPZAR(0),U,7)
+18 SET BGPCIN=0
+19 SET X=0
FOR
SET X=$ORDER(BGPZAR(X))
IF X'=+X
QUIT
Begin DoDot:1
+20 SET BGPCIN=BGPCIN+1
+21 IF BGPDENV]""
SET BGPDENV=BGPDENV_"; "
+22 SET BGPNUMV(X)=""
+23 SET I=0
SET C=0
SET BGPHXX=""
FOR
SET I=$ORDER(BGPZAR(X,I))
IF I=""
QUIT
Begin DoDot:2
+24 IF $DATA(BGPZAR(X,I,0))
SET C=C+1
SET BGPDENV=BGPDENV_$SELECT(C=1:BGPCIN_") ",1:", ")_$PIECE(BGPZAR(X,I,0),U,5)
+25 IF $GET(BGPYAR(I,"NUM","HIV"))=1
SET BGPHXX=$ORDER(BGPYAR(I,"NUM","HIV",0))
IF BGPHXX
SET J=$PIECE(BGPYAR(I,"NUM","HIV",BGPHXX),U,2)
IF J'["POV"
SET BGPHXX=""
+26 ;I BGPHXX S BGPN18=1
End DoDot:2
+27 Begin DoDot:2
+28 ;I $G(BGPZAR(X,"CHL"))]"" S Z=$G(BGPZAR(X,"CHL")) S:$P(Z,U) BGPD2=BGPD2+1 S:$P(Z,U,2) BGPN5=BGPN5+1 S:$P(Z,U,3) BGPN6=BGPN6+1 D
+29 ;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"CHL-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;CHL SCREENINGS NEEDED/DONE
+30 ;I $G(BGPZAR(X,"GC"))]"" S Z=$G(BGPZAR(X,"GC")) S:$P(Z,U) BGPD3=BGPD3+1 S:$P(Z,U,2) BGPN7=BGPN7+1 S:$P(Z,U,3) BGPN8=BGPN8+1 D
+31 ;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"GC-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;GON SCREENINGS NEEDED/DONE
+32 IF $GET(BGPZAR(X,"HIV"))]""
SET Z=$GET(BGPZAR(X,"HIV"))
IF $PIECE(Z,U)
SET BGPD4=BGPD4+1
IF $PIECE(Z,U,2)
SET BGPN9=BGPN9+1
IF $PIECE(Z,U,3)
SET BGPN10=BGPN10+1
Begin DoDot:3
+33 IF BGPNUMV(X)]""
SET BGPNUMV(X)=BGPNUMV(X)_", "
+34 SET H=0
SET I=""
IF '($PIECE(Z,U,1)+$PIECE(Z,U,2))
SET H=1
SET I="Contraind Prior DX"
SET BGPN18=1
+35 ;_"; " ;HIV SCREENINGS NEEDED/DONE
SET BGPNUMV(X)=BGPNUMV(X)_"HIV-"_$SELECT($PIECE(Z,U,2):"Y",H:I,1:"N")_$SELECT($PIECE(Z,U,4)]"":" "_$PIECE(Z,U,4),1:"")
End DoDot:3
+36 ;I $G(BGPZAR(X,"SYP"))]"" S Z=$G(BGPZAR(X,"SYP")) S:$P(Z,U) BGPD5=BGPD5+1 S:$P(Z,U,2) BGPN11=BGPN11+1 S:$P(Z,U,3) BGPN12=BGPN12+1 D
+37 ;.S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"SYP-"_$S($P(Z,U,2):"Y",1:"N")_$S($P(Z,U,4)]"":" "_$P(Z,U,4),1:"") ;_"; " ;SYP SCREENINGS NEEDED/DONE
End DoDot:2
+38 ;I H]"" S:BGPNUMV(X)]"" BGPNUMV(X)=BGPNUMV(X)_", " S BGPNUMV(X)=BGPNUMV(X)_"Prior HIV DX (Contraind): "_$$DATE^BGP5UTL(H)
+39 SET BGPVALUE="UP"_$SELECT(BGPACTCL:";AC",1:"")_" Visit "_BGPDENV_"|||"
End DoDot:1
+40 SET BGPCIN=0
SET X=0
FOR
SET X=$ORDER(BGPNUMV(X))
IF X'=+X
QUIT
SET BGPCIN=BGPCIN+1
SET BGPVALUE=BGPVALUE_$SELECT(BGPCIN>1:"; ",1:"")_BGPCIN_") "_$SELECT(BGPNUMV(X)="":"N/A",1:BGPNUMV(X))
+41 QUIT
+42 ;
IASB ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET BGPVALUE=""
+3 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB<15
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB>34
SET BGPSTOP=1
QUIT
+6 ;will return array of all er visits with injury diagnosis fm date^injury dx^screen^positive^text^bni^bni text
KILL BGPERV
+7 DO ERINJ(DFN,BGPBDATE,BGPEDATE,.BGPERV)
+8 ;no injury visits
IF '$GET(BGPERV(0))
SET BGPSTOP=1
QUIT
+9 ;total # of visits
SET BGPD1=BGPERV(0)
+10 IF BGPAGEB>14
IF BGPAGEB<25
SET BGPD2=BGPERV(0)
+11 IF BGPAGEB>24
IF BGPAGEB<35
SET BGPD3=BGPERV(0)
+12 ;SCREEN ON EVERY VISIT?
SET X=0
SET BGPN1=0
FOR
SET X=$ORDER(BGPERV(X))
IF X'=+X
QUIT
IF $PIECE(BGPERV(X),U,4)
SET BGPN1=BGPN1+1
+13 ;positive on at least one
SET X=0
SET BGPN2=0
FOR
SET X=$ORDER(BGPERV(X))
IF X'=+X
QUIT
IF $PIECE(BGPERV(X),U,5)
SET BGPN2=BGPN2+1
+14 IF BGPN2
SET X=0
SET BGPN3=0
FOR
SET X=$ORDER(BGPERV(X))
IF X'=+X
QUIT
Begin DoDot:1
+15 IF $PIECE(BGPERV(X),U,5)
IF $PIECE(BGPERV(X),U,7)
SET BGPN3=BGPN3+1
End DoDot:1
+16 IF BGPN3
SET X=0
FOR
SET X=$ORDER(BGPERV(X))
IF X'=+X
QUIT
IF $PIECE(BGPERV(X),U,5)
IF $PIECE(BGPERV(X),U,10)=1
SET BGPN4=BGPN4+1
IF $PIECE(BGPERV(X),U,10)=2
SET BGPN5=BGPN5+1
+17 SET BGPVALUE="UP"_$SELECT(BGPACTCB:",AC+BH",1:"")
+18 SET V=""
SET X=0
SET D=""
FOR
SET X=$ORDER(BGPERV(X))
IF X'=+X
QUIT
SET D=D_$SELECT(D]"":"; ",1:"")_"ER "_X_") "_$$DATE^BGP5UTL($PIECE(BGPERV(X),U,1))_" POV "_$PIECE(BGPERV(X),U,3)
Begin DoDot:1
+19 ;S V=V_$S(V]"":"; ",1:"")
+20 ;S V=V_"ER Visit "_X_") "
+21 IF '$PIECE(BGPERV(X),U,4)
SET D=D_", SCREEN: None"
QUIT
+22 SET D=D_$SELECT($PIECE(BGPERV(X),U,5):", SCREEN: Pos",1:", SCREEN: Neg/No Res")_" "_$PIECE(BGPERV(X),U,6)
+23 IF '$PIECE(BGPERV(X),U,5)
QUIT
+24 IF '$PIECE(BGPERV(X),U,7)
SET D=D_", BNI: No"
QUIT
+25 SET D=D_", BNI: "_$SELECT($PIECE(BGPERV(X),U,10)=1:$$DATE^BGP5UTL($PIECE(BGPERV(X),U,8))_" Yes ER",1:" Yes Not ER")_" "_$PIECE(BGPERV(X),U,9)
End DoDot:1
+26 SET BGPVALUE=BGPVALUE_"|||"_D
+27 QUIT
+28 ;
ERINJ(P,BDATE,EDATE,BGPRET) ;
+1 ;did patient P have an ER visit with an injury dx?
+2 KILL ^TMP($JOB,"A")
+3 KILL BGPRET
+4 NEW A,G,B,E,D,CNT,T
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET T=$ORDER(^ATXAX("B","BGP INJURY DIAGNOSES",0))
+8 SET E=$ORDER(^ATXAX("B","BGP CAUSE OF INJURY ECODES",0))
+9 SET (X,G,CNT)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 ;ambulatory only
IF $PIECE(^AUPNVSIT(V,0),U,7)'="A"
QUIT
+14 IF $$CLINIC^APCLV(V,"C")'=30
QUIT
+15 ;no Contract health
IF "CV"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+16 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+17 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+18 ;check diagnosis for injury
+19 SET (G,A)=0
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+20 SET B=$PIECE($GET(^AUPNVPOV(A,0)),U)
+21 IF $$ICD^BGP5UTL2(B,T,9)
SET CNT=CNT+1
SET BGPRET(CNT)=D_U_V_U_$PIECE($$ICDDX^BGP5UTL2(B),U,2)
SET G=1
SET $PIECE(BGPRET(CNT),U,4)=$$ERAS(V)
SET $PIECE(BGPRET(CNT),U,7)=$$BNI(P,V,BGPRET(CNT))
QUIT
+22 SET B=$PIECE($GET(^AUPNVPOV(A,0)),U,9)
+23 IF $$ICD^BGP5UTL2(B,E,9)
SET CNT=CNT+1
SET BGPRET(CNT)=D_U_V_U_$PIECE($$ICDDX^BGP5UTL2(B),U,2)
SET G=1
SET $PIECE(BGPRET(CNT),U,4)=$$ERAS(V)
SET $PIECE(BGPRET(CNT),U,7)=$$BNI(P,V,BGPRET(CNT))
QUIT
End DoDot:2
End DoDot:1
+24 SET BGPRET(0)=CNT
+25 QUIT
+26 ;
ERAS(V) ;was there screening on this visit V and was it positive
+1 IF $GET(V)=""
QUIT ""
+2 NEW X,Y,Z,A,T
+3 SET X=0
SET Z=""
FOR
SET X=$ORDER(^AUPNVXAM("AD",V,X))
IF X'=+X!($PIECE(Z,U,2))
QUIT
IF $PIECE(^AUTTEXAM(+$GET(^AUPNVXAM(X,0)),0),U,2)=35
Begin DoDot:1
+4 SET Y=$PIECE(^AUPNVXAM(X,0),U,4)
+5 SET Z=1_U_$SELECT(Y="PO":"1^Ex 35",1:"0^Ex 35")
+6 QUIT
End DoDot:1
+7 IF $PIECE(Z,U)
IF $PIECE(Z,U,2)
QUIT Z
+8 ;check measurements
+9 SET X=0
SET Z=""
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X!($PIECE(Z,U,2))
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+11 IF $PIECE(^AUTTMSR(+$GET(^AUPNVMSR(X,0)),0),U,1)="AUDT"
Begin DoDot:2
+12 SET Y=$PIECE(^AUPNVMSR(X,0),U,4)
+13 SET Z=1_U_$SELECT(Y>7.99999:"1^MSR AUDT",1:"0^MSR AUDT")
End DoDot:2
QUIT
+14 IF $PIECE(^AUTTMSR(+$GET(^AUPNVMSR(X,0)),0),U,1)="AUDC"
Begin DoDot:2
+15 SET Y=$PIECE(^AUPNVMSR(X,0),U,4)
+16 IF $PIECE(^DPT(P,0),U,2)="M"
SET Z=1_U_$SELECT(Y]""&(Y'<4):"1^MSR AUDC",1:"0^MSR AUDC")
+17 IF $PIECE(^DPT(P,0),U,2)="F"
SET Z=1_U_$SELECT(Y]""&(Y'<3):"1^MSR AUDC",1:"0^MSR AUDC")
End DoDot:2
+18 IF $PIECE(^AUTTMSR(+$GET(^AUPNVMSR(X,0)),0),U,1)="CRFT"
Begin DoDot:2
+19 SET Y=$PIECE(^AUPNVMSR(X,0),U,4)
+20 SET Z=1_U_$SELECT(Y=2!(Y=3)!(Y=4)!(Y=5)!(Y=6):"1^MSR CRFT",1:"0^MSR CRFT")
End DoDot:2
QUIT
End DoDot:1
+21 IF $PIECE(Z,U)
IF $PIECE(Z,U,2)
QUIT Z
+22 SET X=0
FOR
SET X=$ORDER(^AUPNVHF("AD",V,X))
IF X'=+X!($PIECE(Z,U,2))
QUIT
IF $PIECE(^AUTTHF($PIECE(^AUTTHF(+$GET(^AUPNVHF(X,0)),0),U,3),0),U)["ALCOHOL"
Begin DoDot:1
+23 SET Y=$PIECE(^AUTTHF(+$GET(^AUPNVHF(X,0)),0),U)
+24 SET A=""
IF Y["CAGE"
IF Y'[0
SET A=1
+25 SET Z=1_U_A_U_Y
End DoDot:1
+26 IF Z]""
IF $PIECE(Z,U,2)
QUIT Z
+27 ;screening CPT
+28 SET T=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!($PIECE(Z,U,2))
QUIT
Begin DoDot:1
+30 IF $$ICD^BGP5UTL2($PIECE(+$GET(^AUPNVCPT(X,0)),U,1),T,1)
Begin DoDot:2
+31 SET Y=$$VAL^XBDIQ1(9000010.18,X,.01)
+32 SET Z=1_U_U_"CPT "_Y
+33 IF Y="G0396"!(Y="G0397")!(Y=99408)!(Y=99409)
SET $PIECE(Z,U,2)=1
End DoDot:2
+34 QUIT
End DoDot:1
+35 IF Z]""
QUIT Z
+36 ;screening pov
+37 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!($PIECE(Z,U,2))
QUIT
IF $$ICD^BGP5UTL2(+^AUPNVPOV(X,0),$ORDER(^ATXAX("B","BGP SCREEN FOR ALCOHOLISM DX",0)),9)
Begin DoDot:1
+38 SET Z=1_U_U_"POV "_$$VAL^XBDIQ1(9000010.07,X,.01)
+39 QUIT
End DoDot:1
+40 QUIT Z
+41 ;
BNI(P,V,E) ;
+1 ;not a positive screen
IF $PIECE(E,U,4)'=1
QUIT ""
+2 NEW D,X,%
+3 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET %=""
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVPED("AD",V,X))
IF X'=+X!(%]"")
QUIT
SET Z=$PIECE(^AUTTEDT(+$GET(^AUPNVPED(X,0)),0),U,2)
IF Z="AOD-BNI"!($PIECE(Z,"-")="99408")!($PIECE(Z,"-")="99409")!($PIECE(Z,"-")="H0050")!($PIECE(Z,"-")="G0397")!($PIECE(Z,"-")="G0396")
SET %=1_U_D_U_Z_U_1
+5 IF %]""
QUIT %
+6 SET T=$ORDER(^ATXAX("B","BGP BNI CPTS",0))
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+8 IF '$$ICD^BGP5UTL2($PIECE(+$GET(^AUPNVCPT(X,0)),U,1),T,1)
QUIT
+9 SET %=1_U_D_U_"CPT "_$$VAL^XBDIQ1(9000010.18,X,.01)_U_1
End DoDot:1
+10 IF %]""
QUIT %
+11 SET X=$$BNII(P,D)
+12 QUIT X
BNII(P,BD) ;
+1 NEW Y,BGPG,E,X,T,%,D
+2 SET Y=$$CPT^BGP5DU(P,BD,$$FMADD^XLFDT(BD,7),$ORDER(^ATXAX("B","BGP BNI CPTS",0)),6,"CT")
+3 IF $PIECE(Y,U)
QUIT 1_U_$PIECE(Y,U,2)_U_"CPT "_$PIECE(Y,U,3)_U_2
+4 KILL BGPG
+5 SET Y="BGPG("
SET BGPDEP=""
+6 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT($$FMADD^XLFDT(BD,7))
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPG(1))
GOTO BNIMH
+8 SET (X,D,E)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET V=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U,3)
+10 IF 'V
QUIT
+11 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+12 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+13 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)
+14 IF 'T
QUIT
+15 IF '$DATA(^AUTTEDT(T,0))
QUIT
+16 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+17 IF T="AOD-BNI"!($PIECE(T,"-")="99408")!($PIECE(T,"-")="99409")!($PIECE(T,"-")="H0050")!($PIECE(T,"-")="G0397")!($PIECE(T,"-")="G0396")
SET %=1_U_$PIECE(BGPG(X),U)_U_T_U_2
+18 QUIT
End DoDot:1
IF %]""
QUIT
+19 IF %]""
QUIT %
BNIMH ;
+1 SET T=""
SET %=""
SET E=9999999-BD
SET D=9999999-($$FMADD^XLFDT(BD,7))-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)!(%]"")
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V!(%]"")
QUIT
Begin DoDot:1
+2 SET Z=$PIECE(^AMHREC(V,0),U,7)
IF Z
SET Z=$PIECE(^AMHTSET(Z,0),U,2)
IF Z=1
QUIT
IF Z=10
QUIT
IF Z=7
QUIT
+3 SET X=0
SET %=""
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X!(%]"")
QUIT
SET T=$PIECE($GET(^AMHREDU(X,0)),U)
Begin DoDot:2
+4 IF 'T
QUIT
+5 IF '$DATA(^AUTTEDT(T,0))
QUIT
+6 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+7 IF T="AOD-BNI"!($PIECE(T,"-")="99408")!($PIECE(T,"-")="99409")!($PIECE(T,"-")="H0050")!($PIECE(T,"-")="G0397")!($PIECE(T,"-")="G0396")
SET %=1_U_(9999999-D)_U_T_U_2
QUIT
End DoDot:2
+8 SET T=$ORDER(^ATXAX("B","BGP BNI CPTS",0))
+9 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:2
+10 IF '$$ICD^BGP5UTL2($PIECE(+$GET(^AMHRPROC(X,0)),U,1),T,1)
QUIT
+11 SET %=1_U_(9999999-D)_U_"BH CPT: "_$$VAL^XBDIQ1(9002011.04,X,.01)_U_2
QUIT
+12 QUIT
End DoDot:2
End DoDot:1
+13 QUIT %
IPC ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET BGPVALUE=""
+3 ;not active clinical
IF 'BGPACTCL
QUIT
+4 ;return #visits^list string
SET BGPVAL=$$PCV(DFN,BGPBDATE,BGPEDATE)
+5 SET BGPN1=$PIECE(BGPVAL,U)
+6 IF BGPAGEB<18
SET BGPN2=BGPN1
+7 IF BGPAGEB>17
IF BGPAGEB<55
SET BGPN3=BGPN1
+8 IF BGPAGEB>54
SET BGPN4=BGPN1
+9 ;I BGPCANCE,BGPN1>1 S BGPN5=1
+10 SET BGPVALUE="AC"_"|||"_BGPN1_$SELECT(BGPN1'=1:" visits: ",1:" visit: ")_$PIECE(BGPVAL,U,2)
+11 KILL BGPVAL
+12 QUIT
+13 ;
PCV(P,BDATE,EDATE) ;EP
+1 ;all dxs BGP PALLIATIVE CARE DXS and get unique visits count
+2 NEW BGPG,X,Y,E
+3 KILL BGPG
+4 SET Y="BGPG("
+5 SET X=P_"^ALL DX [BGP PALLIATIVE CARE DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+6 ;no visits
IF '$DATA(BGPG(1))
QUIT 0
+7 NEW X,C,R
+8 SET R=""
SET C=0
+9 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
IF '$DATA(X($PIECE(BGPG(X),U,5)))
Begin DoDot:1
+10 SET X($PIECE(BGPG(X),U,5))=""
+11 SET C=C+1
+12 SET R=R_$SELECT(R="":"",1:", ")_$$DATE^BGP5UTL($PIECE($PIECE(^AUPNVSIT($PIECE(BGPG(X),U,5),0),U),"."))
End DoDot:1
+13 QUIT C_U_R
