BGP0DP.m

BGP0DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2009 6:26 AM ;

 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010

 ;

 ;

PRINT ;

 K ^TMP($J)

 K BGPDELIM

 S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))

 S BGPQUIT=""

 S ^TMP($J,"BGPDEL",0)=0

 I $G(BGPAREAA) D SETEXCEL

 S BGPIFTR=""

 I BGPROT="D" G DEL

 S BGPPTYPE="P"

 S BGPQHDR=0

 D ^BGP0DH

 I BGPQHDR D KITM Q

 S BGPGPG=0

 S BGPQUIT=""

 D PRINT1

 K ^TMP($J)

 I BGPROT="P" D KITM Q

 ;

DEL ;create delimited output file

 I '$D(BGPGUI) D ^%ZISC ;close printer device

 K ^TMP($J)

 S ^TMP($J,"BGPDEL",0)=0

 S BGPQHDR=0

 S BGPPTYPE="D"

 D ^BGP0DH

 S BGPGPG=0

 S BGPQUIT=""

 D PRINT1

 D SAVEDEL^BGP0PDL   ;D ^BGP0PDL ;create ^tmp of delimited report

 S BGPIFTR=1

 K ^XTMP("BGP0D",BGPJ,BGPH)

 K ^XTMP("BGP0DNP",BGPJ,BGPH)

 K ^XTMP("BGP10CPL",BGPJ,BGPH)

 K ^TMP($J)

 Q

W(V,C,F,M,P,T) ;EP

 I $G(F)="" S F=1

 I $G(C)="" S C=0

 I $G(P)="" S P=1

 I $G(T)="" S T=0

 I M="P" D  Q

 .;I $Y>(BGPIOSL-2) D EOP W:$D(IOF) @IOF

 .NEW X

 .F X=1:1:F W !

 .I C W $$CJ^XLFSTR(V,80)

 .I 'C W ?T,V

 ;set up array

 I '$G(F) S F=0

 NEW %,Z

 S Z=""

 S %=$P(^TMP($J,"BGPDEL",0),U)

 F Z=1:1:F S %=%+1 S ^TMP($J,"BGPDEL",%)=""

 S $P(^TMP($J,"BGPDEL",0),U)=%

 I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""

 S $P(^TMP($J,"BGPDEL",%),U,P)=V

 Q

 ;

WTITLE(I) ;EP - write title line

 NEW T,X,Y,S

 S T=$P(^BGPINDT(I,0),U,3)

 I BGPPTYPE="P",$L(T)<81 D W(T,0,1,BGPPTYPE),W("",0,1,BGPPTYPE) Q  ; W !,T,! Q

 I BGPPTYPE="D" D W(T,0,1,BGPPTYPE),W("",0,1,BGPPTYPE) Q

 F X=$E(T,1,80)

 S S=""

 F Y=80:-1:1 Q:S  S I=$E(X,Y) I I=" " S S=Y

 D W^BGP0DP($E(T,1,S),0,1,BGPPTYPE)  ;W !,$E(T,1,S)

 D W^BGP0DP($E(T,(S+1),$L(T)),0,1,BGPPTYPE),W("",0,1,BGPPTYPE)  ;W !,$E(T,(S+1),$L(T)),!

 Q

ANYDEV() ;

 NEW X,G,Y

 S G=0

 S X=0 F  S X=$O(BGPINDL(X)) Q:X'=+X  S Y=0 F  S Y=$O(BGPINDL(X,Y)) Q:Y'=+Y  I $P(^BGPNPLT(Y,0),U,7)=9 S G=1

 Q G

ALLDEV() ;

 NEW X,G,Y

 S G=1

 S X=0 F  S X=$O(BGPINDL(X)) Q:X'=+X  S Y=0 F  S Y=$O(BGPINDL(X,Y)) Q:Y'=+Y  I $P(^BGPNPLT(Y,0),U,7)=1 S G=0

 Q G

