BARDBQ02 ; IHS/SD/TMM - DOUBLE QUEUING SHELL HANDLER - A/R ; 07/26/2010
;;1.8;IHS ACCOUNTS RECEIVABLE;**5,8,9,19**;OCT 26, 2005
;
; --------------------------------------------------------------------
; BARDBQ02 is a modified version of ^XBDBQUE --> 07/26/2010
; Refer to XBDBQDOC for instructions, examples, and tests
;
; Variables that can be passed from calling routine
; BAR("MULTI") ------ Allows calling routine to send number of copies
; to print. Calling routine should prompt user for
; number of copies and set this value.
; BAR("NOQUE")=1 ---- Turns off QUEING prompts. Used when report
; will not be queued (i.e. receipts) so user is
; not required to answer queing prompts. Value
; set in calling routine.
; FLAT FILE --------- Passing routine should set S %ZIS("B")="HOST FILE SERVER"
; --------------------------------------------------------------------
; M819 TMM 07/26/2010 ^BARDBQ02 created from ^XBDBQUE and modified to
; allow user to specify # of copies, and turn off
; queing prompts
;
; --------------------------------------------------------------------
;
START ;
NEW XB ; use a fresh array in case of nesting double queues
; insure IO array is set fully
I ($D(IO)'>10) S IOP="HOME" D ^%ZIS
I $D(ZTQUEUED) S XBFQ=1 S:'$D(XBDTH) XBDTH="NOW" ; insure auto-requeue if called from a queued
I '$D(XBRC),'$D(XBRP) Q ; insure one of RC or RP exist
S XB("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL ; store current IO params
I $G(IOPAR)]"" S XB("IOPAR")=IOPAR ; store IOPAR
I $L($G(XBRC))=0 S XBRC="NORC^XBDBQUE" ; no compute identified
S XB("RC")=XBRC,XB("RP")=$G(XBRP),XB("RX")=$G(XBRX)
; load XBNS="xx;yy;.." into XB("NS",xx*) ...
F XBI=1:1 S XBNSX=$P($G(XBNS),";",XBI) Q:XBNSX="" S:(XBNSX'["*") XBNSX=XBNSX_"*" S XB("NS",XBNSX)=""
S XB("NS","XB*")=""
; load XBNS("xxx") array into XB("NS","xxx")
S XBNSX=""
F S XBNSX=$O(XBNS(XBNSX)) Q:XBNSX="" S XB("NS",XBNSX)=""
; 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
S XB("IOP")=$G(XBIOP)
I $D(XBIOP) S IOP=XBIOP
; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
. I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
. S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""")
. S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""")
. S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
. ;this code drops through
; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
ZIS ;
KILL IO("Q")
I $G(XBRC)]"",$G(XBRP)="" G ZISQ
S %ZIS="PQM"
I $G(BAR("NOQUE"))=1 S %ZIS=$TR(%ZIS,"Q") ;calling routine can opt to not allow queuing ;M819*ADD*TMM*20100726
D ^%ZIS ; get parameters without an open
I POP W !,"REPORTING-ABORTED",*7 G END1
S XB("IO")=IO,XB("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL,XB("IOPAR")=$G(IOPAR),XB("CPU")=$G(IOCPU),XB("ION")=ION
ZISQ ;
I '$D(IO("Q")),'$G(XBFQ) D
. I $G(BAR("NOQUE"))=1 Q ;M819*ADD*TMM*20100726
. I $D(ZTQUEUED) S XBFQ=1 Q
. I IO=IO(0),$G(XBRP)]"" Q
. 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
. KILL DIR
. S DIR(0)="Y",DIR("B")="Y",DIR("A")="Won't you queue this "
. D ^DIR
. KILL DIR
. I X["^" S XBQUIT=1
. S:Y=1 IO("Q")=1
. Q
;
KILL XB("ZTSK")
I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
KILL ZTSK
; quit if user says so
I $G(XBQUIT) KILL DIR S DIR(0)="E",DIR("A")="Report Aborted .. <CR> to continue" D ^DIR KILL DIR G END1
;
QUE1 ;
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 ;--->
. I '$D(ZTQUEUED),IO=IO(0),$G(XBRP)]"" W !,"Queing to slave printer not allowed ... Report Aborting" Q ;---^
. S ZTDESC="Double Que COMPUTing "_XBRC_" "_$G(XBRP),ZTIO="",ZTRTN="DEQUE1^XBDBQUE"
. S:$D(XBDTH) ZTDTH=XBDTH
. S:$G(XB("CPU"))]"" ZTCPU=XB("CPU")
. S XBNSX=""
. F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)=""
. KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI
. S ZTIO="" ; insure no device loaded
. D ^%ZTLOAD
. Q ; these do .s branch to END1
; (((if queued the above code branched to END)))
;
DEQUE1 ;EP - > 1st deque From TaskMan.
;
KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH
KILL XB("ZTSK")
I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
;
COMPUTE ;>do computing | routine
;
D @(XB("RC")) ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^XBDBQUE
;
QUE2 ;
;
I $D(ZTQUEUED) D G ENDC ;===> automatically requeue if queued
. Q:XB("RP")=""
. S ZTDESC="Double Que PRINT "_XB("RC")_" "_XB("RP"),ZTIO=XB("IO"),ZTDTH=$H,ZTRTN="DEQUE2^XBDBQUE" ;IHS/SET/GTH 07/16/2002
. S XBNSX=""
. F S XBNSX=$O(XB("NS",XBNSX)) Q:XBNSX="" S ZTSAVE(XBNSX)=""
. D SETIOPN K ZTIO
. D ^%ZTLOAD
. I '$D(ZTSK) S XBERR="SECOND QUE FAILED" D @^%ZOSF("ERRTN") Q
. S XBDBQUE=1
. Q ; ======> this branches to ENDC
;
; device opened from the first que ask
DEQUE2 ;EP - 2nd Deque | printing
KILL XB("ZTSK")
I $D(ZTQUEUED),$G(ZTSK) S XB("ZTSK")=ZTSK
;open printer device for printing with all selected parameters
G:(XB("RP")="") END ;---> exit if no print
;
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
U IO
;---BEGIN ADD(1)---> ;M819*ADD*TMM*20100723
; D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE M819*DEL*TMM*20100723
;M819*DEL*TMM*20100727 I +$G(BAR("MULTI"))>0 D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE
;M819*DEL*TMM*20100727 I +$G(BAR("MULTI"))>1 D
;M819*DEL*TMM*20100727 . S BARTMP=BAR("MULTI")-1
;M819*DEL*TMM*20100727 . I '$D(IOF) S IOF="#"
;M819*DEL*TMM*20100727 . F I=1:1:BARTMP D @(XB("RP")) W @IOF ; >>>PERFORM PRINTING ROUTINE
;
I +$G(BAR("MULTI"))>0 D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE
I '$D(IOF) S IOF="#"
S BARPRT=BAR("MULTI")-1
I +$G(BAR("MULTI"))>1 F D Q:BARPRT<1
. W @IOF ; form feed
. D @(XB("RP")) ; print routine
. S BARPRT=BARPRT-1
K BARPRT
;-----END ADD(1)---> ;M819*ADD*TMM*20100723
;
;-------
END ;>End | cleanup
;
I $G(XB("RX"))'="" D @(XB("RX")) ; >>>PERFORM CLEANUP ROUTINE<<<
;
END0 ;EP - from compute cycle when XB("RP") EXISTS
I $D(XB("ZTSK")) S XBTZTSK=$G(ZTSK),ZTSK=XB("ZTSK") D KILL^%ZTLOAD K ZTSK S:$G(XBTZTSK) ZTSK=XBTZTSK KILL XBTZTSK
END1 ;EP clean out xb as passed in
D ^%ZISC
S IOP=XB("IOP1") ; restore original IO parameters
D ^%ZIS
K IOPAR,IOUPAR,IOP
KILL XB,XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBERR,XBI,XBNSX,XBQUIT,XBDBQUE
;
Q
ENDC ;EP - end computing cycle
I $G(XB("RP"))="" G END
G END0
;
;----------------
;----------------
SUB ;>Subroutines
;----------
NORC ;used if no XBRC identified
Q
;
SETIOPN ;EP Set IOP parameters with (N)o open
Q:'$D(XB("IOP"))
S IOP=XB("IOP")
;Begin New Code;XB*3*9 10/29/2002
I $$VERSION^%ZOSV(1)["Cache",$G(XB("ION"))="HFS" D Q
. S %ZIS("HFSNAME")=XB("IO"),%ZIS("IOPAR")="WNS",%ZIS("HFSMODE")="W",IOP=$P(XB("IOP"),";"),XB("IOP")=IOP,%ZIS="N"
. D ^%ZIS
.Q
;End New Code;XB*3*9 10/29/2002
; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
I $G(XB("IOPAR"))]"" S %ZIS("IOPAR")=XB("IOPAR") D
. I XB("IOPAR")'?1"(""".E1""":""".E1""")" Q ; skip HFS if not an HFS
. ; XB*3*8 - IHS/ASDST/GTH 00-12-05 start block
. ; Index into XB("IOPAR") correctly if ":" in Pathname.
. NEW A,I
. S (I,A)=1
. F S C=$E(XB("IOPAR"),A) Q:A=$L(XB("IOPAR")) S A=A+1,I=I+(C=":")
. ; XB*3*8 - IHS/ASDST/GTH 00-12-05 end block
. ; S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
. S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
. ;S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
. S XBHFSNM=$P(XB("IOPAR"),":",I-2,I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
. ; S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
. S XBHFSMD=$P(XB("IOPAR"),":",I),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
. S %ZIS("HFSNAME")=XBHFSNM,%ZIS("HFSMODE")=XBHFSMD
. Q
; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
S %ZIS="N"
D ^%ZIS
Q
BARDBQ02 ; IHS/SD/TMM - DOUBLE QUEUING SHELL HANDLER - A/R ; 07/26/2010
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;**5,8,9,19**;OCT 26, 2005
+2 ;
+3 ; --------------------------------------------------------------------
+4 ; BARDBQ02 is a modified version of ^XBDBQUE --> 07/26/2010
+5 ; Refer to XBDBQDOC for instructions, examples, and tests
+6 ;
+7 ; Variables that can be passed from calling routine
+8 ; BAR("MULTI") ------ Allows calling routine to send number of copies
+9 ; to print. Calling routine should prompt user for
+10 ; number of copies and set this value.
+11 ; BAR("NOQUE")=1 ---- Turns off QUEING prompts. Used when report
+12 ; will not be queued (i.e. receipts) so user is
+13 ; not required to answer queing prompts. Value
+14 ; set in calling routine.
+15 ; FLAT FILE --------- Passing routine should set S %ZIS("B")="HOST FILE SERVER"
+16 ; --------------------------------------------------------------------
+17 ; M819 TMM 07/26/2010 ^BARDBQ02 created from ^XBDBQUE and modified to
+18 ; allow user to specify # of copies, and turn off
+19 ; queing prompts
+20 ;
+21 ; --------------------------------------------------------------------
+22 ;
START ;
+1 ; use a fresh array in case of nesting double queues
NEW XB
+2 ; insure IO array is set fully
+3 IF ($DATA(IO)'>10)
SET IOP="HOME"
DO ^%ZIS
+4 ; insure auto-requeue if called from a queued
IF $DATA(ZTQUEUED)
SET XBFQ=1
IF '$DATA(XBDTH)
SET XBDTH="NOW"
+5 ; insure one of RC or RP exist
IF '$DATA(XBRC)
IF '$DATA(XBRP)
QUIT
+6 ; store current IO params
SET XB("IOP1")=ION_";"_IOST_";"_IOM_";"_IOSL
+7 ; store IOPAR
IF $GET(IOPAR)]""
SET XB("IOPAR")=IOPAR
+8 ; no compute identified
IF $LENGTH($GET(XBRC))=0
SET XBRC="NORC^XBDBQUE"
+9 SET XB("RC")=XBRC
SET XB("RP")=$GET(XBRP)
SET XB("RX")=$GET(XBRX)
+10 ; load XBNS="xx;yy;.." into XB("NS",xx*) ...
+11 FOR XBI=1:1
SET XBNSX=$PIECE($GET(XBNS),";",XBI)
IF XBNSX=""
QUIT
IF (XBNSX'["*")
SET XBNSX=XBNSX_"*"
SET XB("NS",XBNSX)=""
+12 SET XB("NS","XB*")=""
+13 ; load XBNS("xxx") array into XB("NS","xxx")
+14 SET XBNSX=""
+15 FOR
SET XBNSX=$ORDER(XBNS(XBNSX))
IF XBNSX=""
QUIT
SET XB("NS",XBNSX)=""
+16 ; 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
+17 SET XB("IOP")=$GET(XBIOP)
+18 IF $DATA(XBIOP)
SET IOP=XBIOP
+19 ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
+20 IF $GET(XB("IOPAR"))]""
SET %ZIS("IOPAR")=XB("IOPAR")
Begin DoDot:1
+21 ; skip HFS if not an HFS
IF XB("IOPAR")'?1"(""".E1""":""".E1""")"
QUIT
+22 SET XBHFSNM=$PIECE(XB("IOPAR"),":")
SET XBHFSNM=$TRANSLATE(XBHFSNM,"()""")
+23 SET XBHFSMD=$PIECE(XB("IOPAR"),":",2)
SET XBHFSMD=$TRANSLATE(XBHFSMD,"()""")
+24 SET %ZIS("HFSNAME")=XBHFSNM
SET %ZIS("HFSMODE")=XBHFSMD
+25 ;this code drops through
End DoDot:1
+26 ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
ZIS ;
+1 KILL IO("Q")
+2 IF $GET(XBRC)]""
IF $GET(XBRP)=""
GOTO ZISQ
+3 SET %ZIS="PQM"
+4 ;calling routine can opt to not allow queuing ;M819*ADD*TMM*20100726
IF $GET(BAR("NOQUE"))=1
SET %ZIS=$TRANSLATE(%ZIS,"Q")
+5 ; get parameters without an open
DO ^%ZIS
+6 IF POP
WRITE !,"REPORTING-ABORTED",*7
GOTO END1
+7 SET XB("IO")=IO
SET XB("IOP")=ION_";"_IOST_";"_IOM_";"_IOSL
SET XB("IOPAR")=$GET(IOPAR)
SET XB("CPU")=$GET(IOCPU)
SET XB("ION")=ION
ZISQ ;
+1 IF '$DATA(IO("Q"))
IF '$GET(XBFQ)
Begin DoDot:1
+2 ;M819*ADD*TMM*20100726
IF $GET(BAR("NOQUE"))=1
QUIT
+3 IF $DATA(ZTQUEUED)
SET XBFQ=1
QUIT
+4 IF IO=IO(0)
IF $GET(XBRP)]""
QUIT
+5 ;Q'ing not allowed to DEVICE selected;IHS/SET/GTH XB*3*9 10/29/2002
IF $$VALI^XBDIQ1(3.5,IOS,5.5)=2
QUIT
+6 KILL DIR
+7 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Won't you queue this "
+8 DO ^DIR
+9 KILL DIR
+10 IF X["^"
SET XBQUIT=1
+11 IF Y=1
SET IO("Q")=1
+12 QUIT
End DoDot:1
+13 ;
+14 KILL XB("ZTSK")
+15 IF $DATA(ZTQUEUED)
IF $GET(ZTSK)
SET XB("ZTSK")=ZTSK
+16 KILL ZTSK
+17 ; quit if user says so
+18 IF $GET(XBQUIT)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Report Aborted .. <CR> to continue"
DO ^DIR
KILL DIR
GOTO END1
+19 ;
QUE1 ;
+1 ;--->
IF ($DATA(IO("Q"))!($GET(XBFQ)))
Begin DoDot:1
+2 ;---^
IF '$DATA(ZTQUEUED)
IF IO=IO(0)
IF $GET(XBRP)]""
WRITE !,"Queing to slave printer not allowed ... Report Aborting"
QUIT
+3 SET ZTDESC="Double Que COMPUTing "_XBRC_" "_$GET(XBRP)
SET ZTIO=""
SET ZTRTN="DEQUE1^XBDBQUE"
+4 IF $DATA(XBDTH)
SET ZTDTH=XBDTH
+5 IF $GET(XB("CPU"))]""
SET ZTCPU=XB("CPU")
+6 SET XBNSX=""
+7 FOR
SET XBNSX=$ORDER(XB("NS",XBNSX))
IF XBNSX=""
QUIT
SET ZTSAVE(XBNSX)=""
+8 KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBNSX,XBI
+9 ; insure no device loaded
SET ZTIO=""
+10 DO ^%ZTLOAD
+11 ; these do .s branch to END1
QUIT
End DoDot:1
KILL IO("Q")
IF (($GET(ZTSK))&('$DATA(XB("ZTSK"))))
WRITE !,"Tasked with ",ZTSK
IF '$GET(ZTSK)
WRITE !,*7,"Que not successful ... REPORTING ABORTED"
DO ^%ZISC
SET IOP=XB("IOP1")
DO ^%ZIS
GOTO END1
+12 ; (((if queued the above code branched to END)))
+13 ;
DEQUE1 ;EP - > 1st deque From TaskMan.
+1 ;
+2 KILL XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH
+3 KILL XB("ZTSK")
+4 IF $DATA(ZTQUEUED)
IF $GET(ZTSK)
SET XB("ZTSK")=ZTSK
+5 ;
COMPUTE ;>do computing | routine
+1 ;
+2 ; >>>PERFORM THE COMPUTE ROUTINE<<< ;stuffed if not provided with NORC^XBDBQUE
DO @(XB("RC"))
+3 ;
QUE2 ;
+1 ;
+2 ;===> automatically requeue if queued
IF $DATA(ZTQUEUED)
Begin DoDot:1
+3 IF XB("RP")=""
QUIT
+4 ;IHS/SET/GTH 07/16/2002
SET ZTDESC="Double Que PRINT "_XB("RC")_" "_XB("RP")
SET ZTIO=XB("IO")
SET ZTDTH=$HOROLOG
SET ZTRTN="DEQUE2^XBDBQUE"
+5 SET XBNSX=""
+6 FOR
SET XBNSX=$ORDER(XB("NS",XBNSX))
IF XBNSX=""
QUIT
SET ZTSAVE(XBNSX)=""
+7 DO SETIOPN
KILL ZTIO
+8 DO ^%ZTLOAD
+9 IF '$DATA(ZTSK)
SET XBERR="SECOND QUE FAILED"
DO @^%ZOSF("ERRTN")
QUIT
+10 SET XBDBQUE=1
+11 ; ======> this branches to ENDC
QUIT
End DoDot:1
GOTO ENDC
+12 ;
+13 ; device opened from the first que ask
DEQUE2 ;EP - 2nd Deque | printing
+1 KILL XB("ZTSK")
+2 IF $DATA(ZTQUEUED)
IF $GET(ZTSK)
SET XB("ZTSK")=ZTSK
+3 ;open printer device for printing with all selected parameters
+4 ;---> exit if no print
IF (XB("RP")="")
GOTO END
+5 ;
+6 ;IHS/SET/GTH XB*3*9 10/29/2002
IF $DATA(ZTQUEUED)
IF $$VERSION^%ZOSV(1)["Cache"
IF ION="HFS"
DO ^%ZISC
SET IOP=ION
SET %ZIS("HFSNAME")=XB("IO")
SET %ZIS("HFSMODE")="W"
DO ^%ZIS
+7 USE IO
+8 ;---BEGIN ADD(1)---> ;M819*ADD*TMM*20100723
+9 ; D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE M819*DEL*TMM*20100723
+10 ;M819*DEL*TMM*20100727 I +$G(BAR("MULTI"))>0 D @(XB("RP")) ; >>>PERFORM PRINTING ROUTINE
+11 ;M819*DEL*TMM*20100727 I +$G(BAR("MULTI"))>1 D
+12 ;M819*DEL*TMM*20100727 . S BARTMP=BAR("MULTI")-1
+13 ;M819*DEL*TMM*20100727 . I '$D(IOF) S IOF="#"
+14 ;M819*DEL*TMM*20100727 . F I=1:1:BARTMP D @(XB("RP")) W @IOF ; >>>PERFORM PRINTING ROUTINE
+15 ;
+16 ; >>>PERFORM PRINTING ROUTINE
IF +$GET(BAR("MULTI"))>0
DO @(XB("RP"))
+17 IF '$DATA(IOF)
SET IOF="#"
+18 SET BARPRT=BAR("MULTI")-1
+19 IF +$GET(BAR("MULTI"))>1
FOR
Begin DoDot:1
+20 ; form feed
WRITE @IOF
+21 ; print routine
DO @(XB("RP"))
+22 SET BARPRT=BARPRT-1
End DoDot:1
IF BARPRT<1
QUIT
+23 KILL BARPRT
+24 ;-----END ADD(1)---> ;M819*ADD*TMM*20100723
+25 ;
+26 ;-------
END ;>End | cleanup
+1 ;
+2 ; >>>PERFORM CLEANUP ROUTINE<<<
IF $GET(XB("RX"))'=""
DO @(XB("RX"))
+3 ;
END0 ;EP - from compute cycle when XB("RP") EXISTS
+1 IF $DATA(XB("ZTSK"))
SET XBTZTSK=$GET(ZTSK)
SET ZTSK=XB("ZTSK")
DO KILL^%ZTLOAD
KILL ZTSK
IF $GET(XBTZTSK)
SET ZTSK=XBTZTSK
KILL XBTZTSK
END1 ;EP clean out xb as passed in
+1 DO ^%ZISC
+2 ; restore original IO parameters
SET IOP=XB("IOP1")
+3 DO ^%ZIS
+4 KILL IOPAR,IOUPAR,IOP
+5 KILL XB,XBRC,XBRP,XBRX,XBNS,XBFQ,XBDTH,XBIOP,XBPAR,XBDTH,XBERR,XBI,XBNSX,XBQUIT,XBDBQUE
+6 ;
+7 QUIT
ENDC ;EP - end computing cycle
+1 IF $GET(XB("RP"))=""
GOTO END
+2 GOTO END0
+3 ;
+4 ;----------------
+5 ;----------------
SUB ;>Subroutines
+1 ;----------
NORC ;used if no XBRC identified
+1 QUIT
+2 ;
SETIOPN ;EP Set IOP parameters with (N)o open
+1 IF '$DATA(XB("IOP"))
QUIT
+2 SET IOP=XB("IOP")
+3 ;Begin New Code;XB*3*9 10/29/2002
+4 IF $$VERSION^%ZOSV(1)["Cache"
IF $GET(XB("ION"))="HFS"
Begin DoDot:1
+5 SET %ZIS("HFSNAME")=XB("IO")
SET %ZIS("IOPAR")="WNS"
SET %ZIS("HFSMODE")="W"
SET IOP=$PIECE(XB("IOP"),";")
SET XB("IOP")=IOP
SET %ZIS="N"
+6 DO ^%ZIS
+7 QUIT
End DoDot:1
QUIT
+8 ;End New Code;XB*3*9 10/29/2002
+9 ; XB*3*5 - IHS/ADC/GTH 10-31-97 start block
+10 IF $GET(XB("IOPAR"))]""
SET %ZIS("IOPAR")=XB("IOPAR")
Begin DoDot:1
+11 ; skip HFS if not an HFS
IF XB("IOPAR")'?1"(""".E1""":""".E1""")"
QUIT
+12 ; XB*3*8 - IHS/ASDST/GTH 00-12-05 start block
+13 ; Index into XB("IOPAR") correctly if ":" in Pathname.
+14 NEW A,I
+15 SET (I,A)=1
+16 FOR
SET C=$EXTRACT(XB("IOPAR"),A)
IF A=$LENGTH(XB("IOPAR"))
QUIT
SET A=A+1
SET I=I+(C=":")
+17 ; XB*3*8 - IHS/ASDST/GTH 00-12-05 end block
+18 ; S XBHFSNM=$P(XB("IOPAR"),":"),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8
+19 ; XB*3*8
SET XBHFSNM=$PIECE(XB("IOPAR"),":",I-1)
SET XBHFSNM=$TRANSLATE(XBHFSNM,"()""")
+20 ;S XBHFSNM=$P(XB("IOPAR"),":",I-1),XBHFSNM=$TR(XBHFSNM,"()""") ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
+21 ; XB*3*8 ;IHS/SET/GTH XB*3*9 10/29/2002
SET XBHFSNM=$PIECE(XB("IOPAR"),":",I-2,I-1)
SET XBHFSNM=$TRANSLATE(XBHFSNM,"()""")
+22 ; S XBHFSMD=$P(XB("IOPAR"),":",2),XBHFSMD=$TR(XBHFSMD,"()""") ; XB*3*8
+23 ; XB*3*8
SET XBHFSMD=$PIECE(XB("IOPAR"),":",I)
SET XBHFSMD=$TRANSLATE(XBHFSMD,"()""")
+24 SET %ZIS("HFSNAME")=XBHFSNM
SET %ZIS("HFSMODE")=XBHFSMD
+25 QUIT
End DoDot:1
+26 ; XB*3*5 - IHS/ADC/GTH 10-31-97 end block
+27 SET %ZIS="N"
+28 DO ^%ZIS
+29 QUIT
