source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACB.m@ 623

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

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1PRCFACB ;WISC/CTB/CLH-BACKGROUND BATCH PRINT CODE SHEETS ;7/14/93 08:17
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N %DT,I,%,DIC,DIE,DR,DA,PRX,X,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y,PRIOP,PMOTYP,PCOUNT,PRIO,%H,%I,B,PRCFLN,TCH,ERROR,A,C,D,D0,DI,DQ,ZTREQ
5 D NOW^%DTC S PRCFKEY=%_"-"_DUZ
6 S PRIOP=$O(^PRC(411,PRC("SITE"),2,"AC","S","")) D 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)
7 S X=PRCFASYS_" BATCH/TRANSMIT" D LOCK^PRCFALCK G:'% QUE
8TRANS 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
9 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,PRCF("TRNM"))=+Y,PTR=$P(Y,"^",2) D NOW^%DTC S DIE=DIC,DR=".5////T;.7////"_%_";.8////"_DUZ D ^DIE
10 F S N=$O(^PRCF(423,"AP",1,N)) Q:N="" D
11 .I '$D(^PRCF(423,N)) K ^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N) Q
12 .I '$D(^PRCF(423,N,0)) S X=1 D ERR Q
13 .S PRCF(0)=^PRCF(423,N,0) I PRCFASYS'[$P(PRCF(0),"^",10) D KILL Q
14 .S PSN=$P(PRCF(0),U,2)
15 .I $S('$D(PSN):1,PSN="":1,1:0) S X=5 D ERR Q
16 .I PSN'=PRC("SITE") D KILL Q
17 .I '$D(^PRCF(423,N,"TRANS")) S X=2 D ERR Q
18 .S PRCF("T")=^PRCF(423,N,"TRANS") I $P(PRCF("T"),U,3)>T D KILL Q
19 .S PMO=$P(PRCF(0),U,5)
20 .I PMO="" S X=3 D ERR Q
21 .S PMO="2"_$E(PMO,5,6)_$E(PMO,1,2)_"00",PTYP=$P(PRCF("T"),U,4)
22 .I $S('$D(PTYP):1,PTYP="":1,1:0) S X=6 D ERR Q
23 .S:$P(PRCF("T"),U,6)="" $P(PRCF("T"),U,6)="3" S PRIO=$P(PRCF("T"),U,6)
24 .S ^TMP("PRCF-BATCH",$J,PMO_"-"_PTYP,PRIO,N)=""
25 .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")
26 .K PRIO,PMO,PSN,PTYP,PBA,PBAT
27 .Q
28 D
29 .S PMOTYP=0 F S PMOTYP=$O(^TMP("PRCF-BATCH",$J,PMOTYP)) Q:'PMOTYP S PMO=$P(PMOTYP,"-"),PTYP=$P(PMOTYP,"-",2) D
30 ..K PRCF(PMOTYP) D BATCH^PRCFACP2 S PRCF("BTCH")=PBAT
31 ..S PRCF(PMOTYP)=0,PCOUNT=$S($D(^PRCF(423.9,PTYP,0)):$P(^(0),"^",3),1:"") S:+PCOUNT=0 PCOUNT=100
32 ..S PRIO=0 F S PRIO=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO)) Q:'PRIO D
33 ...S DA=0 F S DA=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO,DA)) Q:'DA D
34 ....S PRCF("CSDA")=DA I $D(PRCF(PMOTYP))[0 S PRCF(PMOTYP)=0 D BATCH^PRCFACP2
35 ....I PRCF(PMOTYP)'<PCOUNT D:"2,12"[PTYP CREATE^PRCFACP2 D BATCH^PRCFACP2 S PRCF(PMOTYP)=0
36 ....S DA=PRCF("CSDA") K PRCF("CSDA") S X=$P(^PRCF(423,DA,0),"^",5),%DT="",X=$E(X,1,2)_" "_$E(X,3,4)_" "_$E(X,5,6) D ^%DT
37 ....S X=Y S:'$D(PDATE) PDATE=0 S:X>PDATE PDATE=X
38 ....S PRCF("T")=^PRCF(423,DA,"TRANS"),$P(PRCF("T"),"^",5)=PBAT,$P(PRCF("T"),"^",8)=PTR,^PRCF(423,DA,"TRANS")=PRCF("T"),^PRCF(423,"AD",PBAT,DA)=""
39 ....S PRCF(PMOTYP)=PRCF(PMOTYP)+1
40 ....Q
41 ...K PRCFK
42 ...Q
43 ..D:"2,12"[PTYP CREATE^PRCFACP2 K PRCFL S PRIO=0
44 ..Q
45 .K PRCFJ S PMOTYP=0
46 .Q
47 F S N=$O(^PRCF(423,"AJ",PRCFKEY,0)) Q:N="" D
48 .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")
49 .K ^PRCF(423,"AJ",PRCFKEY,N),^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N)
50 K PRCF("T")
51 D:$G(ERROR) PTE
52 K %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
53 F S N=$O(^PRCF(423,"AL",PRCFKEY,0)) Q:N="" D
54 .S PRCF("T")=$S($D(^PRCF(423,N,"TRANS")):^("TRANS"),1:""),$P(PRCF("T"),"^",1,2)="N"_"^"_T2,$P(PRCF("T"),"^",12)=""
55 .S ^PRCF(423,N,"TRANS")=PRCF("T") K ^PRCF(423,"AL",PRCFKEY,N) S (^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N))=""
56 K PRCFKEY,T2
57END S ZTREQ="@",X=PRCFASYS_" BATCH/TRANSMIT" D UNLOCK^PRCFALCK
58 K ^TMP("PRCF-BATCH",$J) Q
59 ;
60ERR ;RECORD CODE SHEET WITH ERRORS
61 S $P(^PRCF(423,N,"TRANS"),"^",14)=X,$P(^("TRANS"),"^",12)=PRCFKEY,^PRCF(423,"AL",PRCFKEY,N)="",ERROR=1
62 Q
63KILL ;
64 K PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
65 Q
66PTE ;print batch error listing
67 S ZTIO=PRIOP,ZTRTN="PTE1^PRCFACB",ZTSAVE("PRC*")="",ZTSAVE("PRIOP")="",ZTDESC="PRINT BACTH LISTING",ZTDTH=$H D ^%ZTLOAD
68 K IO("Q") Q
69PTE1 S DIC="^PRCF(423,",L=0,(BY,FLDS)="[PRCFA ERROR LIST]",(FR,TO)=PRCFKEY
70 S IOP=IO,ZTREQ="@" D EN1^DIP
71 Q
72 ;
73QUE ;requeue
74 S ZTSAVE("*")="",ZTRTN="^PRCFACB",ZTDESC="BACKGROUND BATCHING",ZTDTH=$H D ^%ZTLOAD
75 Q
Note: See TracBrowser for help on using the repository browser.