BGP0DPE2 ; IHS/CMI/LAB - calc measures 29 Apr 2009 7:38 PM 14 Nov 2006 5:02 PM ; 09 Jun 2010 5:18 PM
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
5 ;EP
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED,BGPEDPRV S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2010,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X D
.S Y=+$P(BGPALLED(X),U,4)
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW^BGP0DPE1(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.Q:$P(^AUPNVPED(Y,0),U,5)="" ;SKIP IF NO PROVIDER DOCUMENTED
.S P=$P(^AUPNVPED(Y,0),U,5)
.S D=$P($G(^VA(200,P,"PS")),U,5)
.I 'D Q ;no discipline to tally
.S BGPT=$P($G(^DIC(7,D,9999999)),U,1)
.Q:BGPT="" ;not standard
.S BGPT1=$P(^DIC(7,D,0),U,1)
.;I DUZ=5634,BGPTIME=1 S ^LORIPED0(Y)=""
.D S(BGPRPT,BGPGBL,11,10,1) ;add to total # of topics
.I BGPTIME=1 D SET51
.I BGPTIME=2 D SET52
.I BGPTIME=3 D SET53
.;set PROVS For this patient
.S BGPPROVS(BGPT1)=$G(BGPPROVS(BGPT1))+1
.S %=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U,5)
.;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
.;I %="" S %="UNKNOWN"
.I % S BGPEDPRV(%)=""
Q:'$D(BGPPROVS)
S BGPVALUE=""
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
D SETLIST
Q
SET51 ;
I '$D(^BGPPEDCT(BGPRPT,15,0)) S ^BGPPEDCT(BGPRPT,15,0)="^90377.1215A^0^0"
S Z=$O(^BGPPEDCT(BGPRPT,15,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDCT(BGPRPT,15,Z,0),U,3)=$P(^BGPPEDCT(BGPRPT,15,Z,0),U,3)+1
S Z=$P(^BGPPEDCT(BGPRPT,15,0),U,3)+1,$P(^BGPPEDCT(BGPRPT,15,0),U,3)=Z,$P(^BGPPEDCT(BGPRPT,15,0),U,4)=Z
S ^BGPPEDCT(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDCT(BGPRPT,15,"B",BGPT,Z)=""
Q
SET52 ;
I '$D(^BGPPEDPT(BGPRPT,15,0)) S ^BGPPEDPT(BGPRPT,15,0)="^90377.1315A^0^0"
S Z=$O(^BGPPEDPT(BGPRPT,15,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDPT(BGPRPT,15,Z,0),U,3)=$P(^BGPPEDPT(BGPRPT,15,Z,0),U,3)+1
S Z=$P(^BGPPEDPT(BGPRPT,15,0),U,3)+1,$P(^BGPPEDPT(BGPRPT,15,0),U,3)=Z,$P(^BGPPEDPT(BGPRPT,15,0),U,4)=Z
S ^BGPPEDPT(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDPT(BGPRPT,15,"B",BGPT,Z)=""
Q
SET53 ;
I '$D(^BGPPEDBT(BGPRPT,15,0)) S ^BGPPEDBT(BGPRPT,15,0)="^90377.1515A^0^0"
S Z=$O(^BGPPEDBT(BGPRPT,15,"B",BGPT,0)) I Z D Q
.S $P(^BGPPEDBT(BGPRPT,15,Z,0),U,3)=$P(^BGPPEDBT(BGPRPT,15,Z,0),U,3)+1
S Z=$P(^BGPPEDBT(BGPRPT,15,0),U,3)+1,$P(^BGPPEDBT(BGPRPT,15,0),U,3)=Z,$P(^BGPPEDBT(BGPRPT,15,0),U,4)=Z
S ^BGPPEDBT(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
S ^BGPPEDBT(BGPRPT,15,"B",BGPT,Z)=""
Q
6 ;EP
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED,BGPEDPRV S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2010,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X D
.S Y=+$P(BGPALLED(X),U,4)
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW^BGP0DPE1(BGPFYCT,T)
.;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
.D S(BGPRPT,BGPGBL,11,12,1) ;add to total # of topics
.S BGPLEVEL=$P(^AUPNVPED(Y,0),U,6)
.I BGPLEVEL=1 D S(BGPRPT,BGPGBL,11,13,1)
.I BGPLEVEL=2 D S(BGPRPT,BGPGBL,11,14,1)
.I BGPLEVEL=3 D S(BGPRPT,BGPGBL,11,15,1)
.I BGPLEVEL=5 D S(BGPRPT,BGPGBL,11,16,1)
.I BGPLEVEL=4 D S(BGPRPT,BGPGBL,11,17,1)
.I BGPLEVEL="" D S(BGPRPT,BGPGBL,11,18,1)
.;set PROVS For this patient
.I BGPLEVEL="" S BGPLEVEL="BLANK"
.S BGPPROVS(BGPLEVEL)=$G(BGPPROVS(BGPLEVEL))+1
.S %=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U,5)
.;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
.;I %="" S %="UNKNOWN"
.I % S BGPEDPRV(%)=""
Q:'$D(BGPPROVS)
S BGPVALUE=""
S X="" F S X=$O(BGPPROVS(X)) Q:X="" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_$S(X:$$EXTSET^XBFUNC(9000010.16,.06,X),1:"BLANK-NOT RECORDED")_"-"_BGPPROVS(X)
D SETLIST
Q
;
7 ;EP
Q:'$D(^AUPNVPED("AC",DFN)) ;no education so don't bother
K BGPALLED,BGPEDPRV S BGPVALUE=""
K BGPPROVS
S BGPFYCT=$O(^BGPCTRL("B",2010,0))
S Y="BGPALLED("
S X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPALLED(1)) Q
S (X,D,G)=0,%="",T="" F S X=$O(BGPALLED(X)) Q:X'=+X D
.S Y=+$P(BGPALLED(X),U,4)
.S T=$P(^AUPNVPED(+$P(BGPALLED(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I T="" Q
.Q:'$$EDUALLOW^BGP0DPE1(BGPFYCT,T)
.S G=1
.S BGPLEVEL=$P(^AUPNVPED(Y,0),U,13)
.Q:BGPLEVEL=""
.S BGPPROVS(BGPLEVEL)=$G(BGPPROVS(BGPLEVEL))+1 ;count up
.;get provider
.S R="",R=$P(^AUPNVPED(Y,0),U,5) D
..Q:R]""
..S R=$P($G(^AUPNVPED(Y,12)),U,4)
..Q:R]""
..S R=$P($G(^AUPNVPED(Y,12)),U,2)
..Q:R]""
..S R=$$PRIMPROV^APCLV($P(^AUPNVPED(Y,0),U,3),"I")
.I R D
..S D=$$VALI^XBDIQ1(200,R,53.5)
..S D=$S(D:$$VAL^XBDIQ1(7,D,9999999.01),1:"")
..I D="" S D="??"
..S BGPPROVS(BGPLEVEL,"PROVS")=$G(BGPPROVS(BGPLEVEL,"PROVS"))_"; "_$$VAL^XBDIQ1(200,R,.01)_"-"_D
S BGPVALUE=""
I 'G Q ;no allowable topics
D S(BGPRPT,BGPGBL,11,19,1) ;add to total # of patients with a topic
Q:'$D(BGPPROVS)
I $G(BGPPROVS("GS")) D S(BGPRPT,BGPGBL,11,20,1) S BGPVALUE="GS"_$G(BGPPROVS("GS","PROVS"))
I $G(BGPPROVS("GNS")),'$G(BGPPROVS("GS")) D S(BGPRPT,BGPGBL,11,21,1) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GNS"_$G(BGPPROVS("GNS","PROVS"))
I $G(BGPPROVS("GM")) D S(BGPRPT,BGPGBL,11,22,1) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GM"_$G(BGPPROVS("GM","PROVS"))
I $G(BGPPROVS("GNM")),'$G(BGPPROVS("GM")) D S(BGPRPT,BGPGBL,11,23,1) S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":", ",1:"")_"GNM"_$G(BGPPROVS("GNM","PROVS"))
D SETLIST
Q
S(R,G,N,P,V,J) ;
I 'V Q ;no value to add
I $G(J) S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)=V Q
S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)+V
Q
;
SETLIST ;
Q:'$D(BGPLIST(BGPIC))
Q:BGPTIME'=1
I BGPLIST="P",$P(^AUPNPAT(DFN,0),U,14)'=BGPLPRV Q
I BGPLIST="O",'$D(BGPEDPRV(BGPEPRV)) Q
S BGPLIST(BGPIC)=$G(BGPLIST(BGPIC))+1
S ^XTMP("BGP0PE",BGPJ,BGPH,"LIST",BGPIC,$S($P($G(^AUPNPAT(DFN,11)),U,18)]"":$P(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$P(^DPT(DFN,0),U,2),BGPAGEB,DFN)=$G(BGPVALUE)
Q
BGP0DPE2 ; IHS/CMI/LAB - calc measures 29 Apr 2009 7:38 PM 14 Nov 2006 5:02 PM ; 09 Jun 2010 5:18 PM
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
5 ;EP
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED,BGPEDPRV
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2010,0))
+5 SET Y="BGPALLED("
+6 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPALLED(1))
QUIT
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPALLED(X),U,4)
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW^BGP0DPE1(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 ;SKIP IF NO PROVIDER DOCUMENTED
IF $PIECE(^AUPNVPED(Y,0),U,5)=""
QUIT
+18 SET P=$PIECE(^AUPNVPED(Y,0),U,5)
+19 SET D=$PIECE($GET(^VA(200,P,"PS")),U,5)
+20 ;no discipline to tally
IF 'D
QUIT
+21 SET BGPT=$PIECE($GET(^DIC(7,D,9999999)),U,1)
+22 ;not standard
IF BGPT=""
QUIT
+23 SET BGPT1=$PIECE(^DIC(7,D,0),U,1)
+24 ;I DUZ=5634,BGPTIME=1 S ^LORIPED0(Y)=""
+25 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,10,1)
+26 IF BGPTIME=1
DO SET51
+27 IF BGPTIME=2
DO SET52
+28 IF BGPTIME=3
DO SET53
+29 ;set PROVS For this patient
+30 SET BGPPROVS(BGPT1)=$GET(BGPPROVS(BGPT1))+1
+31 SET %=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U,5)
+32 ;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
+33 ;I %="" S %="UNKNOWN"
+34 IF %
SET BGPEDPRV(%)=""
End DoDot:1
+35 IF '$DATA(BGPPROVS)
QUIT
+36 SET BGPVALUE=""
+37 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_X_"-"_BGPPROVS(X)
+38 DO SETLIST
+39 QUIT
SET51 ;
+1 IF '$DATA(^BGPPEDCT(BGPRPT,15,0))
SET ^BGPPEDCT(BGPRPT,15,0)="^90377.1215A^0^0"
+2 SET Z=$ORDER(^BGPPEDCT(BGPRPT,15,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDCT(BGPRPT,15,Z,0),U,3)=$PIECE(^BGPPEDCT(BGPRPT,15,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDCT(BGPRPT,15,0),U,3)+1
SET $PIECE(^BGPPEDCT(BGPRPT,15,0),U,3)=Z
SET $PIECE(^BGPPEDCT(BGPRPT,15,0),U,4)=Z
+5 SET ^BGPPEDCT(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDCT(BGPRPT,15,"B",BGPT,Z)=""
+7 QUIT
SET52 ;
+1 IF '$DATA(^BGPPEDPT(BGPRPT,15,0))
SET ^BGPPEDPT(BGPRPT,15,0)="^90377.1315A^0^0"
+2 SET Z=$ORDER(^BGPPEDPT(BGPRPT,15,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDPT(BGPRPT,15,Z,0),U,3)=$PIECE(^BGPPEDPT(BGPRPT,15,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDPT(BGPRPT,15,0),U,3)+1
SET $PIECE(^BGPPEDPT(BGPRPT,15,0),U,3)=Z
SET $PIECE(^BGPPEDPT(BGPRPT,15,0),U,4)=Z
+5 SET ^BGPPEDPT(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDPT(BGPRPT,15,"B",BGPT,Z)=""
+7 QUIT
SET53 ;
+1 IF '$DATA(^BGPPEDBT(BGPRPT,15,0))
SET ^BGPPEDBT(BGPRPT,15,0)="^90377.1515A^0^0"
+2 SET Z=$ORDER(^BGPPEDBT(BGPRPT,15,"B",BGPT,0))
IF Z
Begin DoDot:1
+3 SET $PIECE(^BGPPEDBT(BGPRPT,15,Z,0),U,3)=$PIECE(^BGPPEDBT(BGPRPT,15,Z,0),U,3)+1
End DoDot:1
QUIT
+4 SET Z=$PIECE(^BGPPEDBT(BGPRPT,15,0),U,3)+1
SET $PIECE(^BGPPEDBT(BGPRPT,15,0),U,3)=Z
SET $PIECE(^BGPPEDBT(BGPRPT,15,0),U,4)=Z
+5 SET ^BGPPEDBT(BGPRPT,15,Z,0)=BGPT_U_BGPT1_U_1
+6 SET ^BGPPEDBT(BGPRPT,15,"B",BGPT,Z)=""
+7 QUIT
6 ;EP
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED,BGPEDPRV
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2010,0))
+5 SET Y="BGPALLED("
+6 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPALLED(1))
QUIT
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPALLED(X),U,4)
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW^BGP0DPE1(BGPFYCT,T)
QUIT
+16 ;Q:'$D(^BGPCTRL(BGPFYCT,62,"B",T)) ;not an official topic per Chris Lamer's spreadsheet
+17 ;add to total # of topics
DO S(BGPRPT,BGPGBL,11,12,1)
+18 SET BGPLEVEL=$PIECE(^AUPNVPED(Y,0),U,6)
+19 IF BGPLEVEL=1
DO S(BGPRPT,BGPGBL,11,13,1)
+20 IF BGPLEVEL=2
DO S(BGPRPT,BGPGBL,11,14,1)
+21 IF BGPLEVEL=3
DO S(BGPRPT,BGPGBL,11,15,1)
+22 IF BGPLEVEL=5
DO S(BGPRPT,BGPGBL,11,16,1)
+23 IF BGPLEVEL=4
DO S(BGPRPT,BGPGBL,11,17,1)
+24 IF BGPLEVEL=""
DO S(BGPRPT,BGPGBL,11,18,1)
+25 ;set PROVS For this patient
+26 IF BGPLEVEL=""
SET BGPLEVEL="BLANK"
+27 SET BGPPROVS(BGPLEVEL)=$GET(BGPPROVS(BGPLEVEL))+1
+28 SET %=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U,5)
+29 ;I %="" S %=$P($G(^AUPNVPED(+$P(BGPALLED(X),U,4),12)),U,4)
+30 ;I %="" S %="UNKNOWN"
+31 IF %
SET BGPEDPRV(%)=""
End DoDot:1
+32 IF '$DATA(BGPPROVS)
QUIT
+33 SET BGPVALUE=""
+34 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_$SELECT(X:$$EXTSET^XBFUNC(9000010.16,.06,X),1:"BLANK-NOT RECORDED")_"-"_BGPPROVS(X)
+35 DO SETLIST
+36 QUIT
+37 ;
7 ;EP
+1 ;no education so don't bother
IF '$DATA(^AUPNVPED("AC",DFN))
QUIT
+2 KILL BGPALLED,BGPEDPRV
SET BGPVALUE=""
+3 KILL BGPPROVS
+4 SET BGPFYCT=$ORDER(^BGPCTRL("B",2010,0))
+5 SET Y="BGPALLED("
+6 SET X=DFN_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BGPBDATE)_"-"_$$FMTE^XLFDT(BGPEDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF '$DATA(BGPALLED(1))
QUIT
+8 SET (X,D,G)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BGPALLED(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BGPALLED(X),U,4)
+10 SET T=$PIECE(^AUPNVPED(+$PIECE(BGPALLED(X),U,4),0),U)
+11 IF 'T
QUIT
+12 IF '$DATA(^AUTTEDT(T,0))
QUIT
+13 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+14 IF T=""
QUIT
+15 IF '$$EDUALLOW^BGP0DPE1(BGPFYCT,T)
QUIT
+16 SET G=1
+17 SET BGPLEVEL=$PIECE(^AUPNVPED(Y,0),U,13)
+18 IF BGPLEVEL=""
QUIT
+19 ;count up
SET BGPPROVS(BGPLEVEL)=$GET(BGPPROVS(BGPLEVEL))+1
+20 ;get provider
+21 SET R=""
SET R=$PIECE(^AUPNVPED(Y,0),U,5)
Begin DoDot:2
+22 IF R]""
QUIT
+23 SET R=$PIECE($GET(^AUPNVPED(Y,12)),U,4)
+24 IF R]""
QUIT
+25 SET R=$PIECE($GET(^AUPNVPED(Y,12)),U,2)
+26 IF R]""
QUIT
+27 SET R=$$PRIMPROV^APCLV($PIECE(^AUPNVPED(Y,0),U,3),"I")
End DoDot:2
+28 IF R
Begin DoDot:2
+29 SET D=$$VALI^XBDIQ1(200,R,53.5)
+30 SET D=$SELECT(D:$$VAL^XBDIQ1(7,D,9999999.01),1:"")
+31 IF D=""
SET D="??"
+32 SET BGPPROVS(BGPLEVEL,"PROVS")=$GET(BGPPROVS(BGPLEVEL,"PROVS"))_"; "_$$VAL^XBDIQ1(200,R,.01)_"-"_D
End DoDot:2
End DoDot:1
+33 SET BGPVALUE=""
+34 ;no allowable topics
IF 'G
QUIT
+35 ;add to total # of patients with a topic
DO S(BGPRPT,BGPGBL,11,19,1)
+36 IF '$DATA(BGPPROVS)
QUIT
+37 IF $GET(BGPPROVS("GS"))
DO S(BGPRPT,BGPGBL,11,20,1)
SET BGPVALUE="GS"_$GET(BGPPROVS("GS","PROVS"))
+38 IF $GET(BGPPROVS("GNS"))
IF '$GET(BGPPROVS("GS"))
DO S(BGPRPT,BGPGBL,11,21,1)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":", ",1:"")_"GNS"_$GET(BGPPROVS("GNS","PROVS"))
+39 IF $GET(BGPPROVS("GM"))
DO S(BGPRPT,BGPGBL,11,22,1)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":", ",1:"")_"GM"_$GET(BGPPROVS("GM","PROVS"))
+40 IF $GET(BGPPROVS("GNM"))
IF '$GET(BGPPROVS("GM"))
DO S(BGPRPT,BGPGBL,11,23,1)
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":", ",1:"")_"GNM"_$GET(BGPPROVS("GNM","PROVS"))
+41 DO SETLIST
+42 QUIT
S(R,G,N,P,V,J) ;
+1 ;no value to add
IF 'V
QUIT
+2 IF $GET(J)
SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)=V
QUIT
+3 SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)+V
+4 QUIT
+5 ;
SETLIST ;
+1 IF '$DATA(BGPLIST(BGPIC))
QUIT
+2 IF BGPTIME'=1
QUIT
+3 IF BGPLIST="P"
IF $PIECE(^AUPNPAT(DFN,0),U,14)'=BGPLPRV
QUIT
+4 IF BGPLIST="O"
IF '$DATA(BGPEDPRV(BGPEPRV))
QUIT
+5 SET BGPLIST(BGPIC)=$GET(BGPLIST(BGPIC))+1
+6 SET ^XTMP("BGP0PE",BGPJ,BGPH,"LIST",BGPIC,$SELECT($PIECE($GET(^AUPNPAT(DFN,11)),U,18)]"":$PIECE(^AUPNPAT(DFN,11),U,18),1:"UNKNOWN"),$PIECE(^DPT(DFN,0),U,2),BGPAGEB,DFN)=$GET(BGPVALUE)
+7 QUIT
