- PRCFACB ;WISC/CTB/CLH-BACKGROUND BATCH PRINT CODE SHEETS ;7/14/93 08:17
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- D NOW^%DTC S PRCFKEY=%_"-"_DUZ
- 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)
- S X=PRCFASYS_" BATCH/TRANSMIT" D LOCK^PRCFALCK G:'% QUE
- TRANS 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,PRCF("TRNM"))=+Y,PTR=$P(Y,"^",2) D NOW^%DTC S DIE=DIC,DR=".5////T;.7////"_%_";.8////"_DUZ D ^DIE
- F S N=$O(^PRCF(423,"AP",1,N)) Q:N="" D
- .I '$D(^PRCF(423,N)) K ^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,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)
- .I PMO="" S X=3 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
- .Q
- D
- .S PMOTYP=0 F S PMOTYP=$O(^TMP("PRCF-BATCH",$J,PMOTYP)) Q:'PMOTYP S PMO=$P(PMOTYP,"-"),PTYP=$P(PMOTYP,"-",2) D
- ..K PRCF(PMOTYP) D BATCH^PRCFACP2 S PRCF("BTCH")=PBAT
- ..S PRCF(PMOTYP)=0,PCOUNT=$S($D(^PRCF(423.9,PTYP,0)):$P(^(0),"^",3),1:"") S:+PCOUNT=0 PCOUNT=100
- ..S PRIO=0 F S PRIO=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO)) Q:'PRIO D
- ...S DA=0 F S DA=$O(^TMP("PRCF-BATCH",$J,PMOTYP,PRIO,DA)) Q:'DA D
- ....S PRCF("CSDA")=DA I $D(PRCF(PMOTYP))[0 S PRCF(PMOTYP)=0 D BATCH^PRCFACP2
- ....I PRCF(PMOTYP)'<PCOUNT D:"2,12"[PTYP CREATE^PRCFACP2 D BATCH^PRCFACP2 S PRCF(PMOTYP)=0
- ....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
- ....S X=Y S:'$D(PDATE) PDATE=0 S:X>PDATE PDATE=X
- ....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)=""
- ....S PRCF(PMOTYP)=PRCF(PMOTYP)+1
- ....Q
- ...K PRCFK
- ...Q
- ..D:"2,12"[PTYP CREATE^PRCFACP2 K PRCFL S PRIO=0
- ..Q
- .K PRCFJ S PMOTYP=0
- .Q
- F 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),^PRCF(423,"AP",1,N)
- K PRCF("T")
- D:$G(ERROR) PTE
- K %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
- F 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)=""
- .S ^PRCF(423,N,"TRANS")=PRCF("T") K ^PRCF(423,"AL",PRCFKEY,N) S (^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N))=""
- K PRCFKEY,T2
- END S ZTREQ="@",X=PRCFASYS_" BATCH/TRANSMIT" D UNLOCK^PRCFALCK
- K ^TMP("PRCF-BATCH",$J) Q
- ;
- ERR ;RECORD CODE SHEET WITH ERRORS
- S $P(^PRCF(423,N,"TRANS"),"^",14)=X,$P(^("TRANS"),"^",12)=PRCFKEY,^PRCF(423,"AL",PRCFKEY,N)="",ERROR=1
- Q
- KILL ;
- K PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
- Q
- PTE ;print batch error listing
- S ZTIO=PRIOP,ZTRTN="PTE1^PRCFACB",ZTSAVE("PRC*")="",ZTSAVE("PRIOP")="",ZTDESC="PRINT BACTH LISTING",ZTDTH=$H D ^%ZTLOAD
- K IO("Q") Q
- PTE1 S DIC="^PRCF(423,",L=0,(BY,FLDS)="[PRCFA ERROR LIST]",(FR,TO)=PRCFKEY
- S IOP=IO,ZTREQ="@" D EN1^DIP
- Q
- ;
- QUE ;requeue
- S ZTSAVE("*")="",ZTRTN="^PRCFACB",ZTDESC="BACKGROUND BATCHING",ZTDTH=$H D ^%ZTLOAD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACB 4215 printed Mar 13, 2025@21:06:47 Page 2
- PRCFACB ;WISC/CTB/CLH-BACKGROUND BATCH PRINT CODE SHEETS ;7/14/93 08:17
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW %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
- +3 DO NOW^%DTC
- SET PRCFKEY=%_"-"_DUZ
- +4 SET PRIOP=$ORDER(^PRC(411,PRC("SITE"),2,"AC","S",""))
- 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)
- +5 SET X=PRCFASYS_" BATCH/TRANSMIT"
- DO LOCK^PRCFALCK
- if '%
- GOTO QUE
- TRANS 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
- +1 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,PRCF("TRNM"))=+Y
- SET PTR=$PIECE(Y,"^",2)
- DO NOW^%DTC
- SET DIE=DIC
- SET DR=".5////T;.7////"_%_";.8////"_DUZ
- DO ^DIE
- +2 FOR
- SET N=$ORDER(^PRCF(423,"AP",1,N))
- if N=""
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(^PRCF(423,N))
- KILL ^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N)
- QUIT
- +4 IF '$DATA(^PRCF(423,N,0))
- SET X=1
- DO ERR
- QUIT
- +5 SET PRCF(0)=^PRCF(423,N,0)
- IF PRCFASYS'[$PIECE(PRCF(0),"^",10)
- DO KILL
- QUIT
- +6 SET PSN=$PIECE(PRCF(0),U,2)
- +7 IF $SELECT('$DATA(PSN):1,PSN="":1,1:0)
- SET X=5
- DO ERR
- QUIT
- +8 IF PSN'=PRC("SITE")
- DO KILL
- QUIT
- +9 IF '$DATA(^PRCF(423,N,"TRANS"))
- SET X=2
- DO ERR
- QUIT
- +10 SET PRCF("T")=^PRCF(423,N,"TRANS")
- IF $PIECE(PRCF("T"),U,3)>T
- DO KILL
- QUIT
- +11 SET PMO=$PIECE(PRCF(0),U,5)
- +12 IF PMO=""
- SET X=3
- DO ERR
- QUIT
- +13 SET PMO="2"_$EXTRACT(PMO,5,6)_$EXTRACT(PMO,1,2)_"00"
- SET PTYP=$PIECE(PRCF("T"),U,4)
- +14 IF $SELECT('$DATA(PTYP):1,PTYP="":1,1:0)
- SET X=6
- DO ERR
- QUIT
- +15 if $PIECE(PRCF("T"),U,6)=""
- SET $PIECE(PRCF("T"),U,6)="3"
- SET PRIO=$PIECE(PRCF("T"),U,6)
- +16 SET ^TMP("PRCF-BATCH",$JOB,PMO_"-"_PTYP,PRIO,N)=""
- +17 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")
- +18 KILL PRIO,PMO,PSN,PTYP,PBA,PBAT
- +19 QUIT
- End DoDot:1
- +20 Begin DoDot:1
- +21 SET PMOTYP=0
- FOR
- SET PMOTYP=$ORDER(^TMP("PRCF-BATCH",$JOB,PMOTYP))
- if 'PMOTYP
- QUIT
- SET PMO=$PIECE(PMOTYP,"-")
- SET PTYP=$PIECE(PMOTYP,"-",2)
- Begin DoDot:2
- +22 KILL PRCF(PMOTYP)
- DO BATCH^PRCFACP2
- SET PRCF("BTCH")=PBAT
- +23 SET PRCF(PMOTYP)=0
- SET PCOUNT=$SELECT($DATA(^PRCF(423.9,PTYP,0)):$PIECE(^(0),"^",3),1:"")
- if +PCOUNT=0
- SET PCOUNT=100
- +24 SET PRIO=0
- FOR
- SET PRIO=$ORDER(^TMP("PRCF-BATCH",$JOB,PMOTYP,PRIO))
- if 'PRIO
- QUIT
- Begin DoDot:3
- +25 SET DA=0
- FOR
- SET DA=$ORDER(^TMP("PRCF-BATCH",$JOB,PMOTYP,PRIO,DA))
- if 'DA
- QUIT
- Begin DoDot:4
- +26 SET PRCF("CSDA")=DA
- IF $DATA(PRCF(PMOTYP))[0
- SET PRCF(PMOTYP)=0
- DO BATCH^PRCFACP2
- +27 IF PRCF(PMOTYP)'<PCOUNT
- if "2,12"[PTYP
- DO CREATE^PRCFACP2
- DO BATCH^PRCFACP2
- SET PRCF(PMOTYP)=0
- +28 SET DA=PRCF("CSDA")
- KILL PRCF("CSDA")
- SET X=$PIECE(^PRCF(423,DA,0),"^",5)
- SET %DT=""
- SET X=$EXTRACT(X,1,2)_" "_$EXTRACT(X,3,4)_" "_$EXTRACT(X,5,6)
- DO ^%DT
- +29 SET X=Y
- if '$DATA(PDATE)
- SET PDATE=0
- if X>PDATE
- SET PDATE=X
- +30 SET PRCF("T")=^PRCF(423,DA,"TRANS")
- SET $PIECE(PRCF("T"),"^",5)=PBAT
- SET $PIECE(PRCF("T"),"^",8)=PTR
- SET ^PRCF(423,DA,"TRANS")=PRCF("T")
- SET ^PRCF(423,"AD",PBAT,DA)=""
- +31 SET PRCF(PMOTYP)=PRCF(PMOTYP)+1
- +32 QUIT
- End DoDot:4
- +33 KILL PRCFK
- +34 QUIT
- End DoDot:3
- +35 if "2,12"[PTYP
- DO CREATE^PRCFACP2
- KILL PRCFL
- SET PRIO=0
- +36 QUIT
- End DoDot:2
- +37 KILL PRCFJ
- SET PMOTYP=0
- +38 QUIT
- End DoDot:1
- +39 FOR
- SET N=$ORDER(^PRCF(423,"AJ",PRCFKEY,0))
- if N=""
- QUIT
- Begin DoDot:1
- +40 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")
- +41 KILL ^PRCF(423,"AJ",PRCFKEY,N),^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N)
- End DoDot:1
- +42 KILL PRCF("T")
- +43 if $GET(ERROR)
- DO PTE
- +44 KILL %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
- +45 FOR
- SET N=$ORDER(^PRCF(423,"AL",PRCFKEY,0))
- if N=""
- QUIT
- Begin DoDot:1
- +46 SET PRCF("T")=$SELECT($DATA(^PRCF(423,N,"TRANS")):^("TRANS"),1:"")
- SET $PIECE(PRCF("T"),"^",1,2)="N"_"^"_T2
- SET $PIECE(PRCF("T"),"^",12)=""
- +47 SET ^PRCF(423,N,"TRANS")=PRCF("T")
- KILL ^PRCF(423,"AL",PRCFKEY,N)
- SET (^PRCF(423,"AC","N",N),^PRCF(423,"AP",1,N))=""
- End DoDot:1
- +48 KILL PRCFKEY,T2
- END SET ZTREQ="@"
- SET X=PRCFASYS_" BATCH/TRANSMIT"
- DO UNLOCK^PRCFALCK
- +1 KILL ^TMP("PRCF-BATCH",$JOB)
- QUIT
- +2 ;
- ERR ;RECORD CODE SHEET WITH ERRORS
- +1 SET $PIECE(^PRCF(423,N,"TRANS"),"^",14)=X
- SET $PIECE(^("TRANS"),"^",12)=PRCFKEY
- SET ^PRCF(423,"AL",PRCFKEY,N)=""
- SET ERROR=1
- +2 QUIT
- KILL ;
- +1 KILL PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
- +2 QUIT
- PTE ;print batch error listing
- +1 SET ZTIO=PRIOP
- SET ZTRTN="PTE1^PRCFACB"
- SET ZTSAVE("PRC*")=""
- SET ZTSAVE("PRIOP")=""
- SET ZTDESC="PRINT BACTH LISTING"
- SET ZTDTH=$HOROLOG
- DO ^%ZTLOAD
- +2 KILL IO("Q")
- QUIT
- PTE1 SET DIC="^PRCF(423,"
- SET L=0
- SET (BY,FLDS)="[PRCFA ERROR LIST]"
- SET (FR,TO)=PRCFKEY
- +1 SET IOP=IO
- SET ZTREQ="@"
- DO EN1^DIP
- +2 QUIT
- +3 ;
- QUE ;requeue
- +1 SET ZTSAVE("*")=""
- SET ZTRTN="^PRCFACB"
- SET ZTDESC="BACKGROUND BATCHING"
- SET ZTDTH=$HOROLOG
- DO ^%ZTLOAD
- +2 QUIT
