PRCAKMR.m

PRCAKMR ;WASH-ISC@ALTOONA,PA/CMS-Print Status PENDING ARCHIVE ;8/3/93  12:09 PM

V ;;4.5;Accounts Receivable;**78**;Mar 20, 1995

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;Loop on Pending Archive status, entry point after device selection

 NEW PG,PRCAE,PRCAT,STAT,TR,X,Y

 D HDR

 S STAT=+$O(^PRCA(430.3,"B","PENDING ARCHIVE",0))

 I $P($G(^PRCA(430.3,STAT,0)),"^",1)'="PENDING ARCHIVE" W !!,?5,"* The Pending Archive status is not defined.  Please contact IRM!",! G Q1

 F PRCAE=0:0 S PRCAE=$O(^PRCA(430,"AC",STAT,PRCAE)) Q:'PRCAE  S X="" D HDR:$Y+5>IOSL Q:X="^"  D PRNTL

 I $G(X)'="^" W !!!,?5,+$G(PRCAT)," Bills marked Pending Archive"

 G Q1

PRNTL ;

 ;Print detail data line on report

 S PRCAT=$G(PRCAT)+1

 S X=$S($D(^PRCA(430,PRCAE,0)):^(0),1:"") G:X="" PQ W !,$E($P(X,U,1),1,11)

 W ?13,$S($P(X,U,9):$E($P($$NAM^RCFN01($P(X,U,9)),U),1,21),1:"UNKNOWN")

 W ?36,$S($P(X,U,2):$P($G(^PRCA(430.2,$P(X,U,2),0)),U,2),1:"")

 W ?42,$E($P($G(^PRCA(430.3,+$P($G(^PRCA(430,PRCAE,9)),U,6),0)),U,1),1,10)

 W ?54 S Y=$G(^PRCA(430,PRCAE,7)),Y=$P(Y,"^",1)+$P(Y,"^",2)+$P(Y,"^",3)+$P(Y,"^",4)+$P(Y,"^",5) W $J(Y,0,2)

 W ?67 S Y=$$PUR^PRCAFN(PRCAE) I Y>0 S Y=$P(Y,".",1) X ^DD("DD") W Y

PQ Q

HDR ;

 ;Print header on top of page

 I $E(IOST,1,2)="C-",$G(PG) S X="" R !,"Enter '^' to exit, press any key to continue: ",X:DTIME S:'$T X="^" Q:X="^"

 W @IOF S PG=$G(PG)+1

 N %,%H,%I,X,Y

 D NOW^%DTC S Y=% D DD^%DT

 W !,"Status: PENDING ARCHIVE",?46,Y,?70,"PAGE ",PG

 W !!,?42,"Old Bill",?67,"Last Date",!,"Bill No.",?13,"Debtor",?36,"Cat.",?42,"Status",?54,"Balance",?67,"Activity"

 W ! S X="",$P(X,"-",IOM-1)="" W X,!

 Q

ST ;

 NEW ZTSK,STAT

 W !!,"This report will print the AR bills in the PENDING ARCHIVE status.",!

 L +^PRCAK("PRCAK"):1 I '$T W !!,"Another Archive process is running. This report may not be",!,"accurate.  You may want to re-run at a later time.",!

 L -^PRCAK("PRCAK")

 S %ZIS="MQ" D ^%ZIS G:POP Q1

 I '$D(IO("Q")) U IO D PRCAKMR Q

 S ZTRTN="^PRCAKMR",ZTDESC="AR PENDING ARCHIVE Listing" D ^%ZTLOAD

Q1 D ^%ZISC K POP

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCAKMR   2083     printed  Mar 13, 2025@20:44:54                                                                                                                                                                                                     Page 2

PRCAKMR   ;WASH-ISC@ALTOONA,PA/CMS-Print Status PENDING ARCHIVE ;8/3/93  12:09 PM

