DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;06:11 PM 25 Aug 2002
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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) ;HOW MANY LINES WE HAVE TOTAL
;
D:DDWCNT>1 MSG^DDW("...")
F DDWI=DDWCNT:-1:DDWMR+1 D ;PUT HIDDEN LINES INTO ^TMP
. 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 ;start writing from line 1 (!)
. 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) ;HERE'S WHERE A LINE IS WRITTEN OUT
;
I DDWCNT=1,DDWL(1)?1." " S DDWL(1)=""
D:DDWCNT>1 MSG^DDW()
;
CTRLREM D:$G(DDWED) MSG^DDW($C(7)_$P(DDGLVID,DDGLDEL,6)_$$EZBLD^DIALOG(8128)_$P(DDGLVID,DDGLDEL,10)) ;**'CONTROL CHARACTERS REPLACED'
;
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 "["_$$UP^DILIBF($P($$EZBLD^DIALOG(7002),U,$S(DDWREP:2,1:1)))_"]" ;**INSERT/REPLACE
S DX=40-($L(DDWX)\2) X IOXY W "< "_$E(DDWX,1,30)_" >"
N DDWH S DDWH="["_$$EZBLD^DIALOG(8074)_"]",DX=76-$L(DDWH) X IOXY W DDWH ;**
;
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($$EZBLD^DIALOG(8075.5)) H .5 ;**'SAVING CHANGES'
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,$$EZBLD^DIALOG(8075.1),3,"","D QUITVAL^DDW1",.DDWHLP,.DDWANS,.DDWCOD) ;**'DO YOU WANT TO SAVE CHANGES? '
;
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=$$EZBLD^DIALOG(8041) Q ;**'REQUIRED'
;
S:DDWX?.E1L.E DDWX=$$UP^DILIBF(DDWX) ;**
;
I $P("YES",DDWX)]"",$P("NO",DDWX)]"" D Q
. S DDWERR=$$EZBLD^DIALOG(1401) ;**'NOT VALID'
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDW1 5878 printed Apr 09, 2024@21:54:52 Page 2
DDW1 ;SFISC/PD KELTZ-LOAD, SAVE ;06:11 PM 25 Aug 2002
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
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 ;HOW MANY LINES WE HAVE TOTAL
SET DDWCNT=$SELECT(DWLC:DWLC,1:1)
+8 ;
+9 if DDWCNT>1
DO MSG^DDW("...")
+10 ;PUT HIDDEN LINES INTO ^TMP
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 ;start writing from line 1 (!)
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 ;HERE'S WHERE A LINE IS WRITTEN OUT
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 ;
CTRLREM ;**'CONTROL CHARACTERS REPLACED'
if $GET(DDWED)
DO MSG^DDW($CHAR(7)_$PIECE(DDGLVID,DDGLDEL,6)_$$EZBLD^DIALOG(8128)_$PIECE(DDGLVID,DDGLDEL,10))
+1 ;
+2 IF DDWRW="B"
Begin DoDot:1
+3 DO BOT^DDW3
End DoDot:1
+4 IF '$TEST
DO LINE^DDWG(DDWRW,DDWC)
+5 QUIT
+6 ;
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 ;**INSERT/REPLACE
SET DX=12
XECUTE IOXY
WRITE "["_$$UP^DILIBF($PIECE($$EZBLD^DIALOG(7002),U,$SELECT(DDWREP:2,1:1)))_"]"
+14 SET DX=40-($LENGTH(DDWX)\2)
XECUTE IOXY
WRITE "< "_$EXTRACT(DDWX,1,30)_" >"
+15 ;**
NEW DDWH
SET DDWH="["_$$EZBLD^DIALOG(8074)_"]"
SET DX=76-$LENGTH(DDWH)
XECUTE IOXY
WRITE DDWH
+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 ;**'SAVING CHANGES'
DO MSG^DDW($$EZBLD^DIALOG(8075.5))
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 YOU WANT TO SAVE CHANGES? '
DO ASK^DDWG(5,$$EZBLD^DIALOG(8075.1),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 ;**'REQUIRED'
IF DDWX=""
SET DDWERR=$$EZBLD^DIALOG(8041)
QUIT
+4 ;
+5 ;**
if DDWX?.E1L.E
SET DDWX=$$UP^DILIBF(DDWX)
+6 ;
+7 IF $PIECE("YES",DDWX)]""
IF $PIECE("NO",DDWX)]""
Begin DoDot:1
+8 ;**'NOT VALID'
SET DDWERR=$$EZBLD^DIALOG(1401)
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
