source: FOIAVistA/tag/r/CMOP-PSX/PSXARPT.m

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