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

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

Initial commit of XB, move away from sf.net.
Includes kids file and documentation.
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.