Routine: BGP9DSPD

BGP9DSPD ; IHS/CMI/LAB - IHS summary page ;

 ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009

START ;

 I BGPRTYPE'=1 Q

 I $G(BGPNPL) Q  ;not on gpra pat list

 I $G(BGPCPPL) Q  ;not on comp list

 S BGPQUIT="",BGPGPG=0

 D HEADER

 W !!,"GPRA DEVELOPMENTAL MEASURES"

 W !,"---------------------------"

 S BGPC=0 F  S BGPC=$O(^TMP($J,"SUMMARY DEVEL",BGPC)) Q:BGPC'=+BGPC!(BGPQUIT)  D

 .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 .S BGPC1=$O(^BGPSCAT("C",BGPC,0))

 .W !

 .W !,$P(^BGPSCAT(BGPC1,0),U)

 .S BGPO="" F  S BGPO=$O(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO)) Q:BGPO=""!(BGPQUIT)  D

 ..S BGPPC=$O(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,0))

 ..Q:$P($G(^BGPINDNC(BGPPC,22)),U,13)  ;part measure displays last

 ..I $Y>(BGPIOSL-4) D HEADER Q:BGPQUIT

 ..I $P(^BGPINDNC(BGPPC,0),U,4)["014."!($P(^BGPINDNC(BGPPC,0),U,4)["023.")!($P(^BGPINDNC(BGPPC,0),U,4)["016")!($P($G(^BGPINDNC(BGPPC,19)),U,13)) D  I 1

 ...W !?1,$P(^BGPINDNC(BGPPC,22),U,4)

 ...I $P(^BGPINDNC(BGPPC,22),U,7)]"" W !?1,$P(^BGPINDNC(BGPPC,22),U,7)

 ...I $P(^BGPINDNC(BGPPC,22),U,12)]"" W !?1,$P(^BGPINDNC(BGPPC,22),U,12)

 ...W ?26,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,0)

 ...W ?34,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,0)

 ...W ?41,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,0)

 ...W ?57,$P(^BGPINDNC(BGPPC,22),U,2)

 ..E  D

 ...W !?1,$P(^BGPINDNC(BGPPC,22),U,4)

 ...I $P(^BGPINDNC(BGPPC,22),U,7)]"" W !?1,$P(^BGPINDNC(BGPPC,22),U,7)

 ...I $P(^BGPINDNC(BGPPC,22),U,12)]"" W !?1,$P(^BGPINDNC(BGPPC,22),U,12)

 ...W ?26,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,1),"%"

 ...W ?34,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,1),"%"

 ...W ?41,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,1),"%"

 ...W ?57,$TR($P(^BGPINDNC(BGPPC,22),U,2),"$","^")

 ...I $P(^BGPINDNC(BGPPC,22),U,9)]""!($P(^BGPINDNC(BGPPC,22),U,10)]"")!($P(^BGPINDNC(BGPPC,22),U,11)]"") W !?57,$TR($P(^BGPINDNC(BGPPC,22),U,10),"$","^")

 I $Y>(BGPIOSL-2) D HEADER Q:BGPQUIT

 W !!,"* Not GPRA Developmental measure but included to show percentage of"

 W !,"refusals with respect to GPRA Developmental measure."

W !

 D PART

HEADER ;EP

 D HEADER^BGP9DPH

 D H1

H1 ;

 S X="GPRA DEVELOPMENTAL & PART MEASURES CLINICAL PERFORMANCE SUMMARY" W !,$$CTR(X,80)

 I $G(BGPAREAA) W !?26," Area",?34," Area",?43," Area",?57,"Nat'l"

 I '$G(BGPAREAA) W !?26," Site",?34," Site",?43," Site",?57,"Nat'l"

 W !?26,"Current",?34,"Previous",?43,"Baseline",?57,"2008"

 W !,$TR($J("",80)," ","-")

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

