PRCFPR3.m

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 ---PRCFPR3   1331     printed  Apr 09, 2024@21:19:36                                                                                                                                                                                                     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