Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XBDBQUE

XBDBQUE.m

Go to the documentation of this file. 
  1. XBDBQUE ; IHS/ADC/GTH - DOUBLE QUEUING SHELL HANDLER ; 17 Jul 2002  7:47 PM [ 04/28/2003  12:06 PM ]
  1.  ;;3.0;IHS/VA UTILITIES;**5,8,9**;FEB 07, 1997
  1.  ; XB*3*5 - IHS/ADC/GTH 10-31-97
  1.  ; XB*3*8 - IHS/ASDST/GTH 12-07-00
  1.  ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Parse of drive in SETIOPN.
  1.  ; Thanks to Paul Wesley, DSD, for the original routine.
  1.  ; ---------------------------------------------------------
  1.  ; |refer to XBDBQDOC for instructions, examples, and tests|
  1.  ; ---------------------------------------------------------
  1.  ;
  1. START ;
  1.  NEW XB ;     use a fresh array in case of nesting double queues
  1.  ;     insure IO array is set fully
  1.  I ($D(IO)'>10) S IOP="HOME" D ^%ZIS
  1.  I $D(ZTQUEUED) S XBFQ=1 S:'$D(XBDTH) XBDTH="NOW" ;     insure auto-requeue if called from a queued
  1.  I '$D(XBRC),'$D(XBRP) Q  ;                             insure one of RC or RP exist
  1.  S XB("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ;           store current IO params
  1.  I $G(IOPAR)]"" S XB("IOPAR")=IOPAR ;                   store IOPAR
  1.  I $L($G(XBRC))=0 S XBRC="NORC^XBDBQUE" ;               no compute identified
  1.  S XB("RC")=XBRC,XB("RP")=$G(XBRP),XB("RX")=$G(XBRX)
  1.  ;                                                      load XBNS="xx;yy;.." into XB("NS",xx*) ...
  1.  F XBI=1:1 S XBNSX=$P($G(XBNS),";",XBI) Q:XBNSX=""  S:(XBNSX'["*") XBNSX=XBNSX_"*" S XB("NS",XBNSX)=""
  1.  S XB("NS","XB*")=""
  1.  ;                                                     load XBNS("xxx") array into XB("NS","xxx")
  1.  S XBNSX=""
  1.  F  S XBNSX=$O(XBNS(XBNSX)) Q:XBNSX=""  S XB("NS",XBNSX)=""
  1.  ; 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
  1.  S XB("IOP")=$G(XBIOP)
  1.  I $D(XBIOP) S IOP=XBIOP
  1.  ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
  1.  I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
  1.  . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q  ;                skip HFS if not an HFS
  1.  . S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""")
  1.  . S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""")
  1.  . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
  1.  . ;this code drops through
  1.  ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
  1. ZIS ;
  1.  KILL IO("Q")
  1.  I $G(XBRC)]"",$G(XBRP)="" G ZISQ
  1.  S %ZIS="PQM"
  1.  D ^%ZIS ;                 get parameters without an open
  1.  I POP W !,"REPORTING-ABORTED",*7 G END1
  1.  S XB("IO")=IO,XB("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,XB("IOPAR")=$G(IOPAR),XB("CPU")=$G(IOCPU),XB("ION")=ION
  1. ZISQ ;
  1.  I '$D(IO("Q")),'$G(XBFQ) D
  1.  . I $D(ZTQUEUED) S XBFQ=1 Q
  1.  . I IO=IO(0),$G(XBRP)]"" Q
  1.  . 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
  1.  . KILL DIR
  1.  . S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this "
  1.  . D ^DIR
  1.  . KILL DIR
  1.  . I X["^" S XBQUIT=1
  1.  . S:Y=1 IO("Q")=1
  1.  . Q
  1.  ;
  1.  KILL XB("ZTSK")
  1.  I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
  1.  KILL ZTSK
  1.  ;  quit if user says so
  1.  I $G(XBQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. <CR> to continue" D ^DIR KILL DIR G END1
  1.  ;
  1. QUE1 ;
  1.  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 ;--->
  1.  . I '$D(ZTQUEUED),IO=IO(0),$G(XBRP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q  ;---^
  1.  . S ZTDESC="Double Que COMPUTing  "_XBRC_"  "_$G(XBRP),ZTIO="",ZTRTN="DEQUE1^XBDBQUE"
  1.  . S:$D(XBDTH) ZTDTH=XBDTH
  1.  . S:$G(XB("CPU"))]"" ZTCPU=XB("CPU")
  1.  . S XBNSX=""
  1.  . F  S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX=""  S ZTSAVE(XBNSX)=""
  1.  . KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI
  1.  . S ZTIO="" ;                               insure no device loaded
  1.  . D ^%ZTLOAD
  1.  . Q  ; these do .s branch to END1
  1.  ; (((if queued the above code branched to END)))
  1.  ;
  1. DEQUE1 ;EP - > 1st deque From TaskMan.
  1.  ;
  1.  KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH
  1.  KILL XB("ZTSK")
  1.  I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
  1.  ;
  1. COMPUTE ;>do computing | routine
  1.  ;
  1.  D @(XB("RC")) ;  >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^XBDBQUE
  1.  ;
  1. QUE2 ;
  1.  ;
  1.  I $D(ZTQUEUED) D  G ENDC ;===>    automatically requeue if queued
  1.  . Q:XB("RP")=""
  1.  . S ZTDESC="Double Que PRINT "_XB("RC")_" "_XB("RP"),ZTIO=XB("IO"),ZTDTH=$H,ZTRTN="DEQUE2^XBDBQUE" ;IHS/SET/GTH 07/16/2002
  1.  . S XBNSX=""
  1.  . F  S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX=""  S ZTSAVE(XBNSX)=""
  1.  . D SETIOPN K ZTIO
  1.  . D ^%ZTLOAD
  1.  . I '$D(ZTSK) S XBERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q
  1.  . S XBDBQUE=1
  1.  . Q  ;                     ======>         this branches to ENDC
  1.  ;
  1.  ; device opened from the first que ask
  1. DEQUE2 ;EP - 2nd Deque | printing
  1.  KILL XB("ZTSK")
  1.  I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
  1.  ;open printer device for printing with all selected parameters
  1.  G:(XB("RP")="") END ;---> exit if no print
  1.  ;
  1.  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
  1.  U IO
  1.  D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE
  1.  ;
  1.  ;-------
  1. END ;>End | cleanup
  1.  ;
  1.  I $G(XB("RX"))'="" D @(XB("RX")) ;   >>>PERFORM CLEANUP ROUTINE<<<
  1.  ;
  1. END0 ;EP - from compute cycle when XB("RP") EXISTS
  1.  I $D(XB("ZTSK")) S XBTZTSK=$G(ZTSK),ZTSK=XB("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(XBTZTSK) ZTSK=XBTZTSK KILL XBTZTSK
  1. END1 ;EP clean out xb as passed in
  1.  D ^%ZISC
  1.  S IOP=XB("IOP1") ; restore original IO parameters
  1.  D ^%ZIS
  1.  K IOPAR,IOUPAR,IOP
  1.  KILL XB,XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBERR,XBI,XBNSX,XBQUIT,XBDBQUE
  1.  ;
  1.  Q
  1. ENDC ;EP - end computing cycle
  1.  I $G(XB("RP"))="" G END
  1.  G END0
  1.  ;
  1.  ;----------------
  1.  ;----------------
  1. SUB ;>Subroutines
  1.  ;----------
  1. NORC ;used if no XBRC identified
  1.  Q
  1.  ;
  1. SETIOPN ;EP Set IOP parameters with (N)o open
  1.  Q:'$D(XB("IOP"))
  1.  S IOP=XB("IOP")
  1.  ;Begin New Code;XB*3*9 10/29/2002
  1.  I $$VERSION^%ZOSV(1)["Cache",$G(XB("ION"))="HFS" D  Q
  1.  . S %ZIS("HFSNAME")=XB("IO"),%ZIS("IOPAR")="WNS",%ZIS("HFSMODE")="W",IOP=$P(XB("IOP"),";"),XB("IOP")=IOP,%ZIS="N"
  1.  . D ^%ZIS
  1.  .Q
  1.  ;End New Code;XB*3*9 10/29/2002
  1.  ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
  1.  I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
  1.  . I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q  ;                skip HFS if not an HFS
  1.  . ; XB*3*8 - IHS/ASDST/GTH 00-12-05 start block
  1.  . ; Index into XB("IOPAR") correctly if ":" in Pathname.
  1.  . NEW A,I
  1.  . S (I,A)=1
  1.  . F  S C=$E(XB("IOPAR"),A) Q:A=$L(XB("IOPAR"))  S A=A+1,I=I+(C=":")
  1.  . ; XB*3*8 - IHS/ASDST/GTH 00-12-05 end block
  1.  . ; S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
  1.  . S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
  1.  . ;S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
  1.  . S XBHFSNM=$P(XB("IOPAR"),":",I-2,I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
  1.  . ; S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
  1.  . S XBHFSMD=$P(XB("IOPAR"),":",I),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
  1.  . S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
  1.  . Q
  1.  ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
  1.  S %ZIS="N"
  1.  D ^%ZIS
  1.  Q