PART ;

 D HEADERP

 S P1=$S($G(BGPNGR09):14,1:8)

 S BGPC=0 F  S BGPC=$O(^TMP($J,"SUMMARY DEVEL",BGPC)) Q:BGPC'=+BGPC!(BGPQUIT)  D

 .I $Y>(BGPIOSL-3) D HEADERP Q:BGPQUIT

 .S BGPC1=$O(^BGPSCAT("C",BGPC,0))

 .;W !

 .;W !,$P(^BGPSCAT(BGPC1,0),U)

 .S BGPO="" F  S BGPO=$O(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO)) Q:BGPO=""!(BGPQUIT)  D

 ..S BGPPC=$O(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,0))

 ..Q:'$P($G(^BGPINDNC(BGPPC,22)),U,13)  ;part measures only

 ..I $Y>(BGPIOSL-4) D HEADERP Q:BGPQUIT

 ..I $P(^BGPINDNC(BGPPC,0),U,4)["014."!($P(^BGPINDNC(BGPPC,0),U,4)["023.")!($P(^BGPINDNC(BGPPC,0),U,4)["016")!($P($G(^BGPINDNC(BGPPC,19)),U,13)) D  I 1

 ...W !,$P(^BGPINDNC(BGPPC,22),U,4)

 ...I $P(^BGPINDNC(BGPPC,22),U,7)]"" W !,$P(^BGPINDNC(BGPPC,22),U,7)

 ...I $P(^BGPINDNC(BGPPC,22),U,12)]"" W !,$P(^BGPINDNC(BGPPC,22),U,12)

 ...W ?26,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,0)

 ...W ?34,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,0)

 ...W ?41,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,0)

 ...W ?53,$P(^BGPINDNC(BGPPC,22),U,P1),?64,$P(^BGPINDNC(BGPPC,22),U,2),?73,$P(^BGPINDNC(BGPPC,22),U,3)

 ..E  D

 ...W !,$P(^BGPINDNC(BGPPC,22),U,4)

 ...I $P(^BGPINDNC(BGPPC,22),U,7)]"" W !,$P(^BGPINDNC(BGPPC,22),U,7)

 ...I $P(^BGPINDNC(BGPPC,22),U,12)]"" W !,$P(^BGPINDNC(BGPPC,22),U,12)

 ...W ?26,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,1),"%"

 ...W ?34,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,1),"%"

 ...W ?41,$J($P(^TMP($J,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,1),"%"

 ...W ?53,$TR($P(^BGPINDNC(BGPPC,22),U,P1),"$","^"),?64,$TR($P(^BGPINDNC(BGPPC,22),U,2),"$","^"),?73,$P(^BGPINDNC(BGPPC,22),U,3)

 ...I $P(^BGPINDNC(BGPPC,22),U,9)]""!($P(^BGPINDNC(BGPPC,22),U,10)]"")!($P(^BGPINDNC(BGPPC,22),U,11)]"") W !?53,$TR($P(^BGPINDNC(BGPPC,22),U,9),"$","^"),?64,$TR($P(^BGPINDNC(BGPPC,22),U,10),"$","^"),?73,$P(^BGPINDNC(BGPPC,22),U,11)

 I $Y>(BGPIOSL-9) D HEADERP Q:BGPQUIT

W !

 I $G(BGPNGR09) D

 .W !," * PART 2010 target represented here is a preliminary target since it will be"

 .W !,"adjusted for FY 2009 actual results and FY 2010 appropriations."

 W !,$S($G(BGPNGR09):"**",1:"*")," Federally Administered Activities measure.  National 2008 rate is for federal"

 W !,"sites only."

 W ! Q

HEADERP ;EP

 D HEADER^BGP9DPH

 D H1P

