BGP7D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
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=""
I 'BGPACTCL S BGPSTOP=1 Q ;only active clinical pts
S BGPZAR=$$KEYSTI^BGP7D24A(DFN,BGPBDATE,BGPEDATE)
I '$P(BGPZAR,U,1) S BGPSTOP=1 Q ;no incidences or diagnoses
I $P($G(BGPZAR),U)=0 S BGPSTOP=1 Q ;no incidences or diagnoses
S (BGPN1,BGPN2)=$P(BGPZAR,U,1) ;TOTAL # OF INCIDENCES
S BGPD1=$P(BGPZAR,U,2) ;TOTAL # SCREENINGS NEEDED
S BGPN3=$P(BGPZAR,U,3) ;TOTAL # OF SCREENINGS DONE
S BGPN4=$P(BGPZAR,U,4) ;TOTAL # OF REFUSALS
S BGPVALUE="UP"_$S(BGPACTCL:";AC",1:"")_" "_$P(BGPZAR,U,5)_"|||"_$P(BGPZAR,U,6)
;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:10 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 BGPAGEB<9 S BGPSTOP=1 Q
I BGPAGEB>75 S BGPSTOP=1 Q
I BGPACTCB D
.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
I BGPACTUP S BGPD10=1
K BGPALL
D ALSCRN^BGP7D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
I $D(BGPALL) S BGPN1=1
;if screened, is any screen positive
I BGPD10,'BGPD1,'BGPN1 S BGPSTOP=1 Q ;UP 9-75, NOT AC+BH, NOT SCREENED
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
I BGPD10,'BGPD1,'BGPN2 S BGPSTOP=1 Q ;UP 9-75
;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=$S(BGPD10&(BGPN2):"UPPOS",1:"") S:BGPD1 BGPVALUE=BGPVALUE_$S(BGPVALUE]"":",AC+BH",1:"AC+BH") S BGPVALUE=BGPVALUE_"|||"
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^BGP7UTL($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^BGP7UTL2(I,BGPCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP7UTL(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^BGP7UTL2(I,BGPCT,1)
PCS ..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP7UTL(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^BGP7UTL2(I,BGPCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP7UTL(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^BGP7UTL2($P(T,U,1),BGPCT,1)
BHS ..S BGPSC=BGPSC+1
..S BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP7UTL(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^BGP7UTL($P($P(^AUPNVSIT($P(BGPG(X),U,5),0),U),"."))
Q C_U_R
BGP7D24 ; IHS/CMI/LAB - STI MEASURE 18 Oct 2009 8:37 AM 03 Jul 2010 7:56 AM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
STI ;EP
+1 ;D EN^BKMSTIDS(DFN,BGPBDATE,BGPEDATE,"KEY",.BGPYAR,.BGPZAR)
+2 ;Q
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 ;only active clinical pts
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPZAR=$$KEYSTI^BGP7D24A(DFN,BGPBDATE,BGPEDATE)
+6 ;no incidences or diagnoses
IF '$PIECE(BGPZAR,U,1)
SET BGPSTOP=1
QUIT
+7 ;no incidences or diagnoses
IF $PIECE($GET(BGPZAR),U)=0
SET BGPSTOP=1
QUIT
+8 ;TOTAL # OF INCIDENCES
SET (BGPN1,BGPN2)=$PIECE(BGPZAR,U,1)
+9 ;TOTAL # SCREENINGS NEEDED
SET BGPD1=$PIECE(BGPZAR,U,2)
+10 ;TOTAL # OF SCREENINGS DONE
SET BGPN3=$PIECE(BGPZAR,U,3)
+11 ;TOTAL # OF REFUSALS
SET BGPN4=$PIECE(BGPZAR,U,4)
+12 SET BGPVALUE="UP"_$SELECT(BGPACTCL:";AC",1:"")_" "_$PIECE(BGPZAR,U,5)_"|||"_$PIECE(BGPZAR,U,6)
+13 ;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))
+14 QUIT
+15 ;
SBI ;EP
+1 ;9 denominators
FOR X=1:1:10
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 BGPAGEB<9
SET BGPSTOP=1
QUIT
+6 IF BGPAGEB>75
SET BGPSTOP=1
QUIT
+7 IF BGPACTCB
Begin DoDot:1
+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
End DoDot:1
+17 IF BGPACTUP
SET BGPD10=1
+18 KILL BGPALL
+19 DO ALSCRN^BGP7D55(DFN,BGPBDATE,BGPEDATE,.BGPALL,1)
+20 IF $DATA(BGPALL)
SET BGPN1=1
+21 ;if screened, is any screen positive
+22 ;UP 9-75, NOT AC+BH, NOT SCREENED
IF BGPD10
IF 'BGPD1
IF 'BGPN1
SET BGPSTOP=1
QUIT
+23 SET BGPSCRC=""
SET BGPSCRD=""
+24 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)
+25 IF BGPSCRC]""
SET BGPN2=1
+26 ;UP 9-75
IF BGPD10
IF 'BGPD1
IF 'BGPN2
SET BGPSTOP=1
QUIT
+27 ;if no positive then take latest one
+28 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)
+29 ;NO SCREENING SO DON'T BOTHER WITH NUMERATOR BNI
IF BGPSCRD=""
GOTO SETL
+30 ;GET BNI DATE/ITEM/
+31 KILL BGPABNI
+32 SET BGPBNID=""
+33 DO BNI(DFN,BGPSCRD,$$FMADD^XLFDT(BGPSCRD,7),.BGPABNI)
+34 ;NO BNIS
IF '$DATA(BGPABNI)
GOTO TRT
+35 ;GET 1ST ONE
+36 SET D=$ORDER(BGPABNI(0))
IF D
SET Y=$ORDER(BGPABNI(D,0))
SET BGPBNID=BGPABNI(D,Y)
+37 SET BGPN3=1
+38 SET X=$PIECE(BGPBNID,U,5)
+39 IF X=0
SET BGPN4=1
+40 IF X>0
IF X<4
SET BGPN5=1
+41 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=$SELECT(BGPD10&(BGPN2):"UPPOS",1:"")
IF BGPD1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":",AC+BH",1:"AC+BH")
SET BGPVALUE=BGPVALUE_"|||"
+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^BGP7UTL($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^BGP7UTL2(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^BGP7UTL(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^BGP7UTL2(I,BGPCT,1)
QUIT
PCS SET BGPSC=BGPSC+1
+1 SET BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP7UTL(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^BGP7UTL2(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^BGP7UTL(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^BGP7UTL2($PIECE(T,U,1),BGPCT,1)
QUIT
BHS SET BGPSC=BGPSC+1
+1 SET BGPABNI(BGPVD,BGPSC)=1_"^PT ED "_T_"^"_$$DATE^BGP7UTL(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^BGP7UTL($PIECE($PIECE(^AUPNVSIT($PIECE(BGPG(X),U,5),0),U),"."))
End DoDot:1
+13 QUIT C_U_R
