BGP9EOP ; IHS/CMI/LAB - IHS EO REPORT print 05 Jul 2008 9:20 AM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
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 ^BGP9EOH
S BGPGPG=0
S BGPQUIT=""
D PRINT1
K ^TMP($J)
I BGPROT="P",'$G(BGPAREAA) K ^XTMP("BGP9D",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 ^BGP9EOH
S BGPQUIT=""
D PRINT1
I '$G(BGPAREAA) K ^XTMP("BGP9D",BGPJ,BGPH)
K ^TMP($J)
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^BGP9EOH(" ",0,2,BGPPTYPE)
.D W^BGP9EOH($P(^BGPEOMN(BGPIC,0),U,2),0,1,BGPPTYPE)
.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
.D W^BGP9EOH("Denominator(s):",0,2,BGPPTYPE)
.S BGPX=0 F S BGPX=$O(^BGPEOMN(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPEOMN(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...S BGPZ=0 F S BGPZ=$O(^BGPEOMN(BGPIC,61,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT) D
....I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
....D W^BGP9EOH(^BGPEOMN(BGPIC,61,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
....Q
...Q
..Q
.I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
.D W^BGP9EOH("Numerator(s):",0,2,BGPPTYPE)
.S BGPX=0 F S BGPX=$O(^BGPEOMN(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPEOMN(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...S BGPZ=0 F S BGPZ=$O(^BGPEOMN(BGPIC,62,BGPY,1,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT) D
....I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
....D W^BGP9EOH(^BGPEOMN(BGPIC,62,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
....Q
...Q
..Q
.I $O(^BGPEOMN(BGPIC,11,0)) D W^BGP9EOH("Logic:",0,2,BGPPTYPE) S BGPX=0 F S BGPX=$O(^BGPEOMN(BGPIC,11,BGPX)) Q:BGPX'=+BGPX D
..I BGPPTYPE="P",$Y>(BGPIOSL-4) D HEADER Q:BGPQUIT
..D W^BGP9EOH(^BGPEOMN(BGPIC,11,BGPX,0),0,1,BGPPTYPE)
.D W^BGP9EOH("",0,1,BGPPTYPE)
.;I BGPPTYPE="D" D W^BGP9EOH(" ",0,2,BGPPTYPE)
.X ^BGPEOMN(BGPIC,3)
;
I BGPIC="" S BGPIFTR=1
D ^BGP9EOY
D ^BGP9EOS
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 2009 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,^BGPGUIN(BGPGIEN,12,C,0)=^BGPDATA(X)
.S ^BGPGUIN(BGPGIEN,12,0)="^90537.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^BGP9EOH(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^BGP9EOH(BGPX,0,0,BGPPTYPE,2)
Q
;
H1 ;EP
D W^BGP9EOH("REPORT",0,2,BGPPTYPE,2,21)
D W^BGP9EOH("%",0,0,BGPPTYPE,3,31)
D W^BGP9EOH("PREV YR",0,0,BGPPTYPE,4,35)
D W^BGP9EOH("%",0,0,BGPPTYPE,5,46)
D W^BGP9EOH("CHG from",0,0,BGPPTYPE,6,49)
D W^BGP9EOH("BASE",0,0,BGPPTYPE,7,59)
D W^BGP9EOH("%",0,0,BGPPTYPE,8,69)
D W^BGP9EOH("CHG from",0,0,BGPPTYPE,9,72)
D W^BGP9EOH("PERIOD",0,1,BGPPTYPE,2,21)
D W^BGP9EOH("PERIOD",0,0,BGPPTYPE,4,35)
D W^BGP9EOH("PREV YR %",0,0,BGPPTYPE,6,49)
D W^BGP9EOH("PERIOD",0,0,BGPPTYPE,7,59)
D W^BGP9EOH("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^BGP9EOH("ZZZZZZZ",0,0,BGPPTYPE),W^BGP9EOH("",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^BGP9EOH(X,0,1,BGPPTYPE)
D W^BGP9EOH("*** IHS 2009 Executive Order Quality Transparency Measures Report ***",1,2,BGPPTYPE)
D W^BGP9EOH($$RPTVER^BGP9BAN,1,2,BGPPTYPE)
I $G(BGPAREAA) S X="AREA AGGREGATE" D W^BGP9EOH(X,1,1,BGPPTYPE)
I '$G(BGPAREAA) D W^BGP9EOH($P(^DIC(4,DUZ(2),0),U),1,1,BGPPTYPE)
S X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) D W^BGP9EOH(X,1,1,BGPPTYPE)
S X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED) D W^BGP9EOH(X,1,1,BGPPTYPE)
S X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED) D W^BGP9EOH(X,1,1,BGPPTYPE)
S X=$TR($J("",80)," ","-") D W^BGP9EOH(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=^BGPEOCN(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^BGP9UTL($P(N,U,13)) S P=5 F Y=1:1:6 S $P(BGPEI(X),U,P)=$$DATE^BGP9UTL($P(N,U,Y)),P=P+1
..Q
.Q
Q
BGP9EOP ; IHS/CMI/LAB - IHS EO REPORT print 05 Jul 2008 9:20 AM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+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 ^BGP9EOH
+10 SET BGPGPG=0
+11 SET BGPQUIT=""
+12 DO PRINT1
+13 KILL ^TMP($JOB)
+14 IF BGPROT="P"
IF '$GET(BGPAREAA)
KILL ^XTMP("BGP9D",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 ^BGP9EOH
+6 SET BGPQUIT=""
+7 DO PRINT1
+8 IF '$GET(BGPAREAA)
KILL ^XTMP("BGP9D",BGPJ,BGPH)
+9 KILL ^TMP($JOB)
+10 QUIT
+11 ;
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^BGP9EOH(" ",0,2,BGPPTYPE)
+5 DO W^BGP9EOH($PIECE(^BGPEOMN(BGPIC,0),U,2),0,1,BGPPTYPE)
+6 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+7 DO W^BGP9EOH("Denominator(s):",0,2,BGPPTYPE)
+8 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMN(BGPIC,61,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+9 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPEOMN(BGPIC,61,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+10 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^BGPEOMN(BGPIC,61,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ!(BGPQUIT)
QUIT
Begin DoDot:4
+11 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+12 DO W^BGP9EOH(^BGPEOMN(BGPIC,61,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
+13 QUIT
End DoDot:4
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+17 DO W^BGP9EOH("Numerator(s):",0,2,BGPPTYPE)
+18 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMN(BGPIC,62,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+19 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPEOMN(BGPIC,62,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+20 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^BGPEOMN(BGPIC,62,BGPY,1,BGPZ))
IF BGPZ'=+BGPZ!(BGPQUIT)
QUIT
Begin DoDot:4
+21 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+22 DO W^BGP9EOH(^BGPEOMN(BGPIC,62,BGPY,1,BGPZ,0),0,1,BGPPTYPE)
+23 QUIT
End DoDot:4
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
+26 IF $ORDER(^BGPEOMN(BGPIC,11,0))
DO W^BGP9EOH("Logic:",0,2,BGPPTYPE)
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPEOMN(BGPIC,11,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+27 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
+28 DO W^BGP9EOH(^BGPEOMN(BGPIC,11,BGPX,0),0,1,BGPPTYPE)
End DoDot:2
+29 DO W^BGP9EOH("",0,1,BGPPTYPE)
+30 ;I BGPPTYPE="D" D W^BGP9EOH(" ",0,2,BGPPTYPE)
+31 XECUTE ^BGPEOMN(BGPIC,3)
End DoDot:1
+32 ;
+33 IF BGPIC=""
SET BGPIFTR=1
+34 DO ^BGP9EOY
+35 DO ^BGP9EOS
+36 IF BGPPTYPE="P"
DO EXIT
QUIT
+37 IF BGPDELT="S"
DO SCREEN
KILL ^TMP($JOB)
QUIT
+38 ;call xbgsave to create output file
+39 KILL ^TMP($JOB,"SUMMARYDEL")
+40 SET XBGL="BGPDATA"
+41 LOCK +^BGPDATA:300
IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE "Unable to lock global"
QUIT
+42 ;NOTE: kill of unsubscripted export global
KILL ^BGPDATA
+43 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"BGPDEL",X))
IF X'=+X
QUIT
SET ^BGPDATA(X)=^TMP($JOB,"BGPDEL",X)
+44 IF '$DATA(BGPGUI)
Begin DoDot:1
+45 SET XBFLT=1
SET XBFN=BGPDELF_".txt"
SET XBMED="F"
SET XBTLE="CRS 2009 EXECUTIVE ORDER REPORT DELIMITED OUTPUT"
SET XBQ="N"
SET XBF=0
+46 DO ^XBGSAVE
+47 KILL XBFLT,XBFN,XBMED,XBTLE,XBE,XBF
End DoDot:1
+48 IF $DATA(BGPGUI)
Begin DoDot:1
+49 SET (C,X)=0
FOR
SET X=$ORDER(^BGPDATA(X))
IF X'=+X
QUIT
SET C=C+1
SET ^BGPGUIN(BGPGIEN,12,C,0)=^BGPDATA(X)
+50 SET ^BGPGUIN(BGPGIEN,12,0)="^90537.0812^"_C_"^"_C_"^"_DT
End DoDot:1
+51 LOCK -^BGPDATA
+52 ;NOTE: kill of unsubscripted export global
KILL ^BGPDATA
+53 KILL ^TMP($JOB)
+54 QUIT
+55 ;
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^BGP9EOH(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^BGP9EOH(BGPX,0,0,BGPPTYPE,2)
End DoDot:1
+9 QUIT
+10 ;
H1 ;EP
+1 DO W^BGP9EOH("REPORT",0,2,BGPPTYPE,2,21)
+2 DO W^BGP9EOH("%",0,0,BGPPTYPE,3,31)
+3 DO W^BGP9EOH("PREV YR",0,0,BGPPTYPE,4,35)
+4 DO W^BGP9EOH("%",0,0,BGPPTYPE,5,46)
+5 DO W^BGP9EOH("CHG from",0,0,BGPPTYPE,6,49)
+6 DO W^BGP9EOH("BASE",0,0,BGPPTYPE,7,59)
+7 DO W^BGP9EOH("%",0,0,BGPPTYPE,8,69)
+8 DO W^BGP9EOH("CHG from",0,0,BGPPTYPE,9,72)
+9 DO W^BGP9EOH("PERIOD",0,1,BGPPTYPE,2,21)
+10 DO W^BGP9EOH("PERIOD",0,0,BGPPTYPE,4,35)
+11 DO W^BGP9EOH("PREV YR %",0,0,BGPPTYPE,6,49)
+12 DO W^BGP9EOH("PERIOD",0,0,BGPPTYPE,7,59)
+13 DO W^BGP9EOH("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^BGP9EOH("ZZZZZZZ",0,0,BGPPTYPE)
DO W^BGP9EOH("",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^BGP9EOH(X,0,1,BGPPTYPE)
+4 DO W^BGP9EOH("*** IHS 2009 Executive Order Quality Transparency Measures Report ***",1,2,BGPPTYPE)
+5 DO W^BGP9EOH($$RPTVER^BGP9BAN,1,2,BGPPTYPE)
+6 IF $GET(BGPAREAA)
SET X="AREA AGGREGATE"
DO W^BGP9EOH(X,1,1,BGPPTYPE)
+7 IF '$GET(BGPAREAA)
DO W^BGP9EOH($PIECE(^DIC(4,DUZ(2),0),U),1,1,BGPPTYPE)
+8 SET X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)
DO W^BGP9EOH(X,1,1,BGPPTYPE)
+9 SET X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED)
DO W^BGP9EOH(X,1,1,BGPPTYPE)
+10 SET X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED)
DO W^BGP9EOH(X,1,1,BGPPTYPE)
+11 SET X=$TRANSLATE($JUSTIFY("",80)," ","-")
DO W^BGP9EOH(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=^BGPEOCN(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^BGP9UTL($PIECE(N,U,13))
SET P=5
FOR Y=1:1:6
SET $PIECE(BGPEI(X),U,P)=$$DATE^BGP9UTL($PIECE(N,U,Y))
SET P=P+1
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
QUIT
+9 QUIT
