source: IHS-VA_UTILITIES-XB/trunk/XBRSBD.m@ 1545

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

Modified directory structure; moved routines.

File size: 5.0 KB
Line 
1XBRSBD ;IHS-OIRM-DSD/THL;ADAPTATION OF %RS TO SELECT ROUTINES EDITED AFTER SPECIFIED DATE;
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; This routine saves selected routines edited after a given date
5 ;
6START ;
7 S $ZT="ERR^%RS",%SEQ=1 K %SBP
8 W !?10,$P($P($ZV,","),"-")," - Routine Save Utility"
9 O 63::0 E U 0 W !,"Waiting for device 63" O 63
10SDEV D OUT^%SDEV I $D(QUIT) C 63 K %SEQ Q
11 S QUIT=0,%SBP=%DEV>58&(%DEV<63),%TAP=%DEV>46&(%DEV<51)
12 S %TAPV=$S('%TAP:0,1:$ZB(%DEVMODE,"_",1)["V") G:'%TAP SIZE
13 ;U %DEV I @(%MTON_"=0") U 0 W *7,!,"Tape is not ready" C %DEV G SDEV
14 ;I @%MTWLK U 0 W *7,!,"Tape is write protected" C %DEV G SDEV
15 U 0 G RCMT
16SIZE I %SBP S %SIZE=1024*#10000 G RCMT
17 R !,"Enter size of save medium (if applicable): ",%SIZE:$S($D(DTIME):DTIME,1:999) S:%SIZE="" %SIZE=1024*#10000 G SDEV:"^"=%SIZE,EXIT:%SIZE="^Q"!(%SIZE="^q")
18 I %SIZE?1N.N1A S %SIZE=$P(%SIZE,"K"),%SIZE=$P(%SIZE,"k")
19 I %SIZE?1N.N,%SIZE>0 S %SIZE=%SIZE*1024 G RCMT
20 I %SIZE'?1"?".E W " ??" G SIZE
21 W !!,"If using removeable disks or tape for save, enter the number of 1k blocks which",!,"each disk will hold. As each disk becomes full, you will be asked to",!,"replace it with an empty one."
22 W !!,"If not using removeable media, press <RETURN>",! G SIZE
23 ;
24RCMT R !,"Enter comment for dump header : ",%CMT:$S($D(DTIME):DTIME,1:999) G SDEV:%CMT="^",CNT1:%CMT'="?"
25 W !,"The comment will be displayed with the date and time before the routines",!,"are restored." G RCMT
26CNT1 K QUIT D INT^%RSEL I $D(QUIT) W !,"No routines selected" G EXIT
27 S XBTYPE="SAVE" D ^XBDATE ;ADDED TO SPECIFY A DATE AND SCREEN OUT ROUTINES EDITED SINCE SPECIFIED DATE
28 I $D(QUIT) W !,"No routines will be saved." H 2 G EXIT
29 D:%TAP %SET^%MTCHK
30 S QUIT=0,%NEXT="D NEXTVOL^%RS Q:QUIT ZL @%RN"
31 I '%TAP S %ZPRINT="ZR S %S=$S ZL @%RN X:%S-$S>(%SIZE-$ZB-10) %NEXT Q:QUIT U %DEV W %RN,! S:'%SBP&$ZC!($ZA<0&%SBP) QUIT=2 Q:QUIT F %X=1:1 S %J=$T(+%X) W %J,! Q:%J="""""
32 E I '%TAPV S %ZPRINT="ZL @%RN U %DEV W %RN,! S:$ZC QUIT=2 Q:QUIT P"
33 E S %ZPRINT="ZL @%RN U %DEV W %RN S:$ZC QUIT=2 Q:QUIT F %X=1:1 S %J=$T(+%X) W %J Q:%J="""""
34 D INT^%T,INT^%D
35 W !!,"Saving ...",!
36 U %DEV W:'%DEV ! W %TIM1_" "_%DAT1 W:'%TAPV ! W %CMT W:'%TAPV !
37 S %RN=""
38 F %I=1:1 S %RN=$O(^UTILITY($J,%RN)) Q:%RN=""!QUIT U 0 W ?%I-1#8*10,%RN W:(%I#8)=0 ! U %DEV D PCODE Q:QUIT I PCODE X %ZPRINT Q:QUIT I %TAP,@%MTEOT D NEXTTAPE Q:QUIT
39 I QUIT=2 U 0 W !!,"End of file reached, last portion of save may be corrupted! Terminating save."
40 E U %DEV W:'%TAPV !! W:%TAPV "",""
41 U 0 W !!,"Done. "
42QUIT I '$D(%SBP) K %SEQ Q
43 I %SBP,QUIT<2 U %DEV S %BN=$ZA U 0 W "Last block used was ",%BN,"."
44EXIT C 63 U 0 I $D(%DEV),%DEV'=$I,+%DEV C %DEV I $G(%DEVTYPE)="HFS",$ZA=-1 W !!,"Cannot write end of file. Last part of save may be corrupted."
45 I $D(%TAP) D:%TAP %KILL^%MTCHK
46 K %DEV,%RN,%BN,%I,%J,%CMT,%TIM,%TIM1,%DAT,%DAT1,%NEXT,%SEQ,%FN,%S,%SIZE,%SBP,%TAP,%X,%ZA,%ZPRINT,QUIT,%TAPV
47 K XBDAT,RTN
48 Q
49PCODE ; Test for pcode only routine
50 I %DEV<47!(%DEV>62) S PCODE=1 Q
51 S PCODE=$ZBN(^ (%RN)) I PCODE=0 U 0 W !,%RN," does not exist" Q
52 V PCODE I $V(17,0,1)=0 S PCODE=1 Q ; not a pcode routine
53 G:%TAP PC10
54 S %S=1056 F %K=0:0 S %K=$V(1012,0,4) Q:%K=0 V %K S %S=%S+1024 ;1056=1024+32, 32 byte cushion left for rtn name, etc.
55 I %S>(%SIZE-$ZB) X %NEXT Q:QUIT
56PC10 V PCODE U %DEV W %RN_":"_$V(17,0,1) W:'%TAPV ! I $ZC S QUIT=2 Q
57 U:%DEV>58&(%DEV<63) %DEV:(::::"V")
58 F PCODE=PCODE:0 W $V(0,0,1024,1) S PCODE=$V(1012,0,4) Q:PCODE=0 V PCODE ;I %TAP,@%MTEOT D NEXTTAPE U %DEV Q:QUIT
59 I $ZC S QUIT=2
60 U:%DEV>58&(%DEV<63) %DEV:(::::"S") Q
61ERR I $F($ZE,"<INRPT>") U 0 W !!,"...Aborted." D EXIT V 0:$J:$ZB($V(0,$J,2),#0400,7):2
62 ZQ
63NEXTVOL ;
64 S %SEQ=%SEQ+1 U %DEV W "*EOF*",! C %DEV
65 U 0 W !,"Sequence #",%SEQ-1," is full, if using removeable media, please put in the next one"
66NEXTVOL1 ;
67 R !,"Enter 'GO' to proceed: ",%X:$S($D(DTIME):DTIME,1:999) W !
68 I %X="?" W !!,"Remove sequence #",%SEQ-1,", and put the next disk or tape into the drive. If you are",!,"not using removeable media, you should abort this save by typing 'control C';",!,"your save will still be good up to this point." G NEXTVOL1
69 I %X'="GO" W " ??" G NEXTVOL1
70 O %DEV:(%FN:"W") U %DEV I $ZA U 0 W !,"Cannot access ",%FN," please correct" G NEXTVOL1
71 W "DISK#",%SEQ,! S %X=$ZC
72 U 0 I %X W !,"Cannot write to ",%FN," please correct" G NEXTVOL1
73 S QUIT=0 Q
74NEXTTAPE ;
75 U 0 W !,"Tape sequence number ",%SEQ," is full. Last routine was ",%RN,"."
76 W !,"After this tape rewinds, mount the next tape.",!
77 S %SEQ=%SEQ+1 U %DEV W "*EOF*" W:'%TAPV ! W *9
78NT0 U %DEV W *16 U 0
79NT1 W !,"Enter 'GO' when tape sequence number ",%SEQ R " is ready: ",%X:$S($D(DTIME):DTIME,1:999)
80 I %X="?" W !,"Mount the next tape (sequence number ",%SEQ,") and enter 'GO' when it is ready.",!,"Or enter '^' to abort the save.",! G NT1
81 I %X["^" S QUIT=1 Q
82 I %X'="GO",%X'="go" W *7," ??" G NT1
83 U %DEV W *10 I @(%MTON_"=0") U 0 W *7,!,"Tape is not ready" G NT1
84 I @%MTWLK U 0 W *7,!,"Tape is write protected" G NT0
85 W %TIM1_" "_%DAT1_" (sequence "_%SEQ_")" W:'%TAPV ! W %CMT W:'%TAPV !
86 U 0 W !!,"Saving ...",! S QUIT=0 Q
Note: See TracBrowser for help on using the repository browser.