source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDWT1.m@ 914

Last change on this file since 914 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1DDWT1 ;SFISC/PD KELTZ,MKO-READ AND PROCESS ;11:35 AM 25 Aug 2000
2 ;;22.0;VA FileMan;**18**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D LOAD^DDW1 K DUOUT ;GFT
5 F D GETIN Q:$D(DDWFIN)
6 Q
7 ;
8GETIN ;Get input
9 I DDWC'>DDWRMAR,DDWC-DDWOFS<IOM,DDWC>$L(DDWN)!DDWREP,'$D(DDWMARK) D
10 . N DDWANS
11 . D PREAD($$MIN(DDWRMAR,IOM-1+DDWOFS)-DDWC+1,DDWTO,.DDWANS,.DDWQ)
12 . I DDWANS]"" D
13 .. S DDWED=1
14 .. I DDWSTAT,DDWQ="TO",DDWTO<DTIME S DDWQ=""
15 .. S $E(DDWN,DDWC,DDWC+$L(DDWANS)-1)=DDWANS,DDWL(DDWRW)=DDWN
16 .. S DDWC=DDWC+$L(DDWANS)
17 E D
18 . D READ(DDWTO,.DDWQ)
19 . D:$L(DDWQ)=1 DISPL
20 ;
21 I DDWSTAT D
22 . I DDWQ="TO" D
23 .. I $G(DDWTC) S:$$HDIFF(DDWTC,$H)+1<DTIME DDWQ=""
24 .. E S DDWTC=$H,DDWQ="" D:DDWSTAT STATUS
25 . E K DDWTC
26 ;
27 I $G(DDWAUTO),DDWQ'="TO",$$HDIFF(DDWAUTO("H"),$H)'<DDWAUTO("S") D AUTOSV^DDW1
28 ;
29 I $L(DDWQ)>1 D @DDWQ D:DDWSTAT STATUS
30 Q
31 ;
32DISPL ;Display char
33 I DDWC>245 W $C(7) Q
34 ;
35 S DDWED=1
36 I $D(DDWMARK),DDWRW+DDWA'>$P(DDWMARK,U,3) D UNMARK^DDW7
37 S:DDWC-1>$L(DDWN) DDWN=DDWN_$J("",DDWC-$L(DDWN)-1)
38 S (DDWN,DDWL(DDWRW))=$E(DDWN,1,DDWC-1)_DDWQ_$E(DDWN,DDWC+DDWREP,999)
39 S DDWC=DDWC+1
40 ;
41 I DDWREP W DDWQ
42 E D
43 . I $P(DDGLED,DDGLDEL,5)]"" W $P(DDGLED,DDGLDEL,5)_DDWQ
44 . E W DDWQ_$E(DDWN,DDWC,IOM+DDWOFS)
45 D POS(DDWRW,DDWC,"R")
46 D:$L(DDWN)>DDWRMAR WRAP^DDW5
47 Q
48 ;
49RUB N DDWX
50 S DDWED=1
51 I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX
52 ;
53 I DDWC=1 D
54 . I DDWRW=1 D
55 .. I 'DDWA W $C(7)
56 .. E D MVBCK^DDW3(1),POS(1,"E","R")
57 . E D POS(DDWRW-1,"E","RN")
58 E D
59 . S DDWC=DDWC-1,$E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN
60 . S DDWX=$E(DDWN,IOM+DDWOFS)
61 . I DDWC-DDWOFS>0 D
62 .. D CUP(DDWRW,DDWC-DDWOFS)
63 .. I $P(DDGLED,DDGLDEL,6)]"" D
64 ... W $P(DDGLED,DDGLDEL,6)
65 ... I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS)
66 .. E W $E(DDWN_" ",DDWC,IOM+DDWOFS) D CUP(DDWRW,DDWC-DDWOFS)
67 . E D POS(DDWRW,DDWC)
68 Q
69 ;
70DEL N DDWX
71 S DDWED=1
72 I $D(DDWMARK) D CHKDEL^DDW9(.DDWX) Q:DDWX
73 ;
74 I DDWC>$L(DDWN) D Q
75 . I DDWN?." " D
76 .. N DDWLAST
77 .. S DDWLAST=DDWRW+DDWA=DDWCNT
78 .. D XLINE^DDW5()
79 .. D:DDWLAST POS(DDWRW,"E","R")
80 . E D
81 .. N DDWY,DDWX
82 .. S DDWY=DDWRW+DDWA,DDWX=DDWC
83 .. D JOIN^DDW6
84 .. D POS(DDWY-DDWA,DDWX,"RN")
85 ;
86 S $E(DDWN,DDWC)="",DDWL(DDWRW)=DDWN,DDWX=$E(DDWN,IOM+DDWOFS)
87 I $P(DDGLED,DDGLDEL,6)]"" D
88 . W $P(DDGLED,DDGLDEL,6)
89 . I DDWX]" " D CUP(DDWRW,IOM) W DDWX D CUP(DDWRW,DDWC-DDWOFS)
90 E D
91 . W $E(DDWN_" ",DDWC,IOM+DDWOFS)
92 . D CUP(DDWRW,DDWC-DDWOFS)
93 Q
94 ;
95STATUS N DDWX,DDWS
96 S DDWS="Scr "_(DDWA+DDWRW-1\DDWMR+1)_" of "_(DDWCNT-1\DDWMR+1)
97 S DDWX="Ln "_(DDWA+DDWRW)_" of "_DDWCNT
98 S $E(DDWS,IOM\2+1-($L(DDWX)\2),999)=DDWX
99 S DDWX="Col "_DDWC
100 S $E(DDWS,IOM-$L(DDWX),999)=DDWX
101 D CUP(DDWMR+2,1) W $P(DDGLCLR,DDGLDEL)_DDWS
102 D POS(DDWRW,DDWC)
103 Q
104 ;
105UP I DDWRW>1 D
106 . D POS(DDWRW-1,DDWC,"RN")
107 E I DDWA D
108 . D MVBCK^DDW3(1)
109 E W $C(7)
110 I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R")
111 Q
112DN I DDWA+DDWRW'<DDWCNT W $C(7) Q
113 I DDWRW<DDWMR D
114 . D POS(DDWRW+1,DDWC,"RN")
115 E I DDWSTB D
116 . D MVFWD^DDW3(1)
117 E W $C(7) Q
118 I DDWC>246,$L(DDWN)<246 D POS(DDWRW,246,"R")
119 Q
120RT I DDWC>245,DDWC>$L(DDWN) W $C(7)
121 E D POS(DDWRW,DDWC+1,"R")
122 Q
123LT I DDWC=1 D
124 . I DDWRW=1,'DDWA W $C(7)
125 . E D UP,POS(DDWRW,"E","R")
126 E D POS(DDWRW,DDWC-1,"R")
127 Q
128 ;
129SV K DDWED G SV^DDW1
130SW D SAVE^DDW1 S DDWFIN="",DIWESW=1 Q
131EX D SAVE^DDW1 S DDWFIN="" Q
132QT S DUOUT=1 G QUIT^DDW1 ;GFT
133TO D SAVE^DDW1 S DTOUT=1,DDWFIN="" W $C(7) Q
134HLP D HLP^DDWH,POS(DDWRW,DDWC) Q
135AUT G AUTOTM^DDW1
136 ;
137TST G TSET^DDW2
138TSALL G TSALL^DDW2
139LST G LSET^DDW2
140RST G RSET^DDW2
141WRM G WRAPM^DDW2
142RPM G REPLM^DDW2
143ST G STAT^DDW2
144 ;
145TOP G TOP^DDW3
146BOT G BOT^DDW3
147 ;
148PDN G PGDN^DDW4
149PUP G PGUP^DDW4
150TAB G TAB^DDW4
151JLT G JLEFT^DDW4
152JRT G JRIGHT^DDW4
153LB G LBEG^DDW4
154LE G LEND^DDW4
155WRT G WORDR^DDW4
156WLT G WORDL^DDW4
157DLW S DDWED=1 G DELW^DDW4
158DEOL S DDWED=1 G DEOL^DDW4
159 ;
160BRK S DDWED=1 D BREAK^DDW5() Q
161XLN S DDWED=1 D XLINE^DDW5() D:DDWC'=1 POS(DDWRW,1,"R") Q
162 ;
163JN S DDWED=1 G JOIN^DDW6
164RFT S DDWED=1 G REFMT^DDW6
165 ;
166MRK G MARK^DDW7
167UMK G UNMARK^DDW7
168 ;
169CPY D COPY^DDW8() Q
170CUT D CUT^DDW8() Q
171PST D PASTE^DDW8() Q
172 ;
173FND G FIND^DDWF
174 ;
175NXT G NEXT^DDWF
176GTO G GOTO^DDWG
177CHG G CHG^DDWC
178 Q
179 ;
180READ(DDWTO,Y) ;Out: Y = Char or mnemonic
181 F D Q:Y'=-1
182 . R *Y:DDWTO
183 . I Y>127 D HS(.Y)
184 . I Y>31,Y<127 S Y=$C(Y) Q
185 . I Y<0 S Y="TO" Q
186 . D MNE(.Y)
187 Q
188 ;
189PREAD(DDWLEN,DDWTO,DDWST,Y) ;
190 ;In: DDWLEN = # chars to read
191 ;Out: DDWST = String
192 ; Y = Mnemonic, Null if DDWLEN chars read or invalid
193 X DDGLZOSF("EON")
194 R DDWST#DDWLEN:DDWTO E S Y="TO" Q
195 X DDGLZOSF("EOFF"),DDGLZOSF("TRMRD")
196 ;
197 D:DDWST?.E1.C.E H(.DDWST)
198 ;
199 I $C(Y)?1C,Y D
200 . D MNE(.Y)
201 . I Y=-1 S Y=""
202 . E I $L(Y)=1 W Y S DDWST=DDWST_Y,Y=""
203 E S Y=""
204 Q
205 ;
206MNE(Y) ;In: Y = Ascii value of first character
207 ;Out: Y = Mnemonic, or -1 if invalid
208 N S,F,T
209 I Y=13 S DDWHLOG=$P($H,",",2)
210 E I Y=10,$D(DDWHLOG)#2,$P($H,",",2)-DDWHLOG<1 K DDWHLOG S Y=-1 Q
211 E K DDWHLOG
212 S S="",F=0,T="DDW(""IN"")"
213 F D MNELOOP(.S,.Y,.T,.F) Q:F
214 Q
215 ;
216MNELOOP(S,Y,T,F) ;Read more
217 ;In/Out:
218 ; S = string of input chars
219 ; Y = ascii of current char
220 ; T = table under consideration
221 ;Out:
222 ; Y = mnemonic, or -1
223 ; F = 1 : done
224 ;
225 N E
226 S S=S_$C(Y)
227 I @T'[(U_S) D
228 . I $C(Y)?1L D
229 .. S $E(S,$L(S))=$C(Y-32)
230 .. S:@T'[(U_S_U) E=1
231 . E S E=1
232 I $T,$G(E) D Q
233 . S T=$Q(@T)
234 . I T]"" S $E(S,$L(S))=""
235 . E D FLUSH S F=1,Y=-1
236 ;
237 I @T[(U_S_U),S'=$C(27) D Q
238 . S Y=$P(@$TR(T,"IN","OT"),U,$L($P(@T,U_S_U),U)),F=1
239 ;
240 R *Y:5 I Y=-1 D FLUSH S F=1
241 Q
242 ;
243H(DDWST) ;
244 S DDWST=$TR(DDWST,$C(145,146,147,148),"''""""")
245 I DDWST?.E1.C.E D
246 . N DDWCON,DDWI
247 . S DDWCON=""
248 . F DDWI=128:1:255 S DDWCON=DDWCON_$C(DDWI)
249 . S DDWST=$TR(DDWST,DDWCON,$J(" ",128))
250 D POS(DDWRW,DDWC)
251 W DDWST
252 Q
253 ;
254HS(Y) ;
255 I Y>144,Y<149 S Y=$A($E("''""""",Y-144))
256 E S Y=32
257 Q
258 ;
259FLUSH ;
260 N DDWX
261 W $C(7) F R *DDWX:0 E Q
262 Q
263 ;
264CUP(Y,X) ;
265 S DY=IOTM+Y-2,DX=X-1 X IOXY
266 Q
267 ;
268POS(R,C,F) ;Pos cursor based on char pos C
269 N DDWX
270 S:$G(C)="E" C=$L($G(DDWL(R)))+1
271 S:$G(F)["N" DDWN=$G(DDWL(R))
272 S:$G(F)["R" DDWRW=R,DDWC=C
273 ;
274 S DDWX=C-DDWOFS
275 I DDWX>IOM!(DDWX<1) D SHIFT^DDW3(C,.DDWOFS)
276 S DY=IOTM+R-2,DX=C-DDWOFS-1 X IOXY
277 Q
278 ;
279MIN(X,Y) ;
280 Q $S(X<Y:X,1:Y)
281 ;
282HDIFF(H1,H2) ;# seconds between two $H's
283 Q (H2-H1)*86400+$P(H2,",",2)-$P(H1,",",2)
Note: See TracBrowser for help on using the repository browser.