PRINT1 ;EP

 ;if in NGR or GPU now print gpra dev measures and divider page

 I BGPRTYPE=1 D

 .I $G(BGPNPL),'$$ANYDEV() Q  ;in lists and no developmental lists so skip this

 .I '$G(BGPSUMON) D HEADER^BGP0DPH

 .I '$G(BGPSUMON) D W^BGP0DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP0DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP0DP("",0,1,BGPPTYPE)

 .S BGPGDEV=1,BGPRTYPE=9  ;control variable

 .S BGPDEVOR=0 F  S BGPDEVOR=$O(^BGPINDT("ADEVO",BGPDEVOR)) Q:BGPDEVOR'=+BGPDEVOR!(BGPQUIT)  D

 ..S BGPIC=$O(^BGPINDT("ADEVO",BGPDEVOR,0)) Q:BGPIC=""

 ..I $P(^BGPINDT(BGPIC,0),U,14),$D(BGPIND(BGPIC)) D PRINT2

 ..Q:BGPQUIT

 ..I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP0NPLT) S BGPINDT=BGPIC D NPL1^BGP0NPLP ;printed nat gpra list

 ..I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP0NPLT) S BGPINDT=BGPIC D CT^BGP0DSTM ;printed nat gpra SEARCH TEMPLATE

 .S BGPRTYPE=1 K BGPGDEV

 .Q:BGPQUIT

 .;NOW PRINT developmental summary sheet

 .D ^BGP0DSPD  ;DEVELOPMENTAL

 .D ^BGP0SDPD  ;SUMMARY DETAIL

 .;now print gpra divider page

 .;if no lists except developmental skip this

 .I $G(BGPNPL),$$ALLDEV() Q

 .I '$G(BGPSUMON) D HEADER^BGP0DPH

 .I '$G(BGPSUMON) D W^BGP0DP("The following section contains GPRA & PART and Non-GPRA Selected Topics",0,3,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP0DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP0DP("Measures and GPRA & PART Measures.",0,1,BGPPTYPE)

 .I '$G(BGPSUMON) D W^BGP0DP("",0,1,BGPPTYPE)

 ;set back to report 1

 I BGPRTYPE=1,$G(BGPNPL),$$ALLDEV() Q

 S BGPORDSE=0 F  S BGPORDSE=$O(^BGPINDT("AOI",BGPORDSE)) Q:BGPORDSE'=+BGPORDSE!(BGPQUIT)  S BGPIC=$O(^BGPINDT("AOI",BGPORDSE,0)) I $D(BGPIND(BGPIC)) D

 .Q:BGPQUIT

 .I BGPRTYPE=1 Q:$P($G(^BGPINDT(BGPIC,13)),U,3)  ;dev only, not nat gpra report

 .I BGPRTYPE=4 Q:$P($G(^BGPINDT(BGPIC,13)),U,4)  ;not on selected measures report

 .D PRINT2

 .I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP0NPLT) S BGPINDT=BGPIC D NPL1^BGP0NPLP ;printed nat gpra list

 .I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP0NPLT) S BGPINDT=BGPIC D CT^BGP0DSTM ;printed nat gpra SEARCH TEMPLATE

 Q:BGPQUIT

PRINT3 ;

 D SUMP

 Q

