PRCFACR0 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFACR ;4/30/93 3:05 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
I '$D(^PRCF(421.2,"AD",PRCFKEY)) W !!,"NO BATCHES SELECTED OPTION ABORTED",$C(7) G OUT
F I=1:1 S PBATN=$O(^PRCF(421.2,"AD","Y",0)) Q:+PBATN=0 S PBAT=$P(^PRCF(421.2,PBATN,0),"^") D BLIST K ^PRCF(421.2,"AD","Y",PBATN) S I=1
S ZTSAVE("PRCFRT")="",ZTSAVE("PRCFASYS")="",ZTSAVE("PRCFKEY")="",ZTRTN="^PRCFACR1",ZTDESC="TRANSMIT "_$S(PRCFASYS["LOG":"LOG ",PRCFASYS["ISM":"ISM ",PRCFASYS["EDI":"EDI ",1:"")_"CODE SHEETS" D ^PRCFQ
OUT K %,%DT,%H,%Y,A,B,C,DIC,DIJ,DQTIME,ER,FAIL,I,N,POP,POK,PTR,PTRN,PBAT,PBATN,PFLAG,RT,X,X1,XMDUZ,XMDT,XMM,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,IOX,IOY,XMZ,Y,^PRCF("LIST") Q
F I=1:1 S PBATN=$O(^PRCF(421.2,"AD","Y",0)) Q:+PBATN=0 S PBAT=$P(^PRCF(421.2,PBATN,0),"^") D BLIST K ^PRCF(421.2,"AD","Y",PBATN) S I=1
BLIST 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,"AK","Y",N)="",$P(^PRCF(423,N,"TRANS"),"^",11)="Y" W "."
I +PBATN>0 S DA=PBATN D Q15
Q
Q15 I '$D(PRC("PER")) D DUZ^PRCFSITE Q:'%
S:$D(P) PX=P
D NOW^%DTC
S XDT=%
S X1=$P(PRC("PER"),"^",2)
S $P(^PRCF(421.2,DA,0),"^",4+PRCFRT)=XDT
K XDT
S MESSAGE=""
I PRCFRT=0 D ENCODE^PRCFAES1(DA,DUZ,.MESSAGE)
I PRCFRT=3 D ENCODE^PRCFAES2(DA,DUZ,.MESSAGE)
K MESSAGE
K P S:$D(PX) P=PX Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACR0 1408 printed Dec 13, 2024@02:02:08 Page 2
PRCFACR0 ;WISC@ALTOONA/CTB-CONTINUATION OF PRCFACR ;4/30/93 3:05 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 IF '$DATA(^PRCF(421.2,"AD",PRCFKEY))
WRITE !!,"NO BATCHES SELECTED OPTION ABORTED",$CHAR(7)
GOTO OUT
+3 FOR I=1:1
SET PBATN=$ORDER(^PRCF(421.2,"AD","Y",0))
if +PBATN=0
QUIT
SET PBAT=$PIECE(^PRCF(421.2,PBATN,0),"^")
DO BLIST
KILL ^PRCF(421.2,"AD","Y",PBATN)
SET I=1
+4 SET ZTSAVE("PRCFRT")=""
SET ZTSAVE("PRCFASYS")=""
SET ZTSAVE("PRCFKEY")=""
SET ZTRTN="^PRCFACR1"
SET ZTDESC="TRANSMIT "_$SELECT(PRCFASYS["LOG":"LOG ",PRCFASYS["ISM":"ISM ",PRCFASYS["EDI":"EDI ",1:"")_"CODE SHEETS"
DO ^PRCFQ
OUT KILL %,%DT,%H,%Y,A,B,C,DIC,DIJ,DQTIME,ER,FAIL,I,N,POP,POK,PTR,PTRN,PBAT,PBATN,PFLAG,RT,X,X1,XMDUZ,XMDT,XMM,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,IOX,IOY,XMZ,Y,^PRCF("LIST")
QUIT
+1 FOR I=1:1
SET PBATN=$ORDER(^PRCF(421.2,"AD","Y",0))
if +PBATN=0
QUIT
SET PBAT=$PIECE(^PRCF(421.2,PBATN,0),"^")
DO BLIST
KILL ^PRCF(421.2,"AD","Y",PBATN)
SET I=1
BLIST 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,"AK","Y",N)=""
SET $PIECE(^PRCF(423,N,"TRANS"),"^",11)="Y"
WRITE "."
+1 IF +PBATN>0
SET DA=PBATN
DO Q15
+2 QUIT
Q15 IF '$DATA(PRC("PER"))
DO DUZ^PRCFSITE
if '%
QUIT
+1 if $DATA(P)
SET PX=P
+2 DO NOW^%DTC
+3 SET XDT=%
+4 SET X1=$PIECE(PRC("PER"),"^",2)
+5 SET $PIECE(^PRCF(421.2,DA,0),"^",4+PRCFRT)=XDT
+6 KILL XDT
+7 SET MESSAGE=""
+8 IF PRCFRT=0
DO ENCODE^PRCFAES1(DA,DUZ,.MESSAGE)
+9 IF PRCFRT=3
DO ENCODE^PRCFAES2(DA,DUZ,.MESSAGE)
+10 KILL MESSAGE
+11 KILL P
if $DATA(PX)
SET P=PX
QUIT
+12 QUIT
