Routine: PRCB1G1

PRCB1G1 ;WISC/PLT/BGJ-PRCB1G continue ;12/2/97  14:03

V ;;5.1;IFCAP;**44**;Oct 20, 2000

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

 QUIT  ;invalid entry

 ;prcduz - user id #

 ;prcopt data ^1=option #

 ;prca data=fiscal year, ^2=quarter, ^3=fisca year start year, ^4=fy start month, ^5=fy start day, ...

 ;prctd data ^1= today's fiscal year, ^2=today's fy quarter

 ;prcdes = description

TMEN ;accrual

 N PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA,PRCPND

 N PRCDT

 N A,B,C

 I $D(ZTQUEUED) D KILL^%ZTLOAD

 S PRCDT=DT,PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)

 S PRCPND=$P($$DT^PRC0B2($H,"H"),"^",4)

 D ACCR(PRCA,PRCTD)

REP ;start to print

 D PAGE

 S (PRCAMT,PRCAMTP,PRCAMTR,PRCAMTA)=0,PRCSUBT=""

 S PRCRI="" F  S PRCRI=$O(^TMP("PRCB",$J,PRCRI)) QUIT:PRCRI=""  D  QUIT:X["^"

 . S A=^TMP("PRCB",$J,PRCRI,0),B=$P(A,"^",2)-$P(A,"^",3)

 . I $P(PRCSUBT,"^")'=$P(PRCRI,"/",1,4) D  S PRCSUBT=$P(PRCRI,"/",1,4)

 .. I $P(PRCSUBT,"^")]"",$P(PRCSUBT,"^",2)!$P(PRCSUBT,"^",3) W !,"   SUBTOTAL",?40,$J($P(PRCSUBT,"^",2),12,2),$J($P(PRCSUBT,"^",3),12,2),$J($P(PRCSUBT,"^",4),12,2),!

 .. QUIT

 . S PRCAMTP=$P(A,"^",2)+PRCAMTP,PRCAMTR=$P(A,"^",3)+PRCAMTR,PRCAMTA=B+PRCAMTA

 . S $P(PRCSUBT,"^",2)=$P(A,"^",2)+$P(PRCSUBT,"^",2),$P(PRCSUBT,"^",3)=$P(A,"^",3)+$P(PRCSUBT,"^",3),$P(PRCSUBT,"^",4)=B+$P(PRCSUBT,"^",4)

 . I IOSL-3<$Y D:IOST'?1"C-".E PAGE I IOST?1"C-".E S X="",E="O^1:5^",Y(1)="Enter 'RETURN' to continue or '^' to quit" D FT^PRC0A(.X,.Y,"Enter 'RETURN' to continue or '^' to quit",E,"") QUIT:X["^"  D PAGE

 . W !,PRCRI,?40,$J($P(A,"^",2),12,2),$J($P(A,"^",3),12,2),$J(B,12,2)

 . S PRCRI(9999)=PRC("SITE")_"-" F  S PRCRI(9999)=$O(^TMP("PRCB",$J,PRCRI,PRCRI(9999))) QUIT:'PRCRI(9999)  S X="" D  QUIT:X["^"

 .. I IOSL-3<$Y D:IOST'?1"C-".E PAGE I IOST?1"C-".E S X="",E="O^1:5^",Y(1)="Enter 'RETURN' to continue or '^' to quit" D FT^PRC0A(.X,.Y,"Enter 'RETURN' to continue or '^' to quit",E,"") QUIT:X["^"  D PAGE

 .. S A=^TMP("PRCB",$J,PRCRI,PRCRI(9999)),B=^PRC(442,+^(PRCRI(9999)),0),C=$G(^(1)),C=$P(C,"^",15),C=$E(C,4,5)_"/"_$E(C,6,7)_"/"_$E(C,2,3)

 .. W !,?5,$P(B,"^"),?20,C,?40,$J($P(A,"^",2),12,2)

 .. QUIT

 . QUIT

 D:$G(X)'["^"

 . I PRCSUBT]"" W !,"   SUBTOTAL",?40,$J($P(PRCSUBT,"^",2),12,2),$J($P(PRCSUBT,"^",3),12,2),$J($P(PRCSUBT,"^",4),12,2),!

 . W !!,"TOTAL",?40,$J(PRCAMTP,12,2),$J(PRCAMTR,12,2),$J(PRCAMTA,12,2)

 . I IOST?1"C-".E S X="",E="O^1:5^",Y(1)="Report ends, enter 'RETURN' to continue." D FT^PRC0A(.X,.Y,"Report ends, enter 'RETURN' to continue.",E,"")

 . QUIT

