- 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
