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