EXIT QUIT

PAGE ;

 W @IOF,!,"IFCAP YTD Detail Accrual Report for "_$P(PRCA,"^"),?50,"Printed on ",PRCPND

 W !!,"Station: ",$P(PRCID,"-",2)

 W !!,"FUND/BBFY/AO/ACC/CC/BOC",?40,$J("UNPAID PO",12),$J("UNRECON",12),$J("ACCRUAL",12)

 QUIT

 ;prca = date data, prctd= current date data

ACCR(PRCA,PRCTD) ;compiling accrual data

 N PRC,PRCRI,PRCB,PRCC,PRCD,PRCE,PRCF,PRCG,PRCID,PRCDF,PRCDE,PRCAMT,PRCBOC,PRCBBFY,PRCBBEY

 N A,B,C,X,Y

 D:'$D(ZTQUEUED) EN^DDIOL("Compiling...")

 S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)

 K ^TMP("PRCB",$J)

 S PRCB=$P(PRCA,"^",7)

 S PRCDF=+PRCA,PRCDE=+PRCA

 D 410,4406

 QUIT

410 ;compiling purchase card orders

 S PRCRI=PRCB_"-"_PRC("SITE"),PRCC=PRCRI

 F  S PRCC=$O(^PRCS(410,"RB",PRCC)) QUIT:$P(PRCC,"-",1,2)'=PRCRI!'PRCC  D

 . S PRCRI(410)=0 F  S PRCRI(410)=$O(^PRCS(410,"RB",PRCC,PRCRI(410))) QUIT:'PRCRI(410)  S PRCD=^PRCS(410,PRCRI(410),0),PRCE=$G(^(4)) I "EC"'[$P(PRCD,"^",12)&($P(PRCE,"^",5)]"") D

 .. ;Skip entry if txn # in RB x-ref does not match actual txn #

 .. QUIT:$P(PRCC,"-",$L(PRCC,"-"))'=$P($P(PRCD,"^"),"-",$L($P(PRCD,"^"),"-"))

 .. S A=$P(^PRCS(410,PRCRI(410),3),"^",11),PRCAMT=$P(PRCE,"^",8),PRCBBFY=$P($$YEAR^PRC0C($E(A,2,3)),"^")

 .. QUIT:+PRCAMT=0

 .. S PRCF=PRC("SITE")_"-"_$P(PRCE,"^",5)

 .. S PRCRI(442)=$O(^PRC(442,"B",PRCF,0)) QUIT:'PRCRI(442)  S PRCF=$G(^PRC(442,PRCRI(442),1)) QUIT:$P(^(0),"^",2)'=25!($P(^(0),"^",12)'=PRCRI(410))  D:$P(PRCF,"^",15)'>PRCDT

 ... S PRCG=^PRC(442,PRCRI(442),0),PRCRI(9999)=$P(PRCG,"^") QUIT:$P($G(^(7)),"^",2)=40!($P($G(^(7)),"^",2)=41)

 ... S A=$$ACC^PRC0C($P(PRCD,"-"),$P(PRCD,"-",4)_"^"_$P(PRCD,"-",2)_"^"_PRCBBFY)

 ... QUIT:$P(A,"^",6)>PRCDE

 ... QUIT:$P(A,"^",7)<PRCDF&($P(A,"^",13)'="Y")

 ... S PRCRI(442.01)=$O(^PRC(442,PRCRI(442),2,0)) QUIT:'PRCRI(442.01)

 ... S PRCBOC=$P(^PRC(442,PRCRI(442),2,PRCRI(442.01),0),"^",4),PRCBOC=$P(PRCBOC," ")

 ... S B=$P(A,"^",5)_"/"_$P(A,"^",6)_"/"_$P(A,"^")_"/"_$P(A,"^",3)_"/"_$P(PRCG,"^",5)_"/"_PRCBOC

 ... S PRCAMT=PRCAMT-$P($$FP^PRCH0A(PRCRI(442)),"^",2)

 ... S ^TMP("PRCB",$J,B,PRCRI(9999))=PRCRI(442)_"^"_PRCAMT

 ... S $P(^TMP("PRCB",$J,B,0),"^",2)=$P($G(^TMP("PRCB",$J,B,0)),"^",2)+PRCAMT

 ... QUIT

 .. QUIT

 . QUIT

 QUIT

4406 ;compiling unreconciled records

 N A,B,C,D,X,Y

 S PRCRI="N"

 F  S PRCRI=$O(^PRCH(440.6,"ST",PRCRI)) Q:PRCRI'?1"N".E  S PRCRI(440.6)=0 F  S PRCRI(440.6)=$O(^PRCH(440.6,"ST",PRCRI,PRCRI(440.6))) Q:'PRCRI(440.6)  S A=^PRCH(440.6,PRCRI(440.6),0),B=$P(A,"^",6),C=^(5) D:B-1<PRCDT

 . QUIT:PRC("SITE")-$P(A,"^",8)

 . S PRCBBFY=$P($$YEAR^PRC0C($E($P(A,"^",11),2,3)),"^")

 . S PRCBBEY=$P($$YEAR^PRC0C($E($P(A,"^",12),2,3)),"^")

 . S B=$O(^PRCD(420.3,"B",$P(C,"^",1),"")) I B S B=$P(^PRCD(420.3,B,0),"^",8)

 . QUIT:PRCBBFY>PRCDE

 . QUIT:PRCBBEY<PRCDF&(B'="Y")

 . S B=$P(C,"^",1)_"/"_PRCBBFY_"/"_$P(C,"^",5)_"/"_$TR($P(C,"^",2,4),"^","/")

 . S $P(^TMP("PRCB",$J,B,0),"^",3)=$P($G(^TMP("PRCB",$J,B,0)),"^",3)+$P(A,"^",14)

 . QUIT

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1G1   5570     printed  Mar 13, 2025@21:05:13                                                                                                                                                                                                     Page 2

PRCB1G1   ;WISC/PLT/BGJ-PRCB1G continue ;12/2/97  14:03

V         ;;5.1;IFCAP;**44**;Oct 20, 2000

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

 +2       ;invalid entry

           QUIT

 +3       ;

 +4       ;prcduz - user id #

 +5       ;prcopt data ^1=option #

 +6       ;prca data=fiscal year, ^2=quarter, ^3=fisca year start year, ^4=fy start month, ^5=fy start day, ...

 +7       ;prctd data ^1= today's fiscal year, ^2=today's fy quarter

 +8       ;prcdes = description

TMEN      ;accrual

 +1        NEW PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA,PRCPND

 +2        NEW PRCDT

 +3        NEW A,B,C

 +4        IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +5        SET PRCDT=DT

           SET PRCID=$PIECE(PRCA,"^",11)

           SET PRC("SITE")=$PIECE(PRCID,"-",2)

 +6        SET PRCPND=$PIECE($$DT^PRC0B2($HOROLOG,"H"),"^",4)

 +7        DO ACCR(PRCA,PRCTD)

REP       ;start to print

 +1        DO PAGE

 +2        SET (PRCAMT,PRCAMTP,PRCAMTR,PRCAMTA)=0

           SET PRCSUBT=""

 +3        SET PRCRI=""

FOR

               SET PRCRI=$ORDER(^TMP("PRCB",$JOB,PRCRI))

               if PRCRI=""

                   QUIT

               Begin DoDot:1

 +4                SET A=^TMP("PRCB",$JOB,PRCRI,0)

                   SET B=$PIECE(A,"^",2)-$PIECE(A,"^",3)

 +5                IF $PIECE(PRCSUBT,"^")'=$PIECE(PRCRI,"/",1,4)

                       Begin DoDot:2

 +6                        IF $PIECE(PRCSUBT,"^")]""

                               IF $PIECE(PRCSUBT,"^",2)!$PIECE(PRCSUBT,"^",3)

                                   WRITE !,"   SUBTOTAL",?40,$JUSTIFY($PIECE(PRCSUBT,"^",2),12,2),$JUSTIFY($PIECE(PRCSUBT,"^",3),12,2),$JUSTIFY($PIECE(PRCSUBT,"^",4),12,2),!

 +7                        QUIT

                       End DoDot:2

                       SET PRCSUBT=$PIECE(PRCRI,"/",1,4)

 +8                SET PRCAMTP=$PIECE(A,"^",2)+PRCAMTP

                   SET PRCAMTR=$PIECE(A,"^",3)+PRCAMTR

                   SET PRCAMTA=B+PRCAMTA

 +9                SET $PIECE(PRCSUBT,"^",2)=$PIECE(A,"^",2)+$PIECE(PRCSUBT,"^",2)

                   SET $PIECE(PRCSUBT,"^",3)=$PIECE(A,"^",3)+$PIECE(PRCSUBT,"^",3)

                   SET $PIECE(PRCSUBT,"^",4)=B+$PIECE(PRCSUBT,"^",4)

 +10               IF IOSL-3<$Y

                       if IOST'?1"C-".E

                           DO PAGE

                       IF IOST?1"C-".E

                           SET X=""

                           SET E="O^1:5^"

                           SET Y(1)="Enter 'RETURN' to continue or '^' to quit"

                           DO FT^PRC0A(.X,.Y,"Enter 'RETURN' to continue or '^' to quit",E,"")

                           if X["^"

                               QUIT

                           DO PAGE

 +11               WRITE !,PRCRI,?40,$JUSTIFY($PIECE(A,"^",2),12,2),$JUSTIFY($PIECE(A,"^",3),12,2),$JUSTIFY(B,12,2)

 +12               SET PRCRI(9999)=PRC("SITE")_"-"

FOR

                       SET PRCRI(9999)=$ORDER(^TMP("PRCB",$JOB,PRCRI,PRCRI(9999)))

                       if 'PRCRI(9999)

                           QUIT

                       SET X=""

                       Begin DoDot:2

 +13                       IF IOSL-3<$Y

                               if IOST'?1"C-".E

                                   DO PAGE

                               IF IOST?1"C-".E

                                   SET X=""

                                   SET E="O^1:5^"

                                   SET Y(1)="Enter 'RETURN' to continue or '^' to quit"

                                   DO FT^PRC0A(.X,.Y,"Enter 'RETURN' to continue or '^' to quit",E,"")

                                   if X["^"

                                       QUIT

                                   DO PAGE

 +14                       SET A=^TMP("PRCB",$JOB,PRCRI,PRCRI(9999))

                           SET B=^PRC(442,+^(PRCRI(9999)),0)

                           SET C=$GET(^(1))

                           SET C=$PIECE(C,"^",15)

                           SET C=$EXTRACT(C,4,5)_"/"_$EXTRACT(C,6,7)_"/"_$EXTRACT(C,2,3)

 +15                       WRITE !,?5,$PIECE(B,"^"),?20,C,?40,$JUSTIFY($PIECE(A,"^",2),12,2)

 +16                       QUIT

                       End DoDot:2

                       if X["^"

                           QUIT

 +17               QUIT

               End DoDot:1

               if X["^"

                   QUIT

 +18       if $GET(X)'["^"

               Begin DoDot:1

 +19               IF PRCSUBT]""

                       WRITE !,"   SUBTOTAL",?40,$JUSTIFY($PIECE(PRCSUBT,"^",2),12,2),$JUSTIFY($PIECE(PRCSUBT,"^",3),12,2),$JUSTIFY($PIECE(PRCSUBT,"^",4),12,2),!

 +20               WRITE !!,"TOTAL",?40,$JUSTIFY(PRCAMTP,12,2),$JUSTIFY(PRCAMTR,12,2),$JUSTIFY(PRCAMTA,12,2)

 +21               IF IOST?1"C-".E

                       SET X=""

                       SET E="O^1:5^"

                       SET Y(1)="Report ends, enter 'RETURN' to continue."

                       DO FT^PRC0A(.X,.Y,"Report ends, enter 'RETURN' to continue.",E,"")

 +22               QUIT

               End DoDot:1

EXIT       QUIT

 +1       ;

PAGE      ;

 +1        WRITE @IOF,!,"IFCAP YTD Detail Accrual Report for "_$PIECE(PRCA,"^"),?50,"Printed on ",PRCPND

 +2        WRITE !!,"Station: ",$PIECE(PRCID,"-",2)

 +3        WRITE !!,"FUND/BBFY/AO/ACC/CC/BOC",?40,$JUSTIFY("UNPAID PO",12),$JUSTIFY("UNRECON",12),$JUSTIFY("ACCRUAL",12)

 +4        QUIT

 +5       ;

 +6       ;prca = date data, prctd= current date data

ACCR(PRCA,PRCTD) ;compiling accrual data

 +1        NEW PRC,PRCRI,PRCB,PRCC,PRCD,PRCE,PRCF,PRCG,PRCID,PRCDF,PRCDE,PRCAMT,PRCBOC,PRCBBFY,PRCBBEY

 +2        NEW A,B,C,X,Y

 +3        if '$DATA(ZTQUEUED)

               DO EN^DDIOL("Compiling...")

 +4        SET PRCID=$PIECE(PRCA,"^",11)

           SET PRC("SITE")=$PIECE(PRCID,"-",2)

 +5        KILL ^TMP("PRCB",$JOB)

 +6        SET PRCB=$PIECE(PRCA,"^",7)

 +7        SET PRCDF=+PRCA

           SET PRCDE=+PRCA

 +8        DO 410

           DO 4406

 +9        QUIT

 +10      ;

410       ;compiling purchase card orders

 +1        SET PRCRI=PRCB_"-"_PRC("SITE")

           SET PRCC=PRCRI

 +2        FOR

               SET PRCC=$ORDER(^PRCS(410,"RB",PRCC))

               if $PIECE(PRCC,"-",1,2)'=PRCRI!'PRCC

                   QUIT

               Begin DoDot:1

 +3                SET PRCRI(410)=0

FOR

                       SET PRCRI(410)=$ORDER(^PRCS(410,"RB",PRCC,PRCRI(410)))

                       if 'PRCRI(410)

                           QUIT

                       SET PRCD=^PRCS(410,PRCRI(410),0)

                       SET PRCE=$GET(^(4))

                       IF "EC"'[$PIECE(PRCD,"^",12)&($PIECE(PRCE,"^",5)]"")

                           Begin DoDot:2

 +4       ;Skip entry if txn # in RB x-ref does not match actual txn #

 +5                            if $PIECE(PRCC,"-",$LENGTH(PRCC,"-"))'=$PIECE($PIECE(PRCD,"^"),"-",$LENGTH($PIECE(PRCD,"^"),"-"))

                                   QUIT

 +6                            SET A=$PIECE(^PRCS(410,PRCRI(410),3),"^",11)

                               SET PRCAMT=$PIECE(PRCE,"^",8)

                               SET PRCBBFY=$PIECE($$YEAR^PRC0C($EXTRACT(A,2,3)),"^")

 +7                            if +PRCAMT=0

                                   QUIT

 +8                            SET PRCF=PRC("SITE")_"-"_$PIECE(PRCE,"^",5)

 +9                            SET PRCRI(442)=$ORDER(^PRC(442,"B",PRCF,0))

                               if 'PRCRI(442)

                                   QUIT

                               SET PRCF=$GET(^PRC(442,PRCRI(442),1))

                               if $PIECE(^(0),"^",2)'=25!($PIECE(^(0),"^",12)'=PRCRI(410))

                                   QUIT

                               if $PIECE(PRCF,"^",15)'>PRCDT

                                   Begin DoDot:3

 +10                                   SET PRCG=^PRC(442,PRCRI(442),0)

                                       SET PRCRI(9999)=$PIECE(PRCG,"^")

                                       if $PIECE($GET(^(7)),"^",2)=40!($PIECE($GET(^(7)),"^",2)=41)

                                           QUIT

 +11                                   SET A=$$ACC^PRC0C($PIECE(PRCD,"-"),$PIECE(PRCD,"-",4)_"^"_$PIECE(PRCD,"-",2)_"^"_PRCBBFY)

 +12                                   if $PIECE(A,"^",6)>PRCDE

                                           QUIT

 +13                                   if $PIECE(A,"^",7)<PRCDF&($PIECE(A,"^",13)'="Y")

                                           QUIT

 +14                                   SET PRCRI(442.01)=$ORDER(^PRC(442,PRCRI(442),2,0))

                                       if 'PRCRI(442.01)

                                           QUIT

 +15                                   SET PRCBOC=$PIECE(^PRC(442,PRCRI(442),2,PRCRI(442.01),0),"^",4)

                                       SET PRCBOC=$PIECE(PRCBOC," ")

 +16                                   SET B=$PIECE(A,"^",5)_"/"_$PIECE(A,"^",6)_"/"_$PIECE(A,"^")_"/"_$PIECE(A,"^",3)_"/"_$PIECE(PRCG,"^",5)_"/"_PRCBOC

 +17                                   SET PRCAMT=PRCAMT-$PIECE($$FP^PRCH0A(PRCRI(442)),"^",2)

 +18                                   SET ^TMP("PRCB",$JOB,B,PRCRI(9999))=PRCRI(442)_"^"_PRCAMT

 +19                                   SET $PIECE(^TMP("PRCB",$JOB,B,0),"^",2)=$PIECE($GET(^TMP("PRCB",$JOB,B,0)),"^",2)+PRCAMT

 +20                                   QUIT

                                   End DoDot:3

 +21                           QUIT

                           End DoDot:2

 +22               QUIT

               End DoDot:1

 +23       QUIT

 +24      ;

4406      ;compiling unreconciled records

 +1        NEW A,B,C,D,X,Y

 +2        SET PRCRI="N"

 +3        FOR

               SET PRCRI=$ORDER(^PRCH(440.6,"ST",PRCRI))

               if PRCRI'?1"N".E

                   QUIT

               SET PRCRI(440.6)=0

FOR

                   SET PRCRI(440.6)=$ORDER(^PRCH(440.6,"ST",PRCRI,PRCRI(440.6)))

                   if 'PRCRI(440.6)

                       QUIT

                   SET A=^PRCH(440.6,PRCRI(440.6),0)

                   SET B=$PIECE(A,"^",6)

                   SET C=^(5)

                   if B-1<PRCDT

                       Begin DoDot:1

 +4                        if PRC("SITE")-$PIECE(A,"^",8)

                               QUIT

 +5                        SET PRCBBFY=$PIECE($$YEAR^PRC0C($EXTRACT($PIECE(A,"^",11),2,3)),"^")

 +6                        SET PRCBBEY=$PIECE($$YEAR^PRC0C($EXTRACT($PIECE(A,"^",12),2,3)),"^")

 +7                        SET B=$ORDER(^PRCD(420.3,"B",$PIECE(C,"^",1),""))

                           IF B

                               SET B=$PIECE(^PRCD(420.3,B,0),"^",8)

 +8                        if PRCBBFY>PRCDE

                               QUIT

 +9                        if PRCBBEY<PRCDF&(B'="Y")

                               QUIT

 +10                       SET B=$PIECE(C,"^",1)_"/"_PRCBBFY_"/"_$PIECE(C,"^",5)_"/"_$TRANSLATE($PIECE(C,"^",2,4),"^","/")

 +11                       SET $PIECE(^TMP("PRCB",$JOB,B,0),"^",3)=$PIECE($GET(^TMP("PRCB",$JOB,B,0)),"^",3)+$PIECE(A,"^",14)

 +12                       QUIT

                       End DoDot:1

 +13       QUIT

 +14      ;

PRCB1G1.m