H1P ;

 S X="GPRA DEVELOPMENTAL & PART MEASURES CLINICAL PERFORMANCE SUMMARY" W !,$$CTR(X,80)

 I $G(BGPAREAA) W !?26," Area",?34," Area",?43," Area",?53,$S($G(BGPNGR09):"PART10",1:"PART09"),?64,"Nat'l",?73,"2010"

 I '$G(BGPAREAA) W !?26," Site",?34," Site",?43," Site",?53,$S($G(BGPNGR09):"PART10",1:"PART09"),?64,"Nat'l",?73,"2010"

 W !?26,"Current",?34,"Previous",?43,"Baseline",?53,"Target",?64,"2008",?73,"Target"

 W !,$TR($J("",80)," ","-")

 W !!,"PART MEASURE"

 W !,"------------"

W !

BGP9DSPD  ; IHS/CMI/LAB - IHS summary page ;

 +1       ;;9.0;IHS CLINICAL REPORTING;**1**;JUL 01, 2009

 +2       ;

START     ;

 +1        IF BGPRTYPE'=1

               QUIT

 +2       ;not on gpra pat list

           IF $GET(BGPNPL)

               QUIT

 +3       ;not on comp list

           IF $GET(BGPCPPL)

               QUIT

 +4        SET BGPQUIT=""

           SET BGPGPG=0

 +5        DO HEADER

 +6        WRITE !!,"GPRA DEVELOPMENTAL MEASURES"

 +7        WRITE !,"---------------------------"

 +8        SET BGPC=0

FOR

               SET BGPC=$ORDER(^TMP($JOB,"SUMMARY DEVEL",BGPC))

               IF BGPC'=+BGPC!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +9                IF $Y>(BGPIOSL-3)

                       DO HEADER

                       IF BGPQUIT

                           QUIT

 +10               SET BGPC1=$ORDER(^BGPSCAT("C",BGPC,0))

 +11               WRITE !

 +12               WRITE !,$PIECE(^BGPSCAT(BGPC1,0),U)

 +13               SET BGPO=""

FOR

                       SET BGPO=$ORDER(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO))

                       IF BGPO=""!(BGPQUIT)

                           QUIT

                       Begin DoDot:2

 +14                       SET BGPPC=$ORDER(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,0))

 +15      ;part measure displays last

                           IF $PIECE($GET(^BGPINDNC(BGPPC,22)),U,13)

                               QUIT

 +16                       IF $Y>(BGPIOSL-4)

                               DO HEADER

                               IF BGPQUIT

                                   QUIT

 +17                       IF $PIECE(^BGPINDNC(BGPPC,0),U,4)["014."!($PIECE(^BGPINDNC(BGPPC,0),U,4)["023.")!($PIECE(^BGPINDNC(BGPPC,0),U,4)["016")!($PIECE($GET(^BGPINDNC(BGPPC,19)),U,13))

                               Begin DoDot:3

 +18                               WRITE !?1,$PIECE(^BGPINDNC(BGPPC,22),U,4)

 +19                               IF $PIECE(^BGPINDNC(BGPPC,22),U,7)]""

                                       WRITE !?1,$PIECE(^BGPINDNC(BGPPC,22),U,7)

 +20                               IF $PIECE(^BGPINDNC(BGPPC,22),U,12)]""

                                       WRITE !?1,$PIECE(^BGPINDNC(BGPPC,22),U,12)

 +21                               WRITE ?26,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,0)

 +22                               WRITE ?34,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,0)

 +23                               WRITE ?41,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,0)

 +24                               WRITE ?57,$PIECE(^BGPINDNC(BGPPC,22),U,2)

                               End DoDot:3

                               IF 1

 +25                      IF '$TEST

                               Begin DoDot:3

 +26                               WRITE !?1,$PIECE(^BGPINDNC(BGPPC,22),U,4)

 +27                               IF $PIECE(^BGPINDNC(BGPPC,22),U,7)]""

                                       WRITE !?1,$PIECE(^BGPINDNC(BGPPC,22),U,7)

 +28                               IF $PIECE(^BGPINDNC(BGPPC,22),U,12)]""

                                       WRITE !?1,$PIECE(^BGPINDNC(BGPPC,22),U,12)

 +29                               WRITE ?26,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,1),"%"

 +30                               WRITE ?34,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,1),"%"

 +31                               WRITE ?41,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,1),"%"

 +32                               WRITE ?57,$TRANSLATE($PIECE(^BGPINDNC(BGPPC,22),U,2),"$","^")

 +33                               IF $PIECE(^BGPINDNC(BGPPC,22),U,9)]""!($PIECE(^BGPINDNC(BGPPC,22),U,10)]"")!($PIECE(^BGPINDNC(BGPPC,22),U,11)]"")

                                       WRITE !?57,$TRANSLATE($PIECE(^BGPINDNC(BGPPC,22),U,10),"$","^")

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +34       IF $Y>(BGPIOSL-2)

               DO HEADER

               IF BGPQUIT

                   QUIT

 +35       WRITE !!,"* Not GPRA Developmental measure but included to show percentage of"

 +36       WRITE !,"refusals with respect to GPRA Developmental measure."

 +37       WRITE !

 +38       DO PART

 +39       QUIT

 +40      ;

