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

Last change on this file since 1582 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PRCFACP1 ;WISC@ALTOONA/CTB-BATCH CODE SHEETS ;4/20/93 16:02
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 I '$D(PRC("SITE")) D ^PRCFSITE Q:'% S:'$D(PRCFASYS) PRCFASYS="CLMFEEFENIRSCLI"
5 D NOW^%DTC S PRCFKEY=%_"-"_DUZ
6 S X=$E(PRCFASYS,1,3)_" BATCH/TRANSMIT" D LOCK^PRCFALCK Q:'%
7 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)
8TRANS ;GET NEXT TRANSMISSION NUMBER
9 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
10 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
11 F PRCFI=1:1 S N=$O(^PRCF(423,"AC","N",N)) Q:N="" D PROC
12 D ASSIGN
13 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
14 S T=T2
15 F I=1:1 S N=$O(^PRCF(423,"AJ",PRCFKEY,0)) Q:N="" D
16 .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")
17 .K ^PRCF(423,"AJ",PRCFKEY,N),^PRCF(423,"AC","N",N)
18 K PRCF("T")
19 K %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
20 D:$D(ZTQUEUED) KILL^%ZTLOAD
21BEL ;PRINT BATCH ERROR LISTING
22 I '$D(^PRCF(423,"AL",PRCFKEY)) W !!,"NO CODE SHEET ERRORS FOUND WHILE BATCHING",!!! G END
23 S IOP=$S($D(ION):ION,1:IO)
24 S DIC="^PRCF(423,",L=0,(BY,FLDS)="[PRCFA ERROR LIST]",(FR,TO)=PRCFKEY D EN1^DIP
25 F I=1:1 S N=$O(^PRCF(423,"AL",PRCFKEY,0)) Q:N="" D
26 .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)=""
27 .K ^PRCF(423,"AL",PRCFKEY,N)
28 K PRCFKEY,T2
29END S X=$E(PRCFASYS,1,3)_" BATCH/TRANSMIT" D UNLOCK^PRCFALCK K PRCF("PCODE") Q
30 ;
31ER S X="UNABLE TO CREATE TEMPORARY LIST ENTRY. NO FURTHER ACTION TAKEN." D MSG^PRCFQ Q
32PROC ;PROCESS ENTRY IN CROSS REFERENCE
33 I '$D(^PRCF(423,N)) K ^PRCF(423,"AC","N",N) Q
34 I '$D(^PRCF(423,N,0)) S X=1 D ERR Q
35 S PRCF(0)=^PRCF(423,N,0) I PRCFASYS'[$P(PRCF(0),"^",10) D KILL Q
36 S PSN=$P(PRCF(0),U,2)
37 I $S('$D(PSN):1,PSN="":1,1:0) S X=5 D ERR Q
38 I PSN'=PRC("SITE") D KILL Q
39 I '$D(^PRCF(423,N,"TRANS")) S X=2 D ERR Q
40 S PRCF("T")=^PRCF(423,N,"TRANS") I $P(PRCF("T"),U,3)>T D KILL Q
41 S PMO=$P(PRCF(0),U,5),PTECH=$P(PRCF(0),"^",8)
42 I PMO="" S X=3 D ERR Q
43 I PTECH="" S X=4 D ERR Q
44 S PMO="2"_$E(PMO,5,6)_$E(PMO,1,2)_"00",PTYP=$P(PRCF("T"),U,4)
45 I $S('$D(PTYP):1,PTYP="":1,1:0) S X=6 D ERR Q
46 S:$P(PRCF("T"),U,6)="" $P(PRCF("T"),U,6)="3" S PRIO=$P(PRCF("T"),U,6)
47 S ^TMP("PRCF-BATCH",$J,PMO_"-"_PTYP,PRIO,N)=""
48 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")
49 K PRIO,PMO,PSN,PTYP,PBA,PBAT,PTECH Q
50ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
51 ;MOVED 'ASSIGN' TO PRCFACP2 DUE TO SIZE LIMITATIONS
52 D ASSIGN^PRCFACP2
53 Q
54ERR ;RECORD CODE SHEET WITH ERRORS
55 S $P(^PRCF(423,N,"TRANS"),"^",12,14)=PRCFKEY_"^^"_X,^PRCF(423,"AL",PRCFKEY,N)=""
56 Q
57KILL ;
58 K PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
59 Q
60REP ;PRINT ERROR LIST (PRCFA ERROR REPRINT) OPTION
61 S PRCF("X")="AS" D ^PRCFSITE I '% K PRC Q
62 N PRCFDHIT S DIOBEG="S PRCFDHIT=0",DHIT="S PRCFDHIT=PRCFDHIT+1"
63 S DIOEND="I 'PRCFDHIT W !!,""LOG CODE SHEET BATCHING ERROR LIST"",!!,""NO CODE SHEET BATCHING ERRORS FOUND"",!!,""[ End of Report ]"""
64 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
65 Q
Note: See TracBrowser for help on using the repository browser.