- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACP1 3773 printed Apr 23, 2025@18:16:33 Page 2
- PRCFACP1 ;WISC@ALTOONA/CTB-BATCH CODE SHEETS ;4/20/93 16:02
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 IF '$DATA(PRC("SITE"))
- DO ^PRCFSITE
- if '%
- QUIT
- if '$DATA(PRCFASYS)
- SET PRCFASYS="CLMFEEFENIRSCLI"
- +3 DO NOW^%DTC
- SET PRCFKEY=%_"-"_DUZ
- +4 SET X=$EXTRACT(PRCFASYS,1,3)_" BATCH/TRANSMIT"
- DO LOCK^PRCFALCK
- if '%
- QUIT
- +5 SET IOP=$SELECT($DATA(ION):ION,1:IO)
- DO ^%ZIS
- 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)
- TRANS ;GET NEXT TRANSMISSION NUMBER
- +1 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
- +2 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)=+Y
- SET PTR=$PIECE(Y,"^",2)
- DO NOW^%DTC
- SET DIE=DIC
- SET DR=".5////T;.7////"_%_";.8////"_DUZ
- DO ^DIE
- +3 FOR PRCFI=1:1
- SET N=$ORDER(^PRCF(423,"AC","N",N))
- if N=""
- QUIT
- DO PROC
- +4 DO ASSIGN
- +5 SET IOP=$SELECT($DATA(ION):ION,1:IO)
- SET DIC="^PRCF(423,"
- SET L=0
- SET BY="[PRCFA BATCH PRINT SORT]"
- SET FLDS="[PRCFA BATCH LISTING TRAILER]"
- SET (TO,FR)=PRCFKEY
- DO EN1^DIP
- +6 SET T=T2
- +7 FOR I=1:1
- SET N=$ORDER(^PRCF(423,"AJ",PRCFKEY,0))
- if N=""
- QUIT
- Begin DoDot:1
- +8 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")
- +9 KILL ^PRCF(423,"AJ",PRCFKEY,N),^PRCF(423,"AC","N",N)
- End DoDot:1
- +10 KILL PRCF("T")
- +11 KILL %,%H,%I,DLAYGO,DP,DR,I,IOX,IOY,N,PBA,PBAT,PBATN,PDATE,PMO,PSN,PTR,PTECH,PTRN,PTYP,PYR,T,T1,Y
- +12 if $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- BEL ;PRINT BATCH ERROR LISTING
- +1 IF '$DATA(^PRCF(423,"AL",PRCFKEY))
- WRITE !!,"NO CODE SHEET ERRORS FOUND WHILE BATCHING",!!!
- GOTO END
- +2 SET IOP=$SELECT($DATA(ION):ION,1:IO)
- +3 SET DIC="^PRCF(423,"
- SET L=0
- SET (BY,FLDS)="[PRCFA ERROR LIST]"
- SET (FR,TO)=PRCFKEY
- DO EN1^DIP
- +4 FOR I=1:1
- SET N=$ORDER(^PRCF(423,"AL",PRCFKEY,0))
- if N=""
- QUIT
- Begin DoDot:1
- +5 SET PRCF("T")=$SELECT($DATA(^PRCF(423,N,"TRANS")):^("TRANS"),1:"")
- SET $PIECE(PRCF("T"),"^",1,2)="N"_"^"_T2
- SET $PIECE(PRCF("T"),"^",12)=""
- SET ^("TRANS")=PRCF("T")
- SET ^PRCF(423,"AC","N",N)=""
- +6 KILL ^PRCF(423,"AL",PRCFKEY,N)
- End DoDot:1
- +7 KILL PRCFKEY,T2
- END SET X=$EXTRACT(PRCFASYS,1,3)_" BATCH/TRANSMIT"
- DO UNLOCK^PRCFALCK
- KILL PRCF("PCODE")
- QUIT
- +1 ;
- ER SET X="UNABLE TO CREATE TEMPORARY LIST ENTRY. NO FURTHER ACTION TAKEN."
- DO MSG^PRCFQ
- QUIT
- PROC ;PROCESS ENTRY IN CROSS REFERENCE
- +1 IF '$DATA(^PRCF(423,N))
- KILL ^PRCF(423,"AC","N",N)
- QUIT
- +2 IF '$DATA(^PRCF(423,N,0))
- SET X=1
- DO ERR
- QUIT
- +3 SET PRCF(0)=^PRCF(423,N,0)
- IF PRCFASYS'[$PIECE(PRCF(0),"^",10)
- DO KILL
- QUIT
- +4 SET PSN=$PIECE(PRCF(0),U,2)
- +5 IF $SELECT('$DATA(PSN):1,PSN="":1,1:0)
- SET X=5
- DO ERR
- QUIT
- +6 IF PSN'=PRC("SITE")
- DO KILL
- QUIT
- +7 IF '$DATA(^PRCF(423,N,"TRANS"))
- SET X=2
- DO ERR
- QUIT
- +8 SET PRCF("T")=^PRCF(423,N,"TRANS")
- IF $PIECE(PRCF("T"),U,3)>T
- DO KILL
- QUIT
- +9 SET PMO=$PIECE(PRCF(0),U,5)
- SET PTECH=$PIECE(PRCF(0),"^",8)
- +10 IF PMO=""
- SET X=3
- DO ERR
- QUIT
- +11 IF PTECH=""
- SET X=4
- DO ERR
- QUIT
- +12 SET PMO="2"_$EXTRACT(PMO,5,6)_$EXTRACT(PMO,1,2)_"00"
- SET PTYP=$PIECE(PRCF("T"),U,4)
- +13 IF $SELECT('$DATA(PTYP):1,PTYP="":1,1:0)
- SET X=6
- DO ERR
- QUIT
- +14 if $PIECE(PRCF("T"),U,6)=""
- SET $PIECE(PRCF("T"),U,6)="3"
- SET PRIO=$PIECE(PRCF("T"),U,6)
- +15 SET ^TMP("PRCF-BATCH",$JOB,PMO_"-"_PTYP,PRIO,N)=""
- +16 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")
- +17 KILL PRIO,PMO,PSN,PTYP,PBA,PBAT,PTECH
- QUIT
- ASSIGN ;ASSIGN CODE SHEETS TO BATCHES BY MONTH, BATCH TYPE AND PRIORITY
- +1 ;MOVED 'ASSIGN' TO PRCFACP2 DUE TO SIZE LIMITATIONS
- +2 DO ASSIGN^PRCFACP2
- +3 QUIT
- ERR ;RECORD CODE SHEET WITH ERRORS
- +1 SET $PIECE(^PRCF(423,N,"TRANS"),"^",12,14)=PRCFKEY_"^^"_X
- SET ^PRCF(423,"AL",PRCFKEY,N)=""
- +2 QUIT
- KILL ;
- +1 KILL PRCF(0),PRCF("T"),PMO,PDATE,PTECH,PSN,PTYP
- +2 QUIT
- REP ;PRINT ERROR LIST (PRCFA ERROR REPRINT) OPTION
- +1 SET PRCF("X")="AS"
- DO ^PRCFSITE
- IF '%
- KILL PRC
- QUIT
- +2 NEW PRCFDHIT
- SET DIOBEG="S PRCFDHIT=0"
- SET DHIT="S PRCFDHIT=PRCFDHIT+1"
- +3 SET DIOEND="I 'PRCFDHIT W !!,""LOG CODE SHEET BATCHING ERROR LIST"",!!,""NO CODE SHEET BATCHING ERRORS FOUND"",!!,""[ End of Report ]"""
- +4 SET DIC="^PRCF(423,"
- SET BY="[PRCFA REPRINT ERROR LIST]"
- SET FLDS="[PRCFA ERROR LIST]"
- SET DIS(0)="I $P(^PRCF(423,D0,0),U,2)=PRC(""SITE"")"
- SET L=0
- DO EN1^DIP
- +5 QUIT