HEADER    ;EP

 +1        DO HEADER^BGP9DPH

 +2        DO H1

 +3        QUIT

H1        ;

 +1        SET X="GPRA DEVELOPMENTAL & PART MEASURES CLINICAL PERFORMANCE SUMMARY"

           WRITE !,$$CTR(X,80)

 +2        IF $GET(BGPAREAA)

               WRITE !?26," Area",?34," Area",?43," Area",?57,"Nat'l"

 +3        IF '$GET(BGPAREAA)

               WRITE !?26," Site",?34," Site",?43," Site",?57,"Nat'l"

 +4        WRITE !?26,"Current",?34,"Previous",?43,"Baseline",?57,"2008"

 +5        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +6        QUIT

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 +2       ;----------

PART      ;

 +1        DO HEADERP

 +2        SET P1=$SELECT($GET(BGPNGR09):14,1:8)

 +3        SET BGPC=0

FOR

               SET BGPC=$ORDER(^TMP($JOB,"SUMMARY DEVEL",BGPC))

               IF BGPC'=+BGPC!(BGPQUIT)

                   QUIT

               Begin DoDot:1

 +4                IF $Y>(BGPIOSL-3)

                       DO HEADERP

                       IF BGPQUIT

                           QUIT

 +5                SET BGPC1=$ORDER(^BGPSCAT("C",BGPC,0))

 +6       ;W !

 +7       ;W !,$P(^BGPSCAT(BGPC1,0),U)

 +8                SET BGPO=""

