PRCHQUE ;WISC/CLH,ID/RSD/TKW/REW/BGJ-QUE PRINTOUTS ; [7/2/98 3:20pm]
;;5.1;IFCAP;**14**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
; INPUT TO PRCHQUE:
;
; D0,D1
; PRCHQ=ROUTINE
; PRCHQ("DEST")=DESTINATION
; PRC("SITE")=STATION #
; PRC("SST")=SUBSTATION #
; DUZ
; PRCHQ("DEST2")=INDICATOR THAT ROUTES PRINT OF RECEIVING
; REPORT TO FISCAL
;
D CLNUP
S (ZTRTN,ZTDESC)=PRCHQ
S:$D(D0) PRCHXXD0=D0
S:$D(D1) PRCHXXD1=D1
I PRCHQ["PRCPRIB" D
. N PRCPRIB
. S (PRCPRIB,ZTSAVE("PRCPRIB"))=D0
. Q
S:$D(PPMFLG) ZTSAVE("NOPRINT")=""
K IOP,ZTSK
S IOP=""
S X=""
I $D(PRCHQ("DEST2")) S X=PRCHQ("DEST2")
I X=""&($D(PRCHQ("DEST"))) S X=PRCHQ("DEST")
;Check for substation
I $G(PRC("SST"))]"" D SUBST Q
I $D(^PRC(411,PRC("SITE"),2)) D GETIOP(PRC("SITE"))
;Check for Fiscal Stack
I IOP'=""&(X'="IFP")&(X'="IFR")&(X="F"!(X="FR")) S DA=$O(^PRC(411,PRC("SITE"),2,"AC",X,IOP,0)) I $P($G(^PRC(411,PRC("SITE"),2,DA,0)),U,3) D ^PRCFPR Q
QDEV G Q:$G(PRCHIO)=IO(0)
I IOP'="" D G:'POP Q
. S %ZIS=$S(IOP=" ":"",1:"NQ")
. D ^%ZIS
. Q:'POP
. W $C(7),!!,">>>> ",X," IS NOT A VALID PRINTER, POSSIBLY FROM ",PRC("SITE"),"'S SITE PARAMETER FILE ",!!
. Q
;
SDEV S %ZIS("B")=""
;
SDEV1 S %ZIS("A")="QUEUE ON DEVICE: "
S %ZIS="NQ"
S NOZTDTH=""
K IOP
D ^%ZIS
G:POP EXIT
S IOP=ION_";"_IOST_";"_IOM_";"_IOSL
I IO=IO(0) D G EXIT
. D ^%ZIS
. U IO
. D @ZTRTN
. D ^%ZISC
. Q
;
Q S U="^"
S:$D(PRCHXXD0) D0=PRCHXXD0,ZTSAVE("D0")=""
S:$D(PRCHXXD1) D1=PRCHXXD1,ZTSAVE("D1")=""
S ZTSAVE("U")=""
S:$D(PRCHQ("DEST")) ZTSAVE("PRCHQ(""DEST"")")=""
S:$D(PRCHFPT) ZTSAVE("PRCHFPT")=""
S:$D(DEST) ZTSAVE("DEST")=""
S:$D(PRC("SITE")) ZTSAVE("PRC(""SITE"")")=""
S:$D(PRCHREPR) ZTSAVE("PRCHREPR")=""
I ZTRTN="EN2^PRCHRPT9"!(ZTRTN="EN2^PRCHRPL") D
. D PP3
. S ZTDTH=""
. Q
E D
. D:ZTRTN="STQUE^PRCHPNT1" PP2
. S:'$D(NOZTDTH) ZTDTH=$H
. ; Per SAAN for P69 -- allow scheduling for user selected devices.
. Q
;
I $G(PRCHIO)=IO(0)!($G(PRCHIO)=" ") D
. D @ZTRTN,^%ZISC:$G(PRCHIO)=" "
. ;Specify device 0;##;### TO RUN PRINT PROGRAMS THAT
. ;NORMALLY RUN IN THE BACKGROUND IN THE FOREGROUND.
. Q
E D ^%ZTLOAD,^%ZISC
;
EXIT K IOP,PRCHQ,XMAPHOST,NOZTDTH
;
CLNUP K ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTSK,ZTSKT,ZTCPU,ZTI,ZTJOB,ZTM1
K ZTM2,ZTMAST,ZTMGR,ZTNLG,ZTOS,ZTPD,ZTPO,ZTPROD,ZTPT,ZTRET,ZTSIZ
K ZTU1,ZTVOL,ZTXMB,PRCHXXD0,PRCHXXD1
Q
;
SUBST ;Substation is being used
N DONE
S DONE=0
I $D(^PRC(411,PRC("SST"),2)) D Q:DONE
. D GETIOP(PRC("SST"))
. ;Check for Fiscal Stack
. I IOP'=""&(X'="IFP")&(X'="IFR")&(X="F"!(X="FR")) S DA=$O(^PRC(411,PRC("SST"),2,"AC",X,IOP,0)) I $P($G(^PRC(411,PRC("SST"),2,DA,0)),U,3) D ^PRCFPR S DONE=1
I IOP="",$D(^PRC(411,PRC("SITE"),2)) D Q:DONE
. D GETIOP(PRC("SITE"))
. ;Check for Fiscal Stack
. I IOP'=""&(X'="IFP")&(X'="IFR")&(X="F"!(X="FR")) S DA=$O(^PRC(411,PRC("SITE"),2,"AC",X,IOP,0)) I $P($G(^PRC(411,PRC("SITE"),2,DA,0)),U,3) D ^PRCFPR S DONE=1
;Check field 61 in file 411 to see if user should be prompted for device
I +$P($G(^PRC(411,PRC("SITE"),0)),U,26) D Q
. S %ZIS("B")=IOP
. D SDEV1
. Q
D QDEV
Q
;
GETIOP(DA) ;
I X]"" D
. S IOP=$O(^PRC(411,DA,2,"AC",X,0))
. I IOP=""&(X["SPOOL"!(X["LTA")!$D(^%ZIS(1,"B",X))!(X?1N.N)!(X=" ")) S IOP=X
. Q
Q
;
PP2 S ZTSAVE("PRCH0")=""
S ZTSAVE("PRCH1")=""
S ZTSAVE("PRCH")=""
S ZTSAVE("PRCHV")=""
S ZTSAVE("PRCHP")=""
S ZTSAVE("PRCHJ")=""
S ZTSAVE("N")=""
S ZTSAVE("^TMP($J,")=""
Q
;
PP3 ;SETUP FOR PRINTING PL100-322 REPORT
S ZTSAVE("FR")=""
S ZTSAVE("TO")=""
S ZTSAVE("PRCHNULL")=""
S ZTSAVE("PRCHDET")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHQUE 3788 printed Dec 13, 2024@02:10:05 Page 2
PRCHQUE ;WISC/CLH,ID/RSD/TKW/REW/BGJ-QUE PRINTOUTS ; [7/2/98 3:20pm]
+1 ;;5.1;IFCAP;**14**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; INPUT TO PRCHQUE:
+5 ;
+6 ; D0,D1
+7 ; PRCHQ=ROUTINE
+8 ; PRCHQ("DEST")=DESTINATION
+9 ; PRC("SITE")=STATION #
+10 ; PRC("SST")=SUBSTATION #
+11 ; DUZ
+12 ; PRCHQ("DEST2")=INDICATOR THAT ROUTES PRINT OF RECEIVING
+13 ; REPORT TO FISCAL
+14 ;
+15 DO CLNUP
+16 SET (ZTRTN,ZTDESC)=PRCHQ
+17 if $DATA(D0)
SET PRCHXXD0=D0
+18 if $DATA(D1)
SET PRCHXXD1=D1
+19 IF PRCHQ["PRCPRIB"
Begin DoDot:1
+20 NEW PRCPRIB
+21 SET (PRCPRIB,ZTSAVE("PRCPRIB"))=D0
+22 QUIT
End DoDot:1
+23 if $DATA(PPMFLG)
SET ZTSAVE("NOPRINT")=""
+24 KILL IOP,ZTSK
+25 SET IOP=""
+26 SET X=""
+27 IF $DATA(PRCHQ("DEST2"))
SET X=PRCHQ("DEST2")
+28 IF X=""&($DATA(PRCHQ("DEST")))
SET X=PRCHQ("DEST")
+29 ;Check for substation
+30 IF $GET(PRC("SST"))]""
DO SUBST
QUIT
+31 IF $DATA(^PRC(411,PRC("SITE"),2))
DO GETIOP(PRC("SITE"))
+32 ;Check for Fiscal Stack
+33 IF IOP'=""&(X'="IFP")&(X'="IFR")&(X="F"!(X="FR"))
SET DA=$ORDER(^PRC(411,PRC("SITE"),2,"AC",X,IOP,0))
IF $PIECE($GET(^PRC(411,PRC("SITE"),2,DA,0)),U,3)
DO ^PRCFPR
QUIT
QDEV if $GET(PRCHIO)=IO(0)
GOTO Q
+1 IF IOP'=""
Begin DoDot:1
+2 SET %ZIS=$SELECT(IOP=" ":"",1:"NQ")
+3 DO ^%ZIS
+4 if 'POP
QUIT
+5 WRITE $CHAR(7),!!,">>>> ",X," IS NOT A VALID PRINTER, POSSIBLY FROM ",PRC("SITE"),"'S SITE PARAMETER FILE ",!!
+6 QUIT
End DoDot:1
if 'POP
GOTO Q
+7 ;
SDEV SET %ZIS("B")=""
+1 ;
SDEV1 SET %ZIS("A")="QUEUE ON DEVICE: "
+1 SET %ZIS="NQ"
+2 SET NOZTDTH=""
+3 KILL IOP
+4 DO ^%ZIS
+5 if POP
GOTO EXIT
+6 SET IOP=ION_";"_IOST_";"_IOM_";"_IOSL
+7 IF IO=IO(0)
Begin DoDot:1
+8 DO ^%ZIS
+9 USE IO
+10 DO @ZTRTN
+11 DO ^%ZISC
+12 QUIT
End DoDot:1
GOTO EXIT
+13 ;
Q SET U="^"
+1 if $DATA(PRCHXXD0)
SET D0=PRCHXXD0
SET ZTSAVE("D0")=""
+2 if $DATA(PRCHXXD1)
SET D1=PRCHXXD1
SET ZTSAVE("D1")=""
+3 SET ZTSAVE("U")=""
+4 if $DATA(PRCHQ("DEST"))
SET ZTSAVE("PRCHQ(""DEST"")")=""
+5 if $DATA(PRCHFPT)
SET ZTSAVE("PRCHFPT")=""
+6 if $DATA(DEST)
SET ZTSAVE("DEST")=""
+7 if $DATA(PRC("SITE"))
SET ZTSAVE("PRC(""SITE"")")=""
+8 if $DATA(PRCHREPR)
SET ZTSAVE("PRCHREPR")=""
+9 IF ZTRTN="EN2^PRCHRPT9"!(ZTRTN="EN2^PRCHRPL")
Begin DoDot:1
+10 DO PP3
+11 SET ZTDTH=""
+12 QUIT
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 if ZTRTN="STQUE^PRCHPNT1"
DO PP2
+15 if '$DATA(NOZTDTH)
SET ZTDTH=$HOROLOG
+16 ; Per SAAN for P69 -- allow scheduling for user selected devices.
+17 QUIT
End DoDot:1
+18 ;
+19 IF $GET(PRCHIO)=IO(0)!($GET(PRCHIO)=" ")
Begin DoDot:1
+20 DO @ZTRTN
if $GET(PRCHIO)=" "
DO ^%ZISC
+21 ;Specify device 0;##;### TO RUN PRINT PROGRAMS THAT
+22 ;NORMALLY RUN IN THE BACKGROUND IN THE FOREGROUND.
+23 QUIT
End DoDot:1
+24 IF '$TEST
DO ^%ZTLOAD
DO ^%ZISC
+25 ;
EXIT KILL IOP,PRCHQ,XMAPHOST,NOZTDTH
+1 ;
CLNUP KILL ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTSK,ZTSKT,ZTCPU,ZTI,ZTJOB,ZTM1
+1 KILL ZTM2,ZTMAST,ZTMGR,ZTNLG,ZTOS,ZTPD,ZTPO,ZTPROD,ZTPT,ZTRET,ZTSIZ
+2 KILL ZTU1,ZTVOL,ZTXMB,PRCHXXD0,PRCHXXD1
+3 QUIT
+4 ;
SUBST ;Substation is being used
+1 NEW DONE
+2 SET DONE=0
+3 IF $DATA(^PRC(411,PRC("SST"),2))
Begin DoDot:1
+4 DO GETIOP(PRC("SST"))
+5 ;Check for Fiscal Stack
+6 IF IOP'=""&(X'="IFP")&(X'="IFR")&(X="F"!(X="FR"))
SET DA=$ORDER(^PRC(411,PRC("SST"),2,"AC",X,IOP,0))
IF $PIECE($GET(^PRC(411,PRC("SST"),2,DA,0)),U,3)
DO ^PRCFPR
SET DONE=1
End DoDot:1
if DONE
QUIT
+7 IF IOP=""
IF $DATA(^PRC(411,PRC("SITE"),2))
Begin DoDot:1
+8 DO GETIOP(PRC("SITE"))
+9 ;Check for Fiscal Stack
+10 IF IOP'=""&(X'="IFP")&(X'="IFR")&(X="F"!(X="FR"))
SET DA=$ORDER(^PRC(411,PRC("SITE"),2,"AC",X,IOP,0))
IF $PIECE($GET(^PRC(411,PRC("SITE"),2,DA,0)),U,3)
DO ^PRCFPR
SET DONE=1
End DoDot:1
if DONE
QUIT
+11 ;Check field 61 in file 411 to see if user should be prompted for device
+12 IF +$PIECE($GET(^PRC(411,PRC("SITE"),0)),U,26)
Begin DoDot:1
+13 SET %ZIS("B")=IOP
+14 DO SDEV1
+15 QUIT
End DoDot:1
QUIT
+16 DO QDEV
+17 QUIT
+18 ;
GETIOP(DA) ;
+1 IF X]""
Begin DoDot:1
+2 SET IOP=$ORDER(^PRC(411,DA,2,"AC",X,0))
+3 IF IOP=""&(X["SPOOL"!(X["LTA")!$DATA(^%ZIS(1,"B",X))!(X?1N.N)!(X=" "))
SET IOP=X
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
PP2 SET ZTSAVE("PRCH0")=""
+1 SET ZTSAVE("PRCH1")=""
+2 SET ZTSAVE("PRCH")=""
+3 SET ZTSAVE("PRCHV")=""
+4 SET ZTSAVE("PRCHP")=""
+5 SET ZTSAVE("PRCHJ")=""
+6 SET ZTSAVE("N")=""
+7 SET ZTSAVE("^TMP($J,")=""
+8 QUIT
+9 ;
PP3 ;SETUP FOR PRINTING PL100-322 REPORT
+1 SET ZTSAVE("FR")=""
+2 SET ZTSAVE("TO")=""
+3 SET ZTSAVE("PRCHNULL")=""
+4 SET ZTSAVE("PRCHDET")=""
+5 QUIT
