- BGP4DBPR ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;
- ;
- PRINT ;
- I $O(BGPDESGP(0)) D Q ;desg provider print
- .S BGPQUIT=""
- .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 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
- ..D ^BGP4DH
- ..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
- ..W:$D(IOF) @IOF
- ..D ^BGP4DH
- ..I BGPQHDR S BGPQUIT=1 D KITM Q
- ..S BGPGPG=0
- ..S BGPQUIT=""
- ..D PRINT1
- ..D SAVEDEL^BGP4PDL ;D ^BGP4PDL ;create ^tmp of delimited report
- ..S BGPIFTR=1
- ..K ^XTMP("BGP4D",BGPJ,BGPH)
- ..K ^XTMP("BGP4DNP",BGPJ,BGPH)
- ..K ^XTMP("BGP28CPL",BGPJ,BGPH)
- ..K ^TMP($J)
- ..Q
- PRINTN ;EP
- 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 ^BGP4DH ;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 ^BGP4DH
- S BGPGPG=0
- S BGPQUIT=""
- D PRINT1
- D SAVEDEL^BGP4PDL ;D ^BGP4PDL ;create ^tmp of delimited report
- S BGPIFTR=1
- K ^XTMP("BGP4D",BGPJ,BGPH)
- K ^XTMP("BGP4DNP",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(^BGPINDJ(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^BGP4DP($E(T,1,S),0,1,BGPPTYPE) ;W !,$E(T,1,S)
- D W^BGP4DP($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(^BGPNPLJ(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(^BGPNPLJ(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^BGP4DPH
- D W^BGP4DP($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^BGP4DP(" ",0,1,BGPPTYPE)
- D COLHDR
- S BGPORD=0
- S Y=$O(^BGPCTRL("B",2014,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(^BGPINDJC("ADASH",BGPORD)) Q:BGPORD'=+BGPORD!(BGPQUIT) D
- .S BGPPC=0 F S BGPPC=$O(^BGPINDJC("ADASH",BGPORD,BGPPC)) Q:BGPPC'=+BGPPC!(BGPQUIT) D
- ..;GET VALUES FOR PREVIOUS YEAR, CURRENT YEAR, GET DENOM VALUE FOR 2014
- ..S BGPDF=$P(^BGPINDJC(BGPPC,0),U,8)
- ..;get denom value
- ..S BGPNP=$P(^DD(90552.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- ..S BGPCYD=$$V^BGP4DP1C(1,BGPRPT,N,P,1,1)
- ..S BGPPRD=$$V^BGP4DP1C(2,BGPRPT,N,P,1,1)
- ..;get numerator values
- ..S BGPNF=$P(^BGPINDJC(BGPPC,0),U,9)
- ..S BGPNP=$P(^DD(90552.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(^BGPINDJC(BGPPC,23)),U,3) D
- ...S BGPGOAL="",BGPGOAL=$P($G(^BGPINDJC(BGPPC,14)),U,8)
- ...I BGPGOAL'="Baseline" S BGPGOAL=+BGPGOAL
- ...S BGPNEG=$P($G(^BGPINDJC(BGPPC,23)),U,5)
- ...I BGPGOAL="Baseline" S BGPNEED="N/A",BGPOT="N/A" Q
- ...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)
- ...I BGPGG S BGPCOLG=BGPCYPER/BGPGG,BGPCOLG=BGPCOLG*100 I 1
- ...E S BGPCOLG=0.0
- ...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(^BGPINDJC(BGPPC,23)),U,3) D
- ...S BGPGOAL="",BGPGOAL=$P($G(^BGPINDJC(BGPPC,14)),U,8)
- ...I BGPGOAL'="Baseline" S BGPGOAL=+BGPGOAL
- ...S BGPNEG=$P($G(^BGPINDJC(BGPPC,23)),U,5)
- ...I BGPGOAL="Baseline" S BGPNEED="N/A",BGPOT="N/A" Q
- ...S BGPOT=""
- ...S BGPGP=$P($G(^BGPINDJC(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"
- N ..;write out values for this measure
- ..I BGPPTYPE="P" I $Y>(IOSL-4) D HEADER^BGP4DPH Q:BGPQUIT D COLHDR
- ..I $P($G(^BGPINDJC(BGPPC,23)),U,1) D W^BGP4DP(" ",0,1,BGPPTYPE)
- ..D W^BGP4DP($P($G(^BGPINDJC(BGPPC,23)),U,2),0,1,BGPPTYPE,1,0)
- ..I $P($G(^BGPINDJC(BGPPC,23)),U,6)]"" D W^BGP4DP($P($G(^BGPINDJC(BGPPC,23)),U,6),0,1,BGPPTYPE,1,0)
- ..I BGPPTYPE="D" D
- ...D W^BGP4DP($S('$P(^BGPINDJC(BGPPC,23),U,3):BGPGOAL,1:+BGPTN),0,0,BGPPTYPE,2,30)
- ...I '$P(^BGPINDJC(BGPPC,23),U,3) D
- ....D W^BGP4DP($S(BGPPTYPE="D":$$SB($J(BGPPRP,5,1)),1:$J(BGPPRP,5,1)),0,0,BGPPTYPE,3,39)
- ....D W^BGP4DP(BGPCYN,0,0,BGPPTYPE,4,47)
- ....D W^BGP4DP(BGPCYD,0,0,BGPPTYPE,5,55)
- ....D W^BGP4DP($S(BGPPTYPE="D":$$SB($J(BGPCYP,5,1)),1:$J(BGPCYP,5,1)),0,0,BGPPTYPE,6,47)
- ....D W^BGP4DP($S(BGPNEED="N/A":BGPNEED,BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
- ...I $P(^BGPINDJC(BGPPC,23),U,3) D
- ....D W^BGP4DP($S(BGPPTYPE="D":BGPPRN,1:BGPPRN),0,0,BGPPTYPE,3,39)
- ....D W^BGP4DP($S(BGPPTYPE="D":BGPCYN,1:BGPCYN),0,0,BGPPTYPE,4,47)
- ....D W^BGP4DP(BGPCYN,0,0,BGPPTYPE,6,55)
- ....D W^BGP4DP($S(BGPNEED="N/A":BGPNEED,BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
- ...;D W^BGP4DP(BGPOT,0,0,BGPPTYPE,8,75)
- ..I BGPPTYPE="P" D
- ...D W^BGP4DP($S('$P(^BGPINDJC(BGPPC,23),U,3):$J(BGPGOAL,8),1:$$LBLK(+BGPTN,7)),0,0,BGPPTYPE,2,28)
- ...I '$P(^BGPINDJC(BGPPC,23),U,3) D
- ....D W^BGP4DP($S(BGPPTYPE="D":$$SB($J(BGPPRP,5,1)),1:$J(BGPPRP,5,1)),0,0,BGPPTYPE,3,40)
- ....D W^BGP4DP($$C(BGPCYN,0,8),0,0,BGPPTYPE,4,50)
- ....D W^BGP4DP($$C(BGPCYD,0,8),0,0,BGPPTYPE,5,60)
- ....D W^BGP4DP($S(BGPPTYPE="D":$$SB($J(BGPCYP,5,1)),1:$J(BGPCYP,5,1)),0,0,BGPPTYPE,6,70)
- ....D W^BGP4DP("# Needed to Achieve Target: "_$S(BGPNEED="N/A":BGPNEED,BGPNEED>0:$S(BGPNEG:"-",1:"")_BGPNEED,1:0),0,1,BGPPTYPE,0,5)
- ...I $P(^BGPINDJC(BGPPC,23),U,3) D
- ....D W^BGP4DP($S(BGPPTYPE="D":BGPPRN,1:$$C(BGPPRN,0,8)),0,0,BGPPTYPE,3,40)
- ....D W^BGP4DP($S(BGPPTYPE="D":BGPCYN,1:$$C(BGPCYN,0,8)),0,0,BGPPTYPE,4,50)
- ....D W^BGP4DP(BGPCYN,0,0,BGPPTYPE,7,70)
- ....D W^BGP4DP("# Needed to Achieve Target: "_$S(BGPNEED="N/A":BGPNEED,BGPNEED>0:BGPNEED,1:0),0,1,BGPPTYPE,,5)
- ...;D W^BGP4DP(BGPOT,0,0,BGPPTYPE,0,40)
- ..D W^BGP4DP(" ",0,1,BGPPTYPE)
- I BGPPTYPE="P" D W^BGP4DP("*Results reflect services provided as of the date this report was run or the ",0,1,BGPPTYPE) D W^BGP4DP("report period end date, whichever is earlier",0,1,BGPPTYPE)
- I BGPPTYPE="D" D W^BGP4DP("*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^BGP4DP(" ",0,1,BGPPTYPE)
- Q
- SETN ;EP - set numerator fields
- S BGPCYN=$$V^BGP4DP1C(1,BGPRPT,N,P,2)
- S BGPPRN=$$V^BGP4DP1C(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^BGP4DP("National 2014 Target",0,1,BGPPTYPE,2)
- .I $G(BGPAREAA) D W^BGP4DP("National 2014 Target",0,1,BGPPTYPE,2)
- .D W^BGP4DP($$FMTE^XLFDT(BGPDASHP)_" Final",0,0,BGPPTYPE,3)
- .D W^BGP4DP("Numerator",0,0,BGPPTYPE,4)
- .D W^BGP4DP("Denominator",0,0,BGPPTYPE,5)
- .D W^BGP4DP($$FMTE^XLFDT(BGPDASHY)_"*",0,0,BGPPTYPE,6)
- .D W^BGP4DP("# Needed to Achieve Target",0,0,BGPPTYPE,7)
- .;
- D W^BGP4DP("National"_$S('$G(BGPAREAA):"",1:""),0,1,BGPPTYPE,2,30)
- D W^BGP4DP(2014,0,1,BGPPTYPE,2,30)
- D W^BGP4DP($$FMTE^XLFDT(BGPDASHP),0,0,BGPPTYPE,3,40)
- D W^BGP4DP("Denom-",0,0,BGPPTYPE,,60)
- D W^BGP4DP($$FMTE^XLFDT(BGPDASHY)_"*",0,0,BGPPTYPE,,70)
- D W^BGP4DP("Target",0,1,BGPPTYPE,,30)
- D W^BGP4DP("Final",0,0,BGPPTYPE,,40)
- D W^BGP4DP("Numerator",0,0,BGPPTYPE,,50)
- D W^BGP4DP("inator",0,0,BGPPTYPE,,60)
- D W^BGP4DP("(Current)",0,0,BGPPTYPE,,70)
- D W^BGP4DP($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(^BGPINDJ(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
- .S BGPLCNT=BGPLCNT+1
- .S X=^BGPINDJ(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^BGP4DPH Q:BGPQUIT
- .D W^BGP4DP(^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("BGP4D",BGPJ,BGPH)
- K ^XTMP("BGP4DNP",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^BGP4DH1
- 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 ^BGP4PDL ;create ^tmp of delimited report
- S ^TMP($J,"BGPDEL",0)=0
- S BGPPTYPE="D",BGPQUIT=0
- D AREACP^BGP4DH
- S BGPQUIT="",BGPGPG=0,BGPRPT=0
- D PRINT1
- I $G(BGPAREAA) K BGPAREAA D INDSITE S BGPAREAA=1
- D SAVEDEL^BGP4PDL ;D ^BGP4PDL ;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(^BGPGPDCJ(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
- BGP4DBPR ; IHS/CMI/LAB - IHS gpra print 03 Jul 2010 6:26 AM ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +2 ;
- +3 ;
- PRINT ;
- +1 ;desg provider print
- IF $ORDER(BGPDESGP(0))
- Begin DoDot:1
- +2 SET BGPQUIT=""
- +3 SET BGPXX2=0
- FOR
- SET BGPXX2=$ORDER(BGPDESGP(BGPXX2))
- IF BGPXX2'=+BGPXX2!(BGPQUIT)
- QUIT
- Begin DoDot:2
- +4 IF $GET(BGPAREAA)
- QUIT
- +5 ;only delimited so don't bother with print
- IF BGPROT="D"
- QUIT
- +6 SET BGPRPT=$PIECE(BGPDESGP(BGPXX2),U,1)
- +7 SET BGPDELF=$PIECE(BGPDESGP(BGPXX2),U,2)
- +8 SET BGPDESGP=BGPXX2
- +9 KILL ^TMP($JOB)
- +10 KILL BGPDELIM
- +11 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
- +12 SET ^TMP($JOB,"BGPDEL",0)=0
- +13 SET BGPQUIT=""
- +14 SET BGPPTYPE="P"
- +15 SET BGPQHDR=0
- +16 DO ^BGP4DH
- +17 IF BGPQHDR
- SET BGPQUIT=1
- DO KITM
- QUIT
- +18 SET BGPGPG=0
- +19 SET BGPQUIT=""
- +20 DO PRINT1
- +21 KILL ^TMP($JOB)
- +22 QUIT
- End DoDot:2
- +23 ;NOW DO DELIMITED IF NEEDED
- +24 IF BGPROT="P"
- DO KITM
- QUIT
- +25 SET BGPQUIT=""
- +26 ;close printer device
- IF '$DATA(BGPGUI)
- DO ^%ZISC
- +27 SET BGPXX2=0
- FOR
- SET BGPXX2=$ORDER(BGPDESGP(BGPXX2))
- IF BGPXX2'=+BGPXX2!(BGPQUIT)
- QUIT
- Begin DoDot:2
- +28 IF $GET(BGPAREAA)
- QUIT
- +29 SET BGPRPT=$PIECE(BGPDESGP(BGPXX2),U,1)
- +30 SET BGPDELF=$PIECE(BGPDESGP(BGPXX2),U,2)
- +31 SET BGPDESGP=BGPXX2
- +32 KILL ^TMP($JOB)
- +33 KILL BGPDELIM
- +34 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
- +35 SET ^TMP($JOB,"BGPDEL",0)=0
- +36 SET BGPQUIT=""
- +37 SET BGPPTYPE="D"
- +38 SET BGPQHDR=0
- +39 IF $DATA(IOF)
- WRITE @IOF
- +40 DO ^BGP4DH
- +41 IF BGPQHDR
- SET BGPQUIT=1
- DO KITM
- QUIT
- +42 SET BGPGPG=0
- +43 SET BGPQUIT=""
- +44 DO PRINT1
- +45 ;D ^BGP4PDL ;create ^tmp of delimited report
- DO SAVEDEL^BGP4PDL
- +46 SET BGPIFTR=1
- +47 KILL ^XTMP("BGP4D",BGPJ,BGPH)
- +48 KILL ^XTMP("BGP4DNP",BGPJ,BGPH)
- +49 KILL ^XTMP("BGP28CPL",BGPJ,BGPH)
- +50 KILL ^TMP($JOB)
- +51 QUIT
- End DoDot:2
- End DoDot:1
- QUIT
- PRINTN ;EP
- +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 ^BGP4DH
- +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 ^BGP4DH
- +7 SET BGPGPG=0
- +8 SET BGPQUIT=""
- +9 DO PRINT1
- +10 ;D ^BGP4PDL ;create ^tmp of delimited report
- DO SAVEDEL^BGP4PDL
- +11 SET BGPIFTR=1
- +12 KILL ^XTMP("BGP4D",BGPJ,BGPH)
- +13 KILL ^XTMP("BGP4DNP",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(^BGPINDJ(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^BGP4DP($EXTRACT(T,1,S),0,1,BGPPTYPE)
- +9 ;W !,$E(T,(S+1),$L(T)),!
- DO W^BGP4DP($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(^BGPNPLJ(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(^BGPNPLJ(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^BGP4DPH
- +4 DO W^BGP4DP($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^BGP4DP(" ",0,1,BGPPTYPE)
- +6 DO COLHDR
- +7 SET BGPORD=0
- +8 SET Y=$ORDER(^BGPCTRL("B",2014,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(^BGPINDJC("ADASH",BGPORD))
- IF BGPORD'=+BGPORD!(BGPQUIT)
- QUIT
- Begin DoDot:1
- +13 SET BGPPC=0
- FOR
- SET BGPPC=$ORDER(^BGPINDJC("ADASH",BGPORD,BGPPC))
- IF BGPPC'=+BGPPC!(BGPQUIT)
- QUIT
- Begin DoDot:2
- +14 ;GET VALUES FOR PREVIOUS YEAR, CURRENT YEAR, GET DENOM VALUE FOR 2014
- +15 SET BGPDF=$PIECE(^BGPINDJC(BGPPC,0),U,8)
- +16 ;get denom value
- +17 SET BGPNP=$PIECE(^DD(90552.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +18 SET BGPCYD=$$V^BGP4DP1C(1,BGPRPT,N,P,1,1)
- +19 SET BGPPRD=$$V^BGP4DP1C(2,BGPRPT,N,P,1,1)
- +20 ;get numerator values
- +21 SET BGPNF=$PIECE(^BGPINDJC(BGPPC,0),U,9)
- +22 SET BGPNP=$PIECE(^DD(90552.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(^BGPINDJC(BGPPC,23)),U,3)
- Begin DoDot:3
- +26 SET BGPGOAL=""
- SET BGPGOAL=$PIECE($GET(^BGPINDJC(BGPPC,14)),U,8)
- +27 IF BGPGOAL'="Baseline"
- SET BGPGOAL=+BGPGOAL
- +28 SET BGPNEG=$PIECE($GET(^BGPINDJC(BGPPC,23)),U,5)
- +29 IF BGPGOAL="Baseline"
- SET BGPNEED="N/A"
- SET BGPOT="N/A"
- QUIT
- +30 SET BGPOT=""
- +31 SET BGPGG=BGPGOAL/100
- +32 SET BGPNEED1=BGPGG*BGPCYD
- SET BGPNEED1=BGPNEED1+.9
- SET BGPNEED1=$PIECE(BGPNEED1,".")
- +33 SET BGPCYPER=BGPCYP/100
- +34 ;;;
- SET BGPNEED2=BGPCYPER*BGPCYD
- SET BGPNEED2=BGPNEED2+.9
- SET BGPNEED2=$PIECE(BGPNEED2,".")
- +35 SET BGPNEED=BGPNEED1-BGPNEED2
- +36 IF BGPNEG
- SET BGPNEED=BGPNEED2-BGPNEED1
- +37 ;S BGPNEED=BGPNEED+.5,BGPNEED=$P(BGPNEED,".",1)
- +38 IF BGPGG
- SET BGPCOLG=BGPCYPER/BGPGG
- SET BGPCOLG=BGPCOLG*100
- IF 1
- +39 IF '$TEST
- SET BGPCOLG=0.0
- +40 IF 'BGPNEG
- IF BGPCOLG'<100
- SET BGPOT="ON TRACK"
- QUIT
- +41 IF BGPNEG
- IF BGPCOLG'>100
- SET BGPOT="ON TRACK"
- QUIT
- +42 IF 'BGPNEG
- IF BGPCOLG'<BGPPERY
- SET BGPOT="WITHIN RANGE"
- QUIT
- +43 IF BGPNEG
- IF BGPCOLG'>BGPPERY
- SET BGPOT="WITHIN RANGE"
- QUIT
- +44 SET BGPOT="NOT ON TRACK"
- End DoDot:3
- +45 IF $PIECE($GET(^BGPINDJC(BGPPC,23)),U,3)
- Begin DoDot:3
- +46 SET BGPGOAL=""
- SET BGPGOAL=$PIECE($GET(^BGPINDJC(BGPPC,14)),U,8)
- +47 IF BGPGOAL'="Baseline"
- SET BGPGOAL=+BGPGOAL
- +48 SET BGPNEG=$PIECE($GET(^BGPINDJC(BGPPC,23)),U,5)
- +49 IF BGPGOAL="Baseline"
- SET BGPNEED="N/A"
- SET BGPOT="N/A"
- QUIT
- +50 SET BGPOT=""
- +51 SET BGPGP=$PIECE($GET(^BGPINDJC(BGPPC,23)),U,4)
- +52 SET BGPGG=BGPGP/100
- +53 ;S BGPNGA=BGPGG*BGPPRN
- +54 SET BGPTN=BGPPRN*(1+BGPGG)
- +55 SET BGPTN=BGPTN+.9
- SET BGPTN=$PIECE(BGPTN,".")
- +56 SET BGPNEED=BGPTN-BGPCYN
- +57 IF BGPNEED<1
- SET BGPOT="ON TRACK"
- QUIT
- +58 SET G=BGPCYN/BGPTN
- +59 IF G'<BGPPERY
- SET BGPOT="WITHIN RANGE"
- QUIT
- +60 SET BGPOT="NOT ON TRACK"
- End DoDot:3
- N ;write out values for this measure
- +1 IF BGPPTYPE="P"
- IF $Y>(IOSL-4)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- DO COLHDR
- +2 IF $PIECE($GET(^BGPINDJC(BGPPC,23)),U,1)
- DO W^BGP4DP(" ",0,1,BGPPTYPE)
- +3 DO W^BGP4DP($PIECE($GET(^BGPINDJC(BGPPC,23)),U,2),0,1,BGPPTYPE,1,0)
- +4 IF $PIECE($GET(^BGPINDJC(BGPPC,23)),U,6)]""
- DO W^BGP4DP($PIECE($GET(^BGPINDJC(BGPPC,23)),U,6),0,1,BGPPTYPE,1,0)
- +5 IF BGPPTYPE="D"
- Begin DoDot:3
- +6 DO W^BGP4DP($SELECT('$PIECE(^BGPINDJC(BGPPC,23),U,3):BGPGOAL,1:+BGPTN),0,0,BGPPTYPE,2,30)
- +7 IF '$PIECE(^BGPINDJC(BGPPC,23),U,3)
- Begin DoDot:4
- +8 DO W^BGP4DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPPRP,5,1)),1:$JUSTIFY(BGPPRP,5,1)),0,0,BGPPTYPE,3,39)
- +9 DO W^BGP4DP(BGPCYN,0,0,BGPPTYPE,4,47)
- +10 DO W^BGP4DP(BGPCYD,0,0,BGPPTYPE,5,55)
- +11 DO W^BGP4DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPCYP,5,1)),1:$JUSTIFY(BGPCYP,5,1)),0,0,BGPPTYPE,6,47)
- +12 DO W^BGP4DP($SELECT(BGPNEED="N/A":BGPNEED,BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
- End DoDot:4
- +13 IF $PIECE(^BGPINDJC(BGPPC,23),U,3)
- Begin DoDot:4
- +14 DO W^BGP4DP($SELECT(BGPPTYPE="D":BGPPRN,1:BGPPRN),0,0,BGPPTYPE,3,39)
- +15 DO W^BGP4DP($SELECT(BGPPTYPE="D":BGPCYN,1:BGPCYN),0,0,BGPPTYPE,4,47)
- +16 DO W^BGP4DP(BGPCYN,0,0,BGPPTYPE,6,55)
- +17 DO W^BGP4DP($SELECT(BGPNEED="N/A":BGPNEED,BGPNEED>0:BGPNEED,1:0),0,0,BGPPTYPE,7,65)
- End DoDot:4
- +18 ;D W^BGP4DP(BGPOT,0,0,BGPPTYPE,8,75)
- End DoDot:3
- +19 IF BGPPTYPE="P"
- Begin DoDot:3
- +20 DO W^BGP4DP($SELECT('$PIECE(^BGPINDJC(BGPPC,23),U,3):$JUSTIFY(BGPGOAL,8),1:$$LBLK(+BGPTN,7)),0,0,BGPPTYPE,2,28)
- +21 IF '$PIECE(^BGPINDJC(BGPPC,23),U,3)
- Begin DoDot:4
- +22 DO W^BGP4DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPPRP,5,1)),1:$JUSTIFY(BGPPRP,5,1)),0,0,BGPPTYPE,3,40)
- +23 DO W^BGP4DP($$C(BGPCYN,0,8),0,0,BGPPTYPE,4,50)
- +24 DO W^BGP4DP($$C(BGPCYD,0,8),0,0,BGPPTYPE,5,60)
- +25 DO W^BGP4DP($SELECT(BGPPTYPE="D":$$SB($JUSTIFY(BGPCYP,5,1)),1:$JUSTIFY(BGPCYP,5,1)),0,0,BGPPTYPE,6,70)
- +26 DO W^BGP4DP("# Needed to Achieve Target: "_$SELECT(BGPNEED="N/A":BGPNEED,BGPNEED>0:$SELECT(BGPNEG:"-",1:"")_BGPNEED,1:0),0,1,BGPPTYPE,0,5)
- End DoDot:4
- +27 IF $PIECE(^BGPINDJC(BGPPC,23),U,3)
- Begin DoDot:4
- +28 DO W^BGP4DP($SELECT(BGPPTYPE="D":BGPPRN,1:$$C(BGPPRN,0,8)),0,0,BGPPTYPE,3,40)
- +29 DO W^BGP4DP($SELECT(BGPPTYPE="D":BGPCYN,1:$$C(BGPCYN,0,8)),0,0,BGPPTYPE,4,50)
- +30 DO W^BGP4DP(BGPCYN,0,0,BGPPTYPE,7,70)
- +31 DO W^BGP4DP("# Needed to Achieve Target: "_$SELECT(BGPNEED="N/A":BGPNEED,BGPNEED>0:BGPNEED,1:0),0,1,BGPPTYPE,,5)
- End DoDot:4
- +32 ;D W^BGP4DP(BGPOT,0,0,BGPPTYPE,0,40)
- End DoDot:3
- +33 DO W^BGP4DP(" ",0,1,BGPPTYPE)
- End DoDot:2
- End DoDot:1
- +34 IF BGPPTYPE="P"
- DO W^BGP4DP("*Results reflect services provided as of the date this report was run or the ",0,1,BGPPTYPE)
- DO W^BGP4DP("report period end date, whichever is earlier",0,1,BGPPTYPE)
- +35 IF BGPPTYPE="D"
- DO W^BGP4DP("*Results reflect services provided as of the date this report was run or the report period end date, whichever is earlier",0,1,BGPPTYPE)
- +36 DO W^BGP4DP(" ",0,1,BGPPTYPE)
- +37 QUIT
- SETN ;EP - set numerator fields
- +1 SET BGPCYN=$$V^BGP4DP1C(1,BGPRPT,N,P,2)
- +2 SET BGPPRN=$$V^BGP4DP1C(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^BGP4DP("National 2014 Target",0,1,BGPPTYPE,2)
- +3 IF $GET(BGPAREAA)
- DO W^BGP4DP("National 2014 Target",0,1,BGPPTYPE,2)
- +4 DO W^BGP4DP($$FMTE^XLFDT(BGPDASHP)_" Final",0,0,BGPPTYPE,3)
- +5 DO W^BGP4DP("Numerator",0,0,BGPPTYPE,4)
- +6 DO W^BGP4DP("Denominator",0,0,BGPPTYPE,5)
- +7 DO W^BGP4DP($$FMTE^XLFDT(BGPDASHY)_"*",0,0,BGPPTYPE,6)
- +8 DO W^BGP4DP("# Needed to Achieve Target",0,0,BGPPTYPE,7)
- +9 ;
- End DoDot:1
- QUIT
- +10 DO W^BGP4DP("National"_$SELECT('$GET(BGPAREAA):"",1:""),0,1,BGPPTYPE,2,30)
- +11 DO W^BGP4DP(2014,0,1,BGPPTYPE,2,30)
- +12 DO W^BGP4DP($$FMTE^XLFDT(BGPDASHP),0,0,BGPPTYPE,3,40)
- +13 DO W^BGP4DP("Denom-",0,0,BGPPTYPE,,60)
- +14 DO W^BGP4DP($$FMTE^XLFDT(BGPDASHY)_"*",0,0,BGPPTYPE,,70)
- +15 DO W^BGP4DP("Target",0,1,BGPPTYPE,,30)
- +16 DO W^BGP4DP("Final",0,0,BGPPTYPE,,40)
- +17 DO W^BGP4DP("Numerator",0,0,BGPPTYPE,,50)
- +18 DO W^BGP4DP("inator",0,0,BGPPTYPE,,60)
- +19 DO W^BGP4DP("(Current)",0,0,BGPPTYPE,,70)
- +20 DO W^BGP4DP($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(^BGPINDJ(BGPIC,BGPNODE,BGPY,1,BGPZ))
- IF BGPZ'=+BGPZ
- QUIT
- Begin DoDot:1
- +4 SET BGPLCNT=BGPLCNT+1
- +5 SET X=^BGPINDJ(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^BGP4DPH
- IF BGPQUIT
- QUIT
- +3 DO W^BGP4DP(^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("BGP4D",BGPJ,BGPH)
- +3 KILL ^XTMP("BGP4DNP",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^BGP4DH1
- +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 ^BGP4PDL ;create ^tmp of delimited report
- +5 SET ^TMP($JOB,"BGPDEL",0)=0
- +6 SET BGPPTYPE="D"
- SET BGPQUIT=0
- +7 DO AREACP^BGP4DH
- +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 ^BGP4PDL ;create ^tmp of delimited report
- DO SAVEDEL^BGP4PDL
- +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(^BGPGPDCJ(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