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/ZISHONT.m@ 1553

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

initial load of FOIAVistA 6/30/08 version

File size: 8.6 KB
Line 
1%ZISH ;IHS/PR,SFISC/AC - Host File Control for Cache for VMS/NT/UNIX ;1/24/08 16:11
2 ;;8.0;KERNEL;**34,65,84,104,191,306,385,440**;JUL 10, 1995;Build 13
3 ;Per VHA Directive 2004-038, this routine should not be modified
4 ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01**
5 ;
6OPEN(X1,X2,X3,X4,X5,X6) ;SR. Open Host File
7 ;X1=handle name
8 ;X2=directory name \dir\
9 ;X3=file name
10 ;X4=file access mode e.g.: W for write, R for read, A for append.
11 ;X5=Max record size for a new file, X6=Subtype
12 N %,%1,%2,%I,%ZOS,%T,%ZA,%ZISHIO,$ET
13 S $ET="D OPNERR^%ZISH"
14 S U="^",%I=$I,%T=0,POP=0,X2=$$DEFDIR($G(X2)),%ZOS=$$OS^%ZOSV M %ZISHIO=IO
15 I %ZOS'="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"R")_$S(X4["B":"U",1:"S") ;NT & Unix
16 I %ZOS="VMS" S %1=$S(X4["A":"AW",X4["W":"WN",1:"RH")_$S(X4["B":"U",1:"S")
17 ;The next line eliminates the <ENDOFFILE> error for sequential files for the current process.
18 S %ZA=$ZUTIL(68,40,1) ;Work like DSM
19 S %=X2_X3 O %:(%1):2 I '$T S POP=1 Q
20 ;U % S %ZA=$ZA ;Comment out, $ZA is for READ status
21 ;I %ZA=-1 U:%I]"" %I C % S POP=1 Q
22 S IO=%,IO(1,IO)="",IOT="HFS",IOM=80,IOSL=60,POP=0 D SUBTYPE^%ZIS3($G(X6,"P-OTHER"))
23 I $G(X1)]"" D SAVDEV^%ZISUTL(X1)
24 U $S(%I]"":%I,1:$P)
25 Q
26 ;
27OPNERR ;Handle open error
28 S POP=1,$ECODE=""
29 U:$P]"" $P
30 Q
31 ;
32CLOSE(X) ;SR. Close HFS device not opened by %ZIS.
33 ;X=HANDLE NAME
34 ;IO=Device
35 N %
36 I $G(IO)]"" C IO K IO(1,IO)
37 I $G(X)]"" D RMDEV^%ZISUTL(X)
38 ;Only reset home if one setup.
39 I $D(IO("HOME"))!$D(^XUTL("XQ",$J,"IOS")) D HOME^%ZIS
40 Q
41 ;
42OPENERR ;
43 Q 0
44 ;
45DEL(%ZX1,%ZX2) ;ef,SR. Del files, return 1 if deleted all requested.
46 ;S Y=$$DEL^%ZISH("dir path",$NA(array))
47 ; will invoke an OS command to delete file(s)
48 ; UNIX: rm -f filespec[ ...]
49 ; VMS: del filespec[,...]
50 N %ZARG,%ZXDEL,%ZOS,%ZDELIM,%ZCOMND,%ZLIST
51 S %ZARG="",%ZXDEL=1
52 S %ZX1=$$DEFDIR($G(%ZX1))
53 S %ZOS=$$OS^%ZOSV
54 S %ZDELIM=$S(%ZOS="UNIX":" ",1:",")
55 S %ZCOMND=$S(%ZOS="UNIX":"rm -f ",1:"del ")
56 D
57 . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
58 . N %,%ZI,%ZISH,%ZX,%ZFOUND S %ZISH=""
59 . F %ZI=1:1 S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D
60 . . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
61 . . I %ZISH["*" S %ZXDEL=0 Q ; Wild card not allowed.
62 . . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) ; prepend directory path
63 . . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*"
64 . . S %ZFOUND=$ZSEARCH(%ZX)]"" ; File exists
65 . . S:%ZFOUND %ZARG=$S(%ZARG="":%ZX,1:%ZARG_%ZDELIM_%ZX) ; join files
66 . . I $L(%ZARG)>2000 S %=$ZF(-1,%ZCOMND_%ZARG),%ZARG="" H 1 ; delete files at a time
67 . ;
68 . I $L(%ZARG) S %=$ZF(-1,%ZCOMND_%ZARG) ; delete remaining files
69 ;
70 I %ZXDEL S %ZXDEL='$$LIST(%ZX1,%ZX2,"%ZLIST")
71 Q %ZXDEL
72 ;
73DELERR ;Trap any $ETRAP error, unwind and return.
74 S $ETRAP="D UNWIND^%ZTER"
75 S %ZXDEL=0,%ZARG=""
76 D UNWIND^%ZTER
77 Q
78 ;
79DEL1(%ZX3) ;ef,SR. Delete one file
80 N %ZI1,%ZI2
81 D SPLIT(%ZX3,.%ZI1,.%ZI2) S %ZI2(%ZI2)=""
82 Q $$DEL(%ZI1,$NA(%ZI2))
83 ;
84SPLIT(%I,%O1,%O2) ;Split to path,file
85 N %ZOS,%D,D S %ZOS=$$OS^%ZOSV
86 I %ZOS["VMS" D Q
87 . S D=$S(%I["]":"]",1:":")
88 . S %O1=$P(%I,D,1)_D,%O2=$P(%I,D,2)
89 . Q
90 S %D=$S(%ZOS="UNIX":"/",%ZOS="NT":"\",1:""),%O1="",%O2="" Q:%D=""
91 S D=$L(%I,%D),%O1=$P(%I,%D,1,D-1),%O2=$P(%I,%D,D)
92 Q
93 ;
94FEXIST(%PATH,%FL) ;Check if files exsist.
95 ;S Y=$$DTEST("/usr/var",$NA(array))
96 N %ZISH,%ZISHY
97 S %ZISH=$$LIST(%PATH,%FL,"%ZISHY")
98 Q %ZISH
99 ;
100LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names
101 ;S Y=$$LIST^%ZISH("\dir\",$NA(array),$NA(return array)) Return 1 if found anything
102 ;
103 N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS
104 S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV
105 ;S %ZX1=$$TRNLNM(%ZX1)
106 ;Get fls to act on
107 S %ZISH="" F S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH="" D
108 . S %ZISHY=$P(%ZISH,"*")
109 . I %ZOS="VMS",%ZISH'["." S %ZISH=%ZISH_".*" ;Allways upper
110 . ;NT, display case, ignore for lookup
111 . S %ZX=%ZX1_%ZISH
112 . F %ZISHN=0:1 D Q:(%ZX="")
113 . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX))
114 . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".")
115 . . Q:(%ZX="")!(%ZX?.E1.2".")
116 . . I %ZOS="VMS" S %ZX=$P(%ZX,"]",2),@%ZX3@(%ZX)=""
117 . . I %ZOS="NT" S %ZY=$P(%ZX,"\",$L(%ZX,"\")),@%ZX3@(%ZY)=""
118 . . I %ZOS="UNIX" S %ZY=$P(%ZX,"/",$L(%ZX,"/")) Q:%ZX'[%ZISHY S @%ZX3@(%ZY)=""
119 . . Q
120 Q $O(@%ZX3@(""))]""
121 ;
122MV(X1,X2,Y1,Y2) ;ef,SR. Rename a fl
123 ;S Y=$$MV^ZOSHDOS("\dir\","fl","\dir\","fl")
124 ;Unix use mv, NT/VMS use COPY and DEL
125 N %,X,Y,%ZOS,%ZISHX S %ZOS=$$OS^%ZOSV
126 S X1=$$DEFDIR($G(X1)),Y1=$$DEFDIR($G(Y1))
127 S X=$ZSEARCH(X1_X2),Y=Y1_Y2 ;move X to Y
128 I X="" Q 0
129 S %=$ZF(-1,$S(%ZOS="UNIX":"mv ",1:"copy ")_X_" "_Y) ;Use NT/VMS copy
130 I %ZOS'="UNIX" D
131 . S X2=$P(X,X1,2),%ZISHX(X2)=""
132 . S Y=$$DEL^%ZISH(X1,$NA(%ZISHX))
133 Q 1
134 ;
135PWD() ;ef,SR. Print working directory
136 N Y,%ZOS
137 S Y=$$DEFDIR(""),%ZOS=$$OS^%ZOSV
138 I Y="" S Y=$ZSEARCH("*")
139 Q $S(%ZOS["VMS":Y,1:$P(Y,".",1))
140 ;
141TRNLNM(PATH) ;ef. Expand logical path
142 N %ZOS,P1,P2
143 S %ZOS=$$OS^%ZOSV,PATH=$G(PATH)
144 I %ZOS="VMS" D Q PATH
145 . S P1=PATH_$S(PATH[":":"*.*",1:":*.*")
146 . S P2=$ZSEARCH(P1)
147 . S:$L(P2) PATH=$S(P2["]":$P(P2,"]",1)_"]",1:$P(P2,":",1)_":")
148 . Q
149 I %ZOS="NT" D Q PATH
150 . S P1=PATH_$S($E(PATH,$L(PATH))'="\":"\*",1:"*"),P2=$ZSEARCH(P1)
151 . S:$L(P2) PATH=$P(P2,"\",1,$L(P2,"\")-1)_"\"
152 . Q
153 I %ZOS="UNIX" D Q PATH
154 . S P1=PATH_$S($E(PATH,$L(PATH))'="/":"/*",1:"*"),P2=$ZSEARCH(P1)
155 . S:$L(P2) PATH=$P(P2,"/",1,$L(P2,"/")-1)_"/"
156 . Q
157 Q PATH
158 ;
159DEFDIR(DF) ;ef. Default Dir and frmt
160 ;Need to handle NT, VMS and Linux
161 N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF)
162 Q:DF="." "" ;Special way to get current dir.
163 S:DF="" DF=$G(^XTV(8989.3,1,"DEV")),DF=$P(DF,"^",$S($$PRI^%ZOSV<2:1,1:2))
164 Q:DF="" ""
165 ;Check syntax, VMS needs disk:[dir] or logical:
166 I %ZOS="VMS" D
167 . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
168 . E S P1="",P2=DF
169 . I P1="",P2["$" S P1=P2,P2="" ;Could be a logical
170 . I $L(P2) S:P2'["[" P2="["_P2 S:P2'["]" P2=P2_"]"
171 . S DF=P1_P2 S:DF'[":" DF=DF_":"
172 . Q
173 ;Check syntax, Unix needs /mnt/fl, ./fl, ~/fl $HOME/fl
174 I %ZOS="UNIX" D
175 . S DF=$TR(DF,"\","/")
176 . S:$E(DF,$L(DF))'="/" DF=DF_"/"
177 . Q
178 ;Check syntax, NT needs c:\dir\
179 I %ZOS="NT" D
180 . N P1,P2
181 . I DF[":" S P1=$P(DF,":")_":",P2=$P(DF,":",2)
182 . E S P1="",P2=DF
183 . S P2=$TR(P2,"/","\")
184 . I $L(P2) S:".\"'[$E(P2,1) P2="\"_P2 S:$E(P2,$L(P2))'="\" P2=P2_"\"
185 . S DF=P1_P2
186 . Q
187 S DF=$$TRNLNM(DF) ;Resolve logicals
188 Q DF
189 ;
190FL(X) ;Fl len
191 N ZOSHP1,ZOSHP2
192 S ZOSHP1=$P(X,"."),ZOSHP2=$P(X,".",2)
193 I $L(ZOSHP1)>8 S X=4 Q
194 I $L(ZOSHP2)>3 S X=4 Q
195 Q
196 ;
197STATUS() ;ef,SR. Return EOF status
198 U $I
199 Q $$EOF($ZEOF)
200 ;
201EOF(X) ;Eof flag, pass in $ZEOF
202 Q (X=-1)
203 ;
204MAKEREF(HF,IX,OVF) ;Internal call to rebuild global ref.
205 ;Return %ZISHF,%ZISHO,%ZISHI,%ZISUB
206 N I,F,MX
207 S OVF=$G(OVF,"%ZISHOF")
208 S %ZISHI=$QS(HF,IX),MX=$QL(HF) ;
209 S F=$NA(@HF,IX-1) ;Get first part
210 I IX=1 S %ZISHF=F_"(%ZISHI" ;Build root, IX=1
211 I IX>1 S %ZISHF=$E(F,1,$L(F)-1)_",%ZISHI" ;Build root
212 S %ZISHO=%ZISHF_","_OVF_",%OVFCNT)" ;Make overflow
213 F I=IX+1:1:MX S %ZISHF=%ZISHF_",%ZISUB("_I_")",%ZISUB(I)=$QS(HF,I)
214 S %ZISHF=%ZISHF_")"
215 Q
216 ;
217READNXT(REC) ;Read any sized record into array. %ZB has terminator
218 N %,I,X,$ES,$ET S REC="",$ET="D READNX^%ZISH Q"
219 U IO R X:5 S %ZB=$A($ZB),REC=$E(X,1,255)
220 Q:$L(X)<256
221 S %=256 F I=1:1 Q:$L(X)<% S REC(I)=$E(X,%,%+254),%=%+255
222 Q
223READNX ;Check for EOF
224 I $ZE["ENDOFFILE" S %ZA=-1
225 S $EC=""
226 Q
227 ;
228FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
229 ;p1=hostf file directory
230 ;p2=host file name
231 ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
232 ;p4=INCREMENT SUBSCRIPT
233 ;p5=Overflow subscript, defaults to "OVF"
234 N %ZA,%ZB,%ZC,X,%OVFCNT,%ZISHF,%ZISHO,POP,%ZISUB,$ES,$ET
235 N I,%ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHOF,%ZISHOX,%ZISHS,%ZX,%ZISHY
236 S %ZX1=$$DEFDIR($G(%ZX1)),%ZISHOF=$G(%ZX5,"OVF")
237 D MAKEREF(%ZX3,%ZX4,"%ZISHOF")
238 D OPEN^%ZISH(,%ZX1,%ZX2,"R")
239 I POP Q 0
240 S %ZC=1,%ZA=0,$ET="S %ZC=0,%ZA=-1,$EC="""" Q"
241 U IO F K %XX D READNXT(.%XX) Q:$$EOF($ZEOF)!%ZA D
242 . S @%ZISHF=%XX
243 . I $D(%XX)>2 F %OVFCNT=1:1 Q:'$D(%XX(%OVFCNT)) S @%ZISHO=%XX(%OVFCNT)
244 . S %ZISHI=%ZISHI+1
245 . Q
246 D CLOSE() ;Normal exit
247 Q %ZC
248 ;
249GTF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Load contents of global to host file.
250 ;p1=$NAME of global reference
251 ;p2=incrementing subscript
252 ;p3=host file directory
253 ;p4=host file name
254 N %ZISHY,%ZISHOX
255 S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"W")
256 Q %ZISHY
257 ;
258GATF(%ZX1,%ZX2,%ZX3,%ZX4) ;ef,SR. Append to host file.
259 ;
260 ;p1=$NAME of global reference
261 ;p2=incrementing subscript
262 ;p3=host file directory
263 ;p4=host file name
264 N %ZISHY
265 S %ZISHY=$$MGTF(%ZX1,%ZX2,%ZX3,%ZX4,"A")
266 Q %ZISHY
267 ;
268MGTF(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;
269 ;p1=$NAME of global reference
270 ;p2=incrementing subscript
271 ;p3=host file directory
272 ;p4=host file name
273 N %ZISH,%ZISH1,%ZISHI,%ZISHL,%ZISHS,%ZISHOX,IO,%ZX,Y,%ZC
274 D MAKEREF(%ZX1,%ZX2)
275 D OPEN^%ZISH(,$G(%ZX3),%ZX4,%ZX5) ;Default dir set in open
276 I POP Q 0
277 N $ETRAP S $ETRAP="S $EC="""" D CLOSE^%ZISH() Q 0"
278 F Q:'($D(@%ZISHF)#2) S %ZX=@%ZISHF,%ZISHI=%ZISHI+1 U IO W %ZX,!
279 D CLOSE()
280 Q 1
281 ;
Note: See TracBrowser for help on using the repository browser.