DDBRGE ;SFISC/DCL-BROWSE GET/EXECUTE EVENT ;1:50 PM 7 Jan 2013
;;22.0;VA FileMan;**169**;Mar 30, 1999;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
EN N DDBGF
D GETKEY
S DDBRPE=0
W @IOSTBM
S DDBL=$G(DDBL,0) S:DDBL<0 DDBL=0 S:DDBL>DDBTL DDBL=DDBTL D PSR^DDBR0(1)
S DX=0,DY=$P(DDBSY,";",3) X IOXY
X DDGLZOSF("EOFF")
F S DDBRE=$$READ D Q:DDBRE="^"
.I $T(@DDBRE)="" W $C(7) Q
.X DDGLZOSF("EON")
.D @DDBRE
.I DDBRSA S DDBRSA(DDBRSA,"DDBL")=DDBL
.S DX=0,DY=$P(DDBSY,";",3) X IOXY
.S DDBRPE=DDBRE
.X DDGLZOSF("EOFF")
X DDGLZOSF("EON")
I $G(DDBFLG)["H" Q
CLS S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
I DDBRSA S X=DDBL D
.N DDBL S DDBL=X
.D SR^DDBRS(DDBRSA,$S(DDBRSA=2:1,1:2),.DDBRSA)
.W @IOSTBM
.S DX=0 F DY=$P(DDBSY,";"):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
.Q
I $G(DDBC1),$G(DDBC0)]"" K @DDBC0@(1)
K ^TMP("DDBC","DDBC",$J)
S IOTM=1,IOBM=IOSL W @IOSTBM,$P(DDGLVID,DDGLDEL,9)
D:'$D(DDS) KILL^DDGLIB0($G(DDBFLG))
S DX=0,DY=IOSL-1 X IOXY
I DDBSRL+2=IOSL W @IOF
D:$G(DDBFLG)'["P" KTMP
END Q
KTMP D KTMP^DDBRU
Q
READ() N S,Y
F R *Y:DTIME D C Q:Y'=-1
Q Y
C I Y<0 S Y="TO" Q
;I Y=13 S Y="COLR" Q
S S=""
C1 S S=S_$C(Y)
I DDBGF("DDBIN")'[(U_S) D I Y=-1 W $C(7) Q
. I $C(Y)'?1L S Y=-1 Q
. S S=$E(S,1,$L(S)-1)_$C(Y-32) S:DDBGF("DDBIN")'[(U_S_U) Y=-1
I DDBGF("DDBIN")[(U_S_U),S'=$C(27) S Y=$P(DDBGF("DDBOUT"),U,$L($P(DDBGF("DDBIN"),U_S_U),U)) Q
R *Y:5 G:Y'=-1 C1 W $C(7)
Q
GETKEY N AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T
N FIND,SELECT,PREVSC,NEXTSC,HELP,KP7,KP8
S AU=$P(DDGLKEY,U,2)
S AD=$P(DDGLKEY,U,3)
S AR=$P(DDGLKEY,U,4)
S AL=$P(DDGLKEY,U,5)
S F1=$P(DDGLKEY,U,6)
S F2=$P(DDGLKEY,U,7)
S F3=$P(DDGLKEY,U,8)
S F4=$P(DDGLKEY,U,9)
S FIND=$P(DDGLKEY,U,10)
S SELECT=$P(DDGLKEY,U,11)
S PREVSC=$P(DDGLKEY,U,14)
S NEXTSC=$P(DDGLKEY,U,15)
S HELP=$P(DDGLKEY,U,16)
S KP7=$P(DDGLKEY,U,25)
S KP8=$P(DDGLKEY,U,26)
F N="DDB" D
. S DDBGF(N_"IN")="",DDBGF(N_"OUT")=""
. F I=1:1 S T=$P($T(@(N_"MAP")+I),";;",2,999) Q:T="" D
.. S @("K="_$P(T,";",2))
.. I DDBGF(N_"IN")'[(U_K) D
... S DDBGF(N_"IN")=DDBGF(N_"IN")_U_K
... S DDBGF(N_"OUT")=DDBGF(N_"OUT")_$P(T,";")_U
. S DDBGF(N_"IN")=DDBGF(N_"IN")_U
. S DDBGF(N_"OUT")=$E(DDBGF(N_"OUT"),1,$L(DDBGF(N_"OUT"))-1)
Q
TO S DDBRE="^" Q
HELP D HELP^DDBR1 Q
HELPS D HELPS^DDBR1 Q
RETURN D SWITCH^DDBR2("","R") Q
SWITCH D SWITCH^DDBR2() Q
RPS I 'DDBRSA D PSR^DDBR0(1) Q
N DDBRNI F DDBRNI=1,2 D
.I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q
.I DDBRSA=1 S DDBL=DDBRSA(DDBRSA,"DDBL") D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM D PSR^DDBR0(1) Q
.Q
Q
PRINT ;Print document
N DX,DY,X
S DX=0,DY=$P(DDBSY,";"),X=$$CTXT^DDBR("PRINT DOCUMENT",$J("",IOM+1),IOM)
X IOXY
W $P(DDGLVID,DDGLDEL,6) ;rvon
W $P(DDGLVID,DDGLDEL,4) ;uon
W X
W $P(DDGLVID,DDGLDEL,10) ;rvoff
F DY=$P(DDBSY,";",2):1:$P(DDBSY,";",4) X IOXY W $P(DDGLCLR,DDGLDEL)
W $P(DDGLVID,DDGLDEL,6) ;rvon
W $P(DDGLVID,DDGLDEL,4) ;uon
W X
W $P(DDGLVID,DDGLDEL,10) ;rvoff
W @IOSTBM
S DY=$P(DDBSY,";",2)
X IOXY
D PT^DDGLIBP(DDBSA,DDBPMSG),RPS
Q
NEXT D NOOF^DDBR1 Q
FIND D FIND^DDBR1 Q
GOTO D GOTO^DDBR1 Q
BOT D BOT^DDBR0 Q
TOP D TOP^DDBR0 Q
PD D PD^DDBR0 Q
PU D PU^DDBR0 Q
QUIT ;
EXIT D EXIT^DDBR0 Q
COLR D RR^DDBR0 Q
COLL D RL^DDBR0 Q
COLRE D RRE^DDBR0 Q
COLLE D RLE^DDBR0 Q
COLJ D COLJ^DDBR0 Q
LND D LD^DDBR0 Q
LNU D LU^DDBR0 Q
HU D CHDR^DDBR4(-1) Q
HD D CHDR^DDBR4(1) Q
PH D PRTHELP^DDBRP Q
STPB D STPB^DDBRWB Q
VIEW D VIEW^DDBRWB Q
AHT I DDBRHTF D TAB^DDBRAHT Q
G BQT
AHTR I DDBRHTF D REVTAB^DDBRAHTR Q
G BQT
TEHT I DDBRHTF D TEDIT^DDBRAHTE Q
G BQT
RA I DDBRHTF D RA^DDBRAHTE Q
G BQT
SCRN1 I DDBRSA=2 D SR^DDBRS(2,1,.DDBRSA) W @IOSTBM G RPS
G BQT
SCRN2 I DDBRSA=1 D SR^DDBRS(1,2,.DDBRSA) W @IOSTBM G RPS
G BQT
SPLIT I 'DDBRSA,$D(DDBRSA(1)) D SPLIT^DDBRS Q
G BQT
FULL I DDBRSA D FULL^DDBRS(.DDBRSA) Q
G BQT
RESIZU I DDBRSA,(DDBRSA(1,"IOBM")-1)>(DDBRSA(0,"IOTM")+2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")-1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")-1 D 2,1,ENTB^DDBRS(.DDBRSA,-1) G RPS
G BQT
RESIZD I DDBRSA,(DDBRSA(2,"IOTM")+1)<(DDBRSA(0,"IOBM")-2) S DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")+1,DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")+1 D 1,2,ENTB^DDBRS(.DDBRSA,+1) G RPS
G BQT
BQT W $C(7)
Q
1 S DX=0,DY=$P(DDBRSA(1,"DDBSY"),";",4) X IOXY W $P(DDGLCLR,DDGLDEL) Q
2 S DX=0,DY=$P(DDBRSA(2,"DDBSY"),";") X IOXY W $P(DDGLCLR,DDGLDEL) Q
DDBMAP ;
;;LNU;AU;
;;LND;AD;
;;COLR;AR;
;;COLL;AL;
;;EXIT;F1_"E";
;;QUIT;F1_"Q";
;;PU;F1_AU;
;;PU;PREVSC;
;;PD;F1_AD;
;;PD;NEXTSC;
;;COLRE;F1_AR;
;;COLLE;F1_AL;
;;STPB;F1_"C";
;;VIEW;F1_"V";
;;TOP;F1_"T";
;;BOT;F1_"B";
;;GOTO;F1_"G";
;;FIND;F1_"F";
;;FIND;FIND;
;;NEXT;"N";
;;NEXT;F1_"N";
;;RPS;F1_"P";
;;SWITCH;F1_"S";
;;SWITCH;SELECT;
;;RETURN;"R";
;;HELP;F1_"H";
;;HELP;"HELP";
;;HELPS;F1_F1_"H";
;;EXIT;"EXIT";
;;SCRN1;F2_AU;
;;SCRN2;F2_AD;
;;SPLIT;F2_"S";
;;FULL;F2_"F";
;;RESIZU;F2_F2_AU;
;;RESIZD;F2_F2_AD;
;;HU;F1_F1_AU;
;;HD;F1_F1_AD;
;;PH;F1_F1_F1_"H";
;;STPB;F1_F1_"C";
;;AHT;$C(9);
;;AHTR;"Q";
;;TEHT;F4_"T";
;;RA;F4_"A";
;;COLR;$C(13);
;;PRINT;F1_F1_"P";
DDBRGE ;SFISC/DCL-BROWSE GET/EXECUTE EVENT ;1:50 PM 7 Jan 2013
+1 ;;22.0;VA FileMan;**169**;Mar 30, 1999;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
EN NEW DDBGF
+1 DO GETKEY
+2 SET DDBRPE=0
+3 WRITE @IOSTBM
+4 SET DDBL=$GET(DDBL,0)
IF DDBL<0
SET DDBL=0
IF DDBL>DDBTL
SET DDBL=DDBTL
DO PSR^DDBR0(1)
+5 SET DX=0
SET DY=$PIECE(DDBSY,";",3)
XECUTE IOXY
+6 XECUTE DDGLZOSF("EOFF")
+7 FOR
SET DDBRE=$$READ
Begin DoDot:1
+8 IF $TEXT(@DDBRE)=""
WRITE $CHAR(7)
QUIT
+9 XECUTE DDGLZOSF("EON")
+10 DO @DDBRE
+11 IF DDBRSA
SET DDBRSA(DDBRSA,"DDBL")=DDBL
+12 SET DX=0
SET DY=$PIECE(DDBSY,";",3)
XECUTE IOXY
+13 SET DDBRPE=DDBRE
+14 XECUTE DDGLZOSF("EOFF")
End DoDot:1
IF DDBRE="^"
QUIT
+15 XECUTE DDGLZOSF("EON")
+16 IF $GET(DDBFLG)["H"
QUIT
CLS SET DX=0
FOR DY=$PIECE(DDBSY,";"):1:$PIECE(DDBSY,";",4)
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+1 IF DDBRSA
SET X=DDBL
Begin DoDot:1
+2 NEW DDBL
SET DDBL=X
+3 DO SR^DDBRS(DDBRSA,$SELECT(DDBRSA=2:1,1:2),.DDBRSA)
+4 WRITE @IOSTBM
+5 SET DX=0
FOR DY=$PIECE(DDBSY,";"):1:$PIECE(DDBSY,";",4)
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+6 QUIT
End DoDot:1
+7 IF $GET(DDBC1)
IF $GET(DDBC0)]""
KILL @DDBC0@(1)
+8 KILL ^TMP("DDBC","DDBC",$JOB)
+9 SET IOTM=1
SET IOBM=IOSL
WRITE @IOSTBM,$PIECE(DDGLVID,DDGLDEL,9)
+10 IF '$DATA(DDS)
DO KILL^DDGLIB0($GET(DDBFLG))
+11 SET DX=0
SET DY=IOSL-1
XECUTE IOXY
+12 IF DDBSRL+2=IOSL
WRITE @IOF
+13 IF $GET(DDBFLG)'["P"
DO KTMP
END QUIT
KTMP DO KTMP^DDBRU
+1 QUIT
READ() NEW S,Y
+1 FOR
READ *Y:DTIME
DO C
IF Y'=-1
QUIT
+2 QUIT Y
C IF Y<0
SET Y="TO"
QUIT
+1 ;I Y=13 S Y="COLR" Q
+2 SET S=""
C1 SET S=S_$CHAR(Y)
+1 IF DDBGF("DDBIN")'[(U_S)
Begin DoDot:1
+2 IF $CHAR(Y)'?1L
SET Y=-1
QUIT
+3 SET S=$EXTRACT(S,1,$LENGTH(S)-1)_$CHAR(Y-32)
IF DDBGF("DDBIN")'[(U_S_U)
SET Y=-1
End DoDot:1
IF Y=-1
WRITE $CHAR(7)
QUIT
+4 IF DDBGF("DDBIN")[(U_S_U)
IF S'=$CHAR(27)
SET Y=$PIECE(DDBGF("DDBOUT"),U,$LENGTH($PIECE(DDBGF("DDBIN"),U_S_U),U))
QUIT
+5 READ *Y:5
IF Y'=-1
GOTO C1
WRITE $CHAR(7)
+6 QUIT
GETKEY NEW AU,AD,AR,AL,F1,F2,F3,F4,I,K,N,T
+1 NEW FIND,SELECT,PREVSC,NEXTSC,HELP,KP7,KP8
+2 SET AU=$PIECE(DDGLKEY,U,2)
+3 SET AD=$PIECE(DDGLKEY,U,3)
+4 SET AR=$PIECE(DDGLKEY,U,4)
+5 SET AL=$PIECE(DDGLKEY,U,5)
+6 SET F1=$PIECE(DDGLKEY,U,6)
+7 SET F2=$PIECE(DDGLKEY,U,7)
+8 SET F3=$PIECE(DDGLKEY,U,8)
+9 SET F4=$PIECE(DDGLKEY,U,9)
+10 SET FIND=$PIECE(DDGLKEY,U,10)
+11 SET SELECT=$PIECE(DDGLKEY,U,11)
+12 SET PREVSC=$PIECE(DDGLKEY,U,14)
+13 SET NEXTSC=$PIECE(DDGLKEY,U,15)
+14 SET HELP=$PIECE(DDGLKEY,U,16)
+15 SET KP7=$PIECE(DDGLKEY,U,25)
+16 SET KP8=$PIECE(DDGLKEY,U,26)
+17 FOR N="DDB"
Begin DoDot:1
+18 SET DDBGF(N_"IN")=""
SET DDBGF(N_"OUT")=""
+19 FOR I=1:1
SET T=$PIECE($TEXT(@(N_"MAP")+I),";;",2,999)
IF T=""
QUIT
Begin DoDot:2
+20 SET @("K="_$PIECE(T,";",2))
+21 IF DDBGF(N_"IN")'[(U_K)
Begin DoDot:3
+22 SET DDBGF(N_"IN")=DDBGF(N_"IN")_U_K
+23 SET DDBGF(N_"OUT")=DDBGF(N_"OUT")_$PIECE(T,";")_U
End DoDot:3
End DoDot:2
+24 SET DDBGF(N_"IN")=DDBGF(N_"IN")_U
+25 SET DDBGF(N_"OUT")=$EXTRACT(DDBGF(N_"OUT"),1,$LENGTH(DDBGF(N_"OUT"))-1)
End DoDot:1
+26 QUIT
TO SET DDBRE="^"
QUIT
HELP DO HELP^DDBR1
QUIT
HELPS DO HELPS^DDBR1
QUIT
RETURN DO SWITCH^DDBR2("","R")
QUIT
SWITCH DO SWITCH^DDBR2()
QUIT
RPS IF 'DDBRSA
DO PSR^DDBR0(1)
QUIT
+1 NEW DDBRNI
FOR DDBRNI=1,2
Begin DoDot:1
+2 IF DDBRSA=2
DO SR^DDBRS(2,1,.DDBRSA)
WRITE @IOSTBM
DO PSR^DDBR0(1)
QUIT
+3 IF DDBRSA=1
SET DDBL=DDBRSA(DDBRSA,"DDBL")
DO SR^DDBRS(1,2,.DDBRSA)
WRITE @IOSTBM
DO PSR^DDBR0(1)
QUIT
+4 QUIT
End DoDot:1
+5 QUIT
PRINT ;Print document
+1 NEW DX,DY,X
+2 SET DX=0
SET DY=$PIECE(DDBSY,";")
SET X=$$CTXT^DDBR("PRINT DOCUMENT",$JUSTIFY("",IOM+1),IOM)
+3 XECUTE IOXY
+4 ;rvon
WRITE $PIECE(DDGLVID,DDGLDEL,6)
+5 ;uon
WRITE $PIECE(DDGLVID,DDGLDEL,4)
+6 WRITE X
+7 ;rvoff
WRITE $PIECE(DDGLVID,DDGLDEL,10)
+8 FOR DY=$PIECE(DDBSY,";",2):1:$PIECE(DDBSY,";",4)
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
+9 ;rvon
WRITE $PIECE(DDGLVID,DDGLDEL,6)
+10 ;uon
WRITE $PIECE(DDGLVID,DDGLDEL,4)
+11 WRITE X
+12 ;rvoff
WRITE $PIECE(DDGLVID,DDGLDEL,10)
+13 WRITE @IOSTBM
+14 SET DY=$PIECE(DDBSY,";",2)
+15 XECUTE IOXY
+16 DO PT^DDGLIBP(DDBSA,DDBPMSG)
DO RPS
+17 QUIT
NEXT DO NOOF^DDBR1
QUIT
FIND DO FIND^DDBR1
QUIT
GOTO DO GOTO^DDBR1
QUIT
BOT DO BOT^DDBR0
QUIT
TOP DO TOP^DDBR0
QUIT
PD DO PD^DDBR0
QUIT
PU DO PU^DDBR0
QUIT
QUIT ;
EXIT DO EXIT^DDBR0
QUIT
COLR DO RR^DDBR0
QUIT
COLL DO RL^DDBR0
QUIT
COLRE DO RRE^DDBR0
QUIT
COLLE DO RLE^DDBR0
QUIT
COLJ DO COLJ^DDBR0
QUIT
LND DO LD^DDBR0
QUIT
LNU DO LU^DDBR0
QUIT
HU DO CHDR^DDBR4(-1)
QUIT
HD DO CHDR^DDBR4(1)
QUIT
PH DO PRTHELP^DDBRP
QUIT
STPB DO STPB^DDBRWB
QUIT
VIEW DO VIEW^DDBRWB
QUIT
AHT IF DDBRHTF
DO TAB^DDBRAHT
QUIT
+1 GOTO BQT
AHTR IF DDBRHTF
DO REVTAB^DDBRAHTR
QUIT
+1 GOTO BQT
TEHT IF DDBRHTF
DO TEDIT^DDBRAHTE
QUIT
+1 GOTO BQT
RA IF DDBRHTF
DO RA^DDBRAHTE
QUIT
+1 GOTO BQT
SCRN1 IF DDBRSA=2
DO SR^DDBRS(2,1,.DDBRSA)
WRITE @IOSTBM
GOTO RPS
+1 GOTO BQT
SCRN2 IF DDBRSA=1
DO SR^DDBRS(1,2,.DDBRSA)
WRITE @IOSTBM
GOTO RPS
+1 GOTO BQT
SPLIT IF 'DDBRSA
IF $DATA(DDBRSA(1))
DO SPLIT^DDBRS
QUIT
+1 GOTO BQT
FULL IF DDBRSA
DO FULL^DDBRS(.DDBRSA)
QUIT
+1 GOTO BQT
RESIZU IF DDBRSA
IF (DDBRSA(1,"IOBM")-1)>(DDBRSA(0,"IOTM")+2)
SET DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")-1
SET DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")-1
DO 2
DO 1
DO ENTB^DDBRS(.DDBRSA,-1)
GOTO RPS
+1 GOTO BQT
RESIZD IF DDBRSA
IF (DDBRSA(2,"IOTM")+1)<(DDBRSA(0,"IOBM")-2)
SET DDBRSA(1,"IOBM")=DDBRSA(1,"IOBM")+1
SET DDBRSA(2,"IOTM")=DDBRSA(2,"IOTM")+1
DO 1
DO 2
DO ENTB^DDBRS(.DDBRSA,+1)
GOTO RPS
+1 GOTO BQT
BQT WRITE $CHAR(7)
+1 QUIT
1 SET DX=0
SET DY=$PIECE(DDBRSA(1,"DDBSY"),";",4)
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
QUIT
2 SET DX=0
SET DY=$PIECE(DDBRSA(2,"DDBSY"),";")
XECUTE IOXY
WRITE $PIECE(DDGLCLR,DDGLDEL)
QUIT
DDBMAP ;
+1 ;;LNU;AU;
+2 ;;LND;AD;
+3 ;;COLR;AR;
+4 ;;COLL;AL;
+5 ;;EXIT;F1_"E";
+6 ;;QUIT;F1_"Q";
+7 ;;PU;F1_AU;
+8 ;;PU;PREVSC;
+9 ;;PD;F1_AD;
+10 ;;PD;NEXTSC;
+11 ;;COLRE;F1_AR;
+12 ;;COLLE;F1_AL;
+13 ;;STPB;F1_"C";
+14 ;;VIEW;F1_"V";
+15 ;;TOP;F1_"T";
+16 ;;BOT;F1_"B";
+17 ;;GOTO;F1_"G";
+18 ;;FIND;F1_"F";
+19 ;;FIND;FIND;
+20 ;;NEXT;"N";
+21 ;;NEXT;F1_"N";
+22 ;;RPS;F1_"P";
+23 ;;SWITCH;F1_"S";
+24 ;;SWITCH;SELECT;
+25 ;;RETURN;"R";
+26 ;;HELP;F1_"H";
+27 ;;HELP;"HELP";
+28 ;;HELPS;F1_F1_"H";
+29 ;;EXIT;"EXIT";
+30 ;;SCRN1;F2_AU;
+31 ;;SCRN2;F2_AD;
+32 ;;SPLIT;F2_"S";
+33 ;;FULL;F2_"F";
+34 ;;RESIZU;F2_F2_AU;
+35 ;;RESIZD;F2_F2_AD;
+36 ;;HU;F1_F1_AU;
+37 ;;HD;F1_F1_AD;
+38 ;;PH;F1_F1_F1_"H";
+39 ;;STPB;F1_F1_"C";
+40 ;;AHT;$C(9);
+41 ;;AHTR;"Q";
+42 ;;TEHT;F4_"T";
+43 ;;RA;F4_"A";
+44 ;;COLR;$C(13);
+45 ;;PRINT;F1_F1_"P";
