- 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 Feb 18, 2025@23:30:40 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