V         ;;4.5;Accounts Receivable;**78**;Mar 20, 1995

 +1       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;Loop on Pending Archive status, entry point after device selection

 +3        NEW PG,PRCAE,PRCAT,STAT,TR,X,Y

 +4        DO HDR

 +5        SET STAT=+$ORDER(^PRCA(430.3,"B","PENDING ARCHIVE",0))

 +6        IF $PIECE($GET(^PRCA(430.3,STAT,0)),"^",1)'="PENDING ARCHIVE"

               WRITE !!,?5,"* The Pending Archive status is not defined.  Please contact IRM!",!

               GOTO Q1

 +7        FOR PRCAE=0:0

               SET PRCAE=$ORDER(^PRCA(430,"AC",STAT,PRCAE))

               if 'PRCAE

                   QUIT 

               SET X=""

               if $Y+5>IOSL

                   DO HDR

               if X="^"

                   QUIT 

               DO PRNTL

 +8        IF $GET(X)'="^"

               WRITE !!!,?5,+$GET(PRCAT)," Bills marked Pending Archive"

 +9        GOTO Q1

PRNTL     ;

 +1       ;Print detail data line on report

 +2        SET PRCAT=$GET(PRCAT)+1

 +3        SET X=$SELECT($DATA(^PRCA(430,PRCAE,0)):^(0),1:"")

           if X=""

               GOTO PQ

           WRITE !,$EXTRACT($PIECE(X,U,1),1,11)

 +4        WRITE ?13,$SELECT($PIECE(X,U,9):$EXTRACT($PIECE($$NAM^RCFN01($PIECE(X,U,9)),U),1,21),1:"UNKNOWN")

 +5        WRITE ?36,$SELECT($PIECE(X,U,2):$PIECE($GET(^PRCA(430.2,$PIECE(X,U,2),0)),U,2),1:"")

 +6        WRITE ?42,$EXTRACT($PIECE($GET(^PRCA(430.3,+$PIECE($GET(^PRCA(430,PRCAE,9)),U,6),0)),U,1),1,10)

 +7        WRITE ?54

           SET Y=$GET(^PRCA(430,PRCAE,7))

           SET Y=$PIECE(Y,"^",1)+$PIECE(Y,"^",2)+$PIECE(Y,"^",3)+$PIECE(Y,"^",4)+$PIECE(Y,"^",5)

           WRITE $JUSTIFY(Y,0,2)

 +8        WRITE ?67

           SET Y=$$PUR^PRCAFN(PRCAE)

           IF Y>0

               SET Y=$PIECE(Y,".",1)

               XECUTE ^DD("DD")

               WRITE Y

PQ         QUIT 

HDR       ;

 +1       ;Print header on top of page

 +2        IF $EXTRACT(IOST,1,2)="C-"

               IF $GET(PG)

                   SET X=""

                   READ !,"Enter '^' to exit, press any key to continue: ",X:DTIME

                   if '$TEST

                       SET X="^"

                   if X="^"

                       QUIT 

 +3        WRITE @IOF

           SET PG=$GET(PG)+1

 +4        NEW %,%H,%I,X,Y

 +5        DO NOW^%DTC

           SET Y=%

           DO DD^%DT

 +6        WRITE !,"Status: PENDING ARCHIVE",?46,Y,?70,"PAGE ",PG

 +7        WRITE !!,?42,"Old Bill",?67,"Last Date",!,"Bill No.",?13,"Debtor",?36,"Cat.",?42,"Status",?54,"Balance",?67,"Activity"

 +8        WRITE !

           SET X=""

           SET $PIECE(X,"-",IOM-1)=""

           WRITE X,!

 +9        QUIT 

ST        ;

 +1        NEW ZTSK,STAT

 +2        WRITE !!,"This report will print the AR bills in the PENDING ARCHIVE status.",!

 +3        LOCK +^PRCAK("PRCAK"):1

           IF '$TEST

               WRITE !!,"Another Archive process is running. This report may not be",!,"accurate.  You may want to re-run at a later time.",!

 +4        LOCK -^PRCAK("PRCAK")

 +5        SET %ZIS="MQ"

           DO ^%ZIS

           if POP

               GOTO Q1

 +6        IF '$DATA(IO("Q"))

               USE IO

               DO PRCAKMR

               QUIT 

 +7        SET ZTRTN="^PRCAKMR"

           SET ZTDESC="AR PENDING ARCHIVE Listing"

           DO ^%ZTLOAD

Q1         DO ^%ZISC

           KILL POP

 +1        QUIT