PRCFQ ;WISC@ALTOONA/CTB/ID/RSD/BOISE/TKW/DL-QUE PRINTOUTS ;1/23/98 1400
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;IF PRCFQ("FORCEQ") IS DEFINED ROUTINE WILL FORCE %ZTLOAD
K IOP,ZTSK G:$D(ZTIO) TIME W:$D(PRCFQ("FORCEQ")) !,"QUEUE TO PRINT ON:" S %ZIS("B")="",%ZIS="NQ" D ^%ZIS I POP W " <No Device Selected>",$C(7),! R X:2 S NODEV="" G EXIT
S (PRIOP,IOP)=ION_";"_IOST_";"_IOM_";"_IOSL I IO=IO(0),'$D(PRCFQ("FORCEQ")),'$D(IO("Q")) D ^%ZIS,HILO,@ZTRTN,CLOSE G EXIT
TIME I '$D(ZTDTH) D DQTIME I '% D CLOSE W:(IOM-$X)<20 ! W " <Nothing Queued>",$C(7) S NODEV="" G EXIT
D HILO S (ZTSAVE("DUZ"),ZTSAVE("PRIOP"),ZTSAVE("IOIN*"))="" D ^%ZTLOAD,CLOSE W:(IOM-$X)<20 ! W " <Request Queued>",$C(7),!
EXIT K %ZIS,I,IO("Q"),IOP,K,N,PRIOP,PRCFL,PRCFQ G ZTKILL
CLOSE D ^%ZISC Q
DQTIME S U="^",%=1 K ZTDTH W !,"Enter DATE & TIME to ",$S('$D(ZTIO):"print",ZTIO]"":"print",1:"run"),". NOW// " R X:$S($D(DTIME):DTIME,1:30) I X[U!('$T) S %=0 K X Q
S:X="" X="NOW" S %DT="ER" D ^%DT S %=0 I Y<0 G DQTIME
S X=Y D H^%DTC S Y=Y_"000",ZTDTH=%H_","_($E(Y,9,10)*60+$E(Y,11,12)*60),%=1
K %DT,%H,%Y,X,Y Q
MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
N X1,X2,ZX Q:'$D(X) I $S('$D(IOM):1,IOM="":1,1:0) W $P(X,"*") R X:2 K X Q
I ($L($P(X,"*"))+4+$X)>IOM W !,?(IOM-($L($P(X,"*"))+4))
F ZX=1:1 D BRK:($L(X)+6)>IOM W " ",$P(X,"*"),! Q:'$D(X1) S X=X1 K X1
W:X["*" $C(7)
Q
BRK N I
S X1=X F I=1:1 Q:$L($P(X," ",1,I))>(IOM-6)!($L(X)<(IOM-6)) S X1=$P(X," ",1,I)
S X2=$P(X," ",I,999),X=X1,X1=X2 K X2 Q
PAUSE ; MAKES TERMINAL PAUSE WHEN DISPLAYING DATA ONLINE
S %=1 W !!,"Press RETURN to continue or '^' to quit: " R X:DTIME S:'$T!(X["^") %=0 Q
ENCON W !," ** Press RETURN to Continue **" R X:DTIME Q
DIKILL ; KILL STANDARD FILE MANAGER VARIABLES
K %,%DT,%X,%Y,BY,D,DA,DCC,DIC,DIE,DIJ,DIPT,DP,DR,D0,D1,D2,DQ,DHD,DLAYGO,F,FLDS,FR,I,IOX,IOY,J,K,L,O,P,POP,W,X,Y,Z,ZTSK Q
DIWKILL ; KILL FILE MANAGER WORD PROCESSING VARIABLES
K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DWLW,X1 Q
ZTKILL ; KILL VARIABLES USED BY UNIVERSAL TASK MANAGER
K %ZIS,POP,ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTIO,ZTSK,ZTSKT Q
CNVD ; CONVERTS DATE FROM INTERNAL (YYYMMDD) STORAGE FORMAT TO MM/DD/YY
S (Y,%X)="" I X]"" S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3) S %X=Y_$S(X[".":" "_$E($P(X,".",2)_"0000",1,2)_":"_$E($P(X,".",2)_"0000",3,4),1:"")
Q
NOW S %=$$NOW^XLFDT,%X=$$FMTE^XLFDT(%),X=%\1,Y=$P(%X,"@") Q
; Original code from NOW:
;N %H,%I,%M,%D,%Y S %H=$H D TT S %=$P($H,",",2),%=%#3600\60/100+(%\3600)/100,%=X_$S(%:%,1:"") S Y=% D D S %X=Y S Y=X D D Q
TT ;D 7 S %I(1)=%M,%I(2)=%D,%I(3)=%Y Q
7 ;S %=%H>21608+%H-.1,%Y=%\365.25+141,%=%#365.25\1
;S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1
;S X=%Y_"00"+%M_"00"+%D Q
Q
D ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")
Q
HILO I $D(IOST)["0" S IOP=$S($D(ION):ION,1:IO(0)) D ^%ZIS K IOP,POP
S X="IOINHI;IOINLOW;IOINORM" D ENDR^%ZISS
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFQ 3211 printed Sep 23, 2025@19:40:23 Page 2
PRCFQ ;WISC@ALTOONA/CTB/ID/RSD/BOISE/TKW/DL-QUE PRINTOUTS ;1/23/98 1400
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;IF PRCFQ("FORCEQ") IS DEFINED ROUTINE WILL FORCE %ZTLOAD
+3 KILL IOP,ZTSK
if $DATA(ZTIO)
GOTO TIME
if $DATA(PRCFQ("FORCEQ"))
WRITE !,"QUEUE TO PRINT ON:"
SET %ZIS("B")=""
SET %ZIS="NQ"
DO ^%ZIS
IF POP
WRITE " <No Device Selected>",$CHAR(7),!
READ X:2
SET NODEV=""
GOTO EXIT
+4 SET (PRIOP,IOP)=ION_";"_IOST_";"_IOM_";"_IOSL
IF IO=IO(0)
IF '$DATA(PRCFQ("FORCEQ"))
IF '$DATA(IO("Q"))
DO ^%ZIS
DO HILO
DO @ZTRTN
DO CLOSE
GOTO EXIT
TIME IF '$DATA(ZTDTH)
DO DQTIME
IF '%
DO CLOSE
if (IOM-$X)<20
WRITE !
WRITE " <Nothing Queued>",$CHAR(7)
SET NODEV=""
GOTO EXIT
+1 DO HILO
SET (ZTSAVE("DUZ"),ZTSAVE("PRIOP"),ZTSAVE("IOIN*"))=""
DO ^%ZTLOAD
DO CLOSE
if (IOM-$X)<20
WRITE !
WRITE " <Request Queued>",$CHAR(7),!
EXIT KILL %ZIS,I,IO("Q"),IOP,K,N,PRIOP,PRCFL,PRCFQ
GOTO ZTKILL
CLOSE DO ^%ZISC
QUIT
DQTIME SET U="^"
SET %=1
KILL ZTDTH
WRITE !,"Enter DATE & TIME to ",$SELECT('$DATA(ZTIO):"print",ZTIO]"":"print",1:"run"),". NOW// "
READ X:$SELECT($DATA(DTIME):DTIME,1:30)
IF X[U!('$TEST)
SET %=0
KILL X
QUIT
+1 if X=""
SET X="NOW"
SET %DT="ER"
DO ^%DT
SET %=0
IF Y<0
GOTO DQTIME
+2 SET X=Y
DO H^%DTC
SET Y=Y_"000"
SET ZTDTH=%H_","_($EXTRACT(Y,9,10)*60+$EXTRACT(Y,11,12)*60)
SET %=1
+3 KILL %DT,%H,%Y,X,Y
QUIT
MSG ;;PRINTS MESSAGE CONTAINED IN X. IF IT DOESNT FIT ON ONE LINE, X IS PRINTED ON THE NEXT LINE.
+1 NEW X1,X2,ZX
if '$DATA(X)
QUIT
IF $SELECT('$DATA(IOM):1,IOM="":1,1:0)
WRITE $PIECE(X,"*")
READ X:2
KILL X
QUIT
+2 IF ($LENGTH($PIECE(X,"*"))+4+$X)>IOM
WRITE !,?(IOM-($LENGTH($PIECE(X,"*"))+4))
+3 FOR ZX=1:1
if ($LENGTH(X)+6)>IOM
DO BRK
WRITE " ",$PIECE(X,"*"),!
if '$DATA(X1)
QUIT
SET X=X1
KILL X1
+4 if X["*"
WRITE $CHAR(7)
+5 QUIT
BRK NEW I
+1 SET X1=X
FOR I=1:1
if $LENGTH($PIECE(X," ",1,I))>(IOM-6)!($LENGTH(X)<(IOM-6))
QUIT
SET X1=$PIECE(X," ",1,I)
+2 SET X2=$PIECE(X," ",I,999)
SET X=X1
SET X1=X2
KILL X2
QUIT
PAUSE ; MAKES TERMINAL PAUSE WHEN DISPLAYING DATA ONLINE
+1 SET %=1
WRITE !!,"Press RETURN to continue or '^' to quit: "
READ X:DTIME
if '$TEST!(X["^")
SET %=0
QUIT
ENCON WRITE !," ** Press RETURN to Continue **"
READ X:DTIME
QUIT
DIKILL ; KILL STANDARD FILE MANAGER VARIABLES
+1 KILL %,%DT,%X,%Y,BY,D,DA,DCC,DIC,DIE,DIJ,DIPT,DP,DR,D0,D1,D2,DQ,DHD,DLAYGO,F,FLDS,FR,I,IOX,IOY,J,K,L,O,P,POP,W,X,Y,Z,ZTSK
QUIT
DIWKILL ; KILL FILE MANAGER WORD PROCESSING VARIABLES
+1 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DWLW,X1
QUIT
ZTKILL ; KILL VARIABLES USED BY UNIVERSAL TASK MANAGER
+1 KILL %ZIS,POP,ZTRTN,ZTUCI,ZTDTH,ZTSAVE,ZTDESC,ZTIO,ZTSK,ZTSKT
QUIT
CNVD ; CONVERTS DATE FROM INTERNAL (YYYMMDD) STORAGE FORMAT TO MM/DD/YY
+1 SET (Y,%X)=""
IF X]""
SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
SET %X=Y_$SELECT(X[".":" "_$EXTRACT($PIECE(X,".",2)_"0000",1,2)_":"_$EXTRACT($PIECE(X,".",2)_"0000",3,4),1:"")
+2 QUIT
NOW SET %=$$NOW^XLFDT
SET %X=$$FMTE^XLFDT(%)
SET X=%\1
SET Y=$PIECE(%X,"@")
QUIT
+1 ; Original code from NOW:
+2 ;N %H,%I,%M,%D,%Y S %H=$H D TT S %=$P($H,",",2),%=%#3600\60/100+(%\3600)/100,%=X_$S(%:%,1:"") S Y=% D D S %X=Y S Y=X D D Q
TT ;D 7 S %I(1)=%M,%I(2)=%D,%I(3)=%Y Q
7 ;S %=%H>21608+%H-.1,%Y=%\365.25+141,%=%#365.25\1
+1 ;S %D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1
+2 ;S X=%Y_"00"+%M_"00"+%D Q
+3 QUIT
D ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
+1 if Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
+2 QUIT
HILO IF $DATA(IOST)["0"
SET IOP=$SELECT($DATA(ION):ION,1:IO(0))
DO ^%ZIS
KILL IOP,POP
+1 SET X="IOINHI;IOINLOW;IOINORM"
DO ENDR^%ZISS
+2 QUIT
+3 ;
