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 Apr 09, 2024@21:11:37 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 ;
