PRCFACP1 ;WISC@ALTOONA/CTB-BATCH CODE SHEETS ;4/20/93 16:02
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
I '$D(PRC("SITE")) D ^PRCFSITE Q:'% S:'$D(PRCFASYS) PRCFASYS="CLMFEEFENIRSCLI"
D NOW^%DTC S PRCFKEY=%_"-"_DUZ
S X=$E(PRCFASYS,1,3)_" BATCH/TRANSMIT" D LOCK^PRCFALCK Q:'%
S IOP=$S($D(ION):ION,1:IO) D ^%ZIS,NOW^%DTC S (T2,T)=X,PMO=$E(X,1,5)_"00",PYR=$E(PMO,2,3),U="^",N=0 K ^TMP("PRCF-BATCH",$J)
TRANS ;GET NEXT TRANSMISSION NUMBER
S (X,PRX)=PRC("SITE")_"-"_$E(PRCFASYS,1,3)_"-"_PYR D COUNTER^PRCFACP Q:Y<0 S X=PRX_"-"_$E("000"_Y,$L(Y),10) K PRX
S (DLAYGO,DIC)=421.2,DIC(0)="MXL" D ^DIC K DLAYGO Q:Y<0 G:$P(Y,U,3)'=1 TRANS S (DA,PTRN)=+Y,PTR=$P(Y,"^",2) D NOW^%DTC S DIE=DIC,DR=".5////T;.7////"_%_";.8////"_DUZ D ^DIE
F PRCFI=1:1 S N=$O(^PRCF(423,"AC","N",N)) Q:N="" D PROC
D ASSIGN
S IOP=$S($D(ION):ION,1:IO),DIC="^PRCF(423,",L=0,BY="[PRCFA BATCH PRINT SORT]",FLDS="[PRCFA BATCH LISTING TRAILER]",(TO,FR)=PRCFKEY D EN1^DIP
S T=T2
F I=1:1 S N=$O(^PRCF(423,"AJ",PRCFKEY,0)) Q:N="" D
.S PRCF("T")=$S($D(^PRCF(423,N,"TRANS")):^("TRANS"),1:""),$P(PRCF("T"),"^",1,2)="Y^"_T,$P(PRCF("T"),"^",10)="",$P(PRCF("T"),"^",14)="",^("TRANS")=PRCF("T")
.K ^PRCF(423,"AJ",PRCFKEY,N),^PRCF(423,"AC","N",N)
K PRCF("T")
K %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
D:$D(ZTQUEUED) KILL^%ZTLOAD
BEL ;PRINT BATCH ERROR LISTING
I '$D(^PRCF(423,"AL",PRCFKEY)) W !!,"NO CODE SHEET ERRORS FOUND WHILE BATCHING",!!! G END
S IOP=$S($D(ION):ION,1:IO)
S DIC="^PRCF(423,",L=0,(BY,FLDS)="[PRCFA ERROR LIST]",(FR,TO)=PRCFKEY D EN1^DIP
F I=1:1 S N=$O(^PRCF(423,"AL",PRCFKEY,0)) Q:N="" D
.S PRCF("T")=$S($D(^PRCF(423,N,"TRANS")):^("TRANS"),1:""),$P(PRCF("T"),"^",1,2)="N"_"^"_T2,$P(PRCF("T"),"^",12)="",^("TRANS")=PRCF("T"),^PRCF(423,"AC","N",N)=""
.K ^PRCF(423,"AL",PRCFKEY,N)
K PRCFKEY,T2
END S X=$E(PRCFASYS,1,3)_" BATCH/TRANSMIT" D UNLOCK^PRCFALCK K PRCF("PCODE") Q
;
ER S X="UNABLE TO CREATE TEMPORARY LIST ENTRY. NO FURTHER ACTION TAKEN." D MSG^PRCFQ Q
PROC ;PROCESS ENTRY IN CROSS REFERENCE
I '$D(^PRCF(423,N)) K ^PRCF(423,"AC","N",N) Q
I '$D(^PRCF(423,N,0)) S X=1 D ERR Q
S PRCF(0)=^PRCF(423,N,0) I PRCFASYS'[$P(PRCF(0),"^",10) D KILL Q
S PSN=$P(PRCF(0),U,2)
I $S('$D(PSN):1,PSN="":1,1:0) S X=5 D ERR Q
I PSN'=PRC("SITE") D KILL Q
I '$D(^PRCF(423,N,"TRANS")) S X=2 D ERR Q
S PRCF("T")=^PRCF(423,N,"TRANS") I $P(PRCF("T"),U,3)>T D KILL Q
S PMO=$P(PRCF(0),U,5),PTECH=$P(PRCF(0),"^",8)
I PMO="" S X=3 D ERR Q
I PTECH="" S X=4 D ERR Q
S PMO="2"_$E(PMO,5,6)_$E(PMO,1,2)_"00",PTYP=$P(PRCF("T"),U,4)
I $S('$D(PTYP):1,PTYP="":1,1:0) S X=6 D ERR Q
S:$P(PRCF("T"),U,6)="" $P(PRCF("T"),U,6)="3" S PRIO=$P(PRCF("T"),U,6)
S ^TMP("PRCF-BATCH",$J,PMO_"-"_PTYP,PRIO,N)=""
S $P(PRCF("T"),"^",8)=PTR,$P(PRCF("T"),"^",10)=PRCFKEY,^PRCF(423,N,"TRANS")=PRCF("T"),^PRCF(423,"AJ",PRCFKEY,N)="" K PRCF("T")
K PRIO,PMO,PSN,PTYP,PBA,PBAT,PTECH Q
ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
;MOVED 'ASSIGN' TO PRCFACP2 DUE TO SIZE LIMITATIONS
D ASSIGN^PRCFACP2
Q
ERR ;RECORD CODE SHEET WITH ERRORS
S $P(^PRCF(423,N,"TRANS"),"^",12,14)=PRCFKEY_"^^"_X,^PRCF(423,"AL",PRCFKEY,N)=""
Q
KILL ;
K PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
Q
REP ;PRINT ERROR LIST (PRCFA ERROR REPRINT) OPTION
S PRCF("X")="AS" D ^PRCFSITE I '% K PRC Q
N PRCFDHIT S DIOBEG="S PRCFDHIT=0",DHIT="S PRCFDHIT=PRCFDHIT+1"
S DIOEND="I 'PRCFDHIT W !!,""LOG CODE SHEET BATCHING ERROR LIST"",!!,""NO CODE SHEET BATCHING ERRORS FOUND"",!!,""[ End of Report ]"""
S DIC="^PRCF(423,",BY="[PRCFA REPRINT ERROR LIST]",FLDS="[PRCFA ERROR LIST]",DIS(0)="I $P(^PRCF(423,D0,0),U,2)=PRC(""SITE"")",L=0 D EN1^DIP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACP1 3773 printed Dec 13, 2024@02:02:04 Page 2
PRCFACP1 ;WISC@ALTOONA/CTB-BATCH CODE SHEETS ;4/20/93 16:02
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 IF '$DATA(PRC("SITE"))
DO ^PRCFSITE
if '%
QUIT
if '$DATA(PRCFASYS)
SET PRCFASYS="CLMFEEFENIRSCLI"
+3 DO NOW^%DTC
SET PRCFKEY=%_"-"_DUZ
+4 SET X=$EXTRACT(PRCFASYS,1,3)_" BATCH/TRANSMIT"
DO LOCK^PRCFALCK
if '%
QUIT
+5 SET IOP=$SELECT($DATA(ION):ION,1:IO)
DO ^%ZIS
DO NOW^%DTC
SET (T2,T)=X
SET PMO=$EXTRACT(X,1,5)_"00"
SET PYR=$EXTRACT(PMO,2,3)
SET U="^"
SET N=0
KILL ^TMP("PRCF-BATCH",$JOB)
TRANS ;GET NEXT TRANSMISSION NUMBER
+1 SET (X,PRX)=PRC("SITE")_"-"_$EXTRACT(PRCFASYS,1,3)_"-"_PYR
DO COUNTER^PRCFACP
if Y<0
QUIT
SET X=PRX_"-"_$EXTRACT("000"_Y,$LENGTH(Y),10)
KILL PRX
+2 SET (DLAYGO,DIC)=421.2
SET DIC(0)="MXL"
DO ^DIC
KILL DLAYGO
if Y<0
QUIT
if $PIECE(Y,U,3)'=1
GOTO TRANS
SET (DA,PTRN)=+Y
SET PTR=$PIECE(Y,"^",2)
DO NOW^%DTC
SET DIE=DIC
SET DR=".5////T;.7////"_%_";.8////"_DUZ
DO ^DIE
+3 FOR PRCFI=1:1
SET N=$ORDER(^PRCF(423,"AC","N",N))
if N=""
QUIT
DO PROC
+4 DO ASSIGN
+5 SET IOP=$SELECT($DATA(ION):ION,1:IO)
SET DIC="^PRCF(423,"
SET L=0
SET BY="[PRCFA BATCH PRINT SORT]"
SET FLDS="[PRCFA BATCH LISTING TRAILER]"
SET (TO,FR)=PRCFKEY
DO EN1^DIP
+6 SET T=T2
+7 FOR I=1:1
SET N=$ORDER(^PRCF(423,"AJ",PRCFKEY,0))
if N=""
QUIT
Begin DoDot:1
+8 SET PRCF("T")=$SELECT($DATA(^PRCF(423,N,"TRANS")):^("TRANS"),1:"")
SET $PIECE(PRCF("T"),"^",1,2)="Y^"_T
SET $PIECE(PRCF("T"),"^",10)=""
SET $PIECE(PRCF("T"),"^",14)=""
SET ^("TRANS")=PRCF("T")
+9 KILL ^PRCF(423,"AJ",PRCFKEY,N),^PRCF(423,"AC","N",N)
End DoDot:1
+10 KILL PRCF("T")
+11 KILL %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
+12 if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
BEL ;PRINT BATCH ERROR LISTING
+1 IF '$DATA(^PRCF(423,"AL",PRCFKEY))
WRITE !!,"NO CODE SHEET ERRORS FOUND WHILE BATCHING",!!!
GOTO END
+2 SET IOP=$SELECT($DATA(ION):ION,1:IO)
+3 SET DIC="^PRCF(423,"
SET L=0
SET (BY,FLDS)="[PRCFA ERROR LIST]"
SET (FR,TO)=PRCFKEY
DO EN1^DIP
+4 FOR I=1:1
SET N=$ORDER(^PRCF(423,"AL",PRCFKEY,0))
if N=""
QUIT
Begin DoDot:1
+5 SET PRCF("T")=$SELECT($DATA(^PRCF(423,N,"TRANS")):^("TRANS"),1:"")
SET $PIECE(PRCF("T"),"^",1,2)="N"_"^"_T2
SET $PIECE(PRCF("T"),"^",12)=""
SET ^("TRANS")=PRCF("T")
SET ^PRCF(423,"AC","N",N)=""
+6 KILL ^PRCF(423,"AL",PRCFKEY,N)
End DoDot:1
+7 KILL PRCFKEY,T2
END SET X=$EXTRACT(PRCFASYS,1,3)_" BATCH/TRANSMIT"
DO UNLOCK^PRCFALCK
KILL PRCF("PCODE")
QUIT
+1 ;
ER SET X="UNABLE TO CREATE TEMPORARY LIST ENTRY. NO FURTHER ACTION TAKEN."
DO MSG^PRCFQ
QUIT
PROC ;PROCESS ENTRY IN CROSS REFERENCE
+1 IF '$DATA(^PRCF(423,N))
KILL ^PRCF(423,"AC","N",N)
QUIT
+2 IF '$DATA(^PRCF(423,N,0))
SET X=1
DO ERR
QUIT
+3 SET PRCF(0)=^PRCF(423,N,0)
IF PRCFASYS'[$PIECE(PRCF(0),"^",10)
DO KILL
QUIT
+4 SET PSN=$PIECE(PRCF(0),U,2)
+5 IF $SELECT('$DATA(PSN):1,PSN="":1,1:0)
SET X=5
DO ERR
QUIT
+6 IF PSN'=PRC("SITE")
DO KILL
QUIT
+7 IF '$DATA(^PRCF(423,N,"TRANS"))
SET X=2
DO ERR
QUIT
+8 SET PRCF("T")=^PRCF(423,N,"TRANS")
IF $PIECE(PRCF("T"),U,3)>T
DO KILL
QUIT
+9 SET PMO=$PIECE(PRCF(0),U,5)
SET PTECH=$PIECE(PRCF(0),"^",8)
+10 IF PMO=""
SET X=3
DO ERR
QUIT
+11 IF PTECH=""
SET X=4
DO ERR
QUIT
+12 SET PMO="2"_$EXTRACT(PMO,5,6)_$EXTRACT(PMO,1,2)_"00"
SET PTYP=$PIECE(PRCF("T"),U,4)
+13 IF $SELECT('$DATA(PTYP):1,PTYP="":1,1:0)
SET X=6
DO ERR
QUIT
+14 if $PIECE(PRCF("T"),U,6)=""
SET $PIECE(PRCF("T"),U,6)="3"
SET PRIO=$PIECE(PRCF("T"),U,6)
+15 SET ^TMP("PRCF-BATCH",$JOB,PMO_"-"_PTYP,PRIO,N)=""
+16 SET $PIECE(PRCF("T"),"^",8)=PTR
SET $PIECE(PRCF("T"),"^",10)=PRCFKEY
SET ^PRCF(423,N,"TRANS")=PRCF("T")
SET ^PRCF(423,"AJ",PRCFKEY,N)=""
KILL PRCF("T")
+17 KILL PRIO,PMO,PSN,PTYP,PBA,PBAT,PTECH
QUIT
ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
+1 ;MOVED 'ASSIGN' TO PRCFACP2 DUE TO SIZE LIMITATIONS
+2 DO ASSIGN^PRCFACP2
+3 QUIT
ERR ;RECORD CODE SHEET WITH ERRORS
+1 SET $PIECE(^PRCF(423,N,"TRANS"),"^",12,14)=PRCFKEY_"^^"_X
SET ^PRCF(423,"AL",PRCFKEY,N)=""
+2 QUIT
KILL ;
+1 KILL PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
+2 QUIT
REP ;PRINT ERROR LIST (PRCFA ERROR REPRINT) OPTION
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
IF '%
KILL PRC
QUIT
+2 NEW PRCFDHIT
SET DIOBEG="S PRCFDHIT=0"
SET DHIT="S PRCFDHIT=PRCFDHIT+1"
+3 SET DIOEND="I 'PRCFDHIT W !!,""LOG CODE SHEET BATCHING ERROR LIST"",!!,""NO CODE SHEET BATCHING ERRORS FOUND"",!!,""[ End of Report ]"""
+4 SET DIC="^PRCF(423,"
SET BY="[PRCFA REPRINT ERROR LIST]"
SET FLDS="[PRCFA ERROR LIST]"
SET DIS(0)="I $P(^PRCF(423,D0,0),U,2)=PRC(""SITE"")"
SET L=0
DO EN1^DIP
+5 QUIT
