source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIR01.m@ 1474

DIR01 ;SFISC/MKO-FIELD EDITOR ;12:37 PM  15 Feb 1995
 ;;22.0;VA FileMan;;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 I DIR0A]"",DIR0C=1 D F X IOXY Q:DIR0QT
 F  D E X IOXY Q:DIR0QT
 Q
 ;
F D READ(.DIR0CH)
 I "?^"'[DIR0CH=$L(DIR0CH) S DIR0A="" D REP,DEOF Q
 D:DIR0CH]"" E1
 Q
 ;
E I $G(DIR0("REP"))&DIR0C>1!(DIR0C>$L(DIR0A)),DIR0F>DX,DIR0M>$L(DIR0A),'$D(DIR0KD) D
 . D PREAD($$MIN(DIR0F-DX,DIR0M-DIR0C+1),.DIR0ST,.DIR0CH)
 . Q:DIR0ST=""
 . S DIR0CHG=1
 . I '$G(DIR0("REP")) S DIR0A=DIR0A_DIR0ST
 . E  S $E(DIR0A,DIR0C,DIR0C+$L(DIR0ST)-1)=DIR0ST
 . S DX=DX+$L(DIR0ST),DIR0C=DIR0C+$L(DIR0ST)
 E  D READ(.DIR0CH)
 Q:DIR0CH=""
 ;
E1 I "?^"[DIR0CH,DIR0C=1,'DIR0QU S DIR0A="",DIR0QU=1 D REP,DEOF Q
 D @$S($L(DIR0CH)>1:DIR0CH,$G(DIR0("REP")):"REP",1:"INS")
 I DIR0QU,"?^"'[$E(DIR0A)!'$L(DIR0A) S DIR0QU=0,DIR0A="" D CLR
 Q
 ;
REP I DIR0C>DIR0M W $C(7) Q
 S DIR0CHG=1
 S $E(DIR0A,DIR0C)=DIR0CH,DIR0C=DIR0C+1
 I DIR0F>DX S DX=DX+1 W DIR0CH Q
 N DIX
 S DIX=DIR0C-(DIR0L\2)
 S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
 S DX=DIR0S X IOXY
 W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
 Q
 ;
INS I $L(DIR0A)'<DIR0M W $C(7) Q
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C,999),DIR0C=DIR0C+1
 I DIR0F>DX S DX=DX+1 W $E(DIR0A,DIR0C-1,DIR0C+DIR0F-DX-1) Q
 S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1) S DX=DIR0F
 Q
 ;
RIGHT Q:DIR0C>$L(DIR0A)
 I DX<DIR0F S DX=DX+1,DIR0C=DIR0C+1 Q
 S DIR0C=DIR0C+1,DX=DIR0S X IOXY
 W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
 S DX=DIR0F
 Q
 ;
LEFT Q:DIR0C'>1
 I DX>DIR0S S DX=DX-1,DIR0C=DIR0C-1 Q
 S DIR0C=DIR0C-1 W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
 Q
 ;
JRT Q:DIR0C>$L(DIR0A)
 I DIR0F=DX D  Q
 . S DIR0C=DIR0C+DIR0L S:DIR0C+1>$L(DIR0A) DIR0C=$L(DIR0A)+1
 . S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
 . S DX=DIR0F
 N DIX
 S DIX=$L(DIR0A)-DIR0C+1
 I DIR0F-DX>DIX S DX=DX+DIX,DIR0C=DIR0C+DIX Q
 S DIR0C=DIR0C+DIR0F-DX,DX=DIR0F
 Q
 ;
JLT Q:DIR0C'>1
 I DX=DIR0S D  Q
 . S DIR0C=DIR0C-DIR0L S:DIR0C<1 DIR0C=1
 . W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
 S DIR0C=DIR0C-DX+DIR0S,DX=DIR0S
 Q
 ;
FDE Q:DIR0C>$L(DIR0A)
 I DX+$L(DIR0A)-DIR0C-DIR0L<DIR0S D  Q
 . S DX=DX+$L(DIR0A)-DIR0C+1,DIR0C=$L(DIR0A)+1
 S DIR0C=$L(DIR0A)+1,DX=DIR0S X IOXY
 W $E(DIR0A,DIR0C-DIR0L,DIR0C)
 S DX=DIR0F
 Q
 ;
