BGP0D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2008 8:37 AM 03 Jul 2009 7:56 AM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
ISTI ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,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
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 X=0 F S X=$O(BGPZAR(X)) Q:X'=+X D
.S BGPNUMV(X)=""
.S I=0,C=0,H="" 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:X_") ",1:"")_$P(BGPZAR(X,I,0),U,5)_"; "
..I $G(BGPYAR(I,"NUM","HIV"))=1 S H=$O(BGPYAR(I,"NUM","HIV",0)) I H S J=$P(BGPYAR(I,"NUM","HIV",H),U,2) I J'["POV" S H=""
.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)_"CHL-"_$S($P(Z,U,2):"Y",1:"N")_" "_$P(Z,U,4)_"; " ;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)_"GC-"_$S($P(Z,U,2):"Y",1:"N")_" "_$P(Z,U,4)_"; " ;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)_"HIV-"_$S($P(Z,U,2):"Y",1:"N")_" "_$P(Z,U,4)_"; " ;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)_"SYP-"_$S($P(Z,U,2):"Y",1:"N")_" "_$P(Z,U,4)_"; " ;SYP SCREENINGS NEEDED/DONE
.I H]"" S BGPNUMV(X)=BGPNUMV(X)_"Prior HIV DX (Contraind): "_$$DATE^BGP0UTL(H)
.S BGPVALUE="UP"_$S(BGPACTCL:";AC",1:"")_" "_BGPDENV_"|||"
S X=0 F S X=$O(BGPNUMV(X)) Q:X'=+X S BGPVALUE=BGPVALUE_X_") "_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(BGPACTCL:";AC",1:"")
S V="",X=0,D="" F S X=$O(BGPERV(X)) Q:X'=+X S D=D_$S(D]"":"; ",1:"")_"ER Visit "_X_") "_$$DATE^BGP0UTL($P(BGPERV(X),U,1))_" ["_$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 V=V_"No Scrn" Q
.S V=V_$S($P(BGPERV(X),U,5):"Pos",1:"Neg/No Res")_" Scrn: "_$P(BGPERV(X),U,6)
.I '$P(BGPERV(X),U,5) Q
.I '$P(BGPERV(X),U,7) S V=V_", No BNI" Q
.S V=V_", BNI "_$S($P(BGPERV(X),U,10)=1:"at ER",1:"in 7")_": "_$$DATE^BGP0UTL($P(BGPERV(X),U,8))_" "_$P(BGPERV(X),U,9)
S BGPVALUE=BGPVALUE_" "_D_"|||"_V
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)=""
.I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.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^ATXCHK(B,T,9) S CNT=CNT+1,BGPRET(CNT)=D_U_V_U_$P($$ICDDX^ICDCODE(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^ATXCHK(B,E,9) S CNT=CNT+1,BGPRET(CNT)=D_U_V_U_$P($$ICDDX^ICDCODE(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^EXAM 35",1:"0^EXAM 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^ATXCHK($P(+$G(^AUPNVCPT(X,0)),U,1),T,1) D
..S Y=$$VAL^XBDIQ1(9000010.18,X,.01)
..S Z=1_U_U_"screening 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 $P($$ICDDX^ICDCODE(+$G(^AUPNVPOV(X,0))),U,2)="V79.1" D
.S Z=1_U_U_"screening POV V79.1"
.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!(%]"") I $P(^AUTTEDT(+$G(^AUPNVPED(X,0)),0),U,2)="AOD-INJ" S %=1_U_D_U_"AOD-INJ"_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^ATXCHK($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^BGP0DU(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-INJ" S %=1_U_$P(BGPG(X),U)_U_"AOD-INJ"_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-INJ" S %=1_U_(9999999-D)_U_"AOD-INJ"_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^ATXCHK($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)=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
S BGPVALUE="AC|||"_BGPN1_$S(BGPN1'=1:" visits: ",1:" visit: ")_$P(BGPVAL,U,2)
K BGPVAL
Q
;
PCV(P,BDATE,EDATE) ;EP
;all dxs V66.7 and get unique visits count
K BGPG
S Y="BGPG("
S X=P_"^ALL DX V66.7;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^BGP0UTL($P($P(^AUPNVSIT($P(BGPG(X),U,5),0),U),"."))
Q C_U_R
;
BGP0D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2008 8:37 AM 03 Jul 2009 7:56 AM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
ISTI ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET BGPVALUE=""
SET BGPDENV=""
+3 KILL BGPYAR,BGPZAR,BGPNUMV
+4 ;no routine to execute
IF $TEXT(EN^BKMSTIDS)=""
SET BGPSTOP=1
QUIT
+5 DO EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
+6 ;no incidences or diagnoses
IF '$DATA(BGPZAR)
SET BGPSTOP=1
QUIT
+7 ;no incidences or diagnoses
IF $PIECE($GET(BGPZAR(0)),U)=0
SET BGPSTOP=1
QUIT
+8 ;TOTAL # OF INCIDENCES
SET (BGPN1,BGPN2)=$PIECE(BGPZAR(0),U,1)
+9 ;TOTAL # SCREENINGS NEEDED
SET BGPD1=$PIECE(BGPZAR(0),U,2)
+10 ;TOTAL # OF SCREENINGS DONE
SET BGPN3=$PIECE(BGPZAR(0),U,3)
+11 ;TOTAL # OF REFUSALS
SET BGPN4=$PIECE(BGPZAR(0),U,4)
+12 SET X=0
FOR
SET X=$ORDER(BGPZAR(X))
IF X'=+X
QUIT
Begin DoDot:1
+13 SET BGPNUMV(X)=""
+14 SET I=0
SET C=0
SET H=""
FOR
SET I=$ORDER(BGPZAR(X,I))
IF I=""
QUIT
Begin DoDot:2
+15 IF $DATA(BGPZAR(X,I,0))
SET C=C+1
SET BGPDENV=BGPDENV_$SELECT(C=1:X_") ",1:"")_$PIECE(BGPZAR(X,I,0),U,5)_"; "
+16 IF $GET(BGPYAR(I,"NUM","HIV"))=1
SET H=$ORDER(BGPYAR(I,"NUM","HIV",0))
IF H
SET J=$PIECE(BGPYAR(I,"NUM","HIV",H),U,2)
IF J'["POV"
SET H=""
End DoDot:2
+17 Begin DoDot:2
+18 IF $GET(BGPZAR(X,"CHL"))]""
SET Z=$GET(BGPZAR(X,"CHL"))
IF $PIECE(Z,U)
SET BGPD2=BGPD2+1
IF $PIECE(Z,U,2)
SET BGPN5=BGPN5+1
IF $PIECE(Z,U,3)
SET BGPN6=BGPN6+1
Begin DoDot:3
+19 ;CHL SCREENINGS NEEDED/DONE
SET BGPNUMV(X)=BGPNUMV(X)_"CHL-"_$SELECT($PIECE(Z,U,2):"Y",1:"N")_" "_$PIECE(Z,U,4)_"; "
End DoDot:3
+20 IF $GET(BGPZAR(X,"GC"))]""
SET Z=$GET(BGPZAR(X,"GC"))
IF $PIECE(Z,U)
SET BGPD3=BGPD3+1
IF $PIECE(Z,U,2)
SET BGPN7=BGPN7+1
IF $PIECE(Z,U,3)
SET BGPN8=BGPN8+1
Begin DoDot:3
+21 ;GON SCREENINGS NEEDED/DONE
SET BGPNUMV(X)=BGPNUMV(X)_"GC-"_$SELECT($PIECE(Z,U,2):"Y",1:"N")_" "_$PIECE(Z,U,4)_"; "
End DoDot:3
+22 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
+23 ;HIV SCREENINGS NEEDED/DONE
SET BGPNUMV(X)=BGPNUMV(X)_"HIV-"_$SELECT($PIECE(Z,U,2):"Y",1:"N")_" "_$PIECE(Z,U,4)_"; "
End DoDot:3
+24 IF $GET(BGPZAR(X,"SYP"))]""
SET Z=$GET(BGPZAR(X,"SYP"))
IF $PIECE(Z,U)
SET BGPD5=BGPD5+1
IF $PIECE(Z,U,2)
SET BGPN11=BGPN11+1
IF $PIECE(Z,U,3)
SET BGPN12=BGPN12+1
Begin DoDot:3
+25 ;SYP SCREENINGS NEEDED/DONE
SET BGPNUMV(X)=BGPNUMV(X)_"SYP-"_$SELECT($PIECE(Z,U,2):"Y",1:"N")_" "_$PIECE(Z,U,4)_"; "
End DoDot:3
End DoDot:2
+26 IF H]""
SET BGPNUMV(X)=BGPNUMV(X)_"Prior HIV DX (Contraind): "_$$DATE^BGP0UTL(H)
+27 SET BGPVALUE="UP"_$SELECT(BGPACTCL:";AC",1:"")_" "_BGPDENV_"|||"
End DoDot:1
+28 SET X=0
FOR
SET X=$ORDER(BGPNUMV(X))
IF X'=+X
QUIT
SET BGPVALUE=BGPVALUE_X_") "_BGPNUMV(X)_"; "
+29 QUIT
+30 ;
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(BGPACTCL:";AC",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 Visit "_X_") "_$$DATE^BGP0UTL($PIECE(BGPERV(X),U,1))_" ["_$PIECE(BGPERV(X),U,3)_"]"
Begin DoDot:1
+19 SET V=V_$SELECT(V]"":"; ",1:"")
+20 SET V=V_"ER Visit "_X_") "
+21 IF '$PIECE(BGPERV(X),U,4)
SET V=V_"No Scrn"
QUIT
+22 SET V=V_$SELECT($PIECE(BGPERV(X),U,5):"Pos",1:"Neg/No Res")_" Scrn: "_$PIECE(BGPERV(X),U,6)
+23 IF '$PIECE(BGPERV(X),U,5)
QUIT
+24 IF '$PIECE(BGPERV(X),U,7)
SET V=V_", No BNI"
QUIT
+25 SET V=V_", BNI "_$SELECT($PIECE(BGPERV(X),U,10)=1:"at ER",1:"in 7")_": "_$$DATE^BGP0UTL($PIECE(BGPERV(X),U,8))_" "_$PIECE(BGPERV(X),U,9)
End DoDot:1
+26 SET BGPVALUE=BGPVALUE_" "_D_"|||"_V
+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 IF $GET(BGPMFITI)
IF '$DATA(^ATXAX(BGPMFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+18 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+19 ;check diagnosis for injury
+20 SET (G,A)=0
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+21 SET B=$PIECE($GET(^AUPNVPOV(A,0)),U)
+22 IF $$ICD^ATXCHK(B,T,9)
SET CNT=CNT+1
SET BGPRET(CNT)=D_U_V_U_$PIECE($$ICDDX^ICDCODE(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
+23 SET B=$PIECE($GET(^AUPNVPOV(A,0)),U,9)
+24 IF $$ICD^ATXCHK(B,E,9)
SET CNT=CNT+1
SET BGPRET(CNT)=D_U_V_U_$PIECE($$ICDDX^ICDCODE(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
+25 SET BGPRET(0)=CNT
+26 QUIT
+27 ;
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^EXAM 35",1:"0^EXAM 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^ATXCHK($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_"screening 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 $PIECE($$ICDDX^ICDCODE(+$GET(^AUPNVPOV(X,0))),U,2)="V79.1"
Begin DoDot:1
+38 SET Z=1_U_U_"screening POV V79.1"
+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
IF $PIECE(^AUTTEDT(+$GET(^AUPNVPED(X,0)),0),U,2)="AOD-INJ"
SET %=1_U_D_U_"AOD-INJ"_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^ATXCHK($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^BGP0DU(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-INJ"
SET %=1_U_$PIECE(BGPG(X),U)_U_"AOD-INJ"_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-INJ"
SET %=1_U_(9999999-D)_U_"AOD-INJ"_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^ATXCHK($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)=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 SET BGPVALUE="AC|||"_BGPN1_$SELECT(BGPN1'=1:" visits: ",1:" visit: ")_$PIECE(BGPVAL,U,2)
+10 KILL BGPVAL
+11 QUIT
+12 ;
PCV(P,BDATE,EDATE) ;EP
+1 ;all dxs V66.7 and get unique visits count
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^ALL DX V66.7;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 ;no visits
IF '$DATA(BGPG(1))
QUIT 0
+6 NEW X,C,R
+7 SET R=""
SET C=0
+8 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
IF '$DATA(X($PIECE(BGPG(X),U,5)))
Begin DoDot:1
+9 SET X($PIECE(BGPG(X),U,5))=""
+10 SET C=C+1
+11 SET R=R_$SELECT(R="":"",1:"; ")_$$DATE^BGP0UTL($PIECE($PIECE(^AUPNVSIT($PIECE(BGPG(X),U,5),0),U),"."))
End DoDot:1
+12 QUIT C_U_R
+13 ;