WP ;

 K ^UTILITY($J,"W")

 S BGPZ=0,BGPLCNT=0

 S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F  S BGPZ=$O(^BGPINDT(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ  D

 .S BGPLCNT=BGPLCNT+1

 .S X=^BGPINDT(BGPIC,BGPNODE,BGPY,1,BGPZ,0) S:BGPLCNT=1 X=" - "_X D ^DIWP

 .Q

WPS ;

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  D

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 .D W^BGP0DP(^UTILITY($J,"W",DIWL,Z,0),0,1,BGPPTYPE)

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),X

 Q

PRINT2 ;

 D

 .I $G(BGPSUMON) G CALC

 .D HEADER^BGP0DPH ;header for all measures

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 .D WTITLE(BGPIC)

 .;W !,$P(^BGPINDT(BGPIC,0),U,3),!

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 .D W^BGP0DP("Denominator(s):",0,1,BGPPTYPE)

 .S BGPNODE=$S(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,1:61)

 .S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 ..S BGPY=0 F  S BGPY=$O(^BGPINDT(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 ...I BGPRTYPE=4,'$D(^BGPINDT(BGPIC,BGPNODE,BGPY,12,"B",BGPINDT)) Q  ;not this measure type on selected

 ...D WP

 ...Q

 ..Q

 .Q:BGPQUIT

 .I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 .D W^BGP0DP("Numerator(s):",0,2,BGPPTYPE)

 .S BGPNODE=$S(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,1:62)

 .S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 ..S BGPY=0 F  S BGPY=$O(^BGPINDT(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 ...I BGPRTYPE=4,'$D(^BGPINDT(BGPIC,BGPNODE,BGPY,12,"B",BGPINDT)) Q  ;not this measure type on selected

 ...D WP

 ...Q

 ..Q

 .Q:BGPQUIT

 .S BGPNODE=11

 .I BGPRTYPE=1,$O(^BGPINDT(BGPIC,54,0)) S BGPNODE=54

 .I BGPRTYPE=7,$O(^BGPINDT(BGPIC,56,0)) S BGPNODE=56

 .I BGPRTYPE=9,$O(^BGPINDT(BGPIC,58,0)) S BGPNODE=58

 .D W^BGP0DP("Logic:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 ..D W^BGP0DP(^BGPINDT(BGPIC,BGPNODE,BGPX,0),0,1,BGPPTYPE)

 .I BGPRTYPE=9 G CALC

 .D W^BGP0DP("Performance Measure Description:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 ..D W^BGP0DP(^BGPINDT(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX,0),0,1,BGPPTYPE)

 .I $O(^BGPINDT(BGPIC,52,0)) D W^BGP0DP("Past Performance and/or Target:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPIC,52,BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 ..D W^BGP0DP(^BGPINDT(BGPIC,52,BGPX,0),0,1,BGPPTYPE)

 .I $O(^BGPINDT(BGPIC,55,0)) D W^BGP0DP("Source:",0,2,BGPPTYPE) S BGPX=0 F  S BGPX=$O(^BGPINDT(BGPIC,55,BGPX)) Q:BGPX'=+BGPX  D

 ..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP0DPH Q:BGPQUIT

 ..D W^BGP0DP(^BGPINDT(BGPIC,55,BGPX,0),0,1,BGPPTYPE)

 .I '$O(^BGPINDT(BGPIC,55,0)) D W^BGP0DP("",0,1,BGPPTYPE)

CALC .I BGPPTYPE="P" X ^BGPINDT(BGPIC,3) D W^BGP0DP("",0,1,BGPPTYPE)

 .I BGPPTYPE="D" X ^BGPINDT(BGPIC,4) D W^BGP0DP("",0,1,BGPPTYPE)

 .;I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP0NPLT) S BGPINDT=BGPIC D NPL1^BGP0NPLP ;printed nat gpra list

 .;I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP0NPLT) S BGPINDT=BGPIC D CT^BGP0DSTM ;printed nat gpra SEARCH TEMPLATE

 Q

SUMP ;

 I BGPIC="" S BGPIFTR=1

 I BGPRTYPE=1 D ^BGP0DSPN  ;NON GPRA

 I BGPRTYPE=1 D ^BGP0DSP   ;GPRA

 I BGPRTYPE=1 D ^BGP0SDPN

 I BGPRTYPE=1 D ^BGP0SDP

 I BGPRTYPE=7 D ^BGP0DSPO

 I BGPRTYPE=7 D ^BGP0SDPO

 D ^BGP0DS

 I $G(BGPCPPL) D CPPL1^BGP0DCLP  ;print comp pt list

 D EXIT

 Q

KITM ;

 K ^TMP($J)

 K ^XTMP("BGP0D",BGPJ,BGPH)

 K ^XTMP("BGP0DNP",BGPJ,BGPH)

 K ^XTMP("BGP08CPL",BGPJ,BGPH)

 Q

SETEXCEL ;EP

 I $G(BGPAREAA) D  Q

 .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D

 ..S N=^BGPGPDCT(X,0)

 ..S (D,L)=""

 ..S L=$P(N,U,9) I L S L=$O(^AUTTLOC("C",L,0)) I L S D=$P($G(^AUTTLOC(L,1)),U,3),L=$S(L:$P(^DIC(4,L,0),U),1:"?????")

 ..S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..S BGPEI2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI2(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..S BGPEIDV1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV1(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..S BGPEIDV2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV2(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..S BGPONN1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN1(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..S BGPONN2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN2(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..S BGPONN3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN3(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1

 ..Q

 .Q

 Q

EXIT ;

 Q:BGPPTYPE'="P"

 I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO",DIR("A")="End of report.  Press ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

C(X,X2,X3) ;

 D COMMA^%DTC

 Q X

BGP0DP    ; IHS/CMI/LAB - IHS gpra print 03 Jul 2009 6:26 AM ;

 +1       ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010

 +2       ;

 +3       ;

PRINT     ;

 +1        KILL ^TMP($JOB)

 +2        KILL BGPDELIM

 +3        SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))

 +4        SET BGPQUIT=""

 +5        SET ^TMP($JOB,"BGPDEL",0)=0

 +6        IF $GET(BGPAREAA)

               DO SETEXCEL

 +7        SET BGPIFTR=""

 +8        IF BGPROT="D"

               GOTO DEL

 +9        SET BGPPTYPE="P"

 +10       SET BGPQHDR=0

 +11       DO ^BGP0DH

 +12       IF BGPQHDR

               DO KITM

               QUIT 

 +13       SET BGPGPG=0

 +14       SET BGPQUIT=""

 +15       DO PRINT1

 +16       KILL ^TMP($JOB)

 +17       IF BGPROT="P"

               DO KITM

               QUIT 

 +18      ;

DEL       ;create delimited output file

 +1       ;close printer device

           IF '$DATA(BGPGUI)

               DO ^%ZISC

 +2        KILL ^TMP($JOB)

 +3        SET ^TMP($JOB,"BGPDEL",0)=0

 +4        SET BGPQHDR=0

 +5        SET BGPPTYPE="D"

 +6        DO ^BGP0DH

 +7        SET BGPGPG=0

 +8        SET BGPQUIT=""

 +9        DO PRINT1

 +10      ;D ^BGP0PDL ;create ^tmp of delimited report

           DO SAVEDEL^BGP0PDL

 +11       SET BGPIFTR=1

 +12       KILL ^XTMP("BGP0D",BGPJ,BGPH)

 +13       KILL ^XTMP("BGP0DNP",BGPJ,BGPH)

 +14       KILL ^XTMP("BGP10CPL",BGPJ,BGPH)

 +15       KILL ^TMP($JOB)

 +16       QUIT 

W(V,C,F,M,P,T) ;EP

 +1        IF $GET(F)=""

               SET F=1

 +2        IF $GET(C)=""

               SET C=0

 +3        IF $GET(P)=""

               SET P=1

 +4        IF $GET(T)=""

               SET T=0

 +5        IF M="P"

               Begin DoDot:1

 +6       ;I $Y>(BGPIOSL-2) D EOP W:$D(IOF) @IOF

 +7                NEW X

 +8                FOR X=1:1:F

                       WRITE !

 +9                IF C

                       WRITE $$CJ^XLFSTR(V,80)

 +10               IF 'C

                       WRITE ?T,V

               End DoDot:1

               QUIT 

 +11      ;set up array

 +12       IF '$GET(F)

               SET F=0

 +13       NEW %,Z

 +14       SET Z=""

 +15       SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)

 +16       FOR Z=1:1:F

               SET %=%+1

               SET ^TMP($JOB,"BGPDEL",%)=""

 +17       SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%

 +18       IF '$DATA(^TMP($JOB,"BGPDEL",%))

               SET ^TMP($JOB,"BGPDEL",%)=""

 +19       SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=V

 +20       QUIT 

 +21      ;

WTITLE(I) ;EP - write title line

 +1        NEW T,X,Y,S

 +2        SET T=$PIECE(^BGPINDT(I,0),U,3)

 +3       ; W !,T,! Q

           IF BGPPTYPE="P"

               IF $LENGTH(T)<81

                   DO W(T,0,1,BGPPTYPE)

                   DO W("",0,1,BGPPTYPE)

                   QUIT 

 +4        IF BGPPTYPE="D"

               DO W(T,0,1,BGPPTYPE)

               DO W("",0,1,BGPPTYPE)

               QUIT 

 +5        FOR X=$EXTRACT(T,1,80)

 +6        SET S=""

 +7        FOR Y=80:-1:1

               IF S

                   QUIT 

               SET I=$EXTRACT(X,Y)

               IF I=" "

                   SET S=Y

 +8       ;W !,$E(T,1,S)

           DO W^BGP0DP($EXTRACT(T,1,S),0,1,BGPPTYPE)

 +9       ;W !,$E(T,(S+1),$L(T)),!

           DO W^BGP0DP($EXTRACT(T,(S+1),$LENGTH(T)),0,1,BGPPTYPE)

           DO W("",0,1,BGPPTYPE)

 +10       QUIT 

ANYDEV()  ;

 +1        NEW X,G,Y

 +2        SET G=0

 +3        SET X=0

           FOR 

               SET X=$ORDER(BGPINDL(X))

               IF X'=+X

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(BGPINDL(X,Y))

                   IF Y'=+Y

                       QUIT 

                   IF $PIECE(^BGPNPLT(Y,0),U,7)=9

                       SET G=1

 +4        QUIT G

ALLDEV()  ;

 +1        NEW X,G,Y

 +2        SET G=1

 +3        SET X=0

           FOR 

               SET X=$ORDER(BGPINDL(X))

               IF X'=+X

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(BGPINDL(X,Y))

                   IF Y'=+Y

                       QUIT 

                   IF $PIECE(^BGPNPLT(Y,0),U,7)=1

                       SET G=0

 +4        QUIT G

PRINT1    ;EP

 +1       ;if in NGR or GPU now print gpra dev measures and divider page

 +2        IF BGPRTYPE=1

               Begin DoDot:1

 +3       ;in lists and no developmental lists so skip this

                   IF $GET(BGPNPL)

                       IF '$$ANYDEV()

                           QUIT 

 +4                IF '$GET(BGPSUMON)

                       DO HEADER^BGP0DPH

 +5                IF '$GET(BGPSUMON)

                       DO W^BGP0DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)

 +6                IF '$GET(BGPSUMON)

                       DO W^BGP0DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)

 +7                IF '$GET(BGPSUMON)

                       DO W^BGP0DP("",0,1,BGPPTYPE)

 +8       ;control variable

                   SET BGPGDEV=1

                   SET BGPRTYPE=9

 +9                SET BGPDEVOR=0

                   FOR 

                       SET BGPDEVOR=$ORDER(^BGPINDT("ADEVO",BGPDEVOR))

                       IF BGPDEVOR'=+BGPDEVOR!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +10                       SET BGPIC=$ORDER(^BGPINDT("ADEVO",BGPDEVOR,0))

                           IF BGPIC=""

                               QUIT 

 +11                       IF $PIECE(^BGPINDT(BGPIC,0),U,14)

                               IF $DATA(BGPIND(BGPIC))

                                   DO PRINT2

 +12                       IF BGPQUIT

                               QUIT 

 +13      ;printed nat gpra list

                           IF $GET(BGPNPL)

                               IF $DATA(BGPINDL(BGPIC))

                                   IF '$DATA(BGP0NPLT)

                                       SET BGPINDT=BGPIC

                                       DO NPL1^BGP0NPLP

 +14      ;printed nat gpra SEARCH TEMPLATE

                           IF $GET(BGPNPL)

                               IF $DATA(BGPINDL(BGPIC))

                                   IF $DATA(BGP0NPLT)

                                       SET BGPINDT=BGPIC

                                       DO CT^BGP0DSTM

                       End DoDot:2

 +15               SET BGPRTYPE=1

                   KILL BGPGDEV

 +16               IF BGPQUIT

                       QUIT 

 +17      ;NOW PRINT developmental summary sheet

 +18      ;DEVELOPMENTAL

                   DO ^BGP0DSPD

 +19      ;SUMMARY DETAIL

                   DO ^BGP0SDPD

 +20      ;now print gpra divider page

 +21      ;if no lists except developmental skip this

 +22               IF $GET(BGPNPL)

                       IF $$ALLDEV()

                           QUIT 

 +23               IF '$GET(BGPSUMON)

                       DO HEADER^BGP0DPH

 +24               IF '$GET(BGPSUMON)

                       DO W^BGP0DP("The following section contains GPRA & PART and Non-GPRA Selected Topics",0,3,BGPPTYPE)

 +25               IF '$GET(BGPSUMON)

                       DO W^BGP0DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)

 +26               IF '$GET(BGPSUMON)

                       DO W^BGP0DP("Measures and GPRA & PART Measures.",0,1,BGPPTYPE)

 +27               IF '$GET(BGPSUMON)

                       DO W^BGP0DP("",0,1,BGPPTYPE)

               End DoDot:1

 +28      ;set back to report 1

 +29       IF BGPRTYPE=1

               IF $GET(BGPNPL)

                   IF $$ALLDEV()

                       QUIT 

 +30       SET BGPORDSE=0

           FOR 

               SET BGPORDSE=$ORDER(^BGPINDT("AOI",BGPORDSE))

               IF BGPORDSE'=+BGPORDSE!(BGPQUIT)

                   QUIT 

               SET BGPIC=$ORDER(^BGPINDT("AOI",BGPORDSE,0))

               IF $DATA(BGPIND(BGPIC))

                   Begin DoDot:1

 +31                   IF BGPQUIT

                           QUIT 

 +32      ;dev only, not nat gpra report

                       IF BGPRTYPE=1

                           IF $PIECE($GET(^BGPINDT(BGPIC,13)),U,3)

                               QUIT 

 +33      ;not on selected measures report

                       IF BGPRTYPE=4

                           IF $PIECE($GET(^BGPINDT(BGPIC,13)),U,4)

                               QUIT 

 +34                   DO PRINT2

 +35      ;printed nat gpra list

                       IF $GET(BGPNPL)

                           IF $DATA(BGPINDL(BGPIC))

                               IF '$DATA(BGP0NPLT)

                                   SET BGPINDT=BGPIC

                                   DO NPL1^BGP0NPLP

 +36      ;printed nat gpra SEARCH TEMPLATE

                       IF $GET(BGPNPL)

                           IF $DATA(BGPINDL(BGPIC))

                               IF $DATA(BGP0NPLT)

                                   SET BGPINDT=BGPIC

                                   DO CT^BGP0DSTM

                   End DoDot:1

 +37       IF BGPQUIT

               QUIT 

PRINT3    ;

 +1        DO SUMP

 +2        QUIT 

WP        ;

 +1        KILL ^UTILITY($JOB,"W")

 +2        SET BGPZ=0

           SET BGPLCNT=0

 +3        SET DIWL=1

           SET DIWR=80

           SET DIWF=""

           SET BGPZ=0

           FOR 

               SET BGPZ=$ORDER(^BGPINDT(BGPIC,BGPNODE,BGPY,1,BGPZ))

               IF BGPZ'=+BGPZ

                   QUIT 

               Begin DoDot:1

 +4                SET BGPLCNT=BGPLCNT+1

 +5                SET X=^BGPINDT(BGPIC,BGPNODE,BGPY,1,BGPZ,0)

                   IF BGPLCNT=1

                       SET X=" - "_X

                   DO ^DIWP

 +6                QUIT 

               End DoDot:1

WPS       ;

 +1        SET Z=0

           FOR 

               SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))

               IF Z'=+Z

                   QUIT 

               Begin DoDot:1

 +2                IF BGPPTYPE="P"

                       IF $Y>(BGPIOSL-3)

                           DO HEADER^BGP0DPH

                           IF BGPQUIT

                               QUIT 

 +3                DO W^BGP0DP(^UTILITY($JOB,"W",DIWL,Z,0),0,1,BGPPTYPE)

               End DoDot:1

 +4        KILL DIWL,DIWR,DIWF,Z

 +5        KILL ^UTILITY($JOB,"W"),X

 +6        QUIT 

PRINT2    ;

 +1        Begin DoDot:1

 +2            IF $GET(BGPSUMON)

                   GOTO CALC

 +3       ;header for all measures

               DO HEADER^BGP0DPH

 +4            IF BGPPTYPE="P"

                   IF $Y>(BGPIOSL-3)

                       DO HEADER^BGP0DPH

                       IF BGPQUIT

                           QUIT 

 +5            DO WTITLE(BGPIC)

 +6       ;W !,$P(^BGPINDT(BGPIC,0),U,3),!

 +7            IF BGPPTYPE="P"

                   IF $Y>(BGPIOSL-3)

                       DO HEADER^BGP0DPH

                       IF BGPQUIT

                           QUIT 

 +8            DO W^BGP0DP("Denominator(s):",0,1,BGPPTYPE)

 +9            SET BGPNODE=$SELECT(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,1:61)

 +10           SET BGPX=0

               FOR 

                   SET BGPX=$ORDER(^BGPINDT(BGPIC,BGPNODE,"B",BGPX))

                   IF BGPX'=+BGPX!(BGPQUIT)

                       QUIT 

                   Begin DoDot:2

 +11                   SET BGPY=0

                       FOR 

                           SET BGPY=$ORDER(^BGPINDT(BGPIC,BGPNODE,"B",BGPX,BGPY))

                           IF BGPY'=+BGPY!(BGPQUIT)

                               QUIT 

                           Begin DoDot:3

 +12      ;not this measure type on selected

                               IF BGPRTYPE=4

                                   IF '$DATA(^BGPINDT(BGPIC,BGPNODE,BGPY,12,"B",BGPINDT))

                                       QUIT 

 +13                           DO WP

 +14                           QUIT 

                           End DoDot:3

 +15                   QUIT 

                   End DoDot:2

 +16           IF BGPQUIT

                   QUIT 

 +17           IF BGPPTYPE="P"

                   IF $Y>(BGPIOSL-3)

                       DO HEADER^BGP0DPH

                       IF BGPQUIT

                           QUIT 

 +18           DO W^BGP0DP("Numerator(s):",0,2,BGPPTYPE)

 +19           SET BGPNODE=$SELECT(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,1:62)

 +20           SET BGPX=0

               FOR 

                   SET BGPX=$ORDER(^BGPINDT(BGPIC,BGPNODE,"B",BGPX))

                   IF BGPX'=+BGPX!(BGPQUIT)

                       QUIT 

                   Begin DoDot:2