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

Last change on this file since 1639 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1DIR01 ;SFISC/MKO-FIELD EDITOR ;12:37 PM 15 Feb 1995
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 I DIR0A]"",DIR0C=1 D F X IOXY Q:DIR0QT
5 F D E X IOXY Q:DIR0QT
6 Q
7 ;
8F D READ(.DIR0CH)
9 I "?^"'[DIR0CH=$L(DIR0CH) S DIR0A="" D REP,DEOF Q
10 D:DIR0CH]"" E1
11 Q
12 ;
13E I $G(DIR0("REP"))&DIR0C>1!(DIR0C>$L(DIR0A)),DIR0F>DX,DIR0M>$L(DIR0A),'$D(DIR0KD) D
14 . D PREAD($$MIN(DIR0F-DX,DIR0M-DIR0C+1),.DIR0ST,.DIR0CH)
15 . Q:DIR0ST=""
16 . S DIR0CHG=1
17 . I '$G(DIR0("REP")) S DIR0A=DIR0A_DIR0ST
18 . E S $E(DIR0A,DIR0C,DIR0C+$L(DIR0ST)-1)=DIR0ST
19 . S DX=DX+$L(DIR0ST),DIR0C=DIR0C+$L(DIR0ST)
20 E D READ(.DIR0CH)
21 Q:DIR0CH=""
22 ;
23E1 I "?^"[DIR0CH,DIR0C=1,'DIR0QU S DIR0A="",DIR0QU=1 D REP,DEOF Q
24 D @$S($L(DIR0CH)>1:DIR0CH,$G(DIR0("REP")):"REP",1:"INS")
25 I DIR0QU,"?^"'[$E(DIR0A)!'$L(DIR0A) S DIR0QU=0,DIR0A="" D CLR
26 Q
27 ;
28REP I DIR0C>DIR0M W $C(7) Q
29 S DIR0CHG=1
30 S $E(DIR0A,DIR0C)=DIR0CH,DIR0C=DIR0C+1
31 I DIR0F>DX S DX=DX+1 W DIR0CH Q
32 N DIX
33 S DIX=DIR0C-(DIR0L\2)
34 S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
35 S DX=DIR0S X IOXY
36 W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
37 Q
38 ;
39INS I $L(DIR0A)'<DIR0M W $C(7) Q
40 S DIR0CHG=1
41 S DIR0A=$E(DIR0A,1,DIR0C-1)_DIR0CH_$E(DIR0A,DIR0C,999),DIR0C=DIR0C+1
42 I DIR0F>DX S DX=DX+1 W $E(DIR0A,DIR0C-1,DIR0C+DIR0F-DX-1) Q
43 S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1) S DX=DIR0F
44 Q
45 ;
46RIGHT Q:DIR0C>$L(DIR0A)
47 I DX<DIR0F S DX=DX+1,DIR0C=DIR0C+1 Q
48 S DIR0C=DIR0C+1,DX=DIR0S X IOXY
49 W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
50 S DX=DIR0F
51 Q
52 ;
53LEFT Q:DIR0C'>1
54 I DX>DIR0S S DX=DX-1,DIR0C=DIR0C-1 Q
55 S DIR0C=DIR0C-1 W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
56 Q
57 ;
58JRT Q:DIR0C>$L(DIR0A)
59 I DIR0F=DX D Q
60 . S DIR0C=DIR0C+DIR0L S:DIR0C+1>$L(DIR0A) DIR0C=$L(DIR0A)+1
61 . S DX=DIR0S X IOXY W $E(DIR0A,DIR0C-DIR0L,DIR0C-1)
62 . S DX=DIR0F
63 N DIX
64 S DIX=$L(DIR0A)-DIR0C+1
65 I DIR0F-DX>DIX S DX=DX+DIX,DIR0C=DIR0C+DIX Q
66 S DIR0C=DIR0C+DIR0F-DX,DX=DIR0F
67 Q
68 ;
69JLT Q:DIR0C'>1
70 I DX=DIR0S D Q
71 . S DIR0C=DIR0C-DIR0L S:DIR0C<1 DIR0C=1
72 . W $E(DIR0A,DIR0C,DIR0C+DIR0L-1)
73 S DIR0C=DIR0C-DX+DIR0S,DX=DIR0S
74 Q
75 ;
76FDE Q:DIR0C>$L(DIR0A)
77 I DX+$L(DIR0A)-DIR0C-DIR0L<DIR0S D Q
78 . S DX=DX+$L(DIR0A)-DIR0C+1,DIR0C=$L(DIR0A)+1
79 S DIR0C=$L(DIR0A)+1,DX=DIR0S X IOXY
80 W $E(DIR0A,DIR0C-DIR0L,DIR0C)
81 S DX=DIR0F
82 Q
83 ;
84FDB Q:DIR0C'>1
85 I DX-DIR0C+1<DIR0S S DX=DIR0S X IOXY W $E(DIR0A,1,DIR0L)
86 S DX=DIR0S,DIR0C=1
87 Q
88 ;
89BS Q:DIR0C'>1
90 S DIR0CHG=1
91 S DIR0C=DIR0C-1,DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
92 I DX>DIR0S D Q
93 . S DX=DX-1 X IOXY
94 . W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
95 N DIX
96 S DIX=DIR0C-(DIR0L\2)
97 S:$L(DIR0A)-DIX+1<DIR0L DIX=$L(DIR0A)-DIR0L+1
98 S:DIX<1 DIX=1
99 W $E(DIR0A,DIX,DIX+DIR0L-1) S DX=DIR0S+DIR0C-DIX
100 Q
101 ;
102DEL Q:DIR0C>$L(DIR0A)!(DIR0F'>DX)
103 S DIR0CHG=1
104 S DIR0A=$E(DIR0A,1,DIR0C-1)_$E(DIR0A,DIR0C+1,999)
105 W $E(DIR0A_$E(DIR0SP),DIR0C,DIR0C+DIR0F-DX-1)
106 Q
107 ;
108CLR S DIR0CHG=1
109 S DIR0C=1,DX=DIR0S X IOXY
110 I DIR0A]"",DIR0A'=DIR0D S DIR0SV=DIR0A
111 S DIR0A=$S(DIR0A=DIR0D:DIR0SV,DIR0A="":DIR0D,1:"")
112 W $E(DIR0A,1,DIR0L)_$E(DIR0SP,$L(DIR0A)+1,999)
113 Q
114 ;
115DEOF S DIR0CHG=1
116 W $E(DIR0SP,DX-DIR0S+1,999)
117 S DIR0A=$E(DIR0A,1,DIR0C-1)
118 Q
119 ;
120RPM N DX,DY
121 I $D(DDS) S DX=IOM-8,DY=IOSL-1 X IOXY
122 I $G(DIR0("REP")) W:$D(DDS) "Insert " K DIR0("REP")
123 E W:$D(DDS) "Replace" S DIR0("REP")=1
124 Q
125 ;
126KPM I $G(DDGLKPNM) K DDGLKPNM W $P(DDGLED,DDGLDEL,9)
127 E S DDGLKPNM=1 W $P(DDGLED,DDGLDEL,10)
128 Q
129 ;
130WRT G WRT^DIR0W
131WLT G WLT^DIR0W
132DLW G DLW^DIR0W
133HLP G ^DIR0H
134ZM G SM^DIR02
135 ;
136TO I $D(DIR0TO)#2 D @DIR0TO Q
137 S DTOUT=1
138UP ;
139DOWN ;
140TAB ;
141FDL ;
142CR ;
143NB ;
144NP ;
145PP ;
146SEL ;
147EX ;
148QT ;
149CL ;
150SV ;
151RF ;
152 S DIR0QT=1
153 Q
154NOP W $C(7)
155 Q
156 ;
157READ(Y) ;Out: Y=char or mnemonic
158 F D Q:Y'=-1
159 . R *Y:DTIME
160 . I Y>31,Y<127 S Y=$C(Y) Q
161 . I Y<0 S Y="TO" Q
162 . D MNE(.Y)
163 I Y'="TO",$D(DIR0KD) D @DIR0KD
164 Q
165 ;
166PREAD(DIR0LEN,DIR0ST,Y) ;
167 ; Y = Mnem, Null if DIR0LEN chars read or invalid
168 X DDGLZOSF("EON")
169 R DIR0ST#DIR0LEN:DTIME E S Y="TO" Q
170 X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
171 I $C(Y)?1C,Y D
172 . D MNE(.Y) S:Y=-1 Y=""
173 E S Y=""
174 Q
175 ;
176MNE(Y) ;Out: Y=mnemonic, or -1 if invalid
177 N S,F
178 S S="",F=0
179 F D MNELOOP Q:F
180 Q
181 ;
182MNELOOP ;
183 S S=S_$C(Y)
184 I DIR0(DIR0P_"IN")'[(U_S) D I Y=-1 D FLUSH Q
185 . I $C(Y)'?1L S Y=-1 Q
186 . S S=$E(S,1,$L(S)-1)_$C(Y-32)
187 . S:DIR0(DIR0P_"IN")'[(U_S_U) Y=-1
188 ;
189 I DIR0(DIR0P_"IN")[(U_S_U),S'=$C(27) D
190 . S Y=$P(DIR0(DIR0P_"OUT"),";",$L($P(DIR0(DIR0P_"IN"),U_S_U),U)),F=1
191 E R *Y:5 D:Y=-1 FLUSH
192 Q
193 ;
194FLUSH N X
195 S F=1 W $C(7) F R *X:0 E Q
196 Q
197 ;
198MIN(X,Y) ;
199 Q $S(X<Y:X,1:Y)
Note: See TracBrowser for help on using the repository browser.