DDWT1 ;SFISC/PD KELTZ,MKO - READ AND PROCESS ;9NOV2016
;;22.2;VA FileMan;**4,7**;Jan 05, 2016;Build 3
;;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.
;;GFT;**18,1000,1004,1005,1045,1049,1053,1056**;Mar 30, 1999
;
;Called from DDW ROUTINE
D LOAD^DDW1 K DUOUT
;I '$G(DDWRWSET) D BOT^DDW3 I $L(DDWN) D BREAK^DDW5() ;GFT -- GO TO BOTTOM OF TEXT ;P7
F D GETIN Q:$D(DDWFIN)
Q
;
GETIN ;Get input
I DDWC'>DDWRMAR,DDWC-DDWOFS<IOM,DDWC>$L(DDWN)!DDWREP,'$D(DDWMARK) D
. N DDWANS
. D PREAD($$MIN(DDWRMAR,IOM-1+DDWOFS)-DDWC+1,DDWTO,.DDWANS,.DDWQ)
. I DDWANS]"" D
.. S DDWED=1
.. I DDWSTAT,DDWQ="TO",DDWTO<DTIME S DDWQ=""
.. S $E(DDWN,DDWC,DDWC+$L(DDWANS)-1)=DDWANS,DDWL(DDWRW)=DDWN
.. S DDWC=DDWC+$L(DDWANS)
E D
. D READ(DDWTO,.DDWQ)
. D:$L(DDWQ)=1 DISPL
;
I DDWSTAT D
. I DDWQ="TO" D
.. I $G(DDWTC) S:$$HDIFF(DDWTC,$H)+1<DTIME DDWQ=""
.. E S DDWTC=$H,DDWQ="" D:DDWSTAT STATUS
. E K DDWTC
;
I $G(DDWAUTO),DDWQ'="TO",$$HDIFF(DDWAUTO("H"),$H)'<DDWAUTO("S") D AUTOSV^DDW1
;
I $L(DDWQ)>1 D @DDWQ D:DDWSTAT STATUS
Q
;
DISPL ;Display char
I DDWC>245 W $C(7) Q
;
S DDWED=1
I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
S:DDWC-1>$L(DDWN) DDWN=DDWN_$J("",DDWC-$L(DDWN)-1)
S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)_DDWQ_$E(DDWN,DDWC+DDWREP,999)
S DDWC=DDWC+1
;
I DDWREP W DDWQ
E D
IC . I 0 ;$P(DDGLED,DDGLDEL,5)]"" W $P(DDGLED,DDGLDEL,5)_DDWQ GFT -- DON'T USE "INSERT CHARACTER" IT SEEMS NOT TO WORK
. E W DDWQ_$E(DDWN,DDWC,IOM+DDWOFS)
D POS(DDWRW,DDWC,"R")
D:$L(DDWN)>DDWRMAR WRAP^DDW5
Q
;
RUB ;COME HERE ON BACKSPACE
N DDWX
I DDWN="" S DDWCNT=DDWCNT-1 ;if current line is null --Bill Eash
S DDWED=1
I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX
;
I DDWC=1 D
. I DDWRW=1 D
.. I 'DDWA W $C(7)
.. E D MVBCK^DDW3(1),POS(1,"E","R")
. E D POS(DDWRW-1,"E","RN")
E D
. S DDWC=DDWC-1,$E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN
. S DDWX=$E(DDWN,IOM+DDWOFS)
. I DDWC-DDWOFS>0 D
.. D CUP(DDWRW,DDWC-DDWOFS)
.. I $P(DDGLED,DDGLDEL,6)]"" D
... W $P(DDGLED,DDGLDEL,6)
... I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS)
.. E W $E(DDWN_" ",DDWC,IOM+DDWOFS) D CUP(DDWRW,DDWC-DDWOFS)
. E D POS(DDWRW,DDWC)
Q
;
DEL N DDWX
S DDWED=1
I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX
;
I DDWC>$L(DDWN) D Q
. I DDWN?." " D
.. N DDWLAST
.. S DDWLAST=DDWRW+DDWA=DDWCNT
.. D XLINE^DDW5()
.. D:DDWLAST POS(DDWRW,"E","R")
. E D
.. N DDWY,DDWX
.. S DDWY=DDWRW+DDWA,DDWX=DDWC
.. D JOIN^DDW6
.. D POS(DDWY-DDWA,DDWX,"RN")
;
S $E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN,DDWX=$E(DDWN,IOM+DDWOFS)
I $P(DDGLED,DDGLDEL,6)]"" D
. W $P(DDGLED,DDGLDEL,6)
. I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS)
E D
. W $E(DDWN_" ",DDWC,IOM+DDWOFS)
. D CUP(DDWRW,DDWC-DDWOFS)
Q
;
STATUS N DDWX,DDWS
S DDWS="Scr "_(DDWA+DDWRW-1\DDWMR+1)_" of "_(DDWCNT-1\DDWMR+1)
S DDWX="Ln "_(DDWA+DDWRW)_" of "_DDWCNT
S $E(DDWS,IOM\2+1-($L(DDWX)\2),999)=DDWX
S DDWX="Col "_DDWC
S $E(DDWS,IOM-$L(DDWX),999)=DDWX
D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_DDWS
D POS(DDWRW,DDWC)
Q
;
UP I DDWRW>1 D
. D POS(DDWRW-1,DDWC,"RN")
E I DDWA D
. D MVBCK^DDW3(1)
E W $C(7)
I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R")
Q
DN I DDWN="",DDWA+DDWRW>DDWCNT W $C(7) Q ;**GFT DOWN-ARROW: ALLOW GOING TO ENDING BLANK LINE
I DDWRW<DDWMR D
. D POS(DDWRW+1,DDWC,"RN")
E I DDWSTB D
. D MVFWD^DDW3(1)
E W $C(7) Q
I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R")
Q
RT I DDWC>245,DDWC>$L(DDWN) W $C(7)
E D POS(DDWRW,DDWC+1,"R")
Q
LT I DDWC=1 D
. I DDWRW=1,'DDWA W $C(7)
. E D UP,POS(DDWRW,"E","R")
E D POS(DDWRW,DDWC-1,"R")
Q
;
SV K DDWED G SV^DDW1
SW D SAVE^DDW1 S DDWFIN="",DIWESW=1 Q
EX D SAVE^DDW1 S DDWFIN="" Q
QT S DUOUT=1 G QUIT^DDW1 ;GFT
TO D SAVE^DDW1 S DTOUT=1,DDWFIN="" W $C(7) Q
HLP D HLP^DDWH,POS(DDWRW,DDWC) Q
AUT G AUTOTM^DDW1
;
TST G TSET^DDW2
TSALL G TSALL^DDW2
LST G LSET^DDW2
RST G RSET^DDW2
WRM G WRAPM^DDW2
RPM G REPLM^DDW2
ST G STAT^DDW2
;
TOP G TOP^DDW3
BOT G BOT^DDW3
;
PDN G PGDN^DDW4
PUP G PGUP^DDW4
TAB G TAB^DDW4
JLT G JLEFT^DDW4
JRT G JRIGHT^DDW4
LB G LBEG^DDW4
LE G LEND^DDW4
WRT G WORDR^DDW4
WLT G WORDL^DDW4
DLW S DDWED=1 G DELW^DDW4
DEOL S DDWED=1 G DEOL^DDW4
;
BRK ;I 'DDWREP,$G(DDWCNT)>1,$G(DDWN)="",$G(DDWL(DDWRW-1))="",DDWA+DDWRW'<DDWCNT D SAVE^DDW1 S DDWFIN="",DDWCNT=DDWCNT-1 Q ;**GFT GET OUT WITH TWO RETURNS AT BOTTOM
S DDWED=1 D BREAK^DDW5() Q
XLN S DDWED=1 D XLINE^DDW5() D:DDWC'=1 POS(DDWRW,1,"R") Q
;
JN S DDWED=1 G JOIN^DDW6
RFT S DDWED=1 G REFMT^DDW6
;
MRK G MARK^DDW7
UMK G UNMARK^DDW7
;
CPY D COPY^DDW8() Q
CUT D CUT^DDW8() Q
PST D PASTE^DDW8() Q
;
FND G FIND^DDWF
;
NXT G NEXT^DDWF
GTO G GOTO^DDWG
CHG G CHG^DDWC
Q
;
READ(DDWTO,Y) ;Out: Y = Char or mnemonic
F D Q:Y'=-1
. R *Y:DDWTO
. I Y>127 D HS(.Y)
. I Y>31,Y<127 S Y=$C(Y) Q
. I Y<0 S Y="TO" Q
. D MNE(.Y)
Q
;
PREAD(DDWLEN,DDWTO,DDWST,Y) ;
;In: DDWLEN = # chars to read
;Out: DDWST = String
; Y = Mnemonic, Null if DDWLEN chars read or invalid
X DDGLZOSF("EON")
R DDWST#DDWLEN:DDWTO E S Y="TO" Q
X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
;
D:DDWST?.E1.C.E H(.DDWST)
;
I $C(Y)?1C,Y D
. D MNE(.Y)
. I Y=-1 S Y=""
. E I $L(Y)=1 W Y S DDWST=DDWST_Y,Y=""
E S Y=""
Q
;
MNE(Y) ;In: Y = Ascii value of first character
;Out: Y = Mnemonic, or -1 if invalid
N S,F,T
I Y=13 S DDWHLOG=$P($H,",",2)
E I Y=10,$D(DDWHLOG)#2,$P($H,",",2)-DDWHLOG<1 K DDWHLOG S Y=-1 Q
E K DDWHLOG
S S="",F=0,T="DDW(""IN"")" ;We are looking in DDW("IN") for a string of characters, which we translate to something in DDW("OT")
F D MNELOOP(.S,.Y,.T,.F) Q:F
Q
;
MNELOOP(S,Y,T,F) ;Read more
;In/Out:
; S = string of input chars
; Y = ascii of current char
; T = table under consideration
;Out:
; Y = mnemonic, or -1
; F = 1 : done
;
N E
S S=S_$C(Y)
I @T'[(U_S) D
. I $C(Y)?1L D
.. S $E(S,$L(S))=$$UP^DILIBF($C(Y)) ;GEKY --INTERNATIONALIZATION artf16804
.. S:@T'[(U_S_U) E=1
. E S E=1
I $T,$G(E) D Q
. S T=$Q(@T)
. I T]"" S $E(S,$L(S))=""
. E D FLUSH S F=1,Y=-1
;
I @T[(U_S_U),S'=$C(27) D Q
. S Y=$P(@$TR(T,"IN","OT"),U,$L($P(@T,U_S_U),U)),F=1 ;We"ve got Y as the place to go to
;
R *Y:5 I Y=-1 D FLUSH S F=1
Q
;
H(DDWST) ;
S DDWST=$TR(DDWST,$C(145,146,147,148),"''""""")
I DDWST?.E1.C.E D
. N DDWCON,DDWI
. S DDWCON=""
. F DDWI=128:1:255 S DDWCON=DDWCON_$C(DDWI)
. S DDWST=$TR(DDWST,DDWCON,$J(" ",128))
D POS(DDWRW,DDWC)
W DDWST
Q
;
HS(Y) ;
I Y>144,Y<149 S Y=$A($E("''""""",Y-144))
E S Y=32
Q
;
FLUSH ;
N DDWX
W $C(7) F R *DDWX:0 E Q
Q
;
CUP(Y,X) ;
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
;
MIN(X,Y) ;
Q $S(X<Y:X,1:Y)
;
HDIFF(H1,H2) ;# seconds between two $H's
Q (H2-H1)*86400+$P(H2,",",2)-$P(H1,",",2)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDWT1 7372 printed Dec 13, 2024@02:44:06 Page 2
DDWT1 ;SFISC/PD KELTZ,MKO - READ AND PROCESS ;9NOV2016
+1 ;;22.2;VA FileMan;**4,7**;Jan 05, 2016;Build 3
+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 ;;GFT;**18,1000,1004,1005,1045,1049,1053,1056**;Mar 30, 1999
+7 ;
+8 ;Called from DDW ROUTINE
+9 DO LOAD^DDW1
KILL DUOUT
+10 ;I '$G(DDWRWSET) D BOT^DDW3 I $L(DDWN) D BREAK^DDW5() ;GFT -- GO TO BOTTOM OF TEXT ;P7
+11 FOR
DO GETIN
if $DATA(DDWFIN)
QUIT
+12 QUIT
+13 ;
GETIN ;Get input
+1 IF DDWC'>DDWRMAR
IF DDWC-DDWOFS<IOM
IF DDWC>$LENGTH(DDWN)!DDWREP
IF '$DATA(DDWMARK)
Begin DoDot:1
+2 NEW DDWANS
+3 DO PREAD($$MIN(DDWRMAR,IOM-1+DDWOFS)-DDWC+1,DDWTO,.DDWANS,.DDWQ)
+4 IF DDWANS]""
Begin DoDot:2
+5 SET DDWED=1
+6 IF DDWSTAT
IF DDWQ="TO"
IF DDWTO<DTIME
SET DDWQ=""
+7 SET $EXTRACT(DDWN,DDWC,DDWC+$LENGTH(DDWANS)-1)=DDWANS
SET DDWL(DDWRW)=DDWN
+8 SET DDWC=DDWC+$LENGTH(DDWANS)
End DoDot:2
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 DO READ(DDWTO,.DDWQ)
+11 if $LENGTH(DDWQ)=1
DO DISPL
End DoDot:1
+12 ;
+13 IF DDWSTAT
Begin DoDot:1
+14 IF DDWQ="TO"
Begin DoDot:2
+15 IF $GET(DDWTC)
if $$HDIFF(DDWTC,$HOROLOG)+1<DTIME
SET DDWQ=""
+16 IF '$TEST
SET DDWTC=$HOROLOG
SET DDWQ=""
if DDWSTAT
DO STATUS
End DoDot:2
+17 IF '$TEST
KILL DDWTC
End DoDot:1
+18 ;
+19 IF $GET(DDWAUTO)
IF DDWQ'="TO"
IF $$HDIFF(DDWAUTO("H"),$HOROLOG)'<DDWAUTO("S")
DO AUTOSV^DDW1
+20 ;
+21 IF $LENGTH(DDWQ)>1
DO @DDWQ
if DDWSTAT
DO STATUS
+22 QUIT
+23 ;
DISPL ;Display char
+1 IF DDWC>245
WRITE $CHAR(7)
QUIT
+2 ;
+3 SET DDWED=1
+4 IF $DATA(DDWMARK)
IF DDWRW+DDWA'>$PIECE(DDWMARK,U,3)
DO UNMARK^DDW7
+5 if DDWC-1>$LENGTH(DDWN)
SET DDWN=DDWN_$JUSTIFY("",DDWC-$LENGTH(DDWN)-1)
+6 SET (DDWN,DDWL(DDWRW))=$EXTRACT(DDWN,1,DDWC-1)_DDWQ_$EXTRACT(DDWN,DDWC+DDWREP,999)
+7 SET DDWC=DDWC+1
+8 ;
+9 IF DDWREP
WRITE DDWQ
+10 IF '$TEST
Begin DoDot:1
IC ;$P(DDGLED,DDGLDEL,5)]"" W $P(DDGLED,DDGLDEL,5)_DDWQ GFT -- DON'T USE "INSERT CHARACTER" IT SEEMS NOT TO WORK
IF 0
+1 IF '$TEST
WRITE DDWQ_$EXTRACT(DDWN,DDWC,IOM+DDWOFS)
End DoDot:1
+2 DO POS(DDWRW,DDWC,"R")
+3 if $LENGTH(DDWN)>DDWRMAR
DO WRAP^DDW5
+4 QUIT
+5 ;
RUB ;COME HERE ON BACKSPACE
+1 NEW DDWX
+2 ;if current line is null --Bill Eash
IF DDWN=""
SET DDWCNT=DDWCNT-1
+3 SET DDWED=1
+4 IF $DATA(DDWMARK)
DO CHKDEL^DDW9(.DDWX)
if DDWX
QUIT
+5 ;
+6 IF DDWC=1
Begin DoDot:1
+7 IF DDWRW=1
Begin DoDot:2
+8 IF 'DDWA
WRITE $CHAR(7)
+9 IF '$TEST
DO MVBCK^DDW3(1)
DO POS(1,"E","R")
End DoDot:2
+10 IF '$TEST
DO POS(DDWRW-1,"E","RN")
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET DDWC=DDWC-1
SET $EXTRACT(DDWN,DDWC)=""
SET DDWL(DDWRW)=DDWN
+13 SET DDWX=$EXTRACT(DDWN,IOM+DDWOFS)
+14 IF DDWC-DDWOFS>0
Begin DoDot:2
+15 DO CUP(DDWRW,DDWC-DDWOFS)
+16 IF $PIECE(DDGLED,DDGLDEL,6)]""
Begin DoDot:3
+17 WRITE $PIECE(DDGLED,DDGLDEL,6)
+18 IF DDWX]" "
DO CUP(DDWRW,IOM)
WRITE DDWX
DO CUP(DDWRW,DDWC-DDWOFS)
End DoDot:3
+19 IF '$TEST
WRITE $EXTRACT(DDWN_" ",DDWC,IOM+DDWOFS)
DO CUP(DDWRW,DDWC-DDWOFS)
End DoDot:2
+20 IF '$TEST
DO POS(DDWRW,DDWC)
End DoDot:1
+21 QUIT
+22 ;
DEL NEW DDWX
+1 SET DDWED=1
+2 IF $DATA(DDWMARK)
DO CHKDEL^DDW9(.DDWX)
if DDWX
QUIT
+3 ;
+4 IF DDWC>$LENGTH(DDWN)
Begin DoDot:1
+5 IF DDWN?." "
Begin DoDot:2
+6 NEW DDWLAST
+7 SET DDWLAST=DDWRW+DDWA=DDWCNT
+8 DO XLINE^DDW5()
+9 if DDWLAST
DO POS(DDWRW,"E","R")
End DoDot:2
+10 IF '$TEST
Begin DoDot:2
+11 NEW DDWY,DDWX
+12 SET DDWY=DDWRW+DDWA
SET DDWX=DDWC
+13 DO JOIN^DDW6
+14 DO POS(DDWY-DDWA,DDWX,"RN")
End DoDot:2
End DoDot:1
QUIT
+15 ;
+16 SET $EXTRACT(DDWN,DDWC)=""
SET DDWL(DDWRW)=DDWN
SET DDWX=$EXTRACT(DDWN,IOM+DDWOFS)
+17 IF $PIECE(DDGLED,DDGLDEL,6)]""
Begin DoDot:1
+18 WRITE $PIECE(DDGLED,DDGLDEL,6)
+19 IF DDWX]" "
DO CUP(DDWRW,IOM)
WRITE DDWX
DO CUP(DDWRW,DDWC-DDWOFS)
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 WRITE $EXTRACT(DDWN_" ",DDWC,IOM+DDWOFS)
+22 DO CUP(DDWRW,DDWC-DDWOFS)
End DoDot:1
+23 QUIT
+24 ;
STATUS NEW DDWX,DDWS
+1 SET DDWS="Scr "_(DDWA+DDWRW-1\DDWMR+1)_" of "_(DDWCNT-1\DDWMR+1)
+2 SET DDWX="Ln "_(DDWA+DDWRW)_" of "_DDWCNT
+3 SET $EXTRACT(DDWS,IOM\2+1-($LENGTH(DDWX)\2),999)=DDWX
+4 SET DDWX="Col "_DDWC
+5 SET $EXTRACT(DDWS,IOM-$LENGTH(DDWX),999)=DDWX
+6 DO CUP(DDWMR+2,1)
WRITE $PIECE(DDGLCLR,DDGLDEL)_DDWS
+7 DO POS(DDWRW,DDWC)
+8 QUIT
+9 ;
UP IF DDWRW>1
Begin DoDot:1
+1 DO POS(DDWRW-1,DDWC,"RN")
End DoDot:1
+2 IF '$TEST
IF DDWA
Begin DoDot:1
+3 DO MVBCK^DDW3(1)
End DoDot:1
+4 IF '$TEST
WRITE $CHAR(7)
+5 IF DDWC>246
IF $LENGTH(DDWN)<246
DO POS(DDWRW,246,"R")
+6 QUIT
DN ;**GFT DOWN-ARROW: ALLOW GOING TO ENDING BLANK LINE
IF DDWN=""
IF DDWA+DDWRW>DDWCNT
WRITE $CHAR(7)
QUIT
+1 IF DDWRW<DDWMR
Begin DoDot:1
+2 DO POS(DDWRW+1,DDWC,"RN")
End DoDot:1
+3 IF '$TEST
IF DDWSTB
Begin DoDot:1
+4 DO MVFWD^DDW3(1)
End DoDot:1
+5 IF '$TEST
WRITE $CHAR(7)
QUIT
+6 IF DDWC>246
IF $LENGTH(DDWN)<246
DO POS(DDWRW,246,"R")
+7 QUIT
RT IF DDWC>245
IF DDWC>$LENGTH(DDWN)
WRITE $CHAR(7)
+1 IF '$TEST
DO POS(DDWRW,DDWC+1,"R")
+2 QUIT
LT IF DDWC=1
Begin DoDot:1
+1 IF DDWRW=1
IF 'DDWA
WRITE $CHAR(7)
+2 IF '$TEST
DO UP
DO POS(DDWRW,"E","R")
End DoDot:1
+3 IF '$TEST
DO POS(DDWRW,DDWC-1,"R")
+4 QUIT
+5 ;
SV KILL DDWED
GOTO SV^DDW1
SW DO SAVE^DDW1
SET DDWFIN=""
SET DIWESW=1
QUIT
EX DO SAVE^DDW1
SET DDWFIN=""
QUIT
QT ;GFT
SET DUOUT=1
GOTO QUIT^DDW1
TO DO SAVE^DDW1
SET DTOUT=1
SET DDWFIN=""
WRITE $CHAR(7)
QUIT
HLP DO HLP^DDWH
DO POS(DDWRW,DDWC)
QUIT
AUT GOTO AUTOTM^DDW1
+1 ;
TST GOTO TSET^DDW2
TSALL GOTO TSALL^DDW2
LST GOTO LSET^DDW2
RST GOTO RSET^DDW2
WRM GOTO WRAPM^DDW2
RPM GOTO REPLM^DDW2
ST GOTO STAT^DDW2
+1 ;
TOP GOTO TOP^DDW3
BOT GOTO BOT^DDW3
+1 ;
PDN GOTO PGDN^DDW4
PUP GOTO PGUP^DDW4
TAB GOTO TAB^DDW4
JLT GOTO JLEFT^DDW4
JRT GOTO JRIGHT^DDW4
LB GOTO LBEG^DDW4
LE GOTO LEND^DDW4
WRT GOTO WORDR^DDW4
WLT GOTO WORDL^DDW4
DLW SET DDWED=1
GOTO DELW^DDW4
DEOL SET DDWED=1
GOTO DEOL^DDW4
+1 ;
BRK ;I 'DDWREP,$G(DDWCNT)>1,$G(DDWN)="",$G(DDWL(DDWRW-1))="",DDWA+DDWRW'<DDWCNT D SAVE^DDW1 S DDWFIN="",DDWCNT=DDWCNT-1 Q ;**GFT GET OUT WITH TWO RETURNS AT BOTTOM
+1 SET DDWED=1
DO BREAK^DDW5()
QUIT
XLN SET DDWED=1
DO XLINE^DDW5()
if DDWC'=1
DO POS(DDWRW,1,"R")
QUIT
+1 ;
JN SET DDWED=1
GOTO JOIN^DDW6
RFT SET DDWED=1
GOTO REFMT^DDW6
+1 ;
MRK GOTO MARK^DDW7
UMK GOTO UNMARK^DDW7
+1 ;
CPY DO COPY^DDW8()
QUIT
CUT DO CUT^DDW8()
QUIT
PST DO PASTE^DDW8()
QUIT
+1 ;
FND GOTO FIND^DDWF
+1 ;
NXT GOTO NEXT^DDWF
GTO GOTO GOTO^DDWG
CHG GOTO CHG^DDWC
+1 QUIT
+2 ;
READ(DDWTO,Y) ;Out: Y = Char or mnemonic
+1 FOR
Begin DoDot:1
+2 READ *Y:DDWTO
+3 IF Y>127
DO HS(.Y)
+4 IF Y>31
IF Y<127
SET Y=$CHAR(Y)
QUIT
+5 IF Y<0
SET Y="TO"
QUIT
+6 DO MNE(.Y)
End DoDot:1
if Y'=-1
QUIT
+7 QUIT
+8 ;
PREAD(DDWLEN,DDWTO,DDWST,Y) ;
+1 ;In: DDWLEN = # chars to read
+2 ;Out: DDWST = String
+3 ; Y = Mnemonic, Null if DDWLEN chars read or invalid
+4 XECUTE DDGLZOSF("EON")
+5 READ DDWST#DDWLEN:DDWTO
IF '$TEST
SET Y="TO"
QUIT
+6 XECUTE DDGLZOSF("EOFF")
XECUTE DDGLZOSF("TRMRD")
+7 ;
+8 if DDWST?.E1.C.E
DO H(.DDWST)
+9 ;
+10 IF $CHAR(Y)?1C
IF Y
Begin DoDot:1
+11 DO MNE(.Y)
+12 IF Y=-1
SET Y=""
+13 IF '$TEST
IF $LENGTH(Y)=1
WRITE Y
SET DDWST=DDWST_Y
SET Y=""
End DoDot:1
+14 IF '$TEST
SET Y=""
+15 QUIT
+16 ;
MNE(Y) ;In: Y = Ascii value of first character
+1 ;Out: Y = Mnemonic, or -1 if invalid
+2 NEW S,F,T
+3 IF Y=13
SET DDWHLOG=$PIECE($HOROLOG,",",2)
+4 IF '$TEST
IF Y=10
IF $DATA(DDWHLOG)#2
IF $PIECE($HOROLOG,",",2)-DDWHLOG<1
KILL DDWHLOG
SET Y=-1
QUIT
+5 IF '$TEST
KILL DDWHLOG
+6 ;We are looking in DDW("IN") for a string of characters, which we translate to something in DDW("OT")
SET S=""
SET F=0
SET T="DDW(""IN"")"
+7 FOR
DO MNELOOP(.S,.Y,.T,.F)
if F
QUIT
+8 QUIT
+9 ;
MNELOOP(S,Y,T,F) ;Read more
+1 ;In/Out:
+2 ; S = string of input chars
+3 ; Y = ascii of current char
+4 ; T = table under consideration
+5 ;Out:
+6 ; Y = mnemonic, or -1
+7 ; F = 1 : done
+8 ;
+9 NEW E
+10 SET S=S_$CHAR(Y)
+11 IF @T'[(U_S)
Begin DoDot:1
+12 IF $CHAR(Y)?1L
Begin DoDot:2
+13 ;GEKY --INTERNATIONALIZATION artf16804
SET $EXTRACT(S,$LENGTH(S))=$$UP^DILIBF($CHAR(Y))
+14 if @T'[(U_S_U)
SET E=1
End DoDot:2
+15 IF '$TEST
SET E=1
End DoDot:1
+16 IF $TEST
IF $GET(E)
Begin DoDot:1
+17 SET T=$QUERY(@T)
+18 IF T]""
SET $EXTRACT(S,$LENGTH(S))=""
+19 IF '$TEST
DO FLUSH
SET F=1
SET Y=-1
End DoDot:1
QUIT
+20 ;
+21 IF @T[(U_S_U)
IF S'=$CHAR(27)
Begin DoDot:1
+22 ;We"ve got Y as the place to go to
SET Y=$PIECE(@$TRANSLATE(T,"IN","OT"),U,$LENGTH($PIECE(@T,U_S_U),U))
SET F=1
End DoDot:1
QUIT
+23 ;
+24 READ *Y:5
IF Y=-1
DO FLUSH
SET F=1
+25 QUIT
+26 ;
H(DDWST) ;
+1 SET DDWST=$TRANSLATE(DDWST,$CHAR(145,146,147,148),"''""""")
+2 IF DDWST?.E1.C.E
Begin DoDot:1
+3 NEW DDWCON,DDWI
+4 SET DDWCON=""
+5 FOR DDWI=128:1:255
SET DDWCON=DDWCON_$CHAR(DDWI)
+6 SET DDWST=$TRANSLATE(DDWST,DDWCON,$JUSTIFY(" ",128))
End DoDot:1
+7 DO POS(DDWRW,DDWC)
+8 WRITE DDWST
+9 QUIT
+10 ;
HS(Y) ;
+1 IF Y>144
IF Y<149
SET Y=$ASCII($EXTRACT("''""""",Y-144))
+2 IF '$TEST
SET Y=32
+3 QUIT
+4 ;
FLUSH ;
+1 NEW DDWX
+2 WRITE $CHAR(7)
FOR
READ *DDWX:0
IF '$TEST
QUIT
+3 QUIT
+4 ;
CUP(Y,X) ;
+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
+10 ;
MIN(X,Y) ;
+1 QUIT $SELECT(X<Y:X,1:Y)
+2 ;
HDIFF(H1,H2) ;# seconds between two $H's
+1 QUIT (H2-H1)*86400+$PIECE(H2,",",2)-$PIECE(H1,",",2)
