284 lines
6.0 KiB
Mathematica
284 lines
6.0 KiB
Mathematica
DDWT1 ;SFISC/PD KELTZ,MKO-READ AND PROCESS ;11:35 AM 25 Aug 2000
|
|
;;22.0;VA FileMan;**18**;Mar 30, 1999
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
D LOAD^DDW1 K DUOUT ;GFT
|
|
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
|
|
. I $P(DDGLED,DDGLDEL,5)]"" W $P(DDGLED,DDGLDEL,5)_DDWQ
|
|
. E W DDWQ_$E(DDWN,DDWC,IOM+DDWOFS)
|
|
D POS(DDWRW,DDWC,"R")
|
|
D:$L(DDWN)>DDWRMAR WRAP^DDW5
|
|
Q
|
|
;
|
|
RUB N DDWX
|
|
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 DDWA+DDWRW'<DDWCNT W $C(7) Q
|
|
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 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"")"
|
|
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))=$C(Y-32)
|
|
.. 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
|
|
;
|
|
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)
|