BNITGS ; IHS/CMI/LAB - group served table ;
;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
;
;
START ;
W:$D(IOF) @IOF
W !,$$CTR($$LOC)
W !,$$CTR($$USR)
W !!,"This report will list the CPHAD Group Served table.",!!
SORT ;
S BNISORT=""
K DIR S DIR(0)="S^T:Group Served;C:Group Served Code",DIR("A")="How do you want the table sorted",DIR("B")="T" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D EXIT Q
S BNISORT=Y
ZIS ;call to XBDBQUE
S XBRP="PRINT^BNITGS",XBRC="",XBRX="EXIT^BNITGS",XBNS="BNI"
D ^XBDBQUE
D EXIT
Q
EXIT ;clean up and exit
D EN^XBVK("BNI")
Q
PRINT ;EP - called from xbdbque
S BNIPG=0,BNIQ="" D HEAD
I BNISORT="C" D CODE
I BNISORT="T" D TOPIC
DONE ;
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report. HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
CODE ;
S BNIX="" F S BNIX=$O(^BNIGS("C",BNIX)) Q:BNIX=""!(BNIQ) D
.S BNIY=0 F S BNIY=$O(^BNIGS("C",BNIX,BNIY)) Q:BNIY'=+BNIY!(BNIQ) D
..I $Y>(IOSL-2) D HEAD Q:BNIQ
..W !,$P(^BNIGS(BNIY,0),U),?60,$P(^BNIGS(BNIY,0),U,2),?68,$$VAL^XBDIQ1(90511.04,BNIY,.03)
..Q
.Q
Q
TOPIC ;
S BNIX="" F S BNIX=$O(^BNIGS("B",BNIX)) Q:BNIX=""!(BNIQ) D
.S BNIY=0 F S BNIY=$O(^BNIGS("B",BNIX,BNIY)) Q:BNIY'=+BNIY!(BNIQ) D
..I $Y>(IOSL-2) D HEAD Q:BNIQ
..W !,$P(^BNIGS(BNIY,0),U),?65,$P(^BNIGS(BNIY,0),U,2),?74,$$VAL^XBDIQ1(90511.04,BNIY,.03)
..Q
.Q
Q
HEAD I 'BNIPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BNIQ=1 Q
HEAD1 ;
W:$D(IOF) @IOF S BNIPG=BNIPG+1
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",BNIPG,!
W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
W $$CTR("CPHAD GROUP SERVED TABLE LISTING",80),!
PIH W !,"GROUP SERVED",?60,"CODE",?68,"OTHER?",!,$$REPEAT^XLFSTR("-",80),!
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")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
BNITGS ; IHS/CMI/LAB - group served table ;
+1 ;;1.0;BNI CPHD ACTIVITY DATASYSTEM;;DEC 20, 2006
+2 ;
+3 ;
START ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC)
+3 WRITE !,$$CTR($$USR)
+4 WRITE !!,"This report will list the CPHAD Group Served table.",!!
SORT ;
+1 SET BNISORT=""
+2 KILL DIR
SET DIR(0)="S^T:Group Served;C:Group Served Code"
SET DIR("A")="How do you want the table sorted"
SET DIR("B")="T"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
DO EXIT
QUIT
+4 SET BNISORT=Y
ZIS ;call to XBDBQUE
+1 SET XBRP="PRINT^BNITGS"
SET XBRC=""
SET XBRX="EXIT^BNITGS"
SET XBNS="BNI"
+2 DO ^XBDBQUE
+3 DO EXIT
+4 QUIT
EXIT ;clean up and exit
+1 DO EN^XBVK("BNI")
+2 QUIT
PRINT ;EP - called from xbdbque
+1 SET BNIPG=0
SET BNIQ=""
DO HEAD
+2 IF BNISORT="C"
DO CODE
+3 IF BNISORT="T"
DO TOPIC
DONE ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. HIT RETURN"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
CODE ;
+1 SET BNIX=""
FOR
SET BNIX=$ORDER(^BNIGS("C",BNIX))
IF BNIX=""!(BNIQ)
QUIT
Begin DoDot:1
+2 SET BNIY=0
FOR
SET BNIY=$ORDER(^BNIGS("C",BNIX,BNIY))
IF BNIY'=+BNIY!(BNIQ)
QUIT
Begin DoDot:2
+3 IF $Y>(IOSL-2)
DO HEAD
IF BNIQ
QUIT
+4 WRITE !,$PIECE(^BNIGS(BNIY,0),U),?60,$PIECE(^BNIGS(BNIY,0),U,2),?68,$$VAL^XBDIQ1(90511.04,BNIY,.03)
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 QUIT
TOPIC ;
+1 SET BNIX=""
FOR
SET BNIX=$ORDER(^BNIGS("B",BNIX))
IF BNIX=""!(BNIQ)
QUIT
Begin DoDot:1
+2 SET BNIY=0
FOR
SET BNIY=$ORDER(^BNIGS("B",BNIX,BNIY))
IF BNIY'=+BNIY!(BNIQ)
QUIT
Begin DoDot:2
+3 IF $Y>(IOSL-2)
DO HEAD
IF BNIQ
QUIT
+4 WRITE !,$PIECE(^BNIGS(BNIY,0),U),?65,$PIECE(^BNIGS(BNIY,0),U,2),?74,$$VAL^XBDIQ1(90511.04,BNIY,.03)
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 QUIT
HEAD IF 'BNIPG
GOTO HEAD1
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BNIQ=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BNIPG=BNIPG+1
+2 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",BNIPG,!
+3 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!
+4 WRITE $$CTR("CPHAD GROUP SERVED TABLE LISTING",80),!
PIH WRITE !,"GROUP SERVED",?60,"CODE",?68,"OTHER?",!,$$REPEAT^XLFSTR("-",80),!
+1 QUIT
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 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
