BGPDP30A.m

BGPDP30A ; IHS/CMI/LAB - IHS gpra print ;

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 ;

 ;

I30A ;

 D HEADER^BGPDPH Q:BGPQUIT

 W !,"Indicator 30: Tobacco Prevention and Cessation"

 W !,"Denominator is all active patients ages 18-34."

 W !,"Reduce illness, disability, and death related to tobacco use and",!,"exposure to second hand smoke.",!

 D H1^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPCYD=$P($$V(BGPRPT,19,3),"!",1)+$P($$V(BGPRPT,19,3),"!",2),BGPCYN=$P($$V(BGPRPT,19,5),"!",1)+$P($$V(BGPRPT,19,5),"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPPRD=$P($$V(BGPRPT,49,3),"!",1)+$P($$V(BGPRPT,49,3),"!",2),BGPPRN=$P($$V(BGPRPT,49,5),"!",1)+$P($$V(BGPRPT,49,5),"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGP98D=$P($$V(BGPRPT,89,3),"!",1)+$P($$V(BGPRPT,89,3),"!",2),BGP98N=$P($$V(BGPRPT,89,5),"!",1)+$P($$V(BGPRPT,89,5),"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# Active Users",!?2,"ages 18-34 years",?22,$$C(BGP98D,0,8),?37,$$C(BGPPRD,0,8),?52,$$C(BGPCYD,0,8)

 W !!,"# w/Tobacco Use",!?2," Documented"

 D H2^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPY=$$V(BGPRPT,19,7),BGPCYN=$P(BGPY,"!")+$P(BGPY,"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPY=$$V(BGPRPT,49,7),BGPPRN=$P(BGPY,"!")+$P(BGPY,"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPY=$$V(BGPRPT,89,7),BGP98N=$P(BGPY,"!")+$P(BGPY,"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# documented current",!?3,"tobacco users"

 D H2^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPY=$$V(BGPRPT,19,9),BGPCYN=$P(BGPY,"!")+$P(BGPY,"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPY=$$V(BGPRPT,49,9),BGPPRN=$P(BGPY,"!")+$P(BGPY,"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPY=$$V(BGPRPT,89,9),BGP98N=$P(BGPY,"!")+$P(BGPY,"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# w/Smoker in Home"

 D H2^BGPDPH

I30M ;

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPCYD=$P($$V(BGPRPT,19,3),"!",1),BGPCYN=$P($$V(BGPRPT,19,5),"!",1),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPPRD=$P($$V(BGPRPT,49,3),"!",1),BGPPRN=$P($$V(BGPRPT,49,5),"!",1),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGP98D=$P($$V(BGPRPT,89,3),"!",1),BGP98N=$P($$V(BGPRPT,89,5),"!",1),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# MALE Active Users",!?2,"ages 18-34 years",?22,$$C(BGP98D,0,8),?37,$$C(BGPPRD,0,8),?52,$$C(BGPCYD,0,8)

 W !!,"# w/Tobacco Use",!?2," Documented"

 D H2^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPY=$$V(BGPRPT,19,7),BGPCYN=$P(BGPY,"!"),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPY=$$V(BGPRPT,49,7),BGPPRN=$P(BGPY,"!"),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPY=$$V(BGPRPT,89,7),BGP98N=$P(BGPY,"!"),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# documented current",!?3,"tobacco users"

 D H2^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPY=$$V(BGPRPT,19,9),BGPCYN=$P(BGPY,"!"),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPY=$$V(BGPRPT,49,9),BGPPRN=$P(BGPY,"!"),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPY=$$V(BGPRPT,89,9),BGP98N=$P(BGPY,"!"),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# w/Smoker in Home"

 D H2^BGPDPH

I30F ;

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPCYD=$P($$V(BGPRPT,19,3),"!",2),BGPCYN=$P($$V(BGPRPT,19,5),"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPPRD=$P($$V(BGPRPT,49,3),"!",2),BGPPRN=$P($$V(BGPRPT,49,5),"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGP98D=$P($$V(BGPRPT,89,3),"!",2),BGP98N=$P($$V(BGPRPT,89,5),"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# FEMALE Active Users",!?2,"ages 18-34 years",?22,$$C(BGP98D,0,8),?37,$$C(BGPPRD,0,8),?52,$$C(BGPCYD,0,8)

 W !!,"# w/Tobacco Use",!?2," Documented"

 D H2^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPY=$$V(BGPRPT,19,7),BGPCYN=$P(BGPY,"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPY=$$V(BGPRPT,49,7),BGPPRN=$P(BGPY,"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPY=$$V(BGPRPT,89,7),BGP98N=$P(BGPY,"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# documented current",!?3,"tobacco users"

 D H2^BGPDPH

 I $Y>(IOSL-6) D HEADER^BGPDPH Q:BGPQUIT  W !,"Tobacco Use",!

 S BGPY=$$V(BGPRPT,19,9),BGPCYN=$P(BGPY,"!",2),BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPY=$$V(BGPRPT,49,9),BGPPRN=$P(BGPY,"!",2),BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPY=$$V(BGPRPT,89,9),BGP98N=$P(BGPY,"!",2),BGP98P=$S(BGP98D:((BGP98N/BGP98D)*100),1:"")

 W !!,"# w/Smoker in Home"

 D H2^BGPDPH

 Q

CALC(N,O) ;ENTRY POINT

 ;N is new

 ;O is old

 NEW Z

 I O=0!(N=0)!(O="")!(N="") Q "**"

 NEW X,X2,X3

 S X=N,X2=1,X3=0 D COMMA^%DTC S N=X

 S X=O,X2=1,X3=0 D COMMA^%DTC S O=X

 I +O=0 Q "**"

 S Z=(((N-O)/O)*100),Z=$FN(Z,"+,",1)

 Q Z

H ;write header

 W !?44,"% CHANGE",?62,"% CHANGE",!?44,"FROM BASE YR",?62,"FROM PREV YR"

 Q

LOCW ;

 I $Y>(IOSL-3) D HEADER^BGPDPH Q:BGPQUIT

 W !?3,$P(^BGPD(BGPRPT,0),U,5)

 S X=$P(^BGPD(BGPRPT,0),U,5)

 I X="" W ?11,"?????" Q

 S X=$O(^AUTTLOC("C",X,0))

 I X="" W ?11,"?????" Q

 W ?11,$E($P(^DIC(4,X,0),U),1,20)

 S BGPX=$J($$CALC(BGPCYP,BGP98P),6),$E(BGPX,20)=$J($$CALC(BGPCYP,BGPPRP),6)

 W ?46,BGPX

 Q

V(R,N,P) ;

 NEW Y

 I $G(BGPAREAA),'$G(BGPSUMR) G VA

 Q $P($G(^BGPD(R,N)),U,P)

VA ;

 NEW X,C,V,MT,FT,M,F,B S X=0,C="" F  S X=$O(BGPSUL(X)) Q:X'=+X  D

 .S V=$P($G(^BGPD(X,N)),U,P)

 .I C="" S C=V Q

 .S MT=$P(C,"!"),FT=$P(C,"!",2),M=$P(V,"!"),F=$P(V,"!",2)

 .F B=1:1:6 S $P(MT,"~",B)=$P(MT,"~",B)+$P(M,"~",B)

 .F B=1:1:6 S $P(FT,"~",B)=$P(FT,"~",B)+$P(F,"~",B)

 .S C=MT_"!"_FT

 .Q

 Q C

C(X,X2,X3) ;

 D COMMA^%DTC

 Q X

 ;

BGPDP30A  ; IHS/CMI/LAB - IHS gpra print ;

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;

 +3       ;

I30A      ;

 +1        DO HEADER^BGPDPH

           IF BGPQUIT

               QUIT 

 +2        WRITE !,"Indicator 30: Tobacco Prevention and Cessation"

 +3        WRITE !,"Denominator is all active patients ages 18-34."

 +4        WRITE !,"Reduce illness, disability, and death related to tobacco use and",!,"exposure to second hand smoke.",!

 +5        DO H1^BGPDPH

 +6        IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +7        SET BGPCYD=$PIECE($$V(BGPRPT,19,3),"!",1)+$PIECE($$V(BGPRPT,19,3),"!",2)

           SET BGPCYN=$PIECE($$V(BGPRPT,19,5),"!",1)+$PIECE($$V(BGPRPT,19,5),"!",2)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +8        SET BGPPRD=$PIECE($$V(BGPRPT,49,3),"!",1)+$PIECE($$V(BGPRPT,49,3),"!",2)

           SET BGPPRN=$PIECE($$V(BGPRPT,49,5),"!",1)+$PIECE($$V(BGPRPT,49,5),"!",2)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +9        SET BGP98D=$PIECE($$V(BGPRPT,89,3),"!",1)+$PIECE($$V(BGPRPT,89,3),"!",2)

           SET BGP98N=$PIECE($$V(BGPRPT,89,5),"!",1)+$PIECE($$V(BGPRPT,89,5),"!",2)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +10       WRITE !!,"# Active Users",!?2,"ages 18-34 years",?22,$$C(BGP98D,0,8),?37,$$C(BGPPRD,0,8),?52,$$C(BGPCYD,0,8)

 +11       WRITE !!,"# w/Tobacco Use",!?2," Documented"

 +12       DO H2^BGPDPH

 +13       IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +14       SET BGPY=$$V(BGPRPT,19,7)

           SET BGPCYN=$PIECE(BGPY,"!")+$PIECE(BGPY,"!",2)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +15       SET BGPY=$$V(BGPRPT,49,7)

           SET BGPPRN=$PIECE(BGPY,"!")+$PIECE(BGPY,"!",2)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +16       SET BGPY=$$V(BGPRPT,89,7)

           SET BGP98N=$PIECE(BGPY,"!")+$PIECE(BGPY,"!",2)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +17       WRITE !!,"# documented current",!?3,"tobacco users"

 +18       DO H2^BGPDPH

 +19       IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +20       SET BGPY=$$V(BGPRPT,19,9)

           SET BGPCYN=$PIECE(BGPY,"!")+$PIECE(BGPY,"!",2)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +21       SET BGPY=$$V(BGPRPT,49,9)

           SET BGPPRN=$PIECE(BGPY,"!")+$PIECE(BGPY,"!",2)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +22       SET BGPY=$$V(BGPRPT,89,9)

           SET BGP98N=$PIECE(BGPY,"!")+$PIECE(BGPY,"!",2)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +23       WRITE !!,"# w/Smoker in Home"

 +24       DO H2^BGPDPH

I30M      ;

 +1        IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +2        SET BGPCYD=$PIECE($$V(BGPRPT,19,3),"!",1)

           SET BGPCYN=$PIECE($$V(BGPRPT,19,5),"!",1)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +3        SET BGPPRD=$PIECE($$V(BGPRPT,49,3),"!",1)

           SET BGPPRN=$PIECE($$V(BGPRPT,49,5),"!",1)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +4        SET BGP98D=$PIECE($$V(BGPRPT,89,3),"!",1)

           SET BGP98N=$PIECE($$V(BGPRPT,89,5),"!",1)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +5        WRITE !!,"# MALE Active Users",!?2,"ages 18-34 years",?22,$$C(BGP98D,0,8),?37,$$C(BGPPRD,0,8),?52,$$C(BGPCYD,0,8)

 +6        WRITE !!,"# w/Tobacco Use",!?2," Documented"

 +7        DO H2^BGPDPH

 +8        IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +9        SET BGPY=$$V(BGPRPT,19,7)

           SET BGPCYN=$PIECE(BGPY,"!")

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +10       SET BGPY=$$V(BGPRPT,49,7)

           SET BGPPRN=$PIECE(BGPY,"!")

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +11       SET BGPY=$$V(BGPRPT,89,7)

           SET BGP98N=$PIECE(BGPY,"!")

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +12       WRITE !!,"# documented current",!?3,"tobacco users"

 +13       DO H2^BGPDPH

 +14       IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +15       SET BGPY=$$V(BGPRPT,19,9)

           SET BGPCYN=$PIECE(BGPY,"!")

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +16       SET BGPY=$$V(BGPRPT,49,9)

           SET BGPPRN=$PIECE(BGPY,"!")

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +17       SET BGPY=$$V(BGPRPT,89,9)

           SET BGP98N=$PIECE(BGPY,"!")

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +18       WRITE !!,"# w/Smoker in Home"

 +19       DO H2^BGPDPH

I30F      ;

 +1        IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +2        SET BGPCYD=$PIECE($$V(BGPRPT,19,3),"!",2)

           SET BGPCYN=$PIECE($$V(BGPRPT,19,5),"!",2)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +3        SET BGPPRD=$PIECE($$V(BGPRPT,49,3),"!",2)

           SET BGPPRN=$PIECE($$V(BGPRPT,49,5),"!",2)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +4        SET BGP98D=$PIECE($$V(BGPRPT,89,3),"!",2)

           SET BGP98N=$PIECE($$V(BGPRPT,89,5),"!",2)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +5        WRITE !!,"# FEMALE Active Users",!?2,"ages 18-34 years",?22,$$C(BGP98D,0,8),?37,$$C(BGPPRD,0,8),?52,$$C(BGPCYD,0,8)

 +6        WRITE !!,"# w/Tobacco Use",!?2," Documented"

 +7        DO H2^BGPDPH

 +8        IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +9        SET BGPY=$$V(BGPRPT,19,7)

           SET BGPCYN=$PIECE(BGPY,"!",2)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +10       SET BGPY=$$V(BGPRPT,49,7)

           SET BGPPRN=$PIECE(BGPY,"!",2)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +11       SET BGPY=$$V(BGPRPT,89,7)

           SET BGP98N=$PIECE(BGPY,"!",2)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +12       WRITE !!,"# documented current",!?3,"tobacco users"

 +13       DO H2^BGPDPH

 +14       IF $Y>(IOSL-6)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

               WRITE !,"Tobacco Use",!

 +15       SET BGPY=$$V(BGPRPT,19,9)

           SET BGPCYN=$PIECE(BGPY,"!",2)

           SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 +16       SET BGPY=$$V(BGPRPT,49,9)

           SET BGPPRN=$PIECE(BGPY,"!",2)

           SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 +17       SET BGPY=$$V(BGPRPT,89,9)

           SET BGP98N=$PIECE(BGPY,"!",2)

           SET BGP98P=$SELECT(BGP98D:((BGP98N/BGP98D)*100),1:"")

 +18       WRITE !!,"# w/Smoker in Home"

 +19       DO H2^BGPDPH

 +20       QUIT 

CALC(N,O) ;ENTRY POINT

 +1       ;N is new

 +2       ;O is old

 +3        NEW Z

 +4        IF O=0!(N=0)!(O="")!(N="")

               QUIT "**"

 +5        NEW X,X2,X3

 +6        SET X=N

           SET X2=1

           SET X3=0

           DO COMMA^%DTC

           SET N=X

 +7        SET X=O

           SET X2=1

           SET X3=0

           DO COMMA^%DTC

           SET O=X

 +8        IF +O=0

               QUIT "**"

 +9        SET Z=(((N-O)/O)*100)

           SET Z=$FNUMBER(Z,"+,",1)

 +10       QUIT Z

H         ;write header

 +1        WRITE !?44,"% CHANGE",?62,"% CHANGE",!?44,"FROM BASE YR",?62,"FROM PREV YR"

 +2        QUIT 

LOCW      ;

 +1        IF $Y>(IOSL-3)

               DO HEADER^BGPDPH

               IF BGPQUIT

                   QUIT 

 +2        WRITE !?3,$PIECE(^BGPD(BGPRPT,0),U,5)

 +3        SET X=$PIECE(^BGPD(BGPRPT,0),U,5)

 +4        IF X=""

               WRITE ?11,"?????"

               QUIT 

 +5        SET X=$ORDER(^AUTTLOC("C",X,0))

 +6        IF X=""

               WRITE ?11,"?????"

               QUIT 

 +7        WRITE ?11,$EXTRACT($PIECE(^DIC(4,X,0),U),1,20)

 +8        SET BGPX=$JUSTIFY($$CALC(BGPCYP,BGP98P),6)

           SET $EXTRACT(BGPX,20)=$JUSTIFY($$CALC(BGPCYP,BGPPRP),6)

 +9        WRITE ?46,BGPX

 +10       QUIT 

V(R,N,P)  ;

 +1        NEW Y

 +2        IF $GET(BGPAREAA)

               IF '$GET(BGPSUMR)

                   GOTO VA

 +3        QUIT $PIECE($GET(^BGPD(R,N)),U,P)

VA        ;

 +1        NEW X,C,V,MT,FT,M,F,B

           SET X=0

           SET C=""

           FOR 

               SET X=$ORDER(BGPSUL(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +2                SET V=$PIECE($GET(^BGPD(X,N)),U,P)

 +3                IF C=""

                       SET C=V

                       QUIT 

 +4                SET MT=$PIECE(C,"!")

                   SET FT=$PIECE(C,"!",2)

                   SET M=$PIECE(V,"!")

                   SET F=$PIECE(V,"!",2)

 +5                FOR B=1:1:6

                       SET $PIECE(MT,"~",B)=$PIECE(MT,"~",B)+$PIECE(M,"~",B)

 +6                FOR B=1:1:6

                       SET $PIECE(FT,"~",B)=$PIECE(FT,"~",B)+$PIECE(F,"~",B)

 +7                SET C=MT_"!"_FT

 +8                QUIT 

               End DoDot:1

 +9        QUIT C

C(X,X2,X3) ;

 +1        DO COMMA^%DTC

 +2        QUIT X

 +3       ;