BGP6D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
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^BGP6D24","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^BGP6UTL(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
;
SBI ;EP
F X=1:1:9 S Y="BGPD"_X S @Y="" ;9 denominators
F X=1:1:7 S Y="BGPN"_X S @Y="" ;7 numerators
S BGPVALUE=""
I 'BGPACTUP S BGPSTOP=1 Q
I 'BGPACTCB S BGPSTOP=1 Q
I BGPAGEB<9 S BGPSTOP=1 Q
I BGPAGEB>75 S BGPSTOP=1 Q
S BGPD1=1
I BGPAGEB>8,BGPAGEB<13 S BGPD2=1
I BGPAGEB>12,BGPAGEB<19 S BGPD3=1
I BGPAGEB>18,BGPAGEB<25 S BGPD4=1
I BGPAGEB>24,BGPAGEB<35 S BGPD5=1
I BGPAGEB>34,BGPAGEB<45 S BGPD6=1
I BGPAGEB>44,BGPAGEB<55 S BGPD7=1
I BGPAGEB>54,BGPAGEB<65 S BGPD8=1
I BGPAGEB>64 S BGPD9=1
K BGPALL
D ALSCRN^BGP6D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
I $D(BGPALL) S BGPN1=1
;if screened, is any screen positive
S BGPSCRC="",BGPSCRD=""
S D=0 F S D=$O(BGPALL(D)) Q:D'=+D!(BGPSCRC]"") S Y=0 F S Y=$O(BGPALL(D,Y)) Q:Y'=+Y!(BGPSCRC]"") I $P(BGPALL(D,Y),U,5) S BGPSCRC=BGPALL(D,Y),BGPSCRD=$P(BGPALL(D,Y),U,4)
I BGPSCRC]"" S BGPN2=1
;if no positive then take latest one
I BGPSCRC="" S D=$O(BGPALL(0)) I D S Y=$O(BGPALL(D,0)) S BGPSCRC=BGPALL(D,Y),BGPSCRD=$P(BGPALL(D,Y),U,4)
I BGPSCRD="" G SETL ;NO SCREENING SO DON'T BOTHER WITH NUMERATOR BNI
;GET BNI DATE/ITEM/
K BGPABNI
S BGPBNID=""
D BNI(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7),.BGPABNI)
I '$D(BGPABNI) G TRT ;NO BNIS
;GET 1ST ONE
S D=$O(BGPABNI(0)) I D S Y=$O(BGPABNI(D,0)) S BGPBNID=BGPABNI(D,Y)
S BGPN3=1
S X=$P(BGPBNID,U,5)
I X=0 S BGPN4=1
I X>0,X<4 S BGPN5=1
I X>3 S BGPN6=1
TRT S BGPTRT=""
I BGPN2 D
.S BGPTRT=$$TXPTED(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7))
.I BGPTRT S BGPN7=1
SETL ;
S BGPVALUE="AC+BH|||"
I BGPN1 D
.S BGPVALUE=BGPVALUE_"SCREEN: "_$P(BGPSCRC,U,3)_" "_$P(BGPSCRC,U,2)_$S(BGPN2:" result=Pos",1:"")
.S BGPVALUE=BGPVALUE_"; BNI: "_$S(BGPN3:$P(BGPBNID,U,3)_" Yes ["_$P(BGPBNID,U,5)_"]",1:"No")
.S BGPVALUE=BGPVALUE_"; "_$P(BGPTRT,U,2) ;$S(BGPN7:$P(BGPTRT,U,2),1:"No")
X K BGPSCRD,BGPALL,BGPABNI,BGPBNID,BGPSCRC
Q
;
TXPTED(P,BDATE,EDATE) ;
NEW BGPG
K BGPG
S Y="BGPG("
S X=P_"^FIRST EDUC AOD-TX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG) Q 0_U_"REFERRAL: No"
Q 1_U_"REFERRAL: "_$$DATE^BGP6UTL($P(BGPG(1),U))_" Yes"
;
BNI(P,BDATE,EDATE,BGPABNI) ;EP - GET FIRST BNI AVAILABLE ON A VISITS
NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD
K BGPABNI
S BGPSC=0
PCC ;check PCC first
S BGPCT=$O(^ATXAX("B","BGP BNI CPTS",0))
K BGPG
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
S BGPX=0 F S BGPX=$O(BGPG(BGPX)) Q:BGPX'=+BGPX S BGPV=$P(BGPG(BGPX),U,5) D
.Q:$P(^AUPNVSIT(BGPV,0),U,7)'="A" ;IF SBI ONLY AMBULATORY
.S BGPVD=$$VD^APCLV(BGPV)
PCCCPT .;
.S E=0 F S E=$O(^AUPNVCPT("AD",BGPV,E)) Q:E'=+E D
..S I=$P($G(^AUPNVCPT(E,0)),U,1)
..Q:'I
..Q:'$$ICD^BGP6UTL2(I,BGPCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
PCCPTED .;
.S E=0 F S E=$O(^AUPNVPED("AD",BGPV,E)) Q:E'=+E D
..S I=$P($G(^AUPNVPED(E,0)),U,1)
..Q:'I
..S T=$P($G(^AUTTEDT(I,0)),U,2)
..I T="AOD-BNI" G PCS
..Q:$L($P(T,"-",1))'=5
..S I=+$$CODEN^ICPTCOD($P(T,"-",1))
..Q:'$$ICD^BGP6UTL2(I,BGPCT,1)
PCS ..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
BH ;CHECK BH VISITS
S BGPC="",T="",F=""
S E=9999999-BDATE,D=9999999-EDATE-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
BHEX .;
.Q:$$VAL^XBDIQ1(9002011,V,.07)'="OUTPATIENT"
.S BGPVD=9999999-$P(D,".")
BHCPT .;now add in CPT codes
.S X=0 F S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X D
..S I=$P($G(^AMHRPROC(X,0)),U,1)
..Q:'I
..Q:'$$ICD^BGP6UTL2(I,BGPCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
..Q
BHPTED .;
.S X=0 F S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X D
..S I=$P($G(^AMHREDU(X,0)),U,1)
..Q:'I
..S T=$P($G(^AUTTEDT(I,0)),U,2)
..I T="AOD-BNI" G BHS
..Q:$L($P(T,U,1))'=5
..Q:'$$ICD^BGP6UTL2($P(T,U,1),BGPCT,1)
BHS ..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
.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^BGP6UTL($P($P(^AUPNVSIT($P(BGPG(X),U,5),0),U),"."))
Q C_U_R
BGP6D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+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^BGP6D24","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^BGP6UTL(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 ;
SBI ;EP
+1 ;9 denominators
FOR X=1:1:9
SET Y="BGPD"_X
SET @Y=""
+2 ;7 numerators
FOR X=1:1:7
SET Y="BGPN"_X
SET @Y=""
+3 SET BGPVALUE=""
+4 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+5 IF 'BGPACTCB
SET BGPSTOP=1
QUIT
+6 IF BGPAGEB<9
SET BGPSTOP=1
QUIT
+7 IF BGPAGEB>75
SET BGPSTOP=1
QUIT
+8 SET BGPD1=1
+9 IF BGPAGEB>8
IF BGPAGEB<13
SET BGPD2=1
+10 IF BGPAGEB>12
IF BGPAGEB<19
SET BGPD3=1
+11 IF BGPAGEB>18
IF BGPAGEB<25
SET BGPD4=1
+12 IF BGPAGEB>24
IF BGPAGEB<35
SET BGPD5=1
+13 IF BGPAGEB>34
IF BGPAGEB<45
SET BGPD6=1
+14 IF BGPAGEB>44
IF BGPAGEB<55
SET BGPD7=1
+15 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD8=1
+16 IF BGPAGEB>64
SET BGPD9=1
+17 KILL BGPALL
+18 DO ALSCRN^BGP6D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
+19 IF $DATA(BGPALL)
SET BGPN1=1
+20 ;if screened, is any screen positive
+21 SET BGPSCRC=""
SET BGPSCRD=""
+22 SET D=0
FOR
SET D=$ORDER(BGPALL(D))
IF D'=+D!(BGPSCRC]"")
QUIT
SET Y=0
FOR
SET Y=$ORDER(BGPALL(D,Y))
IF Y'=+Y!(BGPSCRC]"")
QUIT
IF $PIECE(BGPALL(D,Y),U,5)
SET BGPSCRC=BGPALL(D,Y)
SET BGPSCRD=$PIECE(BGPALL(D,Y),U,4)
+23 IF BGPSCRC]""
SET BGPN2=1
+24 ;if no positive then take latest one
+25 IF BGPSCRC=""
SET D=$ORDER(BGPALL(0))
IF D
SET Y=$ORDER(BGPALL(D,0))
SET BGPSCRC=BGPALL(D,Y)
SET BGPSCRD=$PIECE(BGPALL(D,Y),U,4)
+26 ;NO SCREENING SO DON'T BOTHER WITH NUMERATOR BNI
IF BGPSCRD=""
GOTO SETL
+27 ;GET BNI DATE/ITEM/
+28 KILL BGPABNI
+29 SET BGPBNID=""
+30 DO BNI(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7),.BGPABNI)
+31 ;NO BNIS
IF '$DATA(BGPABNI)
GOTO TRT
+32 ;GET 1ST ONE
+33 SET D=$ORDER(BGPABNI(0))
IF D
SET Y=$ORDER(BGPABNI(D,0))
SET BGPBNID=BGPABNI(D,Y)
+34 SET BGPN3=1
+35 SET X=$PIECE(BGPBNID,U,5)
+36 IF X=0
SET BGPN4=1
+37 IF X>0
IF X<4
SET BGPN5=1
+38 IF X>3
SET BGPN6=1
TRT SET BGPTRT=""
+1 IF BGPN2
Begin DoDot:1
+2 SET BGPTRT=$$TXPTED(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7))
+3 IF BGPTRT
SET BGPN7=1
End DoDot:1
SETL ;
+1 SET BGPVALUE="AC+BH|||"
+2 IF BGPN1
Begin DoDot:1
+3 SET BGPVALUE=BGPVALUE_"SCREEN: "_$PIECE(BGPSCRC,U,3)_" "_$PIECE(BGPSCRC,U,2)_$SELECT(BGPN2:" result=Pos",1:"")
+4 SET BGPVALUE=BGPVALUE_"; BNI: "_$SELECT(BGPN3:$PIECE(BGPBNID,U,3)_" Yes ["_$PIECE(BGPBNID,U,5)_"]",1:"No")
+5 ;$S(BGPN7:$P(BGPTRT,U,2),1:"No")
SET BGPVALUE=BGPVALUE_"; "_$PIECE(BGPTRT,U,2)
End DoDot:1
X KILL BGPSCRD,BGPALL,BGPABNI,BGPBNID,BGPSCRC
+1 QUIT
+2 ;
TXPTED(P,BDATE,EDATE) ;
+1 NEW BGPG
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^FIRST EDUC AOD-TX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BGPG)
QUIT 0_U_"REFERRAL: No"
+6 QUIT 1_U_"REFERRAL: "_$$DATE^BGP6UTL($PIECE(BGPG(1),U))_" Yes"
+7 ;
BNI(P,BDATE,EDATE,BGPABNI) ;EP - GET FIRST BNI AVAILABLE ON A VISITS
+1 NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD
+2 KILL BGPABNI
+3 SET BGPSC=0
PCC ;check PCC first
+1 SET BGPCT=$ORDER(^ATXAX("B","BGP BNI CPTS",0))
+2 KILL BGPG
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
+4 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPG(BGPX))
IF BGPX'=+BGPX
QUIT
SET BGPV=$PIECE(BGPG(BGPX),U,5)
Begin DoDot:1
+5 ;IF SBI ONLY AMBULATORY
IF $PIECE(^AUPNVSIT(BGPV,0),U,7)'="A"
QUIT
+6 SET BGPVD=$$VD^APCLV(BGPV)
PCCCPT ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",BGPV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVCPT(E,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^BGP6UTL2(I,BGPCT,1)
QUIT
+5 SET J=$PIECE(^ICPT(I,0),U,1)
+6 SET BGPSC=BGPSC+1
+7 SET BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
End DoDot:2
PCCPTED ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVPED("AD",BGPV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVPED(E,0)),U,1)
+3 IF 'I
QUIT
+4 SET T=$PIECE($GET(^AUTTEDT(I,0)),U,2)
+5 IF T="AOD-BNI"
GOTO PCS
+6 IF $LENGTH($PIECE(T,"-",1))'=5
QUIT
+7 SET I=+$$CODEN^ICPTCOD($PIECE(T,"-",1))
+8 IF '$$ICD^BGP6UTL2(I,BGPCT,1)
QUIT
PCS SET BGPSC=BGPSC+1
+1 SET BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
End DoDot:2
End DoDot:1
BH ;CHECK BH VISITS
+1 SET BGPC=""
SET T=""
SET F=""
+2 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
+3 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
BHEX ;
+1 IF $$VAL^XBDIQ1(9002011,V,.07)'="OUTPATIENT"
QUIT
+2 SET BGPVD=9999999-$PIECE(D,".")
BHCPT ;now add in CPT codes
+1 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHRPROC(X,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^BGP6UTL2(I,BGPCT,1)
QUIT
+5 SET J=$PIECE(^ICPT(I,0),U,1)
+6 SET BGPSC=BGPSC+1
+7 SET BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
+8 QUIT
End DoDot:2
BHPTED ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHREDU("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHREDU(X,0)),U,1)
+3 IF 'I
QUIT
+4 SET T=$PIECE($GET(^AUTTEDT(I,0)),U,2)
+5 IF T="AOD-BNI"
GOTO BHS
+6 IF $LENGTH($PIECE(T,U,1))'=5
QUIT
+7 IF '$$ICD^BGP6UTL2($PIECE(T,U,1),BGPCT,1)
QUIT
BHS SET BGPSC=BGPSC+1
+1 SET BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP6UTL(BGPVD)_U_BGPVD_U_$$FMDIFF^XLFDT(BGPVD,BDATE)
End DoDot:2
+2 QUIT
End DoDot:1
+3 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^BGP6UTL($PIECE($PIECE(^AUPNVSIT($PIECE(BGPG(X),U,5),0),U),"."))
End DoDot:1
+13 QUIT C_U_R
