source: IHS-VA_UTILITIES-XB/trunk/XBDBQUE.m@ 846

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

Modified directory structure; moved routines.
File size: 6.9 KB
Line 
1XBDBQUE ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER ; 17 Jul 2002 7:47 PM [ 04/28/2003 12:06 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ; XB*3*5 - IHS/ADC/GTH 10-31-97
4 ; XB*3*8 - IHS/ASDST/GTH 12-07-00
5 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Parse of drive in SETIOPN.
6 ; Thanks to Paul Wesley, DSD, for the original routine.
7 ; ---------------------------------------------------------
8 ; |refer to XBDBQDOC for instructions, examples, and tests|
9 ; ---------------------------------------------------------
10 ;
11START ;
12 NEW XB ; use a fresh array in case of nesting double queues
13 ; insure IO array is set fully
14 I ($D(IO)'>10) S IOP="HOME" D ^%ZIS
15 I $D(ZTQUEUED) S XBFQ=1 S:'$D(XBDTH) XBDTH="NOW" ; insure auto-requeue if called from a queued
16 I '$D(XBRC),'$D(XBRP) Q ; insure one of RC or RP exist
17 S XB("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ; store current IO params
18 I $G(IOPAR)]"" S XB("IOPAR")=IOPAR ; store IOPAR
19 I $L($G(XBRC))=0 S XBRC="NORC^XBDBQUE" ; no compute identified
20 S XB("RC")=XBRC,XB("RP")=$G(XBRP),XB("RX")=$G(XBRX)
21 ; load XBNS="xx;yy;.." into XB("NS",xx*) ...
22 F XBI=1:1 S XBNSX=$P($G(XBNS),";",XBI) Q:XBNSX="" S:(XBNSX'["*") XBNSX=XBNSX_"*" S XB("NS",XBNSX)=""
23 S XB("NS","XB*")=""
24 ; load XBNS("xxx") array into XB("NS","xxx")
25 S XBNSX=""
26 F S XBNSX=$O(XBNS(XBNSX)) Q:XBNSX="" S XB("NS",XBNSX)=""
27 ; if this is a double queue with XB("IOP") setup .. pull the parameters out a ^%ZIS call to set up the parameters without an open
28 S XB("IOP")=$G(XBIOP)
29 I $D(XBIOP) S IOP=XBIOP
30 ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
31 I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
32 . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
33 . S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""")
34 . S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""")
35 . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
36 . ;this code drops through
37 ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
38ZIS ;
39 KILL IO("Q")
40 I $G(XBRC)]"",$G(XBRP)="" G ZISQ
41 S %ZIS="PQM"
42 D ^%ZIS ; get parameters without an open
43 I POP W !,"REPORTING-ABORTED",*7 G END1
44 S XB("IO")=IO,XB("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,XB("IOPAR")=$G(IOPAR),XB("CPU")=$G(IOCPU),XB("ION")=ION
45ZISQ ;
46 I '$D(IO("Q")),'$G(XBFQ) D
47 . I $D(ZTQUEUED) S XBFQ=1 Q
48 . I IO=IO(0),$G(XBRP)]"" Q
49 . Q:$$VALI^XBDIQ1(3.5,IOS,5.5)=2 ;Q'ing not allowed to DEVICE selected;IHS/SET/GTH XB*3*9 10/29/2002
50 . KILL DIR
51 . S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this "
52 . D ^DIR
53 . KILL DIR
54 . I X["^" S XBQUIT=1
55 . S:Y=1 IO("Q")=1
56 . Q
57 ;
58 KILL XB("ZTSK")
59 I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
60 KILL ZTSK
61 ; quit if user says so
62 I $G(XBQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. <CR> to continue" D ^DIR KILL DIR G END1
63 ;
64QUE1 ;
65 I ($D(IO("Q"))!($G(XBFQ))) D K IO("Q") W:(($G(ZTSK))&('$D(XB("ZTSK")))) !,"Tasked with ",ZTSK W:'$G(ZTSK) !,*7,"Que not successful ... REPORTING ABORTED" D ^%ZISC S IOP=XB("IOP1") D ^%ZIS G END1 ;--->
66 . I '$D(ZTQUEUED),IO=IO(0),$G(XBRP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q ;---^
67 . S ZTDESC="Double Que COMPUTing "_XBRC_" "_$G(XBRP),ZTIO="",ZTRTN="DEQUE1^XBDBQUE"
68 . S:$D(XBDTH) ZTDTH=XBDTH
69 . S:$G(XB("CPU"))]"" ZTCPU=XB("CPU")
70 . S XBNSX=""
71 . F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)=""
72 . KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI
73 . S ZTIO="" ; insure no device loaded
74 . D ^%ZTLOAD
75 . Q ; these do .s branch to END1
76 ; (((if queued the above code branched to END)))
77 ;
78DEQUE1 ;EP - > 1st deque From TaskMan.
79 ;
80 KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH
81 KILL XB("ZTSK")
82 I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
83 ;
84COMPUTE ;>do computing | routine
85 ;
86 D @(XB("RC")) ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^XBDBQUE
87 ;
88QUE2 ;
89 ;
90 I $D(ZTQUEUED) D G ENDC ;===> automatically requeue if queued
91 . Q:XB("RP")=""
92 . S ZTDESC="Double Que PRINT "_XB("RC")_" "_XB("RP"),ZTIO=XB("IO"),ZTDTH=$H,ZTRTN="DEQUE2^XBDBQUE" ;IHS/SET/GTH 07/16/2002
93 . S XBNSX=""
94 . F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)=""
95 . D SETIOPN K ZTIO
96 . D ^%ZTLOAD
97 . I '$D(ZTSK) S XBERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q
98 . S XBDBQUE=1
99 . Q ; ======> this branches to ENDC
100 ;
101 ; device opened from the first que ask
102DEQUE2 ;EP - 2nd Deque | printing
103 KILL XB("ZTSK")
104 I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
105 ;open printer device for printing with all selected parameters
106 G:(XB("RP")="") END ;---> exit if no print
107 ;
108 I $D(ZTQUEUED),$$VERSION^%ZOSV(1)["Cache",ION="HFS" D ^%ZISC S IOP=ION,%ZIS("HFSNAME")=XB("IO"),%ZIS("HFSMODE")="W" D ^%ZIS ;IHS/SET/GTH XB*3*9 10/29/2002
109 U IO
110 D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE
111 ;
112 ;-------
113END ;>End | cleanup
114 ;
115 I $G(XB("RX"))'="" D @(XB("RX")) ; >>>PERFORM CLEANUP ROUTINE<<<
116 ;
117END0 ;EP - from compute cycle when XB("RP") EXISTS
118 I $D(XB("ZTSK")) S XBTZTSK=$G(ZTSK),ZTSK=XB("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(XBTZTSK) ZTSK=XBTZTSK KILL XBTZTSK
119END1 ;EP clean out xb as passed in
120 D ^%ZISC
121 S IOP=XB("IOP1") ; restore original IO parameters
122 D ^%ZIS
123 K IOPAR,IOUPAR,IOP
124 KILL XB,XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBERR,XBI,XBNSX,XBQUIT,XBDBQUE
125 ;
126 Q
127ENDC ;EP - end computing cycle
128 I $G(XB("RP"))="" G END
129 G END0
130 ;
131 ;----------------
132 ;----------------
133SUB ;>Subroutines
134 ;----------
135NORC ;used if no XBRC identified
136 Q
137 ;
138SETIOPN ;EP Set IOP parameters with (N)o open
139 Q:'$D(XB("IOP"))
140 S IOP=XB("IOP")
141 ;Begin New Code;XB*3*9 10/29/2002
142 I $$VERSION^%ZOSV(1)["Cache",$G(XB("ION"))="HFS" D Q
143 . S %ZIS("HFSNAME")=XB("IO"),%ZIS("IOPAR")="WNS",%ZIS("HFSMODE")="W",IOP=$P(XB("IOP"),";"),XB("IOP")=IOP,%ZIS="N"
144 . D ^%ZIS
145 .Q
146 ;End New Code;XB*3*9 10/29/2002
147 ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
148 I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
149 . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
150 . ; XB*3*8 - IHS/ASDST/GTH 00-12-05 start block
151 . ; Index into XB("IOPAR") correctly if ":" in Pathname.
152 . NEW A,I
153 . S (I,A)=1
154 . F S C=$E(XB("IOPAR"),A) Q:A=$L(XB("IOPAR")) S A=A+1,I=I+(C=":")
155 . ; XB*3*8 - IHS/ASDST/GTH 00-12-05 end block
156 . ; S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
157 . S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
158 . ;S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
159 . S XBHFSNM=$P(XB("IOPAR"),":",I-2,I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
160 . ; S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
161 . S XBHFSMD=$P(XB("IOPAR"),":",I),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
162 . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
163 . Q
164 ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
165 S %ZIS="N"
166 D ^%ZIS
167 Q
Note: See TracBrowser for help on using the repository browser.