FDB Q:DIR0C'>1
 I DX-DIR0C+1<DIR0S S DX=DIR0S X IOXY W $E(DIR0A,1,DIR0L)
 S DX=DIR0S,DIR0C=1
 Q
 ;
BS Q:DIR0C'>1
 S DIR0CHG=1
 S DIR0C=DIR0C-1,DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
 I DX>DIR0S D  Q
 . S DX=DX-1 X IOXY
 . W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
 N DIX
 S DIX=DIR0C-(DIR0L\2)
 S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
 S:DIX<1 DIX=1
 W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
 Q
 ;
DEL Q:DIR0C>$L(DIR0A)!(DIR0F'>DX)
 S DIR0CHG=1
 S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
 W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
 Q
 ;
CLR S DIR0CHG=1
 S DIR0C=1,DX=DIR0S X IOXY
 I DIR0A]"",DIR0A'=DIR0D S DIR0SV=DIR0A
 S DIR0A=$S(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
 W $E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
 Q
 ;
DEOF S DIR0CHG=1
 W $E(DIR0SP,DX-DIR0S+1,999)
 S DIR0A=$E(DIR0A,1,DIR0C-1)
 Q
 ;
RPM N DX,DY
 I $D(DDS) S DX=IOM-8,DY=IOSL-1 X IOXY
 I $G(DIR0("REP")) W:$D(DDS) "Insert " K DIR0("REP")
 E  W:$D(DDS) "Replace" S DIR0("REP")=1
 Q
 ;
KPM I $G(DDGLKPNM) K DDGLKPNM W $P(DDGLED,DDGLDEL,9)
 E  S DDGLKPNM=1 W $P(DDGLED,DDGLDEL,10)
 Q
 ;
WRT G WRT^DIR0W
WLT G WLT^DIR0W
DLW G DLW^DIR0W
HLP G ^DIR0H
ZM G SM^DIR02
 ;
TO I $D(DIR0TO)#2 D @DIR0TO Q
 S DTOUT=1
UP ;
DOWN ;
TAB ;
FDL ;
CR ;
NB ;
NP ;
PP ;
SEL ;
EX ;
QT ;
CL ;
SV ;
RF ;
 S DIR0QT=1
 Q
NOP W $C(7)
 Q
 ;
READ(Y) ;Out: Y=char or mnemonic
 F  D  Q:Y'=-1
 . R *Y:DTIME
 . I Y>31,Y<127 S Y=$C(Y) Q
 . I Y<0 S Y="TO" Q
 . D MNE(.Y)
 I Y'="TO",$D(DIR0KD) D @DIR0KD
 Q
 ;
PREAD(DIR0LEN,DIR0ST,Y) ;
 ; Y = Mnem, Null if DIR0LEN chars read or invalid
 X DDGLZOSF("EON")
 R DIR0ST#DIR0LEN:DTIME E  S Y="TO" Q
 X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
 I $C(Y)?1C,Y D
 . D MNE(.Y) S:Y=-1 Y=""
 E  S Y=""
 Q
 ;
MNE(Y) ;Out: Y=mnemonic, or -1 if invalid
 N S,F
 S S="",F=0
 F  D MNELOOP Q:F
 Q
 ;
MNELOOP ;
 S S=S_$C(Y)
 I DIR0(DIR0P_"IN")'[(U_S) D  I Y=-1 D FLUSH Q
 . I $C(Y)'?1L S Y=-1 Q
 . S S=$E(S,1,$L(S)-1)_$C(Y-32)
 . S:DIR0(DIR0P_"IN")'[(U_S_U) Y=-1
 ;
 I DIR0(DIR0P_"IN")[(U_S_U),S'=$C(27) D
 . S Y=$P(DIR0(DIR0P_"OUT"),";",$L($P(DIR0(DIR0P_"IN"),U_S_U),U)),F=1
 E  R *Y:5 D:Y=-1 FLUSH
 Q
 ;
FLUSH N X
 S F=1 W $C(7) F  R *X:0 E  Q
 Q
 ;
MIN(X,Y) ;
 Q $S(X<Y:X,1:Y)