source: IHS-VA_UTILITIES-XB/ZIBGSVEM.m@ 641

Last change on this file since 641 was 641, checked in by Sam Habiel, 15 years ago

Initial commit of XB, move away from sf.net.
Includes kids file and documentation.
File size: 5.3 KB
Line 
1ZIBGSVEM ; IHS/ADC/GTH - SAVE GLOBAL TO MSM UNIX ; [ 09/14/2004 4:57 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ;I ^%ZOSF("OS")["PC"!(^%ZOSF("OS")["Windows NT")!($P($G(^AUTTSITE(1,0)),U,21)=2) G ^ZIBGSVEP ;COMMENTED OUT AND REPLACE BY NEXT LINE - AEF/08/08/03
5 I $$VERSION^%ZOSV(1)["Windows" G ^ZIBGSVEP ;XB*3*10 TASSC/MFD 8/15/03
6 G:$D(XBMED) NOSELT
7ASK ;
8 R !!,"Copy transaction file to ('^' TO EXIT WITHOUT SAVING)",!!?10,"[T]ape, [C]artridge, [D]iskette, or [F]ile F// ",XBMED:DTIME
9 S XBMED=$$UP^XLFSTR($E(XBMED_"F"))
10 I U[XBMED S XBFLG(1)="Job Terminated by Operator at Device Select",XBFLG=-1 G END
11 G HELP:"?"[XBMED,ASK:'("CDFT"[XBMED)
12NOSELT ;
13 S (IO,XBZDEV)=XBIO
14 D TAPE:"T"[XBMED,CART:"C"[XBMED,DISK:"D"[XBMED,UNIX:"F"[XBMED
15 Q
16 ;
17HELP ;
18 W !!,"This option saves the ' ",XBNAR," ",XBGL,"' transaction file to either a tape,",!,"a floppy diskette, or a Unix file. The default is to a unix file",!,"in the ",XBUF," directory."
19 W !,"Enter either a ""C"" for tape cartridge, a ""T"" for 9-track tape, a ""D"" for floppy disk, or an ""F"" for Unix file."
20 G ASK
21 ;
22DISK ; ----- Transfer TX Global to floppy disk.
23 U IO(0)
24 W !!,"Mount a FORMATTED Floppy Diskette, 'WRITE ENABLED' ",*7,!,"Press RETURN When Ready or ""^"" to Exit WITHOUT SAVING "
25 R X:DTIME
26 I X[U!('$T) S XBFLG(1)="Job Aborted by Operator During Floppy Mount",XBFLG=-1 G END
27 I $$OPEN^%ZISH("/dev/","fd0","W") S XBERRMSG="Floppy Disk" G ERRMESS
28 U IO
29 I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G DISK
30 U IO(0)
31 W !,"Please Standby - Copying Data to Floppy",!
32 U IO
33 D SAVEMSM
34 D ^%ZISC
35 U IO(0)
36 R !!,"Remove the Floppy... Press RETURN when Ready:",X:DTIME
37 G END
38 ;
39UNIX ; ----- Transfer TX Global to unix file.
40 S XBPRE=$E(XBGL,2,5),XBASUFAC=$S('$D(XBSUFAC):$P(^AUTTLOC(DUZ(2),0),U,10),1:XBSUFAC)
41 S XBFN=$S('$D(XBFN):XBPRE_XBASUFAC_"."_XBCARTNO,1:XBFN)
42 S XBTEMPFN=XBUF_"/"_XBFN
43 S XBPAFN=XBTEMPFN
44 S %=$$OPEN^%ZISH(XBUF_"/",XBFN,"W")
45 I % S XBERRMSG=$S(%=1:"All Host File Servers Busy!",1:"UNIX File") G ERRMESS
46 I '$D(ZTQUEUED) U IO(0) W !,"Please Standby - Copying Data to UNIX File ",XBTEMPFN,!
47 S X=$$JOBWAIT^%HOSTCMD("chmod 666 "_XBUF_"/"_XBFN)
48 U IO
49 D SAVEMSM
50 G CLOSE
51 ;
52TAPE ;
53 S XBDEV="rmt0",XBMSG="9-Track"
54 G TAPETST
55CART ;
56 S XBDEV="rct",XBMSG="Cartridge"
57 ;
58TAPETST ; ----- Transfer global to cartridge or 9-track.
59 W !,"Do you want to test the ",XBMSG," DRIVE? (Y/N) Y//"
60 R Y:DTIME
61 S Y=$E(Y_"Y")
62 I "Yy"[Y D TAPETEST G:$D(XBFLG) CLOSE I Y[U S XBFLG(1)="Job Aborted by Operator During Tape Test",XBFLG=-1 G END
63S ;
64 U IO(0)
65 W !!,"Mount ",XBMSG," Tape, 'WRITE ENABLED' ",*7
66 R !,"Press RETURN When Ready - ""^"" to Exit ",X:DTIME
67 I X[U S XBFLG(1)="Job Terminated By Operator at Mount Message",XBFLG=-1 G CLOSE
68MAGOPEN ;
69 I $$OPEN^%ZISH("/dev/",XBDEV,"W") S XBERRMSG="Magtape Device" G ERRMESS
70 U IO
71 I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G S
72 U IO(0)
73 W !,"Please Standby - Copying Data to Tape",!
74 U IO
75 D SAVEMSM
76 G EXIT
77 ;
78SW ;
79 U IO(0)
80 W *7,!!," The Tape Is WRITE PROTECTED. Please Remove The Tape,"
81 W !," And Re-position The Write Protect/Enable Switch.",!," "
82 G MAGOPEN
83 ;
84ERRMESS ;
85 S XBFLG(1)=XBERRMSG_" Not Available",XBFLG=-1
86 I '$D(ZTQUEUED) U IO(0) W !,XBFLG(1)
87 G END
88 ;
89EXIT ;
90 D ^%ZISC
91 U IO(0)
92 W !!,"Rewinding tape. <WAIT>."
93 H 2
94 W !!,"Remove the tape... Press RETURN when Ready:"
95 R X:DTIME
96 G END
97 ;
98CLOSE ;
99 D ^%ZISC
100END ;
101 I XBMED="F",'$D(XBFLG),XBQ="Y" D UUCPQ
102 D HOME^%ZIS
103 KILL XBPRE,XBASUFAC,XBOUTDAT,XBINDATA,XBDEV,XBMSG,XBERRMSG,XBTEMPFN,XBZDEV
104 Q
105 ;
106TAPETEST ;
107 U IO(0)
108 W !!,"TAPE TEST...Mount ",XBMSG," Tape, 'WRITE ENABLED' ",*7
109 R !,"TAPE TEST...Press RETURN When Ready - ""^"" to Exit ",X:DTIME
110 I X[U S XBFLG(1)="Job Aborted by Operator during Tape Test",XBFLG=-1 Q
111 W !,"TAPE TEST...Opening tape drive."
112 H 1
113 I $$OPEN^%ZISH("/dev/",XBDEV,"W") G TESTERR
114 U IO
115 I $$STATUS^%ZISH U IO(0) W !!,"Please",*7 G TAPETEST
116 U IO(0)
117 W !,"TAPE TEST...Tape drive opened.",!,"TAPE TEST...Writing test data to tape."
118 H 1
119WRITE ;
120 S XBOUTDAT="TEST DATA RECORD WRITTEN TO TAPE ON "_XBDT
121 U IO
122 W XBOUTDAT,!,"**",!,"**",!!
123 U IO(0)
124 W !,"TAPE TEST...Data written."
125 D ^%ZISC
126 H 6
127 U IO(0)
128 W !,"TAPE TEST...Reading test data from tape.",!
129 H 1
130 I $$OPEN^%ZISH("/dev/",XBDEV,"R") G TESTERR
131 U IO
132 R XBINDATA:DTIME
133 D ^%ZISC
134 U IO(0)
135 W !,"WROTE : '",XBOUTDAT,"'",!," READ : '",XBINDATA,"'"
136 I XBINDATA=XBOUTDAT W !,"TAPE TEST...Successful."
137 E W !,"TAPE TEST...FAILED...$#@!" S XBFLG(1)="Tape Test Failed During Testing",XBFLG=-1
138 Q
139 ;
140TESTERR ;
141 S XBFLG(1)="Device Not Available During Tape Testing",XBFLG=-1
142 U IO(0)
143 W !,*7,XBFLG(1),*7
144 Q
145 ;
146UUCPQ ;EP - auto queue to uucp subroutine, must have system id in RPMS SITE file ; IHS/SET/GTH XB*3*9 10/29/2002
147 I $$JOBWAIT^%HOSTCMD("/usr/bin/sendto "_XBQTO_" "_XBUF_"/"_XBFN) S XBFLG=-1,XBFLG(1)="Queue of File to uucp Failed"
148 E W:'$D(ZTQUEUED) !,"Export file ",XBUF,"/",XBFN," queued up to be sent to ",XBQTO,"...",!
149 Q
150 ;
151SAVEMSM ;EP - $QUERY thru global, write to output.
152 K XBQUIT
153 I '$G(XBFLT) W XBDT,!,XBTLE,!
154 S X=XBGL_XBF_")"
155 F D Q:$G(XBQUIT)
156 .S X=$Q(@X)
157 .I X="" S XBQUIT=1 Q
158 .S Y=$P($P($P(X,")",1),"(",2),",",1)
159 .I XBE=+XBE,Y'=+Y S XBQUIT=1 Q
160 .I ($L(XBE)&($$FOLLOW(Y,XBE))) S XBQUIT=1 Q
161 .I $D(XBCON)&('(Y=+Y)) S XBQUIT=1 Q
162 .S Y=X
163 .S:$E(Y,2)="[" Y=U_$P(Y,"]",2,999)
164 .W:'$G(XBFLT) Y,!
165 .W @X,!
166 I '$G(XBFLT) W "**",!,"**",!!
167 K XBQUIT
168 Q
169 ;
170FOLLOW(Y,XBE) ; If Y follows XBE return 1. Else return 0.
171 N Z
172 I '(Y=+Y) D
173 .S Z=(Y]XBE)
174 I Y=+Y D
175 .S Z=(Y>XBE)
176 Q Z
177 ;
Note: See TracBrowser for help on using the repository browser.