PRCFAC5 ;WISC/CTB-REPRINT A BATCH OR TRANSMISSION ;1/9/92 4:00 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S PRCFASYS=""
EN S X="This option will reprint code sheets. You will have the option of reprinting individual batches or all batches within a certain Transmission Number." D MSG^PRCFQ
S PRCF("X")="AS" D ^PRCFSITE G:'% OUT
D NOW^%DTC S PRCFKEY=%_"-"_DUZ
A R !!,"Do you wish to reprint by Batch or Transmission number? (B/T) T//",X:$S($D(DTIME):DTIME,1:60) Q:'$T!(X["^") G:X=""!("Tt"[$E(X,1)) T G:"Bb"[$E(X,1) B
W ! S X="If you respond with a 'B', you will be required to enter the full Batch Number of each Batch that you wish to reprint. A 'T', will cause ALL batches within the Transmission to be reprinted automatically.*"
D MSG^PRCFQ W ! G A
B ;
S DIC("A")="Select Batch Number: ",RT=0 K ^PRCF(423,"AM",PRCFKEY)
B1 S DIC=421.2,DIC(0)="AEMQZ",DIC("S")="S XXX=^(0) I $E($P(XXX,U,3),1)=""B"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")" D ^DIC K DIC,XXX G:Y<0&('$D(POK)) OUT G:Y<0 QUE S PBAT=$P(Y,U,2) D BLIST
S POK="",DIC("A")="Select Next Batch Number: " G B1
T ;
S DIC("A")="Enter Transmission Number: ",RT=0 K ^PRCF(423,"AM",PRCFKEY)
T1 S DIC=421.2,DIC(0)="AMEQZ",DIC("S")="S XXX=^(0) I $E($P(XXX,U,3),1)=""T"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")" D ^DIC K DIC,XXX G:Y<0&('$D(POK)) OUT G:Y<0 QUE S PTR=$P(Y,"^",2),PTRN=+Y
S K=0 F I=1:1 S K=$O(^PRCF(421.2,PTRN,1,K)) Q:+K=0 S PBAT=^(K,0) W !,"Processing Batch # ",PBAT D BLIST
S POK="",DIC("A")="Select Next Transmission Number: " G T1
QUE I '$D(^PRCF(423,"AM",PRCFKEY)) W !!,"NO BATCHES SELECTED OPTION ABORTED",$C(7) G OUT
S ZTRTN="SE^PRCFAC5",ZTSAVE("PRCFKEY")="",ZTSAVE("PRCFASYS")="",ZTDESC="REPRINT A "_$S(PRCFASYS["IRS":"IRS",PRCFASYS["ISM":"ISM",1:"LOG")_" BATCH" D ^PRCFQ I $D(NODEV) K ^PRCF(423,"AM","Y"),NODEV
OUT K %,N,I,%DT,%H,%Y,DIC,DIJ,ER,A,B,C,DQTIME,FAIL,POP,POK,PTR,PTRN,PBAT,PBATN,PRCFKEY,RT,X,X1,XMDUZ,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,IOX,IOY,XMZ,Y Q
FAIL1 S FAIL="" Q
BLIST I '$D(^PRCF(421.2,"B",PBAT)) Q
I $D(^PRCF(423,"AD",PBAT)) S N=0 F I=1:1 S N=$O(^PRCF(423,"AD",PBAT,N)) Q:N'=+N S ^PRCF(423,"AM",PRCFKEY,N)="",$P(^PRCF(423,N,"TRANS"),"^",13)=PRCFKEY W "."
Q
SE D:$D(ZTQUEUED) KILL^%ZTLOAD
D NOW^PRCFQ S IOP=$S($D(ION):ION,1:IO),DIC="^PRCF(423,",L=0,BY="[PRCFA BATCH REPRINT SORT]",FLDS="[PRCFA REPRINT TRAILER]",(FR,TO)=PRCFKEY D EN1^DIP
F I=1:1 S N=$O(^PRCF(423,"AM",PRCFKEY,0)) Q:'N S $P(^PRCF(423,N,"TRANS"),"^",13)="" K ^PRCF(423,"AM",PRCFKEY,N)
K %,%DT,%I,BATCH,BATTYPE,DP,I,J,K,L,M,N,PRCFX,PRCFKEY,PTYP,X,Y,Z1,Z2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC5 2628 printed Dec 13, 2024@02:01:56 Page 2
PRCFAC5 ;WISC/CTB-REPRINT A BATCH OR TRANSMISSION ;1/9/92 4:00 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET PRCFASYS=""
EN SET X="This option will reprint code sheets. You will have the option of reprinting individual batches or all batches within a certain Transmission Number."
DO MSG^PRCFQ
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO OUT
+2 DO NOW^%DTC
SET PRCFKEY=%_"-"_DUZ
A READ !!,"Do you wish to reprint by Batch or Transmission number? (B/T) T//",X:$SELECT($DATA(DTIME):DTIME,1:60)
if '$TEST!(X["^")
QUIT
if X=""!("Tt"[$EXTRACT(X,1))
GOTO T
if "Bb"[$EXTRACT(X,1)
GOTO B
+1 WRITE !
SET X="If you respond with a 'B', you will be required to enter the full Batch Number of each Batch that you wish to reprint. A 'T', will cause ALL batches within the Transmission to be reprinted automatically.*"
+2 DO MSG^PRCFQ
WRITE !
GOTO A
B ;
+1 SET DIC("A")="Select Batch Number: "
SET RT=0
KILL ^PRCF(423,"AM",PRCFKEY)
B1 SET DIC=421.2
SET DIC(0)="AEMQZ"
SET DIC("S")="S XXX=^(0) I $E($P(XXX,U,3),1)=""B"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
DO ^DIC
KILL DIC,XXX
if Y<0&('$DATA(POK))
GOTO OUT
if Y<0
GOTO QUE
SET PBAT=$PIECE(Y,U,2)
DO BLIST
+1 SET POK=""
SET DIC("A")="Select Next Batch Number: "
GOTO B1
T ;
+1 SET DIC("A")="Enter Transmission Number: "
SET RT=0
KILL ^PRCF(423,"AM",PRCFKEY)
T1 SET DIC=421.2
SET DIC(0)="AMEQZ"
SET DIC("S")="S XXX=^(0) I $E($P(XXX,U,3),1)=""T"",PRCFASYS[$P(XXX,""-"",2),+XXX=PRC(""SITE"")"
DO ^DIC
KILL DIC,XXX
if Y<0&('$DATA(POK))
GOTO OUT
if Y<0
GOTO QUE
SET PTR=$PIECE(Y,"^",2)
SET PTRN=+Y
+1 SET K=0
FOR I=1:1
SET K=$ORDER(^PRCF(421.2,PTRN,1,K))
if +K=0
QUIT
SET PBAT=^(K,0)
WRITE !,"Processing Batch # ",PBAT
DO BLIST
+2 SET POK=""
SET DIC("A")="Select Next Transmission Number: "
GOTO T1
QUE IF '$DATA(^PRCF(423,"AM",PRCFKEY))
WRITE !!,"NO BATCHES SELECTED OPTION ABORTED",$CHAR(7)
GOTO OUT
+1 SET ZTRTN="SE^PRCFAC5"
SET ZTSAVE("PRCFKEY")=""
SET ZTSAVE("PRCFASYS")=""
SET ZTDESC="REPRINT A "_$SELECT(PRCFASYS["IRS":"IRS",PRCFASYS["ISM":"ISM",1:"LOG")_" BATCH"
DO ^PRCFQ
IF $DATA(NODEV)
KILL ^PRCF(423,"AM","Y"),NODEV
OUT KILL %,N,I,%DT,%H,%Y,DIC,DIJ,ER,A,B,C,DQTIME,FAIL,POP,POK,PTR,PTRN,PBAT,PBATN,PRCFKEY,RT,X,X1,XMDUZ,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,IOX,IOY,XMZ,Y
QUIT
FAIL1 SET FAIL=""
QUIT
BLIST IF '$DATA(^PRCF(421.2,"B",PBAT))
QUIT
+1 IF $DATA(^PRCF(423,"AD",PBAT))
SET N=0
FOR I=1:1
SET N=$ORDER(^PRCF(423,"AD",PBAT,N))
if N'=+N
QUIT
SET ^PRCF(423,"AM",PRCFKEY,N)=""
SET $PIECE(^PRCF(423,N,"TRANS"),"^",13)=PRCFKEY
WRITE "."
+2 QUIT
SE if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 DO NOW^PRCFQ
SET IOP=$SELECT($DATA(ION):ION,1:IO)
SET DIC="^PRCF(423,"
SET L=0
SET BY="[PRCFA BATCH REPRINT SORT]"
SET FLDS="[PRCFA REPRINT TRAILER]"
SET (FR,TO)=PRCFKEY
DO EN1^DIP
+2 FOR I=1:1
SET N=$ORDER(^PRCF(423,"AM",PRCFKEY,0))
if 'N
QUIT
SET $PIECE(^PRCF(423,N,"TRANS"),"^",13)=""
KILL ^PRCF(423,"AM",PRCFKEY,N)
+3 KILL %,%DT,%I,BATCH,BATTYPE,DP,I,J,K,L,M,N,PRCFX,PRCFKEY,PTYP,X,Y,Z1,Z2
+4 QUIT
