BGP2DBPR ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
;
PRINT ;
K ^TMP($J)
S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
S BGPQUIT=""
S ^TMP($J,"BGPDEL",0)=0
S BGPIFTR=""
I BGPROT="D" G DEL
S BGPPTYPE="P"
S BGPQHDR=0
D ^BGP2DH ;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 ^BGP2DH
S BGPGPG=0
S BGPQUIT=""
D PRINT1
D SAVEDEL^BGP2PDL ;D ^BGP2PDL ;create ^tmp of delimited report
S BGPIFTR=1
K ^XTMP("BGP2D",BGPJ,BGPH)
K ^XTMP("BGP2DNP",BGPJ,BGPH)
K ^XTMP("BGP20CPL",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(^BGPINDW(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^BGP2DP($E(T,1,S),0,1,BGPPTYPE) ;W !,$E(T,1,S)
D W^BGP2DP($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(^BGPNPLW(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(^BGPNPLW(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
NEW BGPPC,BGPORD
I BGPPTYPE="P" D HEADER^BGP2DPH
D W^BGP2DP($S($G(BGPAREAA):"AREA AGGREGATE ",1:"")_"Dashboard Report - "_$P(^DIC(4,$S($G(BGPISITE):BGPISITE,1:DUZ(2)),0),U,1),1,2,BGPPTYPE)
D W^BGP2DP(" ",0,1,BGPPTYPE)
D COLHDR
S BGPORD=0
S Y=$O(^BGPCTRL("B",2012,0))
S Y=$P(^BGPCTRL(Y,0),U,8)
S BGPPERY=$$FMDIFF^XLFDT(DT,Y)
S BGPPERY=BGPPERY/365,BGPPERY=BGPPERY*100,BGPPERY=BGPPERY+.5,BGPPERY=$J(BGPPERY,3,0),BGPPERY=$$STRIP^XLFSTR(BGPPERY," ")
F S BGPORD=$O(^BGPINDWC("ADASH",BGPORD)) Q:BGPORD'=+BGPORD!(BGPQUIT) D
.S BGPPC=0 F S BGPPC=$O(^BGPINDWC("ADASH",BGPORD,BGPPC)) Q:BGPPC'=+BGPPC!(BGPQUIT) D
..;GET VALUES FOR PREVIOUS YEAR, CURRENT YEAR, GET DENOM VALUE FOR 2012
..S BGPDF=$P(^BGPINDWC(BGPPC,0),U,8)
..;get denom value
..S BGPNP=$P(^DD(90548.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
..S BGPCYD=$$V^BGP2DP1C(1,BGPRPT,N,P,1,1)
..S BGPPRD=$$V^BGP2DP1C(2,BGPRPT,N,P,1,1)
..;get numerator values
..S BGPNF=$P(^BGPINDWC(BGPPC,0),U,9)
..S BGPNP=$P(^DD(90548.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
..D SETN
..;now figure out out # needed and on track status
..I '$P($G(^BGPINDWC(BGPPC,23)),U,3) D
...S BGPGOAL=+$P($G(^BGPINDWC(BGPPC,14)),U,8)
...S BGPNEG=$P($G(^BGPINDWC(BGPPC,23)),U,5)
...S BGPOT=""
...S BGPGG=BGPGOAL/100
...S BGPNEED1=BGPGG*BGPCYD,BGPNEED1=BGPNEED1+.9,BGPNEED1=$P(BGPNEED1,".")
...S BGPCYPER=BGPCYP/100
...S BGPNEED2=BGPCYPER*BGPCYD,BGPNEED2=BGPNEED2+.9,BGPNEED2=$P(BGPNEED2,".") ;;;
...S BGPNEED=BGPNEED1-BGPNEED2
...I BGPNEG S BGPNEED=BGPNEED2-BGPNEED1
...;S BGPNEED=BGPNEED+.5,BGPNEED=$P(BGPNEED,".",1)
...S BGPCOLG=BGPCYPER/BGPGG,BGPCOLG=BGPCOLG*100
...I 'BGPNEG,BGPCOLG'<100 S BGPOT="ON TRACK" Q
...I BGPNEG,BGPCOLG'>100 S BGPOT="ON TRACK" Q
...I 'BGPNEG,BGPCOLG'<BGPPERY S BGPOT="WITHIN RANGE" Q
...I BGPNEG,BGPCOLG'>BGPPERY S BGPOT="WITHIN RANGE" Q
...S BGPOT="NOT ON TRACK"
..I $P($G(^BGPINDWC(BGPPC,23)),U,3) D
...S BGPGOAL=$P($G(^BGPINDWC(BGPPC,14)),U,8)
...S BGPOT=""
...S BGPGP=$P($G(^BGPINDWC(BGPPC,23)),U,4)
...S BGPGG=BGPGP/100
...;S BGPNGA=BGPGG*BGPPRN
...S BGPTN=BGPPRN*(1+BGPGG)
...S BGPTN=BGPTN+.9,BGPTN=$P(BGPTN,".")
...S BGPNEED=BGPTN-BGPCYN
...I BGPNEED<1 S BGPOT="ON TRACK" Q
...S G=BGPCYN/BGPTN
...I G'<BGPPERY S BGPOT="WITHIN RANGE" Q
...S BGPOT="NOT ON TRACK"
..;write out values for this measure
..I BGPPTYPE="P" I $Y>(IOSL-4) D HEADER^BGP2DPH Q:BGPQUIT D COLHDR
..I $P($G(^BGPINDWC(BGPPC,23)),U,1) D W^BGP2DP(" ",0,1,BGPPTYPE)
..D W^BGP2DP($P($G(^BGPINDWC(BGPPC,23)),U,2),0,1,BGPPTYPE,1,0)
..I BGPPTYPE="D" D
...D W^BGP2DP($S('$P(^BGPINDWC(BGPPC,23),U,3):BGPGOAL,1:+BGPTN),0,0,BGPPTYPE,2,30)
...I '$P(^BGPINDWC(BGPPC,23),U,3) D
....D W^BGP2DP($S(BGPPTYPE="D":$$SB($J(BGPPRP,5,1)),1:$J(BGPPRP,5,1)),0,0,BGPPTYPE,3,39)
....D W^BGP2DP(BGPCYN,0,0,BGPPTYPE,4,47)
....D W^BGP2DP(BGPCYD,0,0,BGPPTYPE,5,55)
....D W^BGP2DP($S(BGPPTYPE="D":$$SB($J(BGPCYP,5,1)),1:$J(BGPCYP,5,1)),0,0,BGPPTYPE,6,47)
....D W^BGP2DP($S(BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
...I $P(^BGPINDWC(BGPPC,23),U,3) D
....D W^BGP2DP($S(BGPPTYPE="D":BGPPRN,1:BGPPRN),0,0,BGPPTYPE,3,39)
....D W^BGP2DP($S(BGPPTYPE="D":BGPCYN,1:BGPCYN),0,0,BGPPTYPE,4,47)
....D W^BGP2DP(BGPCYN,0,0,BGPPTYPE,6,55)
....D W^BGP2DP($S(BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
...;D W^BGP2DP(BGPOT,0,0,BGPPTYPE,8,75)
..I BGPPTYPE="P" D
...D W^BGP2DP($S('$P(^BGPINDWC(BGPPC,23),U,3):$J(BGPGOAL,8),1:$$LBLK(+BGPTN,7)),0,0,BGPPTYPE,2,28)
...I '$P(^BGPINDWC(BGPPC,23),U,3) D
....D W^BGP2DP($S(BGPPTYPE="D":$$SB($J(BGPPRP,5,1)),1:$J(BGPPRP,5,1)),0,0,BGPPTYPE,3,40)
....D W^BGP2DP($$C(BGPCYN,0,8),0,0,BGPPTYPE,4,50)
....D W^BGP2DP($$C(BGPCYD,0,8),0,0,BGPPTYPE,5,60)
....D W^BGP2DP($S(BGPPTYPE="D":$$SB($J(BGPCYP,5,1)),1:$J(BGPCYP,5,1)),0,0,BGPPTYPE,6,70)
....D W^BGP2DP("# Needed to Achieve Target: "_$S(BGPNEED>0:$S(BGPNEG:"-",1:"")_BGPNEED,1:0),0,1,BGPPTYPE,0,5)
...I $P(^BGPINDWC(BGPPC,23),U,3) D
....D W^BGP2DP($S(BGPPTYPE="D":BGPPRN,1:$$C(BGPPRN,0,8)),0,0,BGPPTYPE,3,40)
....D W^BGP2DP($S(BGPPTYPE="D":BGPCYN,1:$$C(BGPCYN,0,8)),0,0,BGPPTYPE,4,50)
....D W^BGP2DP(BGPCYN,0,0,BGPPTYPE,7,70)
....D W^BGP2DP("# Needed to Achieve Target: "_$S(BGPNEED>0:BGPNEED,1:0),0,1,BGPPTYPE,,5)
...;D W^BGP2DP(BGPOT,0,0,BGPPTYPE,0,40)
..D W^BGP2DP(" ",0,1,BGPPTYPE)
I BGPPTYPE="P" D W^BGP2DP("*Results reflect services provided as of the date this report was run or the ",0,1,BGPPTYPE) D W^BGP2DP("report period end date, whichever is earlier",0,1,BGPPTYPE)
I BGPPTYPE="D" D W^BGP2DP("*Results reflect services provided as of the date this report was run or the report period end date, whichever is earlier",0,1,BGPPTYPE)
D W^BGP2DP(" ",0,1,BGPPTYPE)
Q
SETN ;EP - set numerator fields
S BGPCYN=$$V^BGP2DP1C(1,BGPRPT,N,P,2)
S BGPPRN=$$V^BGP2DP1C(2,BGPRPT,N,P,2)
S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"0.0")
S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"0.0")
Q
COLHDR ;
I BGPPTYPE="D" D Q
.I '$G(BGPAREAA) D W^BGP2DP("National/Site 2012 Target",0,1,BGPPTYPE,2)
.I $G(BGPAREAA) D W^BGP2DP("National/Area 2012 Target",0,1,BGPPTYPE,2)
.D W^BGP2DP("2011 Final",0,0,BGPPTYPE,3)
.D W^BGP2DP("Numerator",0,0,BGPPTYPE,4)
.D W^BGP2DP("Denominator",0,0,BGPPTYPE,5)
.D W^BGP2DP("2012*",0,0,BGPPTYPE,6)
.D W^BGP2DP("# Needed to Achieve Target",0,0,BGPPTYPE,7)
.;
D W^BGP2DP("National"_$S('$G(BGPAREAA):"/Site",1:"/Area"),0,1,BGPPTYPE,2,30)
D W^BGP2DP("2012",0,1,BGPPTYPE,2,30)
D W^BGP2DP("2011",0,0,BGPPTYPE,3,40)
D W^BGP2DP("Denom-",0,0,BGPPTYPE,,60)
D W^BGP2DP("2012*",0,0,BGPPTYPE,,70)
D W^BGP2DP("Target",0,1,BGPPTYPE,,30)
D W^BGP2DP("Final",0,0,BGPPTYPE,,40)
D W^BGP2DP("Numerator",0,0,BGPPTYPE,,50)
D W^BGP2DP("inator",0,0,BGPPTYPE,,60)
D W^BGP2DP("(Current)",0,0,BGPPTYPE,,70)
D W^BGP2DP($TR($J("",80)," ","-"),0,1,BGPPTYPE)
Q
WP ;
K ^UTILITY($J,"W")
S BGPZ=0,BGPLCNT=0
S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F S BGPZ=$O(^BGPINDW(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPINDW(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^BGP2DPH Q:BGPQUIT
.D W^BGP2DP(^UTILITY($J,"W",DIWL,Z,0),0,1,BGPPTYPE)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),X
Q
PRINT2 ;
Q
KITM ;
K ^TMP($J)
K ^XTMP("BGP2D",BGPJ,BGPH)
K ^XTMP("BGP2DNP",BGPJ,BGPH)
K ^XTMP("BGP28CPL",BGPJ,BGPH)
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
SB(X) ;EP - Strip leading and trailing blanks from X.
NEW %
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
AREA ;EP - AREA DASHBOARD PRINT
K ^TMP($J)
S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)
S BGPGPG=0
S BGPQUIT=""
S BGPIFTR=""
S ^TMP($J,"BGPDEL",0)=0
S BGPPTYPE="P"
I BGPROT="D" G DELA
D AREACP^BGP2DH1
S BGPQUIT="",BGPGPG=0,BGPRPT=0
D PRINT1
Q:BGPQUIT
I $G(BGPAREAA) K BGPAREAA D INDSITE S BGPAREAA=1
S BGPIFTR=1
Q:BGPROT="P"
DELA ;create delimited output file
S BGPQUIT="",BGPGPG=0,BGPRPT=0,BGPIFTR=""
D ^%ZISC ;close printer device
K ^TMP($J)
;D ^BGP2PDL ;create ^tmp of delimited report
S ^TMP($J,"BGPDEL",0)=0
S BGPPTYPE="D",BGPQUIT=0
D AREACP^BGP2DH
S BGPQUIT="",BGPGPG=0,BGPRPT=0
D PRINT1
I $G(BGPAREAA) K BGPAREAA D INDSITE S BGPAREAA=1
D SAVEDEL^BGP2PDL ;D ^BGP2PDL ;create ^tmp of delimited report
S BGPIFTR=1
K ^TMP($J)
Q
INDSITE ;
S BGPRPT=0 F S BGPRPT=$O(BGPSUL(BGPRPT)) Q:BGPRPT'=+BGPRPT!(BGPQUIT) D
.S BGPISITE=$P(^BGPGPDCW(BGPRPT,0),U,9),BGPISITE=$O(^AUTTLOC("C",BGPISITE,0))
.D PRINT1
.Q
Q
LBLK(V,L) ;left blank fill
NEW %,I
S %=$L(V),Z=L-% F I=1:1:Z S V=" "_V
Q V
BGP2DBPR ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
+3 ;
PRINT ;
+1 KILL ^TMP($JOB)
+2 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
+3 SET BGPQUIT=""
+4 SET ^TMP($JOB,"BGPDEL",0)=0
+5 SET BGPIFTR=""
+6 IF BGPROT="D"
GOTO DEL
+7 SET BGPPTYPE="P"
+8 SET BGPQHDR=0
+9 ;LORI
DO ^BGP2DH
+10 IF BGPQHDR
DO KITM
QUIT
+11 SET BGPGPG=0
+12 SET BGPQUIT=""
+13 DO PRINT1
+14 KILL ^TMP($JOB)
+15 IF BGPROT="P"
DO KITM
QUIT
+16 ;
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 ^BGP2DH
+7 SET BGPGPG=0
+8 SET BGPQUIT=""
+9 DO PRINT1
+10 ;D ^BGP2PDL ;create ^tmp of delimited report
DO SAVEDEL^BGP2PDL
+11 SET BGPIFTR=1
+12 KILL ^XTMP("BGP2D",BGPJ,BGPH)
+13 KILL ^XTMP("BGP2DNP",BGPJ,BGPH)
+14 KILL ^XTMP("BGP20CPL",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(^BGPINDW(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^BGP2DP($EXTRACT(T,1,S),0,1,BGPPTYPE)
+9 ;W !,$E(T,(S+1),$L(T)),!
DO W^BGP2DP($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(^BGPNPLW(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(^BGPNPLW(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 NEW BGPPC,BGPORD
+3 IF BGPPTYPE="P"
DO HEADER^BGP2DPH
+4 DO W^BGP2DP($SELECT($GET(BGPAREAA):"AREA AGGREGATE ",1:"")_"Dashboard Report - "_$PIECE(^DIC(4,$SELECT($GET(BGPISITE):BGPISITE,1:DUZ(2)),0),U,1),1,2,BGPPTYPE)
+5 DO W^BGP2DP(" ",0,1,BGPPTYPE)
+6 DO COLHDR
+7 SET BGPORD=0
+8 SET Y=$ORDER(^BGPCTRL("B",2012,0))
+9 SET Y=$PIECE(^BGPCTRL(Y,0),U,8)
+10 SET BGPPERY=$$FMDIFF^XLFDT(DT,Y)
+11 SET BGPPERY=BGPPERY/365
SET BGPPERY=BGPPERY*100
SET BGPPERY=BGPPERY+.5
SET BGPPERY=$JUSTIFY(BGPPERY,3,0)
SET BGPPERY=$$STRIP^XLFSTR(BGPPERY," ")
+12 FOR
SET BGPORD=$ORDER(^BGPINDWC("ADASH",BGPORD))
IF BGPORD'=+BGPORD!(BGPQUIT)
QUIT
Begin DoDot:1
+13 SET BGPPC=0
FOR
SET BGPPC=$ORDER(^BGPINDWC("ADASH",BGPORD,BGPPC))
IF BGPPC'=+BGPPC!(BGPQUIT)
QUIT
Begin DoDot:2
+14 ;GET VALUES FOR PREVIOUS YEAR, CURRENT YEAR, GET DENOM VALUE FOR 2012
+15 SET BGPDF=$PIECE(^BGPINDWC(BGPPC,0),U,8)
+16 ;get denom value
+17 SET BGPNP=$PIECE(^DD(90548.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+18 SET BGPCYD=$$V^BGP2DP1C(1,BGPRPT,N,P,1,1)
+19 SET BGPPRD=$$V^BGP2DP1C(2,BGPRPT,N,P,1,1)
+20 ;get numerator values
+21 SET BGPNF=$PIECE(^BGPINDWC(BGPPC,0),U,9)
+22 SET BGPNP=$PIECE(^DD(90548.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+23 DO SETN
+24 ;now figure out out # needed and on track status
+25 IF '$PIECE($GET(^BGPINDWC(BGPPC,23)),U,3)
Begin DoDot:3
+26 SET BGPGOAL=+$PIECE($GET(^BGPINDWC(BGPPC,14)),U,8)
+27 SET BGPNEG=$PIECE($GET(^BGPINDWC(BGPPC,23)),U,5)
+28 SET BGPOT=""
+29 SET BGPGG=BGPGOAL/100
+30 SET BGPNEED1=BGPGG*BGPCYD
SET BGPNEED1=BGPNEED1+.9
SET BGPNEED1=$PIECE(BGPNEED1,".")
+31 SET BGPCYPER=BGPCYP/100
+32 ;;;
SET BGPNEED2=BGPCYPER*BGPCYD
SET BGPNEED2=BGPNEED2+.9
SET BGPNEED2=$PIECE(BGPNEED2,".")
+33 SET BGPNEED=BGPNEED1-BGPNEED2
+34 IF BGPNEG
SET BGPNEED=BGPNEED2-BGPNEED1
+35 ;S BGPNEED=BGPNEED+.5,BGPNEED=$P(BGPNEED,".",1)
+36 SET BGPCOLG=BGPCYPER/BGPGG
SET BGPCOLG=BGPCOLG*100
+37 IF 'BGPNEG
IF BGPCOLG'<100
SET BGPOT="ON TRACK"
QUIT
+38 IF BGPNEG
IF BGPCOLG'>100
SET BGPOT="ON TRACK"
QUIT
+39 IF 'BGPNEG
IF BGPCOLG'<BGPPERY
SET BGPOT="WITHIN RANGE"
QUIT
+40 IF BGPNEG
IF BGPCOLG'>BGPPERY
SET BGPOT="WITHIN RANGE"
QUIT
+41 SET BGPOT="NOT ON TRACK"
End DoDot:3
+42 IF $PIECE($GET(^BGPINDWC(BGPPC,23)),U,3)
Begin DoDot:3
+43 SET BGPGOAL=$PIECE($GET(^BGPINDWC(BGPPC,14)),U,8)
+44 SET BGPOT=""
+45 SET BGPGP=$PIECE($GET(^BGPINDWC(BGPPC,23)),U,4)
+46 SET BGPGG=BGPGP/100
+47 ;S BGPNGA=BGPGG*BGPPRN
+48 SET BGPTN=BGPPRN*(1+BGPGG)
+49 SET BGPTN=BGPTN+.9
SET BGPTN=$PIECE(BGPTN,".")
+50 SET BGPNEED=BGPTN-BGPCYN
+51 IF BGPNEED<1
SET BGPOT="ON TRACK"
QUIT
+52 SET G=BGPCYN/BGPTN
+53 IF G'<BGPPERY
SET BGPOT="WITHIN RANGE"
QUIT
+54 SET BGPOT="NOT ON TRACK"
End DoDot:3
+55 ;write out values for this measure
+56 IF BGPPTYPE="P"
IF $Y>(IOSL-4)
DO HEADER^BGP2DPH
IF BGPQUIT
QUIT
DO COLHDR
+57 IF $PIECE($GET(^BGPINDWC(BGPPC,23)),U,1)
DO W^BGP2DP(" ",0,1,BGPPTYPE)
+58 DO W^BGP2DP($PIECE($GET(^BGPINDWC(BGPPC,23)),U,2),0,1,BGPPTYPE,1,0)
+59 IF BGPPTYPE="D"
Begin DoDot:3
+60 DO W^BGP2DP($SELECT('$PIECE(^BGPINDWC(BGPPC,23),U,3):BGPGOAL,1:+BGPTN),0,0,BGPPTYPE,2,30)
+61 IF '$PIECE(^BGPINDWC(BGPPC,23),U,3)
Begin DoDot:4
+62 DO W^BGP2DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPPRP,5,1)),1:$JUSTIFY(BGPPRP,5,1)),0,0,BGPPTYPE,3,39)
+63 DO W^BGP2DP(BGPCYN,0,0,BGPPTYPE,4,47)
+64 DO W^BGP2DP(BGPCYD,0,0,BGPPTYPE,5,55)
+65 DO W^BGP2DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPCYP,5,1)),1:$JUSTIFY(BGPCYP,5,1)),0,0,BGPPTYPE,6,47)
+66 DO W^BGP2DP($SELECT(BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
End DoDot:4
+67 IF $PIECE(^BGPINDWC(BGPPC,23),U,3)
Begin DoDot:4
+68 DO W^BGP2DP($SELECT(BGPPTYPE="D":BGPPRN,1:BGPPRN),0,0,BGPPTYPE,3,39)
+69 DO W^BGP2DP($SELECT(BGPPTYPE="D":BGPCYN,1:BGPCYN),0,0,BGPPTYPE,4,47)
+70 DO W^BGP2DP(BGPCYN,0,0,BGPPTYPE,6,55)
+71 DO W^BGP2DP($SELECT(BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
End DoDot:4
+72 ;D W^BGP2DP(BGPOT,0,0,BGPPTYPE,8,75)
End DoDot:3
+73 IF BGPPTYPE="P"
Begin DoDot:3
+74 DO W^BGP2DP($SELECT('$PIECE(^BGPINDWC(BGPPC,23),U,3):$JUSTIFY(BGPGOAL,8),1:$$LBLK(+BGPTN,7)),0,0,BGPPTYPE,2,28)
+75 IF '$PIECE(^BGPINDWC(BGPPC,23),U,3)
Begin DoDot:4
+76 DO W^BGP2DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPPRP,5,1)),1:$JUSTIFY(BGPPRP,5,1)),0,0,BGPPTYPE,3,40)
+77 DO W^BGP2DP($$C(BGPCYN,0,8),0,0,BGPPTYPE,4,50)
+78 DO W^BGP2DP($$C(BGPCYD,0,8),0,0,BGPPTYPE,5,60)
+79 DO W^BGP2DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPCYP,5,1)),1:$JUSTIFY(BGPCYP,5,1)),0,0,BGPPTYPE,6,70)
+80 DO W^BGP2DP("# Needed to Achieve Target: "_$SELECT(BGPNEED>0:$SELECT(BGPNEG:"-",1:"")_BGPNEED,1:0),0,1,BGPPTYPE,0,5)
End DoDot:4
+81 IF $PIECE(^BGPINDWC(BGPPC,23),U,3)
Begin DoDot:4
+82 DO W^BGP2DP($SELECT(BGPPTYPE="D":BGPPRN,1:$$C(BGPPRN,0,8)),0,0,BGPPTYPE,3,40)
+83 DO W^BGP2DP($SELECT(BGPPTYPE="D":BGPCYN,1:$$C(BGPCYN,0,8)),0,0,BGPPTYPE,4,50)
+84 DO W^BGP2DP(BGPCYN,0,0,BGPPTYPE,7,70)
+85 DO W^BGP2DP("# Needed to Achieve Target: "_$SELECT(BGPNEED>0:BGPNEED,1:0),0,1,BGPPTYPE,,5)
End DoDot:4
+86 ;D W^BGP2DP(BGPOT,0,0,BGPPTYPE,0,40)
End DoDot:3
+87 DO W^BGP2DP(" ",0,1,BGPPTYPE)
End DoDot:2
End DoDot:1
+88 IF BGPPTYPE="P"
DO W^BGP2DP("*Results reflect services provided as of the date this report was run or the ",0,1,BGPPTYPE)
DO W^BGP2DP("report period end date, whichever is earlier",0,1,BGPPTYPE)
+89 IF BGPPTYPE="D"
DO W^BGP2DP("*Results reflect services provided as of the date this report was run or the report period end date, whichever is earlier",0,1,BGPPTYPE)
+90 DO W^BGP2DP(" ",0,1,BGPPTYPE)
+91 QUIT
SETN ;EP - set numerator fields
+1 SET BGPCYN=$$V^BGP2DP1C(1,BGPRPT,N,P,2)
+2 SET BGPPRN=$$V^BGP2DP1C(2,BGPRPT,N,P,2)
+3 SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"0.0")
+4 SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"0.0")
+5 QUIT
COLHDR ;
+1 IF BGPPTYPE="D"
Begin DoDot:1
+2 IF '$GET(BGPAREAA)
DO W^BGP2DP("National/Site 2012 Target",0,1,BGPPTYPE,2)
+3 IF $GET(BGPAREAA)
DO W^BGP2DP("National/Area 2012 Target",0,1,BGPPTYPE,2)
+4 DO W^BGP2DP("2011 Final",0,0,BGPPTYPE,3)
+5 DO W^BGP2DP("Numerator",0,0,BGPPTYPE,4)
+6 DO W^BGP2DP("Denominator",0,0,BGPPTYPE,5)
+7 DO W^BGP2DP("2012*",0,0,BGPPTYPE,6)
+8 DO W^BGP2DP("# Needed to Achieve Target",0,0,BGPPTYPE,7)
+9 ;
End DoDot:1
QUIT
+10 DO W^BGP2DP("National"_$SELECT('$GET(BGPAREAA):"/Site",1:"/Area"),0,1,BGPPTYPE,2,30)
+11 DO W^BGP2DP("2012",0,1,BGPPTYPE,2,30)
+12 DO W^BGP2DP("2011",0,0,BGPPTYPE,3,40)
+13 DO W^BGP2DP("Denom-",0,0,BGPPTYPE,,60)
+14 DO W^BGP2DP("2012*",0,0,BGPPTYPE,,70)
+15 DO W^BGP2DP("Target",0,1,BGPPTYPE,,30)
+16 DO W^BGP2DP("Final",0,0,BGPPTYPE,,40)
+17 DO W^BGP2DP("Numerator",0,0,BGPPTYPE,,50)
+18 DO W^BGP2DP("inator",0,0,BGPPTYPE,,60)
+19 DO W^BGP2DP("(Current)",0,0,BGPPTYPE,,70)
+20 DO W^BGP2DP($TRANSLATE($JUSTIFY("",80)," ","-"),0,1,BGPPTYPE)
+21 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(^BGPINDW(BGPIC,BGPNODE,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPINDW(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^BGP2DPH
IF BGPQUIT
QUIT
+3 DO W^BGP2DP(^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 QUIT
KITM ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BGP2D",BGPJ,BGPH)
+3 KILL ^XTMP("BGP2DNP",BGPJ,BGPH)
+4 KILL ^XTMP("BGP28CPL",BGPJ,BGPH)
+5 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
SB(X) ;EP - Strip leading and trailing blanks from X.
+1 NEW %
+2 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+3 QUIT X
AREA ;EP - AREA DASHBOARD PRINT
+1 KILL ^TMP($JOB)
+2 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:IOSL)
+3 SET BGPGPG=0
+4 SET BGPQUIT=""
+5 SET BGPIFTR=""
+6 SET ^TMP($JOB,"BGPDEL",0)=0
+7 SET BGPPTYPE="P"
+8 IF BGPROT="D"
GOTO DELA
+9 DO AREACP^BGP2DH1
+10 SET BGPQUIT=""
SET BGPGPG=0
SET BGPRPT=0
+11 DO PRINT1
+12 IF BGPQUIT
QUIT
+13 IF $GET(BGPAREAA)
KILL BGPAREAA
DO INDSITE
SET BGPAREAA=1
+14 SET BGPIFTR=1
+15 IF BGPROT="P"
QUIT
DELA ;create delimited output file
+1 SET BGPQUIT=""
SET BGPGPG=0
SET BGPRPT=0
SET BGPIFTR=""
+2 ;close printer device
DO ^%ZISC
+3 KILL ^TMP($JOB)
+4 ;D ^BGP2PDL ;create ^tmp of delimited report
+5 SET ^TMP($JOB,"BGPDEL",0)=0
+6 SET BGPPTYPE="D"
SET BGPQUIT=0
+7 DO AREACP^BGP2DH
+8 SET BGPQUIT=""
SET BGPGPG=0
SET BGPRPT=0
+9 DO PRINT1
+10 IF $GET(BGPAREAA)
KILL BGPAREAA
DO INDSITE
SET BGPAREAA=1
+11 ;D ^BGP2PDL ;create ^tmp of delimited report
DO SAVEDEL^BGP2PDL
+12 SET BGPIFTR=1
+13 KILL ^TMP($JOB)
+14 QUIT
INDSITE ;
+1 SET BGPRPT=0
FOR
SET BGPRPT=$ORDER(BGPSUL(BGPRPT))
IF BGPRPT'=+BGPRPT!(BGPQUIT)
QUIT
Begin DoDot:1
+2 SET BGPISITE=$PIECE(^BGPGPDCW(BGPRPT,0),U,9)
SET BGPISITE=$ORDER(^AUTTLOC("C",BGPISITE,0))
+3 DO PRINT1
+4 QUIT
End DoDot:1
+5 QUIT
LBLK(V,L) ;left blank fill
+1 NEW %,I
+2 SET %=$LENGTH(V)
SET Z=L-%
FOR I=1:1:Z
SET V=" "_V
+3 QUIT V
