DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;1:31 PM 16 Aug 2000 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**18**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
LOAD ;Put up "box" and load document
N DDWI,DDWX
D BOX
;
I $D(DWLC)[0 D
. S DWLC=$S($D(@DDWDIC@(0))#2:+$P(@DDWDIC@(0),U,4),1:$O(@DDWDIC@(""),-1))
. S:$D(@DDWDIC@(1))#2 $E(DDWBF,4)=1
S DDWCNT=$S(DWLC:DWLC,1:1)
;
D:DDWCNT>1 MSG^DDW("Loading text ...")
F DDWI=DDWCNT:-1:DDWMR+1 D
. S DDWSTB=DDWSTB+1
. S DDWX=$S('$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI)))
. D:DDWX?.E1C.E CTRL
. S ^TMP("DDW1",$J,DDWSTB)=DDWX
;
F DDWI=1:1:DDWMR D
. S DDWX=$S(DDWI>DDWCNT:"",'$E(DDWBF,4):$G(@DDWDIC@(DDWI,0)),1:$G(@DDWDIC@(DDWI)))
. D:DDWX?.E1C.E CTRL
. S DDWL(DDWI)=DDWX
. I DDWC'>IOM,DDWRW'>DDWMR,DDWI'>DDWCNT,DDWX'?." " D
.. D CUP(DDWI,1) W $E(DDWX,1,IOM)
;
I DDWCNT=1,DDWL(1)?1." " S DDWL(1)=""
D:DDWCNT>1 MSG^DDW()
;
D:$G(DDWED) MSG^DDW($C(7)_$P(DDGLVID,DDGLDEL,6)_"WARNING: Control characters in the text have been replaced with spaces."_$P(DDGLVID,DDGLDEL,10))
;
I DDWRW="B" D
. D BOT^DDW3
E D LINE^DDWG(DDWRW,DDWC)
Q
;
CTRL ;Strip control characters from DDWX
N I
S DDWED=1
F I=1:1:$L(DDWX) S:$E(DDWX,I)?1C $E(DDWX,I)=" "
Q
;
BOX ;Draw box
N DDWX
;
I $D(DIWETXT) D
. D CUP(-1,1)
. W $P(DDGLVID,DDGLDEL)_$E(DIWETXT,1,IOM)_$P(DDGLVID,DDGLDEL,10)
;
I $D(DIWESUB) S DDWX=DIWESUB
E I $D(DH)#2,$D(DIE) S DDWX=DH
S DDWX=$E($G(DDWX),1,30)
;
D CUP(0,1) W $TR($J("",IOM)," ","=")
I DDWRAP S DX=2 X IOXY W "[ WRAP ]"
S DX=12 X IOXY W $S(DDWREP:"[ REPLACE ]",1:"[ INSERT ]=")
S DX=40-($L(DDWX)\2) X IOXY W "< "_$E(DDWX,1,30)_" >"
S DX=61 X IOXY W "[ <PF1>H=Help ]"
;
D CUP(DDWMR+1,1) W $E(DDWRUL,1,IOM)
I DDWLMAR-DDWOFS'<1,DDWLMAR-DDWOFS'>IOM D
. S DX=DDWLMAR-DDWOFS-1 X IOXY W "<"
I DDWRMAR-DDWOFS'<1,DDWRMAR-DDWOFS'>IOM D
. S DX=DDWRMAR-DDWOFS-1 X IOXY W ">"
Q
;
AUTOTM ;Prompt for autosave time
N DDWHLP,DDWANS,DDWCOD
S DDWHLP(1)=" Enter the interval in MINUTES you wish to have the Screen Editor"
S DDWHLP(2)=" automatically save the text. Enter a number between 0 and 120."
S DDWHLP(3)=" A value of 0 means text is NOT automatically saved."
D ASK^DDWG(5,"Interval in MINUTES to automatically save text: ",15,+$G(DDWAUTO),"D AUTOVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD)
;
Q:DDWCOD="TO"!(DDWANS=U)
I $G(DDWANS) D
. S DDWAUTO=DDWANS
. S DDWAUTO("H")=$H
. S DDWAUTO("S")=DDWAUTO*60
E K DDWAUTO
Q
;
AUTOVAL ;Validate autosave time
K DDWERR
I DDWX?."^"!($P($G(DDWCOD),U)="TO") S DDWX=U Q
I $L(DDWX)>15 D
. S DDWERR=" Response must not be more than 15 characters in length."
I DDWX'=+$P(DDWX,"E") D
. S DDWERR=" Response must be numeric."
I DDWX>120!(DDWX<0) D
. S DDWERR=" Response must be between 0 and 120."
Q
;
AUTOSV ;Autosave
I $D(DDWED) K DDWED D SV
S DDWAUTO("H")=$H
Q
;
SV ;Called from DDWT1 and AUTOSV
D SAVE
S:DDWCNT<1 DDWCNT=1
I DDWRW+DDWA>DDWCNT D
. D POS(DDWCNT-DDWA,"E","RN")
E D POS(DDWRW,DDWC)
Q
;
SAVE ;Save document
N DDWI,DDWLMEM,DDWLSTB,DDWX
D MSG^DDW("Saving text ...") H .5
S DDWCNT=0
K @DDWDIC
;
F DDWI=1:1:DDWA D
. S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW",$J,DDWI))
. I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX
. E S @DDWDIC@(DDWCNT)=DDWX
;
S DDWLMEM=999
F DDWI=1:1:DDWSTB+1 Q:DDWI>DDWSTB Q:^TMP("DDW1",$J,DDWI)'?." "
I DDWI'>DDWSTB S DDWLSTB=DDWI
E D
. F DDWI=DDWMR:-1:0 Q:'DDWI Q:DDWL(DDWI)'?." "
. S DDWLMEM=DDWI
;
F DDWI=1:1:$$MIN(DDWLMEM,DDWMR) D
. S DDWCNT=DDWCNT+1,DDWX=$$NTS(DDWL(DDWI))
. I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX
. E S @DDWDIC@(DDWCNT)=DDWX
;
I $D(DDWLSTB) F DDWI=DDWSTB:-1:DDWLSTB D
. S DDWCNT=DDWCNT+1,DDWX=$$NTS(^TMP("DDW1",$J,DDWI))
. I '$E(DDWBF,4) S @DDWDIC@(DDWCNT,0)=DDWX
. E S @DDWDIC@(DDWCNT)=DDWX
;
S DWLC=DDWCNT,DWHD=U
I DDWCNT,'$E(DDWBF,4) S @DDWDIC@(0)=U_U_DWLC_U_DWLC_U_DT_U
D MSG^DDW()
Q
;
QUIT ;If any edits were made, issue confirmation prompt.
S DDWFIN=""
Q:$G(DDWFLAGS)["Q"!'$D(DDWED)
;
N DDWHLP,DDWANS,DDWCOD
S DDWHLP(1)=" Enter 'Yes' to save changes and quit."
S DDWHLP(2)=" Enter 'No' to discard changes and quit."
S DDWHLP(3)=" Enter '^' to return to the editor without saving or quitting."
;
D ASK^DDWG(5,"Do you want to save changes? ",3,"","D QUITVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD)
;
I DDWCOD="TO"!(DDWANS=U) K DDWFIN
E I DDWANS="Y" D SAVE K DUOUT ;GFT
Q
;
QUITVAL ;Validate responses to the confirmation prompt
K DDWERR
I DDWX[U!($P(DDWCOD,U)="TO") S DDWX=U Q
I DDWX="" S DDWERR=" Response is required. Enter ? for help." Q
;
S:DDWX?.E1L.E DDWX=$TR(DDWX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
I $P("YES",DDWX)]"",$P("NO",DDWX)]"" D Q
. S DDWERR=" Not a valid response. Enter ? for help."
;
S DDWX=$E(DDWX)
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
;
CUP(Y,X) ;Cursor positioning
S DY=IOTM+Y-2,DX=X-1 X IOXY
Q
;
MIN(X,Y) ;Return the minimum of X and Y
Q $S(X<Y:X,1:Y)
;
NTS(X) ;Change "" to " "
Q $S(X="":" ",1:X)
;
TR(X,F) ;Strip trailing blanks
;If F["B" return " " if X=""
I $G(X)]"" D
. N I
. F I=$L(X):-1:0 Q:$E(X,I)'=" "
. S X=$E(X,1,I)
I X="",$G(F)["B" S X=" "
Q X
DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;1:31 PM 16 Aug 2000 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**18**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 ;
LOAD ;Put up "box" and load document
+1 NEW DDWI,DDWX
+2 DO BOX
+3 ;
+4 IF $DATA(DWLC)[0
Begin DoDot:1
+5 SET DWLC=$SELECT($DATA(@DDWDIC@(0))#2:+$PIECE(@DDWDIC@(0),U,4),1:$ORDER(@DDWDIC@(""),-1))
+6 IF $DATA(@DDWDIC@(1))#2
SET $EXTRACT(DDWBF,4)=1
End DoDot:1
+7 SET DDWCNT=$SELECT(DWLC:DWLC,1:1)
+8 ;
+9 IF DDWCNT>1
DO MSG^DDW("Loading text ...")
+10 FOR DDWI=DDWCNT:-1:DDWMR+1
Begin DoDot:1
+11 SET DDWSTB=DDWSTB+1
+12 SET DDWX=$SELECT('$EXTRACT(DDWBF,4):$GET(@DDWDIC@(DDWI,0)),1:$GET(@DDWDIC@(DDWI)))
+13 IF DDWX?.E1C.E
DO CTRL
+14 SET ^TMP("DDW1",$JOB,DDWSTB)=DDWX
End DoDot:1
+15 ;
+16 FOR DDWI=1:1:DDWMR
Begin DoDot:1
+17 SET DDWX=$SELECT(DDWI>DDWCNT:"",'$EXTRACT(DDWBF,4):$GET(@DDWDIC@(DDWI,0)),1:$GET(@DDWDIC@(DDWI)))
+18 IF DDWX?.E1C.E
DO CTRL
+19 SET DDWL(DDWI)=DDWX
+20 IF DDWC'>IOM
IF DDWRW'>DDWMR
IF DDWI'>DDWCNT
IF DDWX'?." "
Begin DoDot:2
+21 DO CUP(DDWI,1)
WRITE $EXTRACT(DDWX,1,IOM)
End DoDot:2
End DoDot:1
+22 ;
+23 IF DDWCNT=1
IF DDWL(1)?1." "
SET DDWL(1)=""
+24 IF DDWCNT>1
DO MSG^DDW()
+25 ;
+26 IF $GET(DDWED)
DO MSG^DDW($CHAR(7)_$PIECE(DDGLVID,DDGLDEL,6)_"WARNING: Control characters in the text have been replaced with spaces."_$PIECE(DDGLVID,DDGLDEL,10))
+27 ;
+28 IF DDWRW="B"
Begin DoDot:1
+29 DO BOT^DDW3
End DoDot:1
+30 IF '$TEST
DO LINE^DDWG(DDWRW,DDWC)
+31 QUIT
+32 ;
CTRL ;Strip control characters from DDWX
+1 NEW I
+2 SET DDWED=1
+3 FOR I=1:1:$LENGTH(DDWX)
IF $EXTRACT(DDWX,I)?1C
SET $EXTRACT(DDWX,I)=" "
+4 QUIT
+5 ;
BOX ;Draw box
+1 NEW DDWX
+2 ;
+3 IF $DATA(DIWETXT)
Begin DoDot:1
+4 DO CUP(-1,1)
+5 WRITE $PIECE(DDGLVID,DDGLDEL)_$EXTRACT(DIWETXT,1,IOM)_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+6 ;
+7 IF $DATA(DIWESUB)
SET DDWX=DIWESUB
+8 IF '$TEST
IF $DATA(DH)#2
IF $DATA(DIE)
SET DDWX=DH
+9 SET DDWX=$EXTRACT($GET(DDWX),1,30)
+10 ;
+11 DO CUP(0,1)
WRITE $TRANSLATE($JUSTIFY("",IOM)," ","=")
+12 IF DDWRAP
SET DX=2
XECUTE IOXY
WRITE "[ WRAP ]"
+13 SET DX=12
XECUTE IOXY
WRITE $SELECT(DDWREP:"[ REPLACE ]",1:"[ INSERT ]=")
+14 SET DX=40-($LENGTH(DDWX)\2)
XECUTE IOXY
WRITE "< "_$EXTRACT(DDWX,1,30)_" >"
+15 SET DX=61
XECUTE IOXY
WRITE "[ <PF1>H=Help ]"
+16 ;
+17 DO CUP(DDWMR+1,1)
WRITE $EXTRACT(DDWRUL,1,IOM)
+18 IF DDWLMAR-DDWOFS'<1
IF DDWLMAR-DDWOFS'>IOM
Begin DoDot:1
+19 SET DX=DDWLMAR-DDWOFS-1
XECUTE IOXY
WRITE "<"
End DoDot:1
+20 IF DDWRMAR-DDWOFS'<1
IF DDWRMAR-DDWOFS'>IOM
Begin DoDot:1
+21 SET DX=DDWRMAR-DDWOFS-1
XECUTE IOXY
WRITE ">"
End DoDot:1
+22 QUIT
+23 ;
AUTOTM ;Prompt for autosave time
+1 NEW DDWHLP,DDWANS,DDWCOD
+2 SET DDWHLP(1)=" Enter the interval in MINUTES you wish to have the Screen Editor"
+3 SET DDWHLP(2)=" automatically save the text. Enter a number between 0 and 120."
+4 SET DDWHLP(3)=" A value of 0 means text is NOT automatically saved."
+5 DO ASK^DDWG(5,"Interval in MINUTES to automatically save text: ",15,+$GET(DDWAUTO),"D AUTOVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD)
+6 ;
+7 IF DDWCOD="TO"!(DDWANS=U)
QUIT
+8 IF $GET(DDWANS)
Begin DoDot:1
+9 SET DDWAUTO=DDWANS
+10 SET DDWAUTO("H")=$HOROLOG
+11 SET DDWAUTO("S")=DDWAUTO*60
End DoDot:1
+12 IF '$TEST
KILL DDWAUTO
+13 QUIT
+14 ;
AUTOVAL ;Validate autosave time
+1 KILL DDWERR
+2 IF DDWX?."^"!($PIECE($GET(DDWCOD),U)="TO")
SET DDWX=U
QUIT
+3 IF $LENGTH(DDWX)>15
Begin DoDot:1
+4 SET DDWERR=" Response must not be more than 15 characters in length."
End DoDot:1
+5 IF DDWX'=+$PIECE(DDWX,"E")
Begin DoDot:1
+6 SET DDWERR=" Response must be numeric."
End DoDot:1
+7 IF DDWX>120!(DDWX<0)
Begin DoDot:1
+8 SET DDWERR=" Response must be between 0 and 120."
End DoDot:1
+9 QUIT
+10 ;
AUTOSV ;Autosave
+1 IF $DATA(DDWED)
KILL DDWED
DO SV
+2 SET DDWAUTO("H")=$HOROLOG
+3 QUIT
+4 ;
SV ;Called from DDWT1 and AUTOSV
+1 DO SAVE
+2 IF DDWCNT<1
SET DDWCNT=1
+3 IF DDWRW+DDWA>DDWCNT
Begin DoDot:1
+4 DO POS(DDWCNT-DDWA,"E","RN")
End DoDot:1
+5 IF '$TEST
DO POS(DDWRW,DDWC)
+6 QUIT
+7 ;
SAVE ;Save document
+1 NEW DDWI,DDWLMEM,DDWLSTB,DDWX
+2 DO MSG^DDW("Saving text ...")
HANG .5
+3 SET DDWCNT=0
+4 KILL @DDWDIC
+5 ;
+6 FOR DDWI=1:1:DDWA
Begin DoDot:1
+7 SET DDWCNT=DDWCNT+1
SET DDWX=$$NTS(^TMP("DDW",$JOB,DDWI))
+8 IF '$EXTRACT(DDWBF,4)
SET @DDWDIC@(DDWCNT,0)=DDWX
+9 IF '$TEST
SET @DDWDIC@(DDWCNT)=DDWX
End DoDot:1
+10 ;
+11 SET DDWLMEM=999
+12 FOR DDWI=1:1:DDWSTB+1
IF DDWI>DDWSTB
QUIT
IF ^TMP("DDW1",$JOB,DDWI)'?." "
QUIT
+13 IF DDWI'>DDWSTB
SET DDWLSTB=DDWI
+14 IF '$TEST
Begin DoDot:1
+15 FOR DDWI=DDWMR:-1:0
IF 'DDWI
QUIT
IF DDWL(DDWI)'?." "
QUIT
+16 SET DDWLMEM=DDWI
End DoDot:1
+17 ;
+18 FOR DDWI=1:1:$$MIN(DDWLMEM,DDWMR)
Begin DoDot:1
+19 SET DDWCNT=DDWCNT+1
SET DDWX=$$NTS(DDWL(DDWI))
+20 IF '$EXTRACT(DDWBF,4)
SET @DDWDIC@(DDWCNT,0)=DDWX
+21 IF '$TEST
SET @DDWDIC@(DDWCNT)=DDWX
End DoDot:1
+22 ;
+23 IF $DATA(DDWLSTB)
FOR DDWI=DDWSTB:-1:DDWLSTB
Begin DoDot:1
+24 SET DDWCNT=DDWCNT+1
SET DDWX=$$NTS(^TMP("DDW1",$JOB,DDWI))
+25 IF '$EXTRACT(DDWBF,4)
SET @DDWDIC@(DDWCNT,0)=DDWX
+26 IF '$TEST
SET @DDWDIC@(DDWCNT)=DDWX
End DoDot:1
+27 ;
+28 SET DWLC=DDWCNT
SET DWHD=U
+29 IF DDWCNT
IF '$EXTRACT(DDWBF,4)
SET @DDWDIC@(0)=U_U_DWLC_U_DWLC_U_DT_U
+30 DO MSG^DDW()
+31 QUIT
+32 ;
QUIT ;If any edits were made, issue confirmation prompt.
+1 SET DDWFIN=""
+2 IF $GET(DDWFLAGS)["Q"!'$DATA(DDWED)
QUIT
+3 ;
+4 NEW DDWHLP,DDWANS,DDWCOD
+5 SET DDWHLP(1)=" Enter 'Yes' to save changes and quit."
+6 SET DDWHLP(2)=" Enter 'No' to discard changes and quit."
+7 SET DDWHLP(3)=" Enter '^' to return to the editor without saving or quitting."
+8 ;
+9 DO ASK^DDWG(5,"Do you want to save changes? ",3,"","D QUITVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD)
+10 ;
+11 IF DDWCOD="TO"!(DDWANS=U)
KILL DDWFIN
+12 ;GFT
IF '$TEST
IF DDWANS="Y"
DO SAVE
KILL DUOUT
+13 QUIT
+14 ;
QUITVAL ;Validate responses to the confirmation prompt
+1 KILL DDWERR
+2 IF DDWX[U!($PIECE(DDWCOD,U)="TO")
SET DDWX=U
QUIT
+3 IF DDWX=""
SET DDWERR=" Response is required. Enter ? for help."
QUIT
+4 ;
+5 IF DDWX?.E1L.E
SET DDWX=$TRANSLATE(DDWX,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+6 ;
+7 IF $PIECE("YES",DDWX)]""
IF $PIECE("NO",DDWX)]""
Begin DoDot:1
+8 SET DDWERR=" Not a valid response. Enter ? for help."
End DoDot:1
QUIT
+9 ;
+10 SET DDWX=$EXTRACT(DDWX)
+11 QUIT
+12 ;
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
+10 ;
CUP(Y,X) ;Cursor positioning
+1 SET DY=IOTM+Y-2
SET DX=X-1
XECUTE IOXY
+2 QUIT
+3 ;
MIN(X,Y) ;Return the minimum of X and Y
+1 QUIT $SELECT(X<Y:X,1:Y)
+2 ;
NTS(X) ;Change "" to " "
+1 QUIT $SELECT(X="":" ",1:X)
+2 ;
TR(X,F) ;Strip trailing blanks
+1 ;If F["B" return " " if X=""
+2 IF $GET(X)]""
Begin DoDot:1
+3 NEW I
+4 FOR I=$LENGTH(X):-1:0
IF $EXTRACT(X,I)'=" "
QUIT
+5 SET X=$EXTRACT(X,1,I)
End DoDot:1
+6 IF X=""
IF $GET(F)["B"
SET X=" "
+7 QUIT X
