BGP1DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
;
PRINT ;
I $G(BGPDASH) D ^BGP1DBPR Q ;dashboard
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 ^BGP1DH ;LORI
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 ^BGP1DH
S BGPGPG=0
S BGPQUIT=""
D PRINT1
D SAVEDEL^BGP1PDL ;D ^BGP1PDL ;create ^tmp of delimited report
S BGPIFTR=1
K ^XTMP("BGP1D",BGPJ,BGPH)
K ^XTMP("BGP1DNP",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(^BGPINDB(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^BGP1DP($E(T,1,S),0,1,BGPPTYPE) ;W !,$E(T,1,S)
D W^BGP1DP($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(^BGPNPLB(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(^BGPNPLB(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^BGP1DPH
.I '$G(BGPSUMON) D W^BGP1DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP1DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP1DP("",0,1,BGPPTYPE)
.S BGPGDEV=1,BGPRTYPE=9 ;control variable
.S BGPDEVOR=0 F S BGPDEVOR=$O(^BGPINDB("ADEVO",BGPDEVOR)) Q:BGPDEVOR'=+BGPDEVOR!(BGPQUIT) D
..S BGPIC=$O(^BGPINDB("ADEVO",BGPDEVOR,0)) Q:BGPIC=""
..I $P(^BGPINDB(BGPIC,0),U,14),$D(BGPIND(BGPIC)) D PRINT2
..Q:BGPQUIT
..I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP1NPLT) S BGPINDB=BGPIC D NPL1^BGP1NPLP ;printed nat gpra list
..I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP1NPLT) S BGPINDB=BGPIC D CT^BGP1DSTM ;printed nat gpra SEARCH TEMPLATE
.S BGPRTYPE=1 K BGPGDEV
.Q:BGPQUIT
.;NOW PRINT developmental summary sheet
.D ^BGP1DSPD ;DEVELOPMENTAL
.D ^BGP1SDPD ;SUMMARY DETAIL
.;now print gpra divider page
.;if no lists except developmental skip this
.I $G(BGPNPL),$$ALLDEV() Q
.I '$G(BGPSUMON) D HEADER^BGP1DPH
.I '$G(BGPSUMON) D W^BGP1DP("The following section contains GPRA & PART and Non-GPRA Selected Topics",0,3,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP1DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP1DP("Measures and GPRA & PART Measures.",0,1,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP1DP("",0,1,BGPPTYPE)
;set back to report 1
I BGPRTYPE=1,$G(BGPNPL),$$ALLDEV() Q
S BGPORDSE=0 F S BGPORDSE=$O(^BGPINDB("AOI",BGPORDSE)) Q:BGPORDSE'=+BGPORDSE!(BGPQUIT) S BGPIC=$O(^BGPINDB("AOI",BGPORDSE,0)) I $D(BGPIND(BGPIC)) D
.Q:BGPQUIT
.I BGPRTYPE=1 Q:$P($G(^BGPINDB(BGPIC,13)),U,3) ;dev only, not nat gpra report
.I BGPRTYPE=4 Q:$P($G(^BGPINDB(BGPIC,13)),U,4) ;not on selected measures report
.D PRINT2
.I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP1NPLT) S BGPINDB=BGPIC D NPL1^BGP1NPLP ;printed nat gpra list
.I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP1NPLT) S BGPINDB=BGPIC D CT^BGP1DSTM ;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(^BGPINDB(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPINDB(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^BGP1DPH Q:BGPQUIT
.D W^BGP1DP(^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^BGP1DPH ;header for all measures
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
.D WTITLE(BGPIC)
.;W !,$P(^BGPINDB(BGPIC,0),U,3),!
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
.D W^BGP1DP("Denominator(s):",0,1,BGPPTYPE)
.S BGPNODE=$S(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,1:61)
.I BGPRTYPE=4 S BGPNODE=$S(BGPINDB="D":87,BGPINDB="C":89,BGPINDB="W":92,BGPINDB="I":94,BGPINDB="P":96,1:BGPNODE)
.S BGPX=0 F S BGPX=$O(^BGPINDB(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPINDB(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...;I BGPRTYPE=4,'$D(^BGPINDB(BGPIC,BGPNODE,BGPY,12,"B",BGPINDB)) Q ;not this measure type on selected
...D WP
...Q
..Q
.Q:BGPQUIT
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
.D W^BGP1DP("Numerator(s):",0,2,BGPPTYPE)
.S BGPNODE=$S(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,1:62)
.I BGPRTYPE=4 S BGPNODE=$S(BGPINDB="D":88,BGPINDB="C":91,BGPINDB="W":93,BGPINDB="I":95,BGPINDB="P":97,1:BGPNODE)
.S BGPX=0 F S BGPX=$O(^BGPINDB(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPINDB(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...;I BGPRTYPE=4,'$D(^BGPINDB(BGPIC,BGPNODE,BGPY,12,"B",BGPINDB)) Q ;not this measure type on selected
...D WP
...Q
..Q
.Q:BGPQUIT
.S BGPNODE=11
.I BGPRTYPE=1,$O(^BGPINDB(BGPIC,54,0)) S BGPNODE=54
.I BGPRTYPE=7,$O(^BGPINDB(BGPIC,56,0)) S BGPNODE=56
.I BGPRTYPE=9,$O(^BGPINDB(BGPIC,58,0)) S BGPNODE=58
.D W^BGP1DP("Logic:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDB(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
..D W^BGP1DP(^BGPINDB(BGPIC,BGPNODE,BGPX,0),0,1,BGPPTYPE)
.I BGPRTYPE=9 G CALC
.D W^BGP1DP("Performance Measure Description:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDB(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
..D W^BGP1DP(^BGPINDB(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX,0),0,1,BGPPTYPE)
.I $O(^BGPINDB(BGPIC,52,0)) D W^BGP1DP("Past Performance and/or Target:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDB(BGPIC,52,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
..D W^BGP1DP(^BGPINDB(BGPIC,52,BGPX,0),0,1,BGPPTYPE)
.I $O(^BGPINDB(BGPIC,55,0)) D W^BGP1DP("Source:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDB(BGPIC,55,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
..D W^BGP1DP(^BGPINDB(BGPIC,55,BGPX,0),0,1,BGPPTYPE)
.I '$O(^BGPINDB(BGPIC,55,0)) D W^BGP1DP("",0,1,BGPPTYPE)
CALC .I BGPPTYPE="P" X ^BGPINDB(BGPIC,3) D W^BGP1DP("",0,1,BGPPTYPE)
.I BGPPTYPE="D" X ^BGPINDB(BGPIC,4) D W^BGP1DP("",0,1,BGPPTYPE)
.;I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP1NPLT) S BGPINDB=BGPIC D NPL1^BGP1NPLP ;printed nat gpra list
.;I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP1NPLT) S BGPINDB=BGPIC D CT^BGP1DSTM ;printed nat gpra SEARCH TEMPLATE
Q
SUMP ;
I BGPIC="" S BGPIFTR=1
I BGPRTYPE=1 D ^BGP1DSPN ;NON GPRA
I BGPRTYPE=1 D ^BGP1DSP ;GPRA
I BGPRTYPE=1 D ^BGP1SDPN
I BGPRTYPE=1 D ^BGP1SDP
I BGPRTYPE=7 D ^BGP1DSPO
I BGPRTYPE=7 D ^BGP1SDPO
D ^BGP1DS
I $G(BGPCPPL) D CPPL1^BGP1DCLP ;print comp pt list
D EXIT
Q
KITM ;
K ^TMP($J)
K ^XTMP("BGP1D",BGPJ,BGPH)
K ^XTMP("BGP1DNP",BGPJ,BGPH)
K ^XTMP("BGP18CPL",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=^BGPGPDCB(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^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPEI2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI2(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPEIDV1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV1(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPEIDV2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV2(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPEIDV3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV3(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPONN1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN1(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPONN2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN2(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPONN3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN3(X),U,P)=$$DATE^BGP1UTL($P(N,U,Y)),P=P+1
..S BGPONN4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP1UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN4(X),U,P)=$$DATE^BGP1UTL($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
BGP1DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
+3 ;
PRINT ;
+1 ;dashboard
IF $GET(BGPDASH)
DO ^BGP1DBPR
QUIT
+2 KILL ^TMP($JOB)
+3 KILL BGPDELIM
+4 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
+5 SET BGPQUIT=""
+6 SET ^TMP($JOB,"BGPDEL",0)=0
+7 IF $GET(BGPAREAA)
DO SETEXCEL
+8 SET BGPIFTR=""
+9 IF BGPROT="D"
GOTO DEL
+10 SET BGPPTYPE="P"
+11 SET BGPQHDR=0
+12 ;LORI
DO ^BGP1DH
+13 IF BGPQHDR
DO KITM
QUIT
+14 SET BGPGPG=0
+15 SET BGPQUIT=""
+16 DO PRINT1
+17 KILL ^TMP($JOB)
+18 IF BGPROT="P"
DO KITM
QUIT
+19 ;
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 ^BGP1DH
+7 SET BGPGPG=0
+8 SET BGPQUIT=""
+9 DO PRINT1
+10 ;D ^BGP1PDL ;create ^tmp of delimited report
DO SAVEDEL^BGP1PDL
+11 SET BGPIFTR=1
+12 KILL ^XTMP("BGP1D",BGPJ,BGPH)
+13 KILL ^XTMP("BGP1DNP",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(^BGPINDB(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^BGP1DP($EXTRACT(T,1,S),0,1,BGPPTYPE)
+9 ;W !,$E(T,(S+1),$L(T)),!
DO W^BGP1DP($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(^BGPNPLB(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(^BGPNPLB(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^BGP1DPH
+5 IF '$GET(BGPSUMON)
DO W^BGP1DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)
+6 IF '$GET(BGPSUMON)
DO W^BGP1DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)
+7 IF '$GET(BGPSUMON)
DO W^BGP1DP("",0,1,BGPPTYPE)
+8 ;control variable
SET BGPGDEV=1
SET BGPRTYPE=9
+9 SET BGPDEVOR=0
FOR
SET BGPDEVOR=$ORDER(^BGPINDB("ADEVO",BGPDEVOR))
IF BGPDEVOR'=+BGPDEVOR!(BGPQUIT)
QUIT
Begin DoDot:2
+10 SET BGPIC=$ORDER(^BGPINDB("ADEVO",BGPDEVOR,0))
IF BGPIC=""
QUIT
+11 IF $PIECE(^BGPINDB(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(BGP1NPLT)
SET BGPINDB=BGPIC
DO NPL1^BGP1NPLP
+14 ;printed nat gpra SEARCH TEMPLATE
IF $GET(BGPNPL)
IF $DATA(BGPINDL(BGPIC))
IF $DATA(BGP1NPLT)
SET BGPINDB=BGPIC
DO CT^BGP1DSTM
End DoDot:2
+15 SET BGPRTYPE=1
KILL BGPGDEV
+16 IF BGPQUIT
QUIT
+17 ;NOW PRINT developmental summary sheet
+18 ;DEVELOPMENTAL
DO ^BGP1DSPD
+19 ;SUMMARY DETAIL
DO ^BGP1SDPD
+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^BGP1DPH
+24 IF '$GET(BGPSUMON)
DO W^BGP1DP("The following section contains GPRA & PART and Non-GPRA Selected Topics",0,3,BGPPTYPE)
+25 IF '$GET(BGPSUMON)
DO W^BGP1DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)
+26 IF '$GET(BGPSUMON)
DO W^BGP1DP("Measures and GPRA & PART Measures.",0,1,BGPPTYPE)
+27 IF '$GET(BGPSUMON)
DO W^BGP1DP("",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(^BGPINDB("AOI",BGPORDSE))
IF BGPORDSE'=+BGPORDSE!(BGPQUIT)
QUIT
SET BGPIC=$ORDER(^BGPINDB("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(^BGPINDB(BGPIC,13)),U,3)
QUIT
+33 ;not on selected measures report
IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDB(BGPIC,13)),U,4)
QUIT
+34 DO PRINT2
+35 ;printed nat gpra list
IF $GET(BGPNPL)
IF $DATA(BGPINDL(BGPIC))
IF '$DATA(BGP1NPLT)
SET BGPINDB=BGPIC
DO NPL1^BGP1NPLP
+36 ;printed nat gpra SEARCH TEMPLATE
IF $GET(BGPNPL)
IF $DATA(BGPINDL(BGPIC))
IF $DATA(BGP1NPLT)
SET BGPINDB=BGPIC
DO CT^BGP1DSTM
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(^BGPINDB(BGPIC,BGPNODE,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPINDB(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^BGP1DPH
IF BGPQUIT
QUIT
+3 DO W^BGP1DP(^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^BGP1DPH
+4 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+5 DO WTITLE(BGPIC)
+6 ;W !,$P(^BGPINDB(BGPIC,0),U,3),!
+7 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+8 DO W^BGP1DP("Denominator(s):",0,1,BGPPTYPE)
+9 SET BGPNODE=$SELECT(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,1:61)
+10 IF BGPRTYPE=4
SET BGPNODE=$SELECT(BGPINDB="D":87,BGPINDB="C":89,BGPINDB="W":92,BGPINDB="I":94,BGPINDB="P":96,1:BGPNODE)
+11 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDB(BGPIC,BGPNODE,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+12 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPINDB(BGPIC,BGPNODE,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+13 ;I BGPRTYPE=4,'$D(^BGPINDB(BGPIC,BGPNODE,BGPY,12,"B",BGPINDB)) Q ;not this measure type on selected
+14 DO WP
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 IF BGPQUIT
QUIT
+18 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+19 DO W^BGP1DP("Numerator(s):",0,2,BGPPTYPE)
+20 SET BGPNODE=$SELECT(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,1:62)
+21 IF BGPRTYPE=4
SET BGPNODE=$SELECT(BGPINDB="D":88,BGPINDB="C":91,BGPINDB="W":93,BGPINDB="I":95,BGPINDB="P":97,1:BGPNODE)
+22 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDB(BGPIC,BGPNODE,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+23 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPINDB(BGPIC,BGPNODE,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+24 ;I BGPRTYPE=4,'$D(^BGPINDB(BGPIC,BGPNODE,BGPY,12,"B",BGPINDB)) Q ;not this measure type on selected
+25 DO WP
+26 QUIT
End DoDot:3
+27 QUIT
End DoDot:2
+28 IF BGPQUIT
QUIT
+29 SET BGPNODE=11
+30 IF BGPRTYPE=1
IF $ORDER(^BGPINDB(BGPIC,54,0))
SET BGPNODE=54
+31 IF BGPRTYPE=7
IF $ORDER(^BGPINDB(BGPIC,56,0))
SET BGPNODE=56
+32 IF BGPRTYPE=9
IF $ORDER(^BGPINDB(BGPIC,58,0))
SET BGPNODE=58
+33 DO W^BGP1DP("Logic:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDB(BGPIC,BGPNODE,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+34 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+35 DO W^BGP1DP(^BGPINDB(BGPIC,BGPNODE,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+36 IF BGPRTYPE=9
GOTO CALC
+37 DO W^BGP1DP("Performance Measure Description:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDB(BGPIC,$SELECT($GET(BGPNGR09):57,1:51),BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+38 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+39 DO W^BGP1DP(^BGPINDB(BGPIC,$SELECT($GET(BGPNGR09):57,1:51),BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+40 IF $ORDER(^BGPINDB(BGPIC,52,0))
DO W^BGP1DP("Past Performance and/or Target:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDB(BGPIC,52,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+41 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+42 DO W^BGP1DP(^BGPINDB(BGPIC,52,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+43 IF $ORDER(^BGPINDB(BGPIC,55,0))
DO W^BGP1DP("Source:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDB(BGPIC,55,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+44 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+45 DO W^BGP1DP(^BGPINDB(BGPIC,55,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+46 IF '$ORDER(^BGPINDB(BGPIC,55,0))
DO W^BGP1DP("",0,1,BGPPTYPE)
CALC IF BGPPTYPE="P"
XECUTE ^BGPINDB(BGPIC,3)
DO W^BGP1DP("",0,1,BGPPTYPE)
+1 IF BGPPTYPE="D"
XECUTE ^BGPINDB(BGPIC,4)
DO W^BGP1DP("",0,1,BGPPTYPE)
+2 ;I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGP1NPLT) S BGPINDB=BGPIC D NPL1^BGP1NPLP ;printed nat gpra list
+3 ;I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGP1NPLT) S BGPINDB=BGPIC D CT^BGP1DSTM ;printed nat gpra SEARCH TEMPLATE
End DoDot:1
+4 QUIT
SUMP ;
+1 IF BGPIC=""
SET BGPIFTR=1
+2 ;NON GPRA
IF BGPRTYPE=1
DO ^BGP1DSPN
+3 ;GPRA
IF BGPRTYPE=1
DO ^BGP1DSP
+4 IF BGPRTYPE=1
DO ^BGP1SDPN
+5 IF BGPRTYPE=1
DO ^BGP1SDP
+6 IF BGPRTYPE=7
DO ^BGP1DSPO
+7 IF BGPRTYPE=7
DO ^BGP1SDPO
+8 DO ^BGP1DS
+9 ;print comp pt list
IF $GET(BGPCPPL)
DO CPPL1^BGP1DCLP
+10 DO EXIT
+11 QUIT
KITM ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BGP1D",BGPJ,BGPH)
+3 KILL ^XTMP("BGP1DNP",BGPJ,BGPH)
+4 KILL ^XTMP("BGP18CPL",BGPJ,BGPH)
+5 QUIT
SETEXCEL ;EP
+1 IF $GET(BGPAREAA)
Begin DoDot:1
+2 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+3 SET N=^BGPGPDCB(X,0)
+4 SET (D,L)=""
+5 SET L=$PIECE(N,U,9)
IF L
SET L=$ORDER(^AUTTLOC("C",L,0))
IF L
SET D=$PIECE($GET(^AUTTLOC(L,1)),U,3)
SET L=$SELECT(L:$PIECE(^DIC(4,L,0),U),1:"?????")
+6 SET BGPEI(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+7 SET BGPEI2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI2(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+8 SET BGPEIDV1(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV1(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+9 SET BGPEIDV2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV2(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+10 SET BGPEIDV3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV3(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+11 SET BGPONN1(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN1(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+12 SET BGPONN2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN2(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+13 SET BGPONN3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN3(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+14 SET BGPONN4(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP1UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN4(X),U,P)=$$DATE^BGP1UTL($PIECE(N,U,Y))
SET P=P+1
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
QUIT
+17 QUIT
EXIT ;
+1 IF BGPPTYPE'="P"
QUIT
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
SET DIR("A")="End of report. Press ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 QUIT
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
