BGP8DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
PRINT ;
I $G(BGPDASH) D ^BGP8DBPR Q ;dashboard
I $O(BGPDESGP(0)) D Q ;desg provider print
.S BGPQUIT="",BGPFDESG=0
.S BGPXX2=0 F S BGPXX2=$O(BGPDESGP(BGPXX2)) Q:BGPXX2'=+BGPXX2!(BGPQUIT) D
..Q:$G(BGPAREAA)
..Q:BGPROT="D" ;only delimited so don't bother with print
..S BGPFDESG=BGPFDESG+1
..S BGPRPT=$P(BGPDESGP(BGPXX2),U,1)
..S BGPDELF=$P(BGPDESGP(BGPXX2),U,2)
..S BGPDESGP=BGPXX2
..K ^TMP($J)
..K BGPDELIM
..S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
..S ^TMP($J,"BGPDEL",0)=0
..S BGPQUIT=""
..S BGPPTYPE="P"
..S BGPQHDR=0
..I BGPFDESG'=1 W:$D(IOF) @IOF
..D ^BGP8DH
..I BGPQHDR S BGPQUIT=1 D KITM Q
..S BGPGPG=0
..S BGPQUIT=""
..D PRINT1
..K ^TMP($J)
..Q
.;NOW DO DELIMITED IF NEEDED
.I BGPROT="P" D KITM Q
.S BGPQUIT=""
.I '$D(BGPGUI) D ^%ZISC ;close printer device
.S BGPXX2=0 F S BGPXX2=$O(BGPDESGP(BGPXX2)) Q:BGPXX2'=+BGPXX2!(BGPQUIT) D
..Q:$G(BGPAREAA)
..S BGPRPT=$P(BGPDESGP(BGPXX2),U,1)
..S BGPDELF=$P(BGPDESGP(BGPXX2),U,2)
..S BGPDESGP=BGPXX2
..K ^TMP($J)
..K BGPDELIM
..S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
..S ^TMP($J,"BGPDEL",0)=0
..S BGPQUIT=""
..S BGPPTYPE="D"
..S BGPQHDR=0
..D ^BGP8DH
..I BGPQHDR S BGPQUIT=1 D KITM Q
..S BGPGPG=0
..S BGPQUIT=""
..D PRINT1
..D SAVEDEL^BGP8PDL ;D ^BGP8PDL ;create ^tmp of delimited report
..S BGPIFTR=1
..K ^XTMP("BGP8D",BGPJ,BGPH)
..K ^XTMP("BGP8DNP",BGPJ,BGPH)
..K ^XTMP("BGP28CPL",BGPJ,BGPH)
..K ^TMP($J)
..Q
.Q
PRINTN ;
I $G(BGPDASH) D PRINTN^BGP8DBPR 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 ^BGP8DH ;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 ^BGP8DH
S BGPGPG=0
S BGPQUIT=""
D PRINT1
D SAVEDEL^BGP8PDL ;D ^BGP8PDL ;create ^tmp of delimited report
S BGPIFTR=1
K ^XTMP("BGP8D",BGPJ,BGPH)
K ^XTMP("BGP8DNP",BGPJ,BGPH)
K ^XTMP("BGP28CPL",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(^BGPINDR(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^BGP8DP($E(T,1,S),0,1,BGPPTYPE) ;W !,$E(T,1,S)
D W^BGP8DP($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(^BGPNPLR(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(^BGPNPLR(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^BGP8DPH
.I '$G(BGPSUMON) D W^BGP8DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP8DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP8DP("",0,1,BGPPTYPE)
.S BGPGDEV=1,BGPRTYPE=9 ;control variable
.S BGPDEVOR=0 F S BGPDEVOR=$O(^BGPINDR("ADEVO",BGPDEVOR)) Q:BGPDEVOR'=+BGPDEVOR!(BGPQUIT) D
..S BGPIC=$O(^BGPINDR("ADEVO",BGPDEVOR,0)) Q:BGPIC=""
..I $P(^BGPINDR(BGPIC,0),U,14),$D(BGPIND(BGPIC)) D PRINT2
..Q:BGPQUIT
..I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list
..I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;printed nat gpra SEARCH TEMPLATE
.S BGPRTYPE=1 K BGPGDEV
.Q:BGPQUIT
.;NOW PRINT developmental summary sheet
.D ^BGP8DSPD ;DEVELOPMENTAL
.D ^BGP8SDPD ;SUMMARY DETAIL
.;now print gpra divider page
.;if no lists except developmental skip this
.I $G(BGPNPL),$$ALLDEV() Q
.I '$G(BGPSUMON) D HEADER^BGP8DPH
.I '$G(BGPSUMON) D W^BGP8DP("The following section contains GPRA/GPRAMA and Non-GPRA Selected Topics",0,3,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP8DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP8DP("Measures and GPRA/GPRAMA Measures.",0,1,BGPPTYPE)
.I '$G(BGPSUMON) D W^BGP8DP("",0,1,BGPPTYPE)
;set back to report 1
I BGPRTYPE=1,$G(BGPNPL),$$ALLDEV() Q
S BGPORDSE=0 F S BGPORDSE=$O(^BGPINDR("AOI",BGPORDSE)) Q:BGPORDSE'=+BGPORDSE!(BGPQUIT) S BGPIC=$O(^BGPINDR("AOI",BGPORDSE,0)) I $D(BGPIND(BGPIC)) D
.Q:BGPQUIT
.I BGPRTYPE=1 Q:$P($G(^BGPINDR(BGPIC,13)),U,3) ;dev only, not nat gpra report
.I BGPRTYPE=4 Q:$P($G(^BGPINDR(BGPIC,13)),U,4) ;not on selected measures report
.I BGPRTYPE=2 Q:'$P($G(^BGPINDR(BGPIC,12)),U,7) ;not on ipc report
.D PRINT2
.I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list
.I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;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(^BGPINDR(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPINDR(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^BGP8DPH Q:BGPQUIT
.D W^BGP8DP(^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^BGP8DPH ;header for all measures
.I $G(BGPDNT) G CALC
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
.D WTITLE(BGPIC)
.;W !,$P(^BGPINDR(BGPIC,0),U,3),!
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
.D W^BGP8DP("Denominator(s):",0,1,BGPPTYPE)
.S BGPNODE=$S(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,BGPRTYPE=2:94,1:61)
.I BGPRTYPE=4 S BGPNODE=$S(BGPINDG="D":87,BGPINDG="C":89,BGPINDG="W":92,BGPINDG="I":94,BGPINDG="P":96,1:BGPNODE)
.S BGPX=0 F S BGPX=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...;I BGPRTYPE=4,'$D(^BGPINDR(BGPIC,BGPNODE,BGPY,12,"B",BGPINDR)) Q ;not this measure type on selected
...D WP
...Q
..Q
.Q:BGPQUIT
.I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
.D W^BGP8DP("Numerator(s):",0,2,BGPPTYPE)
.S BGPNODE=$S(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,BGPRTYPE=2:95,1:62)
.I BGPRTYPE=4 S BGPNODE=$S(BGPINDG="D":88,BGPINDG="C":91,BGPINDG="W":93,BGPINDG="I":95,BGPINDG="P":97,1:BGPNODE)
.S BGPX=0 F S BGPX=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPINDR(BGPIC,BGPNODE,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...;I BGPRTYPE=4,'$D(^BGPINDR(BGPIC,BGPNODE,BGPY,12,"B",BGPINDR)) Q ;not this measure type on selected
...D WP
...Q
..Q
.Q:BGPQUIT
.S BGPNODE=11
.I BGPRTYPE=1,$O(^BGPINDR(BGPIC,54,0)) S BGPNODE=54
.I BGPRTYPE=7,$O(^BGPINDR(BGPIC,56,0)) S BGPNODE=56
.I BGPRTYPE=9,$O(^BGPINDR(BGPIC,58,0)) S BGPNODE=58
.I BGPRTYPE=2,$O(^BGPINDR(BGPIC,21,0)) S BGPNODE=21
.D W^BGP8DP("Logic:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDR(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
..D W^BGP8DP(^BGPINDR(BGPIC,BGPNODE,BGPX,0),0,1,BGPPTYPE)
.I BGPRTYPE=9 G CALC
.I BGPRTYPE=2 G S
.D W^BGP8DP("Performance Measure Description:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDR(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
..D W^BGP8DP(^BGPINDR(BGPIC,$S($G(BGPNGR09):57,1:51),BGPX,0),0,1,BGPPTYPE)
.I $O(^BGPINDR(BGPIC,52,0)) D W^BGP8DP("Past Performance and/or Target:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDR(BGPIC,52,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
..D W^BGP8DP(^BGPINDR(BGPIC,52,BGPX,0),0,1,BGPPTYPE)
S .I $O(^BGPINDR(BGPIC,55,0)) D W^BGP8DP("Source:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPINDR(BGPIC,55,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-3) D HEADER^BGP8DPH Q:BGPQUIT
..D W^BGP8DP(^BGPINDR(BGPIC,55,BGPX,0),0,1,BGPPTYPE)
.I '$O(^BGPINDR(BGPIC,55,0)) D W^BGP8DP("",0,1,BGPPTYPE)
CALC .I '$G(BGPSUMON) D W^BGP8DP($P(^BGPINDR(BGPIC,0),U,3),0,2,BGPPTYPE),W^BGP8DP(" ",0,1,BGPPTYPE)
.S BGPFONE=1 I BGPPTYPE="P" X ^BGPINDR(BGPIC,3) D W^BGP8DP("",0,1,BGPPTYPE) S BGPFONE=0
.S BGPFONE=1 I BGPPTYPE="D" X ^BGPINDR(BGPIC,4) D W^BGP8DP("",0,1,BGPPTYPE) S BGPFONE=0
.;I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list
.;I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;printed nat gpra SEARCH TEMPLATE
Q
SUMP ;
I BGPIC="" S BGPIFTR=1
I BGPRTYPE=1 D ^BGP8DSPN ;NON GPRA
I BGPRTYPE=1 D ^BGP8DSP ;GPRA
I BGPRTYPE=1 D ^BGP8SDPN
I BGPRTYPE=1 D ^BGP8SDP
I BGPRTYPE=7 D ^BGP8DSPO
I BGPRTYPE=7 D ^BGP8SDPO
D ^BGP8DS
I $G(BGPCPPL) D CPPL1^BGP8DCLP ;print comp pt list
D EXIT
Q
KITM ;
K ^TMP($J)
K ^XTMP("BGP8D",BGPJ,BGPH)
K ^XTMP("BGP8DNP",BGPJ,BGPH)
K ^XTMP("BGP28CPL",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=^BGPGPDCR(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^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPEI2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI2(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPEI3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI3(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..;S BGPEI4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..;S BGPEI5(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI5(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..;S BGPEI6(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI6(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPEIDV1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV1(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPEIDV2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV2(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPEIDV3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV3(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPEIDV4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEIDV4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPONN1(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN1(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPONN2(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN2(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPONN3(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN3(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..S BGPONN4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
..;S BGPONN5(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN5(X),U,P)=$$DATE^BGP8UTL($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
BGP8DP ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
PRINT ;
+1 ;dashboard
IF $GET(BGPDASH)
DO ^BGP8DBPR
QUIT
+2 ;desg provider print
IF $ORDER(BGPDESGP(0))
Begin DoDot:1
+3 SET BGPQUIT=""
SET BGPFDESG=0
+4 SET BGPXX2=0
FOR
SET BGPXX2=$ORDER(BGPDESGP(BGPXX2))
IF BGPXX2'=+BGPXX2!(BGPQUIT)
QUIT
Begin DoDot:2
+5 IF $GET(BGPAREAA)
QUIT
+6 ;only delimited so don't bother with print
IF BGPROT="D"
QUIT
+7 SET BGPFDESG=BGPFDESG+1
+8 SET BGPRPT=$PIECE(BGPDESGP(BGPXX2),U,1)
+9 SET BGPDELF=$PIECE(BGPDESGP(BGPXX2),U,2)
+10 SET BGPDESGP=BGPXX2
+11 KILL ^TMP($JOB)
+12 KILL BGPDELIM
+13 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
+14 SET ^TMP($JOB,"BGPDEL",0)=0
+15 SET BGPQUIT=""
+16 SET BGPPTYPE="P"
+17 SET BGPQHDR=0
+18 IF BGPFDESG'=1
IF $DATA(IOF)
WRITE @IOF
+19 DO ^BGP8DH
+20 IF BGPQHDR
SET BGPQUIT=1
DO KITM
QUIT
+21 SET BGPGPG=0
+22 SET BGPQUIT=""
+23 DO PRINT1
+24 KILL ^TMP($JOB)
+25 QUIT
End DoDot:2
+26 ;NOW DO DELIMITED IF NEEDED
+27 IF BGPROT="P"
DO KITM
QUIT
+28 SET BGPQUIT=""
+29 ;close printer device
IF '$DATA(BGPGUI)
DO ^%ZISC
+30 SET BGPXX2=0
FOR
SET BGPXX2=$ORDER(BGPDESGP(BGPXX2))
IF BGPXX2'=+BGPXX2!(BGPQUIT)
QUIT
Begin DoDot:2
+31 IF $GET(BGPAREAA)
QUIT
+32 SET BGPRPT=$PIECE(BGPDESGP(BGPXX2),U,1)
+33 SET BGPDELF=$PIECE(BGPDESGP(BGPXX2),U,2)
+34 SET BGPDESGP=BGPXX2
+35 KILL ^TMP($JOB)
+36 KILL BGPDELIM
+37 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
+38 SET ^TMP($JOB,"BGPDEL",0)=0
+39 SET BGPQUIT=""
+40 SET BGPPTYPE="D"
+41 SET BGPQHDR=0
+42 DO ^BGP8DH
+43 IF BGPQHDR
SET BGPQUIT=1
DO KITM
QUIT
+44 SET BGPGPG=0
+45 SET BGPQUIT=""
+46 DO PRINT1
+47 ;D ^BGP8PDL ;create ^tmp of delimited report
DO SAVEDEL^BGP8PDL
+48 SET BGPIFTR=1
+49 KILL ^XTMP("BGP8D",BGPJ,BGPH)
+50 KILL ^XTMP("BGP8DNP",BGPJ,BGPH)
+51 KILL ^XTMP("BGP28CPL",BGPJ,BGPH)
+52 KILL ^TMP($JOB)
+53 QUIT
End DoDot:2
+54 QUIT
End DoDot:1
QUIT
PRINTN ;
+1 ;dashboard
IF $GET(BGPDASH)
DO PRINTN^BGP8DBPR
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 ^BGP8DH
+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 ^BGP8DH
+7 SET BGPGPG=0
+8 SET BGPQUIT=""
+9 DO PRINT1
+10 ;D ^BGP8PDL ;create ^tmp of delimited report
DO SAVEDEL^BGP8PDL
+11 SET BGPIFTR=1
+12 KILL ^XTMP("BGP8D",BGPJ,BGPH)
+13 KILL ^XTMP("BGP8DNP",BGPJ,BGPH)
+14 KILL ^XTMP("BGP28CPL",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(^BGPINDR(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^BGP8DP($EXTRACT(T,1,S),0,1,BGPPTYPE)
+9 ;W !,$E(T,(S+1),$L(T)),!
DO W^BGP8DP($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(^BGPNPLR(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(^BGPNPLR(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^BGP8DPH
+5 IF '$GET(BGPSUMON)
DO W^BGP8DP("The following section contains GPRA Developmental topics and measures",0,2,BGPPTYPE)
+6 IF '$GET(BGPSUMON)
DO W^BGP8DP("followed by the GPRA Developmental Measures Clinical Performance Summary.",0,1,BGPPTYPE)
+7 IF '$GET(BGPSUMON)
DO W^BGP8DP("",0,1,BGPPTYPE)
+8 ;control variable
SET BGPGDEV=1
SET BGPRTYPE=9
+9 SET BGPDEVOR=0
FOR
SET BGPDEVOR=$ORDER(^BGPINDR("ADEVO",BGPDEVOR))
IF BGPDEVOR'=+BGPDEVOR!(BGPQUIT)
QUIT
Begin DoDot:2
+10 SET BGPIC=$ORDER(^BGPINDR("ADEVO",BGPDEVOR,0))
IF BGPIC=""
QUIT
+11 IF $PIECE(^BGPINDR(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(BGPYNPLT)
SET BGPINDG=BGPIC
DO NPL1^BGP8NPLP
+14 ;printed nat gpra SEARCH TEMPLATE
IF $GET(BGPNPL)
IF $DATA(BGPINDL(BGPIC))
IF $DATA(BGPYNPLT)
SET BGPINDG=BGPIC
DO CT^BGP8DSTM
End DoDot:2
+15 SET BGPRTYPE=1
KILL BGPGDEV
+16 IF BGPQUIT
QUIT
+17 ;NOW PRINT developmental summary sheet
+18 ;DEVELOPMENTAL
DO ^BGP8DSPD
+19 ;SUMMARY DETAIL
DO ^BGP8SDPD
+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^BGP8DPH
+24 IF '$GET(BGPSUMON)
DO W^BGP8DP("The following section contains GPRA/GPRAMA and Non-GPRA Selected Topics",0,3,BGPPTYPE)
+25 IF '$GET(BGPSUMON)
DO W^BGP8DP("and measures followed by the Clinical Performance Summaries for Non-GPRA",0,1,BGPPTYPE)
+26 IF '$GET(BGPSUMON)
DO W^BGP8DP("Measures and GPRA/GPRAMA Measures.",0,1,BGPPTYPE)
+27 IF '$GET(BGPSUMON)
DO W^BGP8DP("",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(^BGPINDR("AOI",BGPORDSE))
IF BGPORDSE'=+BGPORDSE!(BGPQUIT)
QUIT
SET BGPIC=$ORDER(^BGPINDR("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(^BGPINDR(BGPIC,13)),U,3)
QUIT
+33 ;not on selected measures report
IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDR(BGPIC,13)),U,4)
QUIT
+34 ;not on ipc report
IF BGPRTYPE=2
IF '$PIECE($GET(^BGPINDR(BGPIC,12)),U,7)
QUIT
+35 DO PRINT2
+36 ;printed nat gpra list
IF $GET(BGPNPL)
IF $DATA(BGPINDL(BGPIC))
IF '$DATA(BGPYNPLT)
SET BGPINDG=BGPIC
DO NPL1^BGP8NPLP
+37 ;printed nat gpra SEARCH TEMPLATE
IF $GET(BGPNPL)
IF $DATA(BGPINDL(BGPIC))
IF $DATA(BGPYNPLT)
SET BGPINDG=BGPIC
DO CT^BGP8DSTM
End DoDot:1
+38 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(^BGPINDR(BGPIC,BGPNODE,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPINDR(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^BGP8DPH
IF BGPQUIT
QUIT
+3 DO W^BGP8DP(^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^BGP8DPH
+4 IF $GET(BGPDNT)
GOTO CALC
+5 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+6 DO WTITLE(BGPIC)
+7 ;W !,$P(^BGPINDR(BGPIC,0),U,3),!
+8 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+9 DO W^BGP8DP("Denominator(s):",0,1,BGPPTYPE)
+10 SET BGPNODE=$SELECT(BGPRTYPE=1:81,BGPRTYPE=4:61,BGPRTYPE=7:83,BGPRTYPE=9:85,BGPRTYPE=2:94,1:61)
+11 IF BGPRTYPE=4
SET BGPNODE=$SELECT(BGPINDG="D":87,BGPINDG="C":89,BGPINDG="W":92,BGPINDG="I":94,BGPINDG="P":96,1:BGPNODE)
+12 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDR(BGPIC,BGPNODE,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+13 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPINDR(BGPIC,BGPNODE,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+14 ;I BGPRTYPE=4,'$D(^BGPINDR(BGPIC,BGPNODE,BGPY,12,"B",BGPINDR)) Q ;not this measure type on selected
+15 DO WP
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 IF BGPQUIT
QUIT
+19 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+20 DO W^BGP8DP("Numerator(s):",0,2,BGPPTYPE)
+21 SET BGPNODE=$SELECT(BGPRTYPE=1:82,BGPRTYPE=4:62,BGPRTYPE=7:84,BGPRTYPE=9:86,BGPRTYPE=2:95,1:62)
+22 IF BGPRTYPE=4
SET BGPNODE=$SELECT(BGPINDG="D":88,BGPINDG="C":91,BGPINDG="W":93,BGPINDG="I":95,BGPINDG="P":97,1:BGPNODE)
+23 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDR(BGPIC,BGPNODE,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+24 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPINDR(BGPIC,BGPNODE,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+25 ;I BGPRTYPE=4,'$D(^BGPINDR(BGPIC,BGPNODE,BGPY,12,"B",BGPINDR)) Q ;not this measure type on selected
+26 DO WP
+27 QUIT
End DoDot:3
+28 QUIT
End DoDot:2
+29 IF BGPQUIT
QUIT
+30 SET BGPNODE=11
+31 IF BGPRTYPE=1
IF $ORDER(^BGPINDR(BGPIC,54,0))
SET BGPNODE=54
+32 IF BGPRTYPE=7
IF $ORDER(^BGPINDR(BGPIC,56,0))
SET BGPNODE=56
+33 IF BGPRTYPE=9
IF $ORDER(^BGPINDR(BGPIC,58,0))
SET BGPNODE=58
+34 IF BGPRTYPE=2
IF $ORDER(^BGPINDR(BGPIC,21,0))
SET BGPNODE=21
+35 DO W^BGP8DP("Logic:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDR(BGPIC,BGPNODE,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+36 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+37 DO W^BGP8DP(^BGPINDR(BGPIC,BGPNODE,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+38 IF BGPRTYPE=9
GOTO CALC
+39 IF BGPRTYPE=2
GOTO S
+40 DO W^BGP8DP("Performance Measure Description:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDR(BGPIC,$SELECT($GET(BGPNGR09):57,1:51),BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+41 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+42 DO W^BGP8DP(^BGPINDR(BGPIC,$SELECT($GET(BGPNGR09):57,1:51),BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+43 IF $ORDER(^BGPINDR(BGPIC,52,0))
DO W^BGP8DP("Past Performance and/or Target:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDR(BGPIC,52,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+44 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+45 DO W^BGP8DP(^BGPINDR(BGPIC,52,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
S IF $ORDER(^BGPINDR(BGPIC,55,0))
DO W^BGP8DP("Source:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPINDR(BGPIC,55,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+1 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-3)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
+2 DO W^BGP8DP(^BGPINDR(BGPIC,55,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+3 IF '$ORDER(^BGPINDR(BGPIC,55,0))
DO W^BGP8DP("",0,1,BGPPTYPE)
CALC IF '$GET(BGPSUMON)
DO W^BGP8DP($PIECE(^BGPINDR(BGPIC,0),U,3),0,2,BGPPTYPE)
DO W^BGP8DP(" ",0,1,BGPPTYPE)
+1 SET BGPFONE=1
IF BGPPTYPE="P"
XECUTE ^BGPINDR(BGPIC,3)
DO W^BGP8DP("",0,1,BGPPTYPE)
SET BGPFONE=0
+2 SET BGPFONE=1
IF BGPPTYPE="D"
XECUTE ^BGPINDR(BGPIC,4)
DO W^BGP8DP("",0,1,BGPPTYPE)
SET BGPFONE=0
+3 ;I $G(BGPNPL),$D(BGPINDL(BGPIC)),'$D(BGPYNPLT) S BGPINDG=BGPIC D NPL1^BGP8NPLP ;printed nat gpra list
+4 ;I $G(BGPNPL),$D(BGPINDL(BGPIC)),$D(BGPYNPLT) S BGPINDG=BGPIC D CT^BGP8DSTM ;printed nat gpra SEARCH TEMPLATE
End DoDot:1
+5 QUIT
SUMP ;
+1 IF BGPIC=""
SET BGPIFTR=1
+2 ;NON GPRA
IF BGPRTYPE=1
DO ^BGP8DSPN
+3 ;GPRA
IF BGPRTYPE=1
DO ^BGP8DSP
+4 IF BGPRTYPE=1
DO ^BGP8SDPN
+5 IF BGPRTYPE=1
DO ^BGP8SDP
+6 IF BGPRTYPE=7
DO ^BGP8DSPO
+7 IF BGPRTYPE=7
DO ^BGP8SDPO
+8 DO ^BGP8DS
+9 ;print comp pt list
IF $GET(BGPCPPL)
DO CPPL1^BGP8DCLP
+10 DO EXIT
+11 QUIT
KITM ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BGP8D",BGPJ,BGPH)
+3 KILL ^XTMP("BGP8DNP",BGPJ,BGPH)
+4 KILL ^XTMP("BGP28CPL",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=^BGPGPDCR(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^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+7 SET BGPEI2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI2(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+8 SET BGPEI3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI3(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+9 ;S BGPEI4(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI4(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
+10 ;S BGPEI5(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI5(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
+11 ;S BGPEI6(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI6(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
+12 SET BGPEIDV1(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV1(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+13 SET BGPEIDV2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV2(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+14 SET BGPEIDV3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV3(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+15 SET BGPEIDV4(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEIDV4(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+16 SET BGPONN1(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN1(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+17 SET BGPONN2(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN2(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+18 SET BGPONN3(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN3(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+19 SET BGPONN4(X)=L_U_$PIECE(N,U,9)_U_D_U_$$DATE^BGP8UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPONN4(X),U,P)=$$DATE^BGP8UTL($PIECE(N,U,Y))
SET P=P+1
+20 ;S BGPONN5(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP8UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPONN5(X),U,P)=$$DATE^BGP8UTL($P(N,U,Y)),P=P+1
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
QUIT
+23 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
