BGP0EOP ; IHS/CMI/LAB - IHS EO REPORT print 05 Jul 2009 9:20 AM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
PRINT ;EP
K ^TMP($J)
S BGPIOSL=$S($G(BGPGUI):55,1:IOSL)
S BGPQUIT=""
S ^TMP($J,"BGPDEL",0)=0
I $G(BGPAREAA) S BGPRPT=0
D SETEXP
I BGPROT="D" G DEL
S BGPPTYPE="P"
D ^BGP0EOH
S BGPGPG=0
S BGPQUIT=""
D PRINT1
K ^TMP($J)
I BGPROT="P",'$G(BGPAREAA) K ^XTMP("BGP0D",BGPJ,BGPH) Q
I BGPROT="P" Q
;
DEL ;create delimited output file
D ^%ZISC ;close printer device
K ^TMP($J)
S ^TMP($J,"BGPDEL",0)=0
S BGPPTYPE="D"
D ^BGP0EOH
S BGPQUIT=""
D PRINT1
I '$G(BGPAREAA) K ^XTMP("BGP0D",BGPJ,BGPH)
K ^TMP($J)
Q
WP ;
K ^UTILITY($J,"W")
S BGPZ=0,BGPLCNT=0
S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F S BGPZ=$O(^BGPEOMT(BGPIC,BGPNODE,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPEOMT(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 Q:BGPQUIT
.D W^BGP0EOH(^UTILITY($J,"W",DIWL,Z,0),0,1,BGPPTYPE)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),X
Q
;
PRINT1 ;EP
S BGPIC=0 F S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC=""!(BGPQUIT) D
.I BGPPTYPE="P" D HEADER ;header for all measures
.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
.I BGPPTYPE="D" D W^BGP0EOH(" ",0,2,BGPPTYPE)
.D W^BGP0EOH($P(^BGPEOMT(BGPIC,0),U,2),0,1,BGPPTYPE)
.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
.D W^BGP0EOH("Denominator(s):",0,2,BGPPTYPE)
.S BGPNODE=61
.S BGPX=0 F S BGPX=$O(^BGPEOMT(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPEOMT(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...;S BGPZ=0 F S BGPZ=$O(^BGPEOMT(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT) D
...;.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
...;.D W^BGP0EOH(^BGPEOMT(BGPIC,61,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
...D WP
....Q
...Q
..Q
.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
.D W^BGP0EOH("Numerator(s):",0,2,BGPPTYPE)
.S BGPNODE=62
.S BGPX=0 F S BGPX=$O(^BGPEOMT(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPEOMT(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...D WP
...Q
.I $O(^BGPEOMT(BGPIC,11,0)) D W^BGP0EOH("Logic:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPEOMT(BGPIC,11,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
..D W^BGP0EOH(^BGPEOMT(BGPIC,11,BGPX,0),0,1,BGPPTYPE)
.D W^BGP0EOH("",0,1,BGPPTYPE)
.;I BGPPTYPE="D" D W^BGP0EOH(" ",0,2,BGPPTYPE)
.X ^BGPEOMT(BGPIC,3)
;
I BGPIC="" S BGPIFTR=1
D ^BGP0EOY
D ^BGP0EOS
I BGPPTYPE="P" D EXIT Q
I BGPDELT="S" D SCREEN K ^TMP($J) Q
;call xbgsave to create output file
K ^TMP($J,"SUMMARYDEL")
S XBGL="BGPDATA"
L +^BGPDATA:300 E W:'$D(ZTQUEUED) "Unable to lock global" Q
K ^BGPDATA ;NOTE: kill of unsubscripted export global
S X=0 F S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X S ^BGPDATA(X)=^TMP($J,"BGPDEL",X)
I '$D(BGPGUI) D
.S XBFLT=1,XBFN=BGPDELF_".txt",XBMED="F",XBTLE="CRS 2010 EXECUTIVE ORDER REPORT DELIMITED OUTPUT",XBQ="N",XBF=0
.D ^XBGSAVE
.K XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
I $D(BGPGUI) D
.S (C,X)=0 F S X=$O(^BGPDATA(X)) Q:X'=+X S C=C+1,^BGPGUIT(BGPGIEN,12,C,0)=^BGPDATA(X)
.S ^BGPGUIT(BGPGIEN,12,0)="^90378.0812^"_C_"^"_C_"^"_DT
L -^BGPDATA
K ^BGPDATA ;NOTE: kill of unsubscripted export global
K ^TMP($J)
Q
;
SCREEN ;
S X=0 F S X=$O(^TMP($J,"BGPDEL",X)) Q:X'=+X W !,^TMP($J,"BGPDEL",X)
Q
EXIT ;
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
;
CALC(N,O) ;ENTRY POINT
NEW Z
S Z=N-O,Z=$FN(Z,"+,",1)
Q Z
;
SB(X) ;EP - Strip leading and trailing blanks from X.
NEW %
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
;
C(X,X2,X3) ;
D COMMA^%DTC
Q X
;
H2 ;EP
I BGPPTYPE="P" D
.S BGPX="",BGPX=$$C(BGPCYN,0,8),$E(BGPX,9)=$J(BGPCYP,5,1),$E(BGPX,16)=$$C(BGPPRN,0,8),$E(BGPX,24)=$J(BGPPRP,5,1),$E(BGPX,32)=$J($$CALC(BGPCYP,BGPPRP),6),$E(BGPX,39)=$$C(BGPBLN,0,8),$E(BGPX,47)=$J(BGPBLP,5,1)
.S $E(BGPX,55)=$J($$CALC(BGPCYP,BGPBLP),6)
.D W^BGP0EOH(BGPX,0,0,BGPPTYPE,1,20)
I BGPPTYPE="D" D
.S BGPX="",BGPX=BGPCYN,$P(BGPX,U,2)=$$SB($J(BGPCYP,5,1)),$P(BGPX,U,3)=BGPPRN,$P(BGPX,U,4)=$$SB($J(BGPPRP,5,1)),$P(BGPX,U,5)=$$SB($J($$CALC(BGPCYP,BGPPRP),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=$$SB($J(BGPBLP,5,1))
.S $P(BGPX,U,8)=$$SB($J($$CALC(BGPCYP,BGPBLP),6))
.D W^BGP0EOH(BGPX,0,0,BGPPTYPE,2)
Q
;
H1 ;EP
D W^BGP0EOH("REPORT",0,2,BGPPTYPE,2,21)
D W^BGP0EOH("%",0,0,BGPPTYPE,3,31)
D W^BGP0EOH("PREV YR",0,0,BGPPTYPE,4,35)
D W^BGP0EOH("%",0,0,BGPPTYPE,5,46)
D W^BGP0EOH("CHG from",0,0,BGPPTYPE,6,49)
D W^BGP0EOH("BASE",0,0,BGPPTYPE,7,59)
D W^BGP0EOH("%",0,0,BGPPTYPE,8,69)
D W^BGP0EOH("CHG from",0,0,BGPPTYPE,9,72)
D W^BGP0EOH("PERIOD",0,1,BGPPTYPE,2,21)
D W^BGP0EOH("PERIOD",0,0,BGPPTYPE,4,35)
D W^BGP0EOH("PREV YR %",0,0,BGPPTYPE,6,49)
D W^BGP0EOH("PERIOD",0,0,BGPPTYPE,7,59)
D W^BGP0EOH("BASE %",0,0,BGPPTYPE,9,72)
Q
;
;
G:'BGPGPG HEADER1
K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BGPQUIT=1 Q
;
I BGPPTYPE="P" W:$D(IOF) @IOF S BGPGPG=BGPGPG+1
I $G(BGPGUI),BGPPTYPE="P" D W^BGP0EOH("ZZZZZZZ",0,0,BGPPTYPE),W^BGP0EOH("",0,1,BGPPTYPE) ;GUI
I BGPPTYPE="P" S X=$P(^VA(200,DUZ,0),U,2),$E(X,35)=$$FMTE^XLFDT(DT),$E(X,70)="Page "_BGPGPG D W^BGP0EOH(X,0,1,BGPPTYPE)
D W^BGP0EOH("*** IHS 2010 Executive Order Quality Transparency Measures Report ***",1,2,BGPPTYPE)
D W^BGP0EOH($$RPTVER^BGP0BAN,1,2,BGPPTYPE)
I $G(BGPAREAA) S X="AREA AGGREGATE" D W^BGP0EOH(X,1,1,BGPPTYPE)
I '$G(BGPAREAA) D W^BGP0EOH($P(^DIC(4,DUZ(2),0),U),1,1,BGPPTYPE)
S X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) D W^BGP0EOH(X,1,1,BGPPTYPE)
S X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED) D W^BGP0EOH(X,1,1,BGPPTYPE)
S X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED) D W^BGP0EOH(X,1,1,BGPPTYPE)
S X=$TR($J("",80)," ","-") D W^BGP0EOH(X,0,1,BGPPTYPE)
Q
;
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
SETEXP ;EP
I $G(BGPAREAA) D Q
.S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S N=^BGPEOCT(X,0)
..S (D,L)=""
..S L=$P(N,U,9) I L S L=$O(^AUTTLOC("C",L,0)) I L S D=$P($G(^AUTTLOC(L,1)),U,3),L=$S(L:$P(^DIC(4,L,0),U),1:"?????")
..S BGPEI(X)=L_U_$P(N,U,9)_U_D_U_$$DATE^BGP0UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP0UTL($P(N,U,Y)),P=P+1
..Q
.Q
Q
BGP0EOP ; IHS/CMI/LAB - IHS EO REPORT print 05 Jul 2009 9:20 AM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
PRINT ;EP
+1 KILL ^TMP($JOB)
+2 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:IOSL)
+3 SET BGPQUIT=""
+4 SET ^TMP($JOB,"BGPDEL",0)=0
+5 IF $GET(BGPAREAA)
SET BGPRPT=0
+6 DO SETEXP
+7 IF BGPROT="D"
GOTO DEL
+8 SET BGPPTYPE="P"
+9 DO ^BGP0EOH
+10 SET BGPGPG=0
+11 SET BGPQUIT=""
+12 DO PRINT1
+13 KILL ^TMP($JOB)
+14 IF BGPROT="P"
IF '$GET(BGPAREAA)
KILL ^XTMP("BGP0D",BGPJ,BGPH)
QUIT
+15 IF BGPROT="P"
QUIT
+16 ;
DEL ;create delimited output file
+1 ;close printer device
DO ^%ZISC
+2 KILL ^TMP($JOB)
+3 SET ^TMP($JOB,"BGPDEL",0)=0
+4 SET BGPPTYPE="D"
+5 DO ^BGP0EOH
+6 SET BGPQUIT=""
+7 DO PRINT1
+8 IF '$GET(BGPAREAA)
KILL ^XTMP("BGP0D",BGPJ,BGPH)
+9 KILL ^TMP($JOB)
+10 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(^BGPEOMT(BGPIC,BGPNODE,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPEOMT(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
IF BGPQUIT
QUIT
+3 DO W^BGP0EOH(^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
+7 ;
PRINT1 ;EP
+1 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC=""!(BGPQUIT)
QUIT
Begin DoDot:1
+2 ;header for all measures
IF BGPPTYPE="P"
DO HEADER
+3 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+4 IF BGPPTYPE="D"
DO W^BGP0EOH(" ",0,2,BGPPTYPE)
+5 DO W^BGP0EOH($PIECE(^BGPEOMT(BGPIC,0),U,2),0,1,BGPPTYPE)
+6 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+7 DO W^BGP0EOH("Denominator(s):",0,2,BGPPTYPE)
+8 SET BGPNODE=61
+9 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMT(BGPIC,61,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+10 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPEOMT(BGPIC,61,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+11 ;S BGPZ=0 F S BGPZ=$O(^BGPEOMT(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT) D
+12 ;.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
+13 ;.D W^BGP0EOH(^BGPEOMT(BGPIC,61,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
+14 DO WP
+15 QUIT
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+19 DO W^BGP0EOH("Numerator(s):",0,2,BGPPTYPE)
+20 SET BGPNODE=62
+21 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMT(BGPIC,62,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+22 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPEOMT(BGPIC,62,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+23 DO WP
+24 QUIT
End DoDot:3
End DoDot:2
+25 IF $ORDER(^BGPEOMT(BGPIC,11,0))
DO W^BGP0EOH("Logic:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMT(BGPIC,11,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+26 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+27 DO W^BGP0EOH(^BGPEOMT(BGPIC,11,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+28 DO W^BGP0EOH("",0,1,BGPPTYPE)
+29 ;I BGPPTYPE="D" D W^BGP0EOH(" ",0,2,BGPPTYPE)
+30 XECUTE ^BGPEOMT(BGPIC,3)
End DoDot:1
+31 ;
+32 IF BGPIC=""
SET BGPIFTR=1
+33 DO ^BGP0EOY
+34 DO ^BGP0EOS
+35 IF BGPPTYPE="P"
DO EXIT
QUIT
+36 IF BGPDELT="S"
DO SCREEN
KILL ^TMP($JOB)
QUIT
+37 ;call xbgsave to create output file
+38 KILL ^TMP($JOB,"SUMMARYDEL")
+39 SET XBGL="BGPDATA"
+40 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+41 ;NOTE: kill of unsubscripted export global
KILL ^BGPDATA
+42 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
SET ^BGPDATA(X)=^TMP($JOB,"BGPDEL",X)
+43 IF '$DATA(BGPGUI)
Begin DoDot:1
+44 SET XBFLT=1
SET XBFN=BGPDELF_".txt"
SET XBMED="F"
SET XBTLE="CRS 2010 EXECUTIVE ORDER REPORT DELIMITED OUTPUT"
SET XBQ="N"
SET XBF=0
+45 DO ^XBGSAVE
+46 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
End DoDot:1
+47 IF $DATA(BGPGUI)
Begin DoDot:1
+48 SET (C,X)=0
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
SET ^BGPGUIT(BGPGIEN,12,C,0)=^BGPDATA(X)
+49 SET ^BGPGUIT(BGPGIEN,12,0)="^90378.0812^"_C_"^"_C_"^"_DT
End DoDot:1
+50 LOCK -^BGPDATA
+51 ;NOTE: kill of unsubscripted export global
KILL ^BGPDATA
+52 KILL ^TMP($JOB)
+53 QUIT
+54 ;
SCREEN ;
+1 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
WRITE !,^TMP($JOB,"BGPDEL",X)
+2 QUIT
EXIT ;
+1 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
+2 QUIT
+3 ;
CALC(N,O) ;ENTRY POINT
+1 NEW Z
+2 SET Z=N-O
SET Z=$FNUMBER(Z,"+,",1)
+3 QUIT Z
+4 ;
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
+4 ;
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
+3 ;
H2 ;EP
+1 IF BGPPTYPE="P"
Begin DoDot:1
+2 SET BGPX=""
SET BGPX=$$C(BGPCYN,0,8)
SET $EXTRACT(BGPX,9)=$JUSTIFY(BGPCYP,5,1)
SET $EXTRACT(BGPX,16)=$$C(BGPPRN,0,8)
SET $EXTRACT(BGPX,24)=$JUSTIFY(BGPPRP,5,1)
SET $EXTRACT(BGPX,32)=$JUSTIFY($$CALC(BGPCYP,BGPPRP),6)
SET $EXTRACT(BGPX,39)=$$C(BGPBLN,0,8)
SET $EXTRACT(BGPX,47)=$JUSTIFY(BGPBLP,5,1)
+3 SET $EXTRACT(BGPX,55)=$JUSTIFY($$CALC(BGPCYP,BGPBLP),6)
+4 DO W^BGP0EOH(BGPX,0,0,BGPPTYPE,1,20)
End DoDot:1
+5 IF BGPPTYPE="D"
Begin DoDot:1
+6 SET BGPX=""
SET BGPX=BGPCYN
SET $PIECE(BGPX,U,2)=$$SB($JUSTIFY(BGPCYP,5,1))
SET $PIECE(BGPX,U,3)=BGPPRN
SET $PIECE(BGPX,U,4)=$$SB($JUSTIFY(BGPPRP,5,1))
SET $PIECE(BGPX,U,5)=$$SB($JUSTIFY($$CALC(BGPCYP,BGPPRP),6))
SET $PIECE(BGPX,U,6)=BGPBLN
SET $PIECE(BGPX,U,7)=$$SB($JUSTIFY(BGPBLP,5,1))
+7 SET $PIECE(BGPX,U,8)=$$SB($JUSTIFY($$CALC(BGPCYP,BGPBLP),6))
+8 DO W^BGP0EOH(BGPX,0,0,BGPPTYPE,2)
End DoDot:1
+9 QUIT
+10 ;
H1 ;EP
+1 DO W^BGP0EOH("REPORT",0,2,BGPPTYPE,2,21)
+2 DO W^BGP0EOH("%",0,0,BGPPTYPE,3,31)
+3 DO W^BGP0EOH("PREV YR",0,0,BGPPTYPE,4,35)
+4 DO W^BGP0EOH("%",0,0,BGPPTYPE,5,46)
+5 DO W^BGP0EOH("CHG from",0,0,BGPPTYPE,6,49)
+6 DO W^BGP0EOH("BASE",0,0,BGPPTYPE,7,59)
+7 DO W^BGP0EOH("%",0,0,BGPPTYPE,8,69)
+8 DO W^BGP0EOH("CHG from",0,0,BGPPTYPE,9,72)
+9 DO W^BGP0EOH("PERIOD",0,1,BGPPTYPE,2,21)
+10 DO W^BGP0EOH("PERIOD",0,0,BGPPTYPE,4,35)
+11 DO W^BGP0EOH("PREV YR %",0,0,BGPPTYPE,6,49)
+12 DO W^BGP0EOH("PERIOD",0,0,BGPPTYPE,7,59)
+13 DO W^BGP0EOH("BASE %",0,0,BGPPTYPE,9,72)
+14 QUIT
+15 ;
+16 ;
+1 IF 'BGPGPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BGPQUIT=1
QUIT
+3 ;
+1 IF BGPPTYPE="P"
IF $DATA(IOF)
WRITE @IOF
SET BGPGPG=BGPGPG+1
+2 ;GUI
IF $GET(BGPGUI)
IF BGPPTYPE="P"
DO W^BGP0EOH("ZZZZZZZ",0,0,BGPPTYPE)
DO W^BGP0EOH("",0,1,BGPPTYPE)
+3 IF BGPPTYPE="P"
SET X=$PIECE(^VA(200,DUZ,0),U,2)
SET $EXTRACT(X,35)=$$FMTE^XLFDT(DT)
SET $EXTRACT(X,70)="Page "_BGPGPG
DO W^BGP0EOH(X,0,1,BGPPTYPE)
+4 DO W^BGP0EOH("*** IHS 2010 Executive Order Quality Transparency Measures Report ***",1,2,BGPPTYPE)
+5 DO W^BGP0EOH($$RPTVER^BGP0BAN,1,2,BGPPTYPE)
+6 IF $GET(BGPAREAA)
SET X="AREA AGGREGATE"
DO W^BGP0EOH(X,1,1,BGPPTYPE)
+7 IF '$GET(BGPAREAA)
DO W^BGP0EOH($PIECE(^DIC(4,DUZ(2),0),U),1,1,BGPPTYPE)
+8 SET X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)
DO W^BGP0EOH(X,1,1,BGPPTYPE)
+9 SET X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED)
DO W^BGP0EOH(X,1,1,BGPPTYPE)
+10 SET X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED)
DO W^BGP0EOH(X,1,1,BGPPTYPE)
+11 SET X=$TRANSLATE($JUSTIFY("",80)," ","-")
DO W^BGP0EOH(X,0,1,BGPPTYPE)
+12 QUIT
+13 ;
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
SETEXP ;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=^BGPEOCT(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^BGP0UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI(X),U,P)=$$DATE^BGP0UTL($PIECE(N,U,Y))
SET P=P+1
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
QUIT
+9 QUIT
