PSXARPT ;BIR/HTW-Print Archived data [ 04/08/97 2:06 PM ]
;;2.0;CMOP;;11 Apr 97
S PSXRPT=1,COMCT=1,LBLCT=1
S DIC=555,DIC(0)="AEMQZ"
S DIC("A")="Enter Archived CMOP Transmission Number: " D ^DIC K DIC
Q:$D(DUOUT)!($D(DTOUT))!(+$G(Y)'>0)
S PSXBATCH=$P(Y,"^",2),PSXTNO=$P(^PSXARC(+Y,0),"^",2)
S DIR(0)="F^1:15",DIR("A")="Enter Rx # to report or return for all"
S DIR("B")="ALL"
D ^DIR K DIR I $D(DIRUT)!($D(DIROUT)) Q
S RX=Y K Y
; Get printer and tape device info
DEVICE W !! S %ZIS="MQ",%ZIS("A")="Select Printer: ",%ZIS("B")=""
D ^%ZIS I POP S PSXERR=1 G END
S PSXP=IO K %ZIS
S PSXPIOF=IOF,PSXPIOST=IOST
D MOUNT^PSXARC I $G(PSXERR)=1 G END
; verify correct tape
MAIN U PSXT R X:DTIME G END:X=""
I X["$$HDR|" S PSXTAPE=$P($P(X,"|",2),"^",2)
I $G(PSXTAPE)'=$G(PSXTNO) U IO(0) W !,"The wrong archive tape has been loaded. This is tape #: "_$S($G(PSXTAPE)']"":"UNKNOWN",1:PSXTAPE) K PSXTAPE,X D MOUNT^PSXARC G:($G(PSXERR)=1) END G MAIN
I $G(PSXP)'=IO(0) U IO(0) W !,"Searching...."
FIND ; Find selected batch
D PSXAT^PSXARC1 U PSXT R X:DTIME G END:X=""
I X'["$$REC|"!((X["$$REC|")&(X'[PSXBATCH)) G FIND
I $G(PSXP)'=IO(0) U IO(0) W !,$P($P(X,"|",2),"^")_", "
I X[PSXBATCH G A1
U IO(0) W !!,"Batch not found, please try again." G END
Q
ALL D PSXAT^PSXARC1 R X:DTIME G END:X=""
A1 I X["$$REC|"&(X'[PSXBATCH) G END
I $G(X)["$$REC|",($D(REC)) S XZ=X D ^PSXARC2 S X=XZ K XZ
I $G(X)["$$REC|" S REC=X G ALL
I $G(X)["$$COM|" S COM(COMCT)=X S COMCT=COMCT+1 G ALL
I $G(X)["$$LBL|" S LBL(LBLCT)=X S LBLCT=LBLCT+1 G ALL
I $G(X)["$$ACK|" S ACK=X G ALL
I $D(REC),($G(X)["$$RX,1") S RXX=X D ^PSXARC2 S X=RXX K REC,COM,LBL,ACK,RXX
RX I +$G(RX)>0 G SING1
I $G(X)["$$RX," S REC1=$P(X,"|",2) G ALL
I $G(X)["$$ZX,"&($D(REC1)) S REC2=$P(X,"|",2) D RX^PSXARC2 K REC1,REC2 G ALL
I $G(X)["$$LOT" S LOT=$P(X,"|",2) D LOT^PSXARC2 K LOT G ALL
Q
SING1 I X[RX G S1
SINGLE U PSXT R X:DTIME G ERR:X="" G:X'["$$RX" SINGLE I X'[RX G SINGLE
S1 S REC1=$P(X,"|",2)
S2 U PSXT R X:DTIME G END:X=""
I $G(X)["$$ZX,"&($D(REC1)) S REC2=$P(X,"|",2) D RX^PSXARC2 K REC1,REC2 G S2
I $G(X)["$$LOT" S LOT=$P(X,"|",2) D LOT^PSXARC2 K LOT G S2
G END
ERR U IO(0) W !,"Rx not found. Please make sure the number is correct."
D END G PSXARPT
;
END I $G(PSXP)'=IO(0),($G(PSXERR)'=1) U PSXP W @PSXPIOF
D ^%ZISC
S DEV="" F S DEV=$O(IO(1,DEV)) Q:($G(DEV)'>0) S IOP=DEV D ^%ZIS,^%ZISC
D HOME^%ZIS
K PSXT,PSXP,RX,LOT,X,PSXEOT,PSXBATCH,REC,REC1,COM,LBL,ACK,XX,ZCT,PSXTAPE
K ZQ,ZQ1,PSXAM,PSXPIOF,PSXPIOST,PSXRPT,PSXTBS,PSXTIOF,PSXTNO,PSXTPAR,XZ
K Y,LBLCT,COMCT,C,ZPC,POP,%MT,DIROUT,DIRUT,DTOUT,DUOUT,PSXERR,RXX,XNEW
Q
DUMP ; DUMPS CONTENTS OF TAPE - NO FORMATTING
PQ S XNEW=0,PSXATNM=1 S %ZIS("A")="TAPE DRIVE DEVICE: " W !! D ^%ZIS K %ZIS("A") G END:POP S PSXAT=IO I IOST'["MAGTAPE" D ^%ZISC U IO(0) W !,"MUST SELECT A MAGTAPE DEVICE",!! G PQ
U IO(0) W !! S %ZIS("A")="OUTPUT DEVICE: " D ^%ZIS K %ZIS("A") S PSXAP=IO G END:POP S PSXACPM=IOM,PSXACPF=IOF,PSXACPL=IOSL W !!
I '$D(%MT("REW")) X ^%ZOSF("MAGTAPE")
F U PSXAT R X:DTIME U PSXAP W !,X S ZAL=$G(ZAL)+$L(X) X ^%ZOSF("EOT") G:Y END I $G(X)']"" G STOP
STOP D ^%ZISC
K PSXAT,PSXACPF,PSXACPL,PSXAP,PSXACPM,PSXATNM,ZAL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXARPT 3238 printed Dec 13, 2024@01:43:23 Page 2
PSXARPT ;BIR/HTW-Print Archived data [ 04/08/97 2:06 PM ]
+1 ;;2.0;CMOP;;11 Apr 97
+2 SET PSXRPT=1
SET COMCT=1
SET LBLCT=1
+3 SET DIC=555
SET DIC(0)="AEMQZ"
+4 SET DIC("A")="Enter Archived CMOP Transmission Number: "
DO ^DIC
KILL DIC
+5 if $DATA(DUOUT)!($DATA(DTOUT))!(+$GET(Y)'>0)
QUIT
+6 SET PSXBATCH=$PIECE(Y,"^",2)
SET PSXTNO=$PIECE(^PSXARC(+Y,0),"^",2)
+7 SET DIR(0)="F^1:15"
SET DIR("A")="Enter Rx # to report or return for all"
+8 SET DIR("B")="ALL"
+9 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!($DATA(DIROUT))
QUIT
+10 SET RX=Y
KILL Y
+11 ; Get printer and tape device info
DEVICE WRITE !!
SET %ZIS="MQ"
SET %ZIS("A")="Select Printer: "
SET %ZIS("B")=""
+1 DO ^%ZIS
IF POP
SET PSXERR=1
GOTO END
+2 SET PSXP=IO
KILL %ZIS
+3 SET PSXPIOF=IOF
SET PSXPIOST=IOST
+4 DO MOUNT^PSXARC
IF $GET(PSXERR)=1
GOTO END
+5 ; verify correct tape
MAIN USE PSXT
READ X:DTIME
if X=""
GOTO END
+1 IF X["$$HDR|"
SET PSXTAPE=$PIECE($PIECE(X,"|",2),"^",2)
+2 IF $GET(PSXTAPE)'=$GET(PSXTNO)
USE IO(0)
WRITE !,"The wrong archive tape has been loaded. This is tape #: "_$SELECT($GET(PSXTAPE)']"":"UNKNOWN",1:PSXTAPE)
KILL PSXTAPE,X
DO MOUNT^PSXARC
if ($GET(PSXERR)=1)
GOTO END
GOTO MAIN
+3 IF $GET(PSXP)'=IO(0)
USE IO(0)
WRITE !,"Searching...."
FIND ; Find selected batch
+1 DO PSXAT^PSXARC1
USE PSXT
READ X:DTIME
if X=""
GOTO END
+2 IF X'["$$REC|"!((X["$$REC|")&(X'[PSXBATCH))
GOTO FIND
+3 IF $GET(PSXP)'=IO(0)
USE IO(0)
WRITE !,$PIECE($PIECE(X,"|",2),"^")_", "
+4 IF X[PSXBATCH
GOTO A1
+5 USE IO(0)
WRITE !!,"Batch not found, please try again."
GOTO END
+6 QUIT
ALL DO PSXAT^PSXARC1
READ X:DTIME
if X=""
GOTO END
A1 IF X["$$REC|"&(X'[PSXBATCH)
GOTO END
+1 IF $GET(X)["$$REC|"
IF ($DATA(REC))
SET XZ=X
DO ^PSXARC2
SET X=XZ
KILL XZ
+2 IF $GET(X)["$$REC|"
SET REC=X
GOTO ALL
+3 IF $GET(X)["$$COM|"
SET COM(COMCT)=X
SET COMCT=COMCT+1
GOTO ALL
+4 IF $GET(X)["$$LBL|"
SET LBL(LBLCT)=X
SET LBLCT=LBLCT+1
GOTO ALL
+5 IF $GET(X)["$$ACK|"
SET ACK=X
GOTO ALL
+6 IF $DATA(REC)
IF ($GET(X)["$$RX,1")
SET RXX=X
DO ^PSXARC2
SET X=RXX
KILL REC,COM,LBL,ACK,RXX
RX IF +$GET(RX)>0
GOTO SING1
+1 IF $GET(X)["$$RX,"
SET REC1=$PIECE(X,"|",2)
GOTO ALL
+2 IF $GET(X)["$$ZX,"&($DATA(REC1))
SET REC2=$PIECE(X,"|",2)
DO RX^PSXARC2
KILL REC1,REC2
GOTO ALL
+3 IF $GET(X)["$$LOT"
SET LOT=$PIECE(X,"|",2)
DO LOT^PSXARC2
KILL LOT
GOTO ALL
+4 QUIT
SING1 IF X[RX
GOTO S1
SINGLE USE PSXT
READ X:DTIME
if X=""
GOTO ERR
if X'["$$RX"
GOTO SINGLE
IF X'[RX
GOTO SINGLE
S1 SET REC1=$PIECE(X,"|",2)
S2 USE PSXT
READ X:DTIME
if X=""
GOTO END
+1 IF $GET(X)["$$ZX,"&($DATA(REC1))
SET REC2=$PIECE(X,"|",2)
DO RX^PSXARC2
KILL REC1,REC2
GOTO S2
+2 IF $GET(X)["$$LOT"
SET LOT=$PIECE(X,"|",2)
DO LOT^PSXARC2
KILL LOT
GOTO S2
+3 GOTO END
ERR USE IO(0)
WRITE !,"Rx not found. Please make sure the number is correct."
+1 DO END
GOTO PSXARPT
+2 ;
END IF $GET(PSXP)'=IO(0)
IF ($GET(PSXERR)'=1)
USE PSXP
WRITE @PSXPIOF
+1 DO ^%ZISC
+2 SET DEV=""
FOR
SET DEV=$ORDER(IO(1,DEV))
if ($GET(DEV)'>0)
QUIT
SET IOP=DEV
DO ^%ZIS
DO ^%ZISC
+3 DO HOME^%ZIS
+4 KILL PSXT,PSXP,RX,LOT,X,PSXEOT,PSXBATCH,REC,REC1,COM,LBL,ACK,XX,ZCT,PSXTAPE
+5 KILL ZQ,ZQ1,PSXAM,PSXPIOF,PSXPIOST,PSXRPT,PSXTBS,PSXTIOF,PSXTNO,PSXTPAR,XZ
+6 KILL Y,LBLCT,COMCT,C,ZPC,POP,%MT,DIROUT,DIRUT,DTOUT,DUOUT,PSXERR,RXX,XNEW
+7 QUIT
DUMP ; DUMPS CONTENTS OF TAPE - NO FORMATTING
PQ SET XNEW=0
SET PSXATNM=1
SET %ZIS("A")="TAPE DRIVE DEVICE: "
WRITE !!
DO ^%ZIS
KILL %ZIS("A")
if POP
GOTO END
SET PSXAT=IO
IF IOST'["MAGTAPE"
DO ^%ZISC
USE IO(0)
WRITE !,"MUST SELECT A MAGTAPE DEVICE",!!
GOTO PQ
+1 USE IO(0)
WRITE !!
SET %ZIS("A")="OUTPUT DEVICE: "
DO ^%ZIS
KILL %ZIS("A")
SET PSXAP=IO
if POP
GOTO END
SET PSXACPM=IOM
SET PSXACPF=IOF
SET PSXACPL=IOSL
WRITE !!
+2 IF '$DATA(%MT("REW"))
XECUTE ^%ZOSF("MAGTAPE")
+3 FOR
USE PSXAT
READ X:DTIME
USE PSXAP
WRITE !,X
SET ZAL=$GET(ZAL)+$LENGTH(X)
XECUTE ^%ZOSF("EOT")
if Y
GOTO END
IF $GET(X)']""
GOTO STOP
STOP DO ^%ZISC
+1 KILL PSXAT,PSXACPF,PSXACPL,PSXAP,PSXACPM,PSXATNM,ZAL
+2 QUIT
