PRCFPR3 ;WISC/LDB-QUEUED PRINT OF STACK DOCUMENTS ;8/7/92 2:16 PM [ 08/07/92 3:32 PM ]
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
DQ ;Called from PRCFA STACK DOCUMENTS PRINT option to print entries
;in file 421.8 by date as background job
D DT^DICRW,NOW^%DTC S U="^",PRCDT=+$E(%,1,12)
I ALL S DATE1=DATE1-.0001 F S DATE1=$O(^PRC(421.8,"AB",TYPE,DATE1)) Q:'DATE1!(DATE1>(DATE2+.9999)) S PRCD0=0 F S PRCD0=$O(^PRC(421.8,"AB",TYPE,DATE1,PRCD0)) Q:'PRCD0 D
.S PRCDA=0 F S PRCDA=$O(^PRC(421.8,"AB",TYPE,DATE1,PRCD0,PRCDA)) Q:'PRCDA D:$S(PRNT:1,'PRNT&'$P($G(^PRC(421.8,PRCDA,0)),U,7):1,1:"") PROC
I 'ALL S PRCD0=0 F S PRCD0=$O(^TMP("PRCREC",$J,PRCD0)) Q:'PRCD0 S PRCDA=0 F S PRCDA=$O(^TMP("PRCREC",$J,PRCD0,PRCDA)) Q:'PRCDA D PROC
K ALL,PRCDA,PRCD0,PRCHNRQ,RTN,TYPE,VAR,^TMP("PRCREC",$J) Q
PROC S VAR=0 F S VAR=$O(^PRC(421.8,PRCDA,1,VAR)) Q:'VAR I $P($G(^(VAR,0)),U)'="",$P(^(0),U)'="DUZ" S @$P(^(0),U)=$P(^(0),U,2)
S RTN=$TR($P(^PRC(421.8,PRCDA,0),"^",3),"*","^")
I $D(PRCHXXD1) S D1=PRCHXXD1
N DATE1,DATE2,TYPE,ALL S D0=PRCD0 N PRCD0
D @RTN K PRCHNRQ,D0,D1,DA
S DA=PRCDA,DIE="^PRC(421.8,",DR="8////^S X=PRCDT" D ^DIE
S VAR=0 F S VAR=$O(^PRC(421.8,PRCDA,1,VAR)) Q:'VAR I $P($G(^(VAR,0)),U)'="",$P(^(0),U)'="DUZ" K @($P($G(^(0)),U))
END Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFPR3 1331 printed Dec 13, 2024@02:04:17 Page 2
PRCFPR3 ;WISC/LDB-QUEUED PRINT OF STACK DOCUMENTS ;8/7/92 2:16 PM [ 08/07/92 3:32 PM ]
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
DQ ;Called from PRCFA STACK DOCUMENTS PRINT option to print entries
+1 ;in file 421.8 by date as background job
+2 DO DT^DICRW
DO NOW^%DTC
SET U="^"
SET PRCDT=+$EXTRACT(%,1,12)
+3 IF ALL
SET DATE1=DATE1-.0001
FOR
SET DATE1=$ORDER(^PRC(421.8,"AB",TYPE,DATE1))
if 'DATE1!(DATE1>(DATE2+.9999))
QUIT
SET PRCD0=0
FOR
SET PRCD0=$ORDER(^PRC(421.8,"AB",TYPE,DATE1,PRCD0))
if 'PRCD0
QUIT
Begin DoDot:1
+4 SET PRCDA=0
FOR
SET PRCDA=$ORDER(^PRC(421.8,"AB",TYPE,DATE1,PRCD0,PRCDA))
if 'PRCDA
QUIT
if $SELECT(PRNT
DO PROC
End DoDot:1
+5 IF 'ALL
SET PRCD0=0
FOR
SET PRCD0=$ORDER(^TMP("PRCREC",$JOB,PRCD0))
if 'PRCD0
QUIT
SET PRCDA=0
FOR
SET PRCDA=$ORDER(^TMP("PRCREC",$JOB,PRCD0,PRCDA))
if 'PRCDA
QUIT
DO PROC
+6 KILL ALL,PRCDA,PRCD0,PRCHNRQ,RTN,TYPE,VAR,^TMP("PRCREC",$JOB)
QUIT
PROC SET VAR=0
FOR
SET VAR=$ORDER(^PRC(421.8,PRCDA,1,VAR))
if 'VAR
QUIT
IF $PIECE($GET(^(VAR,0)),U)'=""
IF $PIECE(^(0),U)'="DUZ"
SET @$PIECE(^(0),U)=$PIECE(^(0),U,2)
+1 SET RTN=$TRANSLATE($PIECE(^PRC(421.8,PRCDA,0),"^",3),"*","^")
+2 IF $DATA(PRCHXXD1)
SET D1=PRCHXXD1
+3 NEW DATE1,DATE2,TYPE,ALL
SET D0=PRCD0
NEW PRCD0
+4 DO @RTN
KILL PRCHNRQ,D0,D1,DA
+5 SET DA=PRCDA
SET DIE="^PRC(421.8,"
SET DR="8////^S X=PRCDT"
DO ^DIE
+6 SET VAR=0
FOR
SET VAR=$ORDER(^PRC(421.8,PRCDA,1,VAR))
if 'VAR
QUIT
IF $PIECE($GET(^(VAR,0)),U)'=""
IF $PIECE(^(0),U)'="DUZ"
KILL @($PIECE($GET(^(0)),U))
END QUIT
