DDWG ;SFISC/MKO-GOTO ;3:40 PM 5 Jul 1996
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
GOTO ;Go to a specific location
N DDWANS,DDWI,DDWHLP
S DDWHLP(1)="Examples, to go to a screen: S21, 21, S+3, +3, -3"
S DDWHLP(2)=" to go to a line: L53, L+4, L-5"
S DDWHLP(3)=" to go to a column: C40, C+10, C-20"
D ASK(4,"Go to: ",17,"","D VALGTO",.DDWHLP,.DDWANS)
I U[DDWANS
E I "Ss"[$E(DDWANS)!(DDWANS'?1A.E) D
. D GOTOS
E I "Ll"[$E(DDWANS) D
. D GOTOL
E I "Cc"[$E(DDWANS) D
. D GOTOC
Q
;
GOTOS ;Go to a page
N DDWS
S DDWS=DDWANS
S:DDWS?1A.E DDWS=$E(DDWS,2,999)
S:DDWS?1P.E DDWS=$E(DDWS,2,999)
I DDWANS["+" S DDWS=$$SCREEN+DDWS
E I DDWANS["-" S DDWS=$$SCREEN-DDWS
I DDWS<1 S DDWS=1
E I DDWS>$$LTOSC(DDWCNT) S DDWS=$$LTOSC(DDWCNT)
D LINE(DDWS-1*DDWMR+1)
Q
;
GOTOL ;Go to a line
N DDWLN
S DDWLN=DDWANS
S:DDWLN?1A.E DDWLN=$E(DDWLN,2,999)
S:DDWLN?1P.E DDWLN=$E(DDWLN,2,999)
I DDWANS["+" S DDWLN=DDWA+DDWRW+DDWLN
E I DDWANS["-" S DDWLN=DDWA+DDWRW-DDWLN
I DDWLN<1 S DDWLN=1
E I DDWLN>DDWCNT S DDWLN=DDWCNT
D LINE(DDWLN)
Q
;
GOTOC ;Go to a column
N DDWCOL
S DDWCOL=DDWANS
S:DDWCOL?1A.E DDWCOL=$E(DDWCOL,2,999)
S:DDWCOL?1P.E DDWCOL=$E(DDWCOL,2,999)
I DDWANS["+" S DDWCOL=DDWC+DDWCOL
E I DDWANS["-" S DDWCOL=DDWC-DDWCOL
I DDWCOL<1 S DDWCOL=1
E I DDWCOL>246 S DDWCOL=246
D POS(DDWRW,DDWCOL,"R")
Q
;
LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN
I $G(DDWCOL)'="E",'$G(DDWCOL) S DDWCOL=1
S:DDWLN>DDWCNT DDWLN=DDWCNT
I DDWLN>DDWA,DDWLN'>(DDWA+DDWMR-1) D
. D POS(DDWLN-DDWA,DDWCOL,"RN")
E I DDWLN>DDWA D
. D SHFTDN^DDW3(DDWLN,DDWCOL),POS(DDWLN-DDWA,DDWCOL,"RN")
E D
. D SHFTUP^DDW3(DDWLN),POS(1,DDWCOL,"RN")
Q
;
ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user
N DDWI
D CUP(DDWMR-DDWLC,1)
W $P(DDGLGRA,DDGLDEL)_$TR($J("",IOM)," ",$P(DDGLGRA,DDGLDEL,3))_$P(DDGLGRA,DDGLDEL,2)
F DDWI=DDWMR-DDWLC+1:1:DDWMR D CUP(DDWI,1) W $P(DDGLCLR,DDGLDEL)
K DDWANS F D PROMPT Q:$D(DDWANS)
;
F DDWI=DDWMR-DDWLC:1:DDWMR D
. D CUP(DDWI,1)
. W $P(DDGLCLR,DDGLDEL)_$E(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
D POS(DDWRW,DDWC,"RN")
Q
;
PROMPT ;Issue read
N DDWERR,DDWX
D CUP(DDWMR-DDWLC+1,1) W DDWS_$P(DDGLCLR,DDGLDEL)
D EN^DIR0(IOTM+DDWMR-DDWLC-1,$L(DDWS),DDWLEN,1,$G(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)
;
I DDWX?1."?",$D(DDWHLP)>9!($G(DDWHLP)]"") D HELP(.DDWHLP) Q
I $G(DDWVAL)]"" X DDWVAL I $D(DDWERR) W $C(7) D HELP(.DDWERR) Q
S DDWANS=DDWX
Q
;
VALGTO ;Validate DDWX
N DDWCH
Q:U[DDWX
S DDWERR="Invalid format. Enter ? for examples."
Q:DDWX'?.1A.1P1.15N
I DDWX?1A.E S DDWCH=$E(DDWX) Q:"SsLlCc"'[DDWCH
I DDWX?.E1P.E I DDWX'["+",DDWX'["-" Q
K DDWERR
Q
;
HELP(DDWMSG) ;Print message
N DDWI,DDWEC
S:$D(DDWMSG)<9 DDWMSG(1)=DDWMSG
S DDWEC=$O(DDWMSG(""),-1)
F DDWI=2:1:DDWLC D
. D CUP(DDWMR-DDWLC+DDWI,1)
. W $P(DDGLCLR,DDGLDEL)_$G(DDWMSG(DDWI-DDWLC+DDWEC))
Q
;
SCREEN() ;Return current screen
Q DDWA+DDWRW-1\DDWMR+1
;
LTOSC(L) ;Convert line number to page number
Q L-1\DDWMR+1
;
CUP(Y,X) ;Pos cursor
S DY=IOTM+Y-2,DX=X-1 X IOXY
Q
;
POS(R,C,F) ;Pos cursor based on char pos C
N DDWX
S:$G(C)="E" C=$L($G(DDWL(R)))+1
S:$G(F)["N" DDWN=$G(DDWL(R))
S:$G(F)["R" DDWRW=R,DDWC=C
;
S DDWX=C-DDWOFS
I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
Q
DDWG ;SFISC/MKO-GOTO ;3:40 PM 5 Jul 1996
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
GOTO ;Go to a specific location
+1 NEW DDWANS,DDWI,DDWHLP
+2 SET DDWHLP(1)="Examples, to go to a screen: S21, 21, S+3, +3, -3"
+3 SET DDWHLP(2)=" to go to a line: L53, L+4, L-5"
+4 SET DDWHLP(3)=" to go to a column: C40, C+10, C-20"
+5 DO ASK(4,"Go to: ",17,"","D VALGTO",.DDWHLP,.DDWANS)
+6 IF U[DDWANS
+7 IF '$TEST
IF "Ss"[$EXTRACT(DDWANS)!(DDWANS'?1A.E)
Begin DoDot:1
+8 DO GOTOS
End DoDot:1
+9 IF '$TEST
IF "Ll"[$EXTRACT(DDWANS)
Begin DoDot:1
+10 DO GOTOL
End DoDot:1
+11 IF '$TEST
IF "Cc"[$EXTRACT(DDWANS)
Begin DoDot:1
+12 DO GOTOC
End DoDot:1
+13 QUIT
+14 ;
GOTOS ;Go to a page
+1 NEW DDWS
+2 SET DDWS=DDWANS
+3 IF DDWS?1A.E
SET DDWS=$EXTRACT(DDWS,2,999)
+4 IF DDWS?1P.E
SET DDWS=$EXTRACT(DDWS,2,999)
+5 IF DDWANS["+"
SET DDWS=$$SCREEN+DDWS
+6 IF '$TEST
IF DDWANS["-"
SET DDWS=$$SCREEN-DDWS
+7 IF DDWS<1
SET DDWS=1
+8 IF '$TEST
IF DDWS>$$LTOSC(DDWCNT)
SET DDWS=$$LTOSC(DDWCNT)
+9 DO LINE(DDWS-1*DDWMR+1)
+10 QUIT
+11 ;
GOTOL ;Go to a line
+1 NEW DDWLN
+2 SET DDWLN=DDWANS
+3 IF DDWLN?1A.E
SET DDWLN=$EXTRACT(DDWLN,2,999)
+4 IF DDWLN?1P.E
SET DDWLN=$EXTRACT(DDWLN,2,999)
+5 IF DDWANS["+"
SET DDWLN=DDWA+DDWRW+DDWLN
+6 IF '$TEST
IF DDWANS["-"
SET DDWLN=DDWA+DDWRW-DDWLN
+7 IF DDWLN<1
SET DDWLN=1
+8 IF '$TEST
IF DDWLN>DDWCNT
SET DDWLN=DDWCNT
+9 DO LINE(DDWLN)
+10 QUIT
+11 ;
GOTOC ;Go to a column
+1 NEW DDWCOL
+2 SET DDWCOL=DDWANS
+3 IF DDWCOL?1A.E
SET DDWCOL=$EXTRACT(DDWCOL,2,999)
+4 IF DDWCOL?1P.E
SET DDWCOL=$EXTRACT(DDWCOL,2,999)
+5 IF DDWANS["+"
SET DDWCOL=DDWC+DDWCOL
+6 IF '$TEST
IF DDWANS["-"
SET DDWCOL=DDWC-DDWCOL
+7 IF DDWCOL<1
SET DDWCOL=1
+8 IF '$TEST
IF DDWCOL>246
SET DDWCOL=246
+9 DO POS(DDWRW,DDWCOL,"R")
+10 QUIT
+11 ;
LINE(DDWLN,DDWCOL) ;Adjust arrays and position cursor on line DDWLN
+1 IF $GET(DDWCOL)'="E"
IF '$GET(DDWCOL)
SET DDWCOL=1
+2 IF DDWLN>DDWCNT
SET DDWLN=DDWCNT
+3 IF DDWLN>DDWA
IF DDWLN'>(DDWA+DDWMR-1)
Begin DoDot:1
+4 DO POS(DDWLN-DDWA,DDWCOL,"RN")
End DoDot:1
+5 IF '$TEST
IF DDWLN>DDWA
Begin DoDot:1
+6 DO SHFTDN^DDW3(DDWLN,DDWCOL)
DO POS(DDWLN-DDWA,DDWCOL,"RN")
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 DO SHFTUP^DDW3(DDWLN)
DO POS(1,DDWCOL,"RN")
End DoDot:1
+9 QUIT
+10 ;
ASK(DDWLC,DDWS,DDWLEN,DDWDEF,DDWVAL,DDWHLP,DDWANS,DDWCOD) ;Prompt user
+1 NEW DDWI
+2 DO CUP(DDWMR-DDWLC,1)
+3 WRITE $PIECE(DDGLGRA,DDGLDEL)_$TRANSLATE($JUSTIFY("",IOM)," ",$PIECE(DDGLGRA,DDGLDEL,3))_$PIECE(DDGLGRA,DDGLDEL,2)
+4 FOR DDWI=DDWMR-DDWLC+1:1:DDWMR
DO CUP(DDWI,1)
WRITE $PIECE(DDGLCLR,DDGLDEL)
+5 KILL DDWANS
FOR
DO PROMPT
IF $DATA(DDWANS)
QUIT
+6 ;
+7 FOR DDWI=DDWMR-DDWLC:1:DDWMR
Begin DoDot:1
+8 DO CUP(DDWI,1)
+9 WRITE $PIECE(DDGLCLR,DDGLDEL)_$EXTRACT(DDWL(DDWI),1+DDWOFS,IOM+DDWOFS)
End DoDot:1
+10 DO POS(DDWRW,DDWC,"RN")
+11 QUIT
+12 ;
PROMPT ;Issue read
+1 NEW DDWERR,DDWX
+2 DO CUP(DDWMR-DDWLC+1,1)
WRITE DDWS_$PIECE(DDGLCLR,DDGLDEL)
+3 DO EN^DIR0(IOTM+DDWMR-DDWLC-1,$LENGTH(DDWS),DDWLEN,1,$GET(DDWDEF),245,"","","AKTW",.DDWX,.DDWCOD)
+4 ;
+5 IF DDWX?1."?"
IF $DATA(DDWHLP)>9!($GET(DDWHLP)]"")
DO HELP(.DDWHLP)
QUIT
+6 IF $GET(DDWVAL)]""
XECUTE DDWVAL
IF $DATA(DDWERR)
WRITE $CHAR(7)
DO HELP(.DDWERR)
QUIT
+7 SET DDWANS=DDWX
+8 QUIT
+9 ;
VALGTO ;Validate DDWX
+1 NEW DDWCH
+2 IF U[DDWX
QUIT
+3 SET DDWERR="Invalid format. Enter ? for examples."
+4 IF DDWX'?.1A.1P1.15N
QUIT
+5 IF DDWX?1A.E
SET DDWCH=$EXTRACT(DDWX)
IF "SsLlCc"'[DDWCH
QUIT
+6 IF DDWX?.E1P.E
IF DDWX'["+"
IF DDWX'["-"
QUIT
+7 KILL DDWERR
+8 QUIT
+9 ;
HELP(DDWMSG) ;Print message
+1 NEW DDWI,DDWEC
+2 IF $DATA(DDWMSG)<9
SET DDWMSG(1)=DDWMSG
+3 SET DDWEC=$ORDER(DDWMSG(""),-1)
+4 FOR DDWI=2:1:DDWLC
Begin DoDot:1
+5 DO CUP(DDWMR-DDWLC+DDWI,1)
+6 WRITE $PIECE(DDGLCLR,DDGLDEL)_$GET(DDWMSG(DDWI-DDWLC+DDWEC))
End DoDot:1
+7 QUIT
+8 ;
SCREEN() ;Return current screen
+1 QUIT DDWA+DDWRW-1\DDWMR+1
+2 ;
LTOSC(L) ;Convert line number to page number
+1 QUIT L-1\DDWMR+1
+2 ;
CUP(Y,X) ;Pos cursor
+1 SET DY=IOTM+Y-2
SET DX=X-1
XECUTE IOXY
+2 QUIT
+3 ;
POS(R,C,F) ;Pos cursor based on char pos C
+1 NEW DDWX
+2 IF $GET(C)="E"
SET C=$LENGTH($GET(DDWL(R)))+1
+3 IF $GET(F)["N"
SET DDWN=$GET(DDWL(R))
+4 IF $GET(F)["R"
SET DDWRW=R
SET DDWC=C
+5 ;
+6 SET DDWX=C-DDWOFS
+7 IF DDWX>IOM!(DDWX<1)
DO SHIFT^DDW3(C,.DDWOFS)
+8 SET DY=IOTM+R-2
SET DX=C-DDWOFS-1
XECUTE IOXY
+9 QUIT
