66 lines
3.6 KiB
Mathematica
66 lines
3.6 KiB
Mathematica
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
|