source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHVXD.m@ 1150

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1%ZISH ;ISF/AC,RWF - VAX DSM Host file Control ;05/12/2004 10:43
2 ;;8.0;KERNEL;**24,36,65,84,104,191,306**;JUL 10, 1995
3 ;
4OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open file
5 ;D OPEN^%ZISH([handlename],[directory],filename,[accessmode],[recsize])
6 ;X1=handle name
7 ;X2=directory, X3=filename, X4=access mode
8 ;X5=new file max record size, X6=Subtype
9 ;
10 N %,%1,%2,%I,%IO,%I2,%P,%T,X,Y,$ETRAP
11 S $ETRAP="D OPNERR^%ZISH"
12 S U="^",%I=$I,X2=$$DEFDIR($G(X2)),X4=$$UP^XLFSTR(X4)
13 S Y=$S(X4["A":"",X4["R":"READONLY",X4["W":"NEWVERSION",1:"READONLY")
14 S Y=Y_$S(X4["B":":BLOCKSIZE=512",$G(X5)&(X4["W"):":RECORDSIZE="_+X5,1:"")
15 S:$E(Y)=":" Y=$E(Y,2,999) S %IO=X2_X3,%I2="%IO:"_$S($L(Y):"("_Y_")",1:"")_":3"
16 O @%I2 S %T=$T
17 I '%T S POP=1 Q
18 S IO=%IO,IO(1,IO)="",IOT="HFS",POP=0 D SUBTYPE^%ZIS3($G(X6))
19 I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
20 U IO:NOTRAP U $S(%I]"":%I,1:$P) ;Enable use of $ZA to test EOF condition.
21 Q
22OPNERR ;error on open
23 S POP=1,$ECODE=""
24 U:$P]"" $P
25 Q
26 ;
27CLOSE(X) ;SR. Close HFS device not opened by %ZIS.
28 ;X1=Handle name, IO=device
29 I IO]"" C IO K IO(1,IO)
30 I $G(X)]"" D RMDEV^%ZISUTL(X)
31 ;Only reset home if one setup.
32 I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS
33 Q
34DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
35 ;S Y=$$DEL^%ZISH("/dir/",namevalue)
36 N %ZISH,%ZISHLGR,%ZX,X,%ZXDEL
37 S %ZX1=$$DEFDIR($G(%ZX1)),%ZXDEL=1,%ZISH=""
38 F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D
39 . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
40 . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed.
41 . S %ZX=$ZSEARCH(%ZX1_%ZISH)
42 . Q:%ZX']"" ; File doesn't exist - not an error, just quit.
43 . O %ZX:READONLY:0
44 . I '$T S %ZXDEL=0 Q ; Can't open it.
45 . C %ZX:DELETE
46 . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful.
47 Q %ZXDEL
48DELERR ;Trap any $ETRAP error, unwind and return.
49 S $ETRAP="D UNWIND^%ZTER"
50 S %ZXDEL=0
51 D UNWIND^%ZTER
52 Q
53 ;
54LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Set local array holding fl names
55 ;S Y=$$LIST^ZISH("/dir/","list_root","return_root")
56 ;list_root can have XX("A*"), XX("test.com")...
57 ;Both arrays passed as $NA values (closed roots).
58 N %IO,%X,%ZISH,%ZISH1,%ZISHIO,%ZX,POP,X,%ZISHDL1,%ZISHDL2,%ZISHDN1,%ZISHDN2
59 N $ETRAP,$ESTACK S $ETRAP="",%ZX1=$$DEFDIR($G(%ZX1))
60 S %IO=$I,%ZISHDN1="ZISH"_$J_".TMPA",%ZISHDN2="ZISH"_$J_".TMPB"
61 S %ZISHDL1=%ZX1_%ZISHDN1,%ZISHDL2=%ZX1_%ZISHDN2
62 S $ZT="SPAWNERR^%ZISH"
63 ;Init %ZISHDL1, %ZISHDL2 by deleteing them
64 I $ZSEARCH(%ZISHDL1)["ZISH" S X=$&ZLIB.%SPAWN("DEL "_%ZISHDL1_";*")
65 I $ZSEARCH(%ZISHDL2)["ZISH" S X=$&ZLIB.%SPAWN("DEL "_%ZISHDL2_";*")
66 ;Get fls to act on, Build listing in ZISH_$J_.TMPA (%ZISHDL1)
67 S %ZISH1=0,%ZISH=""
68 F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" S X=$$LIST1(%ZX1_%ZISH)
69 ;Open %ZISHDL1 to read list backin.
70 S $ZT="LSTEOF^%ZISH"
71 O %ZISHDL1::5 I '$T G LSTEOF
72 U %ZISHDL1:NOTRAP R %ZX:5 I $ZA=-1 G LSTEOF
73 F I=0:1 U %ZISHDL1 R %ZX:5 G LSTEOF:$ZA=-1 I %ZX]"" S %X=$P(%ZX,$C(32)) D
74 . I %ZX'["Total of",%ZX'?.E1".DIR;".N,%ZX'?1"Directory".E D
75 . . I (%X[%ZISHDN1)!(%X[%ZISHDN2) Q
76 . . S @%ZX3@(%X)=""
77LSTEOF S $ZT=""
78 I $L(%IO) U:$D(IO(1,%IO)) IO
79 C %ZISHDL1:DELETE
80 I $ZSEARCH(%ZISHDL2)]"" S X=$&ZLIB.%SPAWN("DEL "_%ZISHDL2_";*")
81 I $ZSEARCH(%ZISHDL1)]"" S X=$&ZLIB.%SPAWN("DEL "_%ZISHDL1_";*")
82 S $ECODE=""
83 Q ($Q(@%ZX3)]"")
84 ;
85LIST1(%ZX) ;Get one part of the list
86 S $ZT="LSTERR^%ZISH"
87 I %ZISH1 D
88 . S X=$&ZLIB.%SPAWN("DIR/COL=1 "_%ZX,,%ZISHDL2)
89 . I X S X=$&ZLIB.%SPAWN("APPEND "_%ZISHDL2_" "_%ZISHDL1)
90 I '%ZISH1 S X=$&ZLIB.%SPAWN("DIR/COL=1 "_%ZX,,%ZISHDL1),%ZISH1=1
91 Q 1
92LSTERR ;Error in list
93 I $ZSEARCH(%ZISHDL2)["ZISH" S X=$&ZLIB.%SPAWN("DEL "_%ZISHDL2_";*")
94 Q 0
95 ;
96SPAWNERR ;TRAP ERROR OF SPAWN
97 O %ZISHDL1:READONLY:1 I $T C %ZISHDL1:DELETE
98 S $ECODE=""
99 Q 0
100 ;
101MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl
102 ;S Y=$$MV^ZISH("/dir/","fl","/dir/","fl")
103 N X,Y,%ZISHDL1
104 S %ZISHDL1="ZISH"_$J_".TMPA",X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
105 S $ZT="SPAWNERR^%ZISH"
106 ;Pbv or qit
107 I (X2="")!(Y2="") Q 0
108 I X1=Y1 D
109 .O @(""""_X1_X2_"""")
110 .C @(""""_X1_X2_""":RENAME="_""""_Y1_Y2_"""")
111 E D
112 .S Y=$&ZLIB.%SPAWN("COPY "_X1_X2_" "_Y1_Y2,,%ZISHDL1)
113 .O %ZISHDL1:READONLY:1
114 .I $T C %ZISHDL1:DELETE
115 .S X=$&ZLIB.%PARSE(X1_X2)
116 .S Y=$&ZLIB.%SPAWN("DEL "_X,,%ZISHDL1)
117 .O %ZISHDL1:READONLY:1
118 .I $T C %ZISHDL1:DELETE
119 Q 1
120PWD() ;ef,SR. Print working directory
121 N Y
122 S Y=$$DEFDIR("")
123 S:Y="" Y=$&ZLIB.%PARSE("TMP.TMP",,,"DEVICE")_$&ZLIB.%DIRECTORY
124 Q Y
125 ;
126DEFDIR(DF) ;ef. Default Dir and frmt
127 S DF=$G(DF) Q:DF="." "" ;Special way to get current dir.
128 S:DF="" DF=$G(^XTV(8989.3,1,"DEV"))
129 ;Check syntax, VMS needs [ ] or $
130 N P1,P2
131 I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
132 E S P1="",P2=DF
133 I P1="",P2["$" S DF=P2 Q DF ;Assume a logical
134 I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]"
135 S DF=P1_P2
136 Q DF
137STATUS() ;ef,SR. Return EOF status
138 U $I:NOTRAP
139 Q $$EOF($ZA)
140 ;
141EOF(X) ;Eof flag, Pass in $ZA
142 Q (X=-1)
143QL(X) ;Qlfrs
144 Q:X=""
145 S:$E(X)'="-" X="-"_X
146 Q
147FL(X) ;Fl len
148 N ZOSHP1,ZOSHP2
149 S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
150 I $L(ZOSHP1)>14 S X=4 Q
151 I $L(ZOSHP2)>8 S X=4 Q
152 Q
153 ;
154MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref.
155 ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
156 N I,F,MX
157 S OVF=$G(OVF,"%ZISHOF")
158 S %ZISHI=$QS(HF,IX),MX=$QL(HF) ;
159 S F=$NA(@HF,IX-1) ;Get first part
160 I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
161 I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
162 S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
163 F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I)
164 S %ZISHF=%ZISHF_")"
165 Q
166FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
167 ;p1=host file directory
168 ;p2=host file name
169 ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
170 ;p4=INCREMENT SUBSCRIPT
171 ;p5=Overflow subscript, defaults to "OVF"
172 N %ZA,%ZB,%ZC,%ZL,X,%OVFCNT,%CONT
173 N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY,POP,%ZISUB
174 S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
175 D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
176 D OPEN^%ZISH(,%ZX1,%ZX2,"R")
177 I POP Q 0
178 N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH Q:$Q 0 Q"
179 U IO F K %XX D READNXT(.%XX) Q:$$EOF(%ZA) D
180 . S @%ZISHF=%XX
181 . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT)
182 . S %ZISHI=%ZISHI+1
183 . Q
184 D CLOSE() ;Normal exit
185 Q 1
186 ;
187ERREOF D CLOSE() ;Got error Reading file
188 Q 0
189 ;
190READNXT(REC) ;
191 N T,I,X,%ZL
192 U IO:NOTRAP R REC#255:5 S %ZA=$ZA,%ZB=$ZB,%ZL=%ZA Q:$$EOF(%ZA)
193 F I=1:1:%ZL\255 R X#255:5 S %ZA=$ZA Q:$$EOF(%ZA) S REC(I)=X
194 Q
195GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file.
196 ;Previously name LOAD
197 ;p1=$NAME of global reference
198 ;p2=incrementing subscript
199 ;p3=host file directory
200 ;p4=host file name
201 N %ZISHY,%ZISHLGR,%ZISHOX
202 S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"W")
203 Q %ZISHY
204 ;
205GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
206 ;
207 ;p1=$NAME of global reference
208 ;p2=incrementing subscript
209 ;p3=host file directory
210 ;p4=host file name
211 N %ZISHY
212 S %ZISHY=$$MGTF(%ZX1,%ZX2,$G(%ZX3),%ZX4,"A")
213 Q %ZISHY
214 ;
215MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;
216 ;p1=$NAME of global reference
217 ;p2=incrementing subscript
218 ;p3=host file directory
219 ;p4=host file name
220 N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHLGR,%ZISHS,%ZISHOX,IO,%ZX,Y
221 D MAKEREF(%ZX1,%ZX2)
222 D OPEN^%ZISH(,%ZX3,%ZX4,%ZX5) ;Default dir set in open
223 I POP Q 0
224 N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0"
225 F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
226 D CLOSE() ;Normal Exit
227 Q 1
228 ;
Note: See TracBrowser for help on using the repository browser.