source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACP1.m@ 1150

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