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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSXARPT   3238     printed  Apr 23, 2025@17:57:49                                                                                                                                                                                                     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