BGP0DPE2.m

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