FOR

                       SET BGPO=$ORDER(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO))

                       IF BGPO=""!(BGPQUIT)

                           QUIT

                       Begin DoDot:2

 +9                        SET BGPPC=$ORDER(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,0))

 +10      ;part measures only

                           IF '$PIECE($GET(^BGPINDNC(BGPPC,22)),U,13)

                               QUIT

 +11                       IF $Y>(BGPIOSL-4)

                               DO HEADERP

                               IF BGPQUIT

                                   QUIT

 +12                       IF $PIECE(^BGPINDNC(BGPPC,0),U,4)["014."!($PIECE(^BGPINDNC(BGPPC,0),U,4)["023.")!($PIECE(^BGPINDNC(BGPPC,0),U,4)["016")!($PIECE($GET(^BGPINDNC(BGPPC,19)),U,13))

                               Begin DoDot:3

 +13                               WRITE !,$PIECE(^BGPINDNC(BGPPC,22),U,4)

 +14                               IF $PIECE(^BGPINDNC(BGPPC,22),U,7)]""

                                       WRITE !,$PIECE(^BGPINDNC(BGPPC,22),U,7)

 +15                               IF $PIECE(^BGPINDNC(BGPPC,22),U,12)]""

                                       WRITE !,$PIECE(^BGPINDNC(BGPPC,22),U,12)

 +16                               WRITE ?26,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,0)

 +17                               WRITE ?34,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,0)

 +18                               WRITE ?41,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,0)

 +19                               WRITE ?53,$PIECE(^BGPINDNC(BGPPC,22),U,P1),?64,$PIECE(^BGPINDNC(BGPPC,22),U,2),?73,$PIECE(^BGPINDNC(BGPPC,22),U,3)

                               End DoDot:3

                               IF 1

 +20                      IF '$TEST

                               Begin DoDot:3

 +21                               WRITE !,$PIECE(^BGPINDNC(BGPPC,22),U,4)

 +22                               IF $PIECE(^BGPINDNC(BGPPC,22),U,7)]""

                                       WRITE !,$PIECE(^BGPINDNC(BGPPC,22),U,7)

 +23                               IF $PIECE(^BGPINDNC(BGPPC,22),U,12)]""

                                       WRITE !,$PIECE(^BGPINDNC(BGPPC,22),U,12)

 +24                               WRITE ?26,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U),7,1),"%"

 +25                               WRITE ?34,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,2),7,1),"%"

 +26                               WRITE ?41,$JUSTIFY($PIECE(^TMP($JOB,"SUMMARY DEVEL",BGPC,BGPO,BGPPC),U,3),7,1),"%"

 +27                               WRITE ?53,$TRANSLATE($PIECE(^BGPINDNC(BGPPC,22),U,P1),"$","^"),?64,$TRANSLATE($PIECE(^BGPINDNC(BGPPC,22),U,2),"$","^"),?73,$PIECE(^BGPINDNC(BGPPC,22),U,3)

 +28                               IF $PIECE(^BGPINDNC(BGPPC,22),U,9)]""!($PIECE(^BGPINDNC(BGPPC,22),U,10)]"")!($PIECE(^BGPINDNC(BGPPC,22),U,11)]"")

                                       WRITE !?53,$TRANSLATE($PIECE(^BGPINDNC(BGPPC,22),U,9),"$","^"),?64,$TRANSLATE($PIECE(^BGPINDNC(BGPPC,22),U,10),"$","^"),?73,$PIECE(^BGPINDNC(BGPPC,22),U,11)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +29       IF $Y>(BGPIOSL-9)

               DO HEADERP

               IF BGPQUIT

                   QUIT

 +30       WRITE !

 +31       IF $GET(BGPNGR09)

               Begin DoDot:1

 +32               WRITE !," * PART 2010 target represented here is a preliminary target since it will be"

 +33               WRITE !,"adjusted for FY 2009 actual results and FY 2010 appropriations."

               End DoDot:1

 +34       WRITE !,$SELECT($GET(BGPNGR09):"**",1:"*")," Federally Administered Activities measure.  National 2008 rate is for federal"

 +35       WRITE !,"sites only."

 +36       WRITE !

           QUIT

 +37      ;

HEADERP   ;EP

 +1        DO HEADER^BGP9DPH

 +2        DO H1P

 +3        QUIT

H1P       ;

 +1        SET X="GPRA DEVELOPMENTAL & PART MEASURES CLINICAL PERFORMANCE SUMMARY"

           WRITE !,$$CTR(X,80)

 +2        IF $GET(BGPAREAA)

               WRITE !?26," Area",?34," Area",?43," Area",?53,$SELECT($GET(BGPNGR09):"PART10",1:"PART09"),?64,"Nat'l",?73,"2010"

 +3        IF '$GET(BGPAREAA)

               WRITE !?26," Site",?34," Site",?43," Site",?53,$SELECT($GET(BGPNGR09):"PART10",1:"PART09"),?64,"Nat'l",?73,"2010"

 +4        WRITE !?26,"Current",?34,"Previous",?43,"Baseline",?53,"Target",?64,"2008",?73,"Target"

 +5        WRITE !,$TRANSLATE($JUSTIFY("",80)," ","-")

 +6        WRITE !!,"PART MEASURE"

 +7        WRITE !,"------------"

 +8        WRITE !

 +9        QUIT

BGP9DSPD.m