PRCB1F1 ;WISC/PLT-PRCB1F continue ;9/17/96 16:33
V ;;5.1;IFCAP;**142**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
QUIT ;invalid entry
;
;prcduz - user id #
;prcopt data ^1=option #
;prca data= ^1=accrual mm/yy, ^2...^10= date infor, ^11=.01 in file 440.7, ^12="Y" for recompiling
;prctd=today's date infor.
;prcdes = description
TMEN ;accrual
N PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA
N A,B,C
I $D(ZTQUEUED) D KILL^%ZTLOAD
S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
S PRCRI(440.7)=$O(^PRCH(440.7,"B",PRCID,0))
I $P(PRCA,"^",12)!'PRCRI(440.7) D ACCR(PRCA,PRCTD) S PRCRI(440.7)=$O(^PRCH(440.7,"B",PRCID,0)) QUIT:'PRCRI(440.7)
REP ;start to print
D PAGE
S (PRCAMT,PRCAMTP,PRCAMTR,PRCAMTA)=0,(X,PRCSUBT,PRCRI)=""
F S PRCRI=$O(^PRCH(440.7,PRCRI(440.7),50,"B",PRCRI)) Q:PRCRI=""!(X["^") S PRCRI(440.701)=0 F S PRCRI(440.701)=$O(^PRCH(440.7,PRCRI(440.7),50,"B",PRCRI,PRCRI(440.701))) QUIT:'PRCRI(440.701) Q:X["^" D QUIT:X["^"
. S A=^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),B=$P(A,"^",2)-$P(A,"^",3),C="" I $P(A,"^",5)'="" S B=$P(A,"^",5),C="*",X=""
. QUIT:+$P(A,"^",2)=0&(+$P(A,"^",3)=0)&(+$P(A,"^",5)=0)
. I $P(PRCSUBT,"^")'=$P(A,"/",1,4) D S PRCSUBT=$P(A,"/",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 !,$P(A,"^"),?40,$J($P(A,"^",2),12,2),$J($P(A,"^",3),12,2),$J(B,12,2),C
. 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)
. W !!,"Accrual amount followed by '*' means edited amount."
. 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 N A
S A=$$DATE^PRC0C("T","E"),A=$P(A,"^",4)_"/"_$P(A,"^",5)_"/"_$P(A,"^",3)
W @IOF,!,"IFCAP Accrual Report for "_$P(PRCA,"^"),?50,"Printed on ",A
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)
S PRCRI(440.7)=$O(^PRCH(440.7,"B",PRCID,0)) D:PRCRI(440.7)
. D DELETE^PRC0B1(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7))
. QUIT
S X=PRCID,X("DR")="1///^S X=""N"""
D ADD^PRC0B1(.X,.Y,"440.7;^PRCH(440.7,")
S PRCRI(440.7)=+Y
LOCK L +^PRCH(440.7,PRCRI(440.7)):20 E G LOCK
S PRCB=$P($$QTRDATE^PRC0D($P(PRCA,"^",2),$P(PRCA,"^",3)),"^",7)
S PRCDF=$P($$QTRDATE^PRC0D($P(PRCA,"^",2),1),"^",7),PRCDE=$P(PRCA,"^",8)+31
D 410,4406
L -^PRCH(440.7,PRCRI(440.7))
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)]"") I $P(PRCC,"-",3)=$P(PRCD,"-",4),+$P(PRCC,"-",5)=+$P(PRCD,"-",5) D
.. 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)-1<PRCDE
... S PRCG=^PRC(442,PRCRI(442),0)
... S A=$$ACC^PRC0C($P(PRCD,"-"),$P(PRCD,"-",4)_"^"_$P(PRCD,"-",2)_"^"_PRCBBFY)
... QUIT:$P(A,"^",6)>$$DATE^PRC0C(PRCDE,"I")
... QUIT:$P(A,"^",7)<$$DATE^PRC0C(PRCDF,"I")&($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)
... D AE4407(PRCRI(440.7),B,PRCAMT,1)
... 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=$G(^PRCH(440.6,PRCRI(440.6),0)),B=$P(A,"^",6),C=^(5) D:B-1<PRCDE
. 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>$$DATE^PRC0C(PRCDE,"I")
. QUIT:PRCBBEY<$$DATE^PRC0C(PRCDF,"I")&(B'="Y")
. S B=$P(C,"^",1)_"/"_PRCBBFY_"/"_$P(C,"^",5)_"/"_$TR($P(C,"^",2,4),"^","/")
. D AE4407(PRCRI(440.7),B,$P(A,"^",14),2)
. QUIT
QUIT
;
;prca = ri of file 440.7, prcb=account elements, prcc=amount, prcd=1 if order unpaid, 2=if unreconciled
AE4407(PRCA,PRCB,PRCC,PRCD) ;add/edit file 440.701
N PRCDI,PRCRI
N A,B,C,X,Y,Z
S PRCRI(440.7)=PRCA
S PRCDI="440.7;^PRCH(440.7,;"_PRCRI(440.7)_";50~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,"
S PRCRI(440.701)=$O(^PRCH(440.7,PRCRI(440.7),50,"B",PRCB,0)) D:'PRCRI(440.701)
. S X=PRCB
. D ADD^PRC0B1(.X,.Y,PRCDI)
. S PRCRI(440.701)=+Y
. D EDIT^PRC0B(.X,PRCDI_";"_PRCRI(440.701),"5///"_$P(PRCB,"/",5)_";6///"_$P(PRCB,"/",6))
. QUIT
S PRCDI=PRCDI_";"_PRCRI(440.701)
S A=$P(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),"^",PRCD+1)+PRCC
D EDIT^PRC0B(.X,PRCDI,PRCD_"////"_$J(A,"",2))
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1F1 6356 printed Apr 09, 2024@21:00:51 Page 2
PRCB1F1 ;WISC/PLT-PRCB1F continue ;9/17/96 16:33
V ;;5.1;IFCAP;**142**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;prcduz - user id #
+5 ;prcopt data ^1=option #
+6 ;prca data= ^1=accrual mm/yy, ^2...^10= date infor, ^11=.01 in file 440.7, ^12="Y" for recompiling
+7 ;prctd=today's date infor.
+8 ;prcdes = description
TMEN ;accrual
+1 NEW PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA
+2 NEW A,B,C
+3 IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+4 SET PRCID=$PIECE(PRCA,"^",11)
SET PRC("SITE")=$PIECE(PRCID,"-",2)
+5 SET PRCRI(440.7)=$ORDER(^PRCH(440.7,"B",PRCID,0))
+6 IF $PIECE(PRCA,"^",12)!'PRCRI(440.7)
DO ACCR(PRCA,PRCTD)
SET PRCRI(440.7)=$ORDER(^PRCH(440.7,"B",PRCID,0))
if 'PRCRI(440.7)
QUIT
REP ;start to print
+1 DO PAGE
+2 SET (PRCAMT,PRCAMTP,PRCAMTR,PRCAMTA)=0
SET (X,PRCSUBT,PRCRI)=""
+3 FOR
SET PRCRI=$ORDER(^PRCH(440.7,PRCRI(440.7),50,"B",PRCRI))
if PRCRI=""!(X["^")
QUIT
SET PRCRI(440.701)=0
FOR
SET PRCRI(440.701)=$ORDER(^PRCH(440.7,PRCRI(440.7),50,"B",PRCRI,PRCRI(440.701)))
if 'PRCRI(440.701)
QUIT
if X["^"
QUIT
Begin DoDot:1
+4 SET A=^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0)
SET B=$PIECE(A,"^",2)-$PIECE(A,"^",3)
SET C=""
IF $PIECE(A,"^",5)'=""
SET B=$PIECE(A,"^",5)
SET C="*"
SET X=""
+5 if +$PIECE(A,"^",2)=0&(+$PIECE(A,"^",3)=0)&(+$PIECE(A,"^",5)=0)
QUIT
+6 IF $PIECE(PRCSUBT,"^")'=$PIECE(A,"/",1,4)
Begin DoDot:2
+7 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),!
+8 QUIT
End DoDot:2
SET PRCSUBT=$PIECE(A,"/",1,4)
+9 SET PRCAMTP=$PIECE(A,"^",2)+PRCAMTP
SET PRCAMTR=$PIECE(A,"^",3)+PRCAMTR
SET PRCAMTA=B+PRCAMTA
+10 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)
+11 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
+12 WRITE !,$PIECE(A,"^"),?40,$JUSTIFY($PIECE(A,"^",2),12,2),$JUSTIFY($PIECE(A,"^",3),12,2),$JUSTIFY(B,12,2),C
+13 QUIT
End DoDot:1
if X["^"
QUIT
+14 if $GET(X)'["^"
Begin DoDot:1
+15 IF PRCSUBT]""
WRITE !," SUBTOTAL",?40,$JUSTIFY($PIECE(PRCSUBT,"^",2),12,2),$JUSTIFY($PIECE(PRCSUBT,"^",3),12,2),$JUSTIFY($PIECE(PRCSUBT,"^",4),12,2),!
+16 WRITE !!,"TOTAL",?40,$JUSTIFY(PRCAMTP,12,2),$JUSTIFY(PRCAMTR,12,2),$JUSTIFY(PRCAMTA,12,2)
+17 WRITE !!,"Accrual amount followed by '*' means edited amount."
+18 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,"")
+19 QUIT
End DoDot:1
EXIT QUIT
+1 ;
PAGE NEW A
+1 SET A=$$DATE^PRC0C("T","E")
SET A=$PIECE(A,"^",4)_"/"_$PIECE(A,"^",5)_"/"_$PIECE(A,"^",3)
+2 WRITE @IOF,!,"IFCAP Accrual Report for "_$PIECE(PRCA,"^"),?50,"Printed on ",A
+3 WRITE !!,"Station: ",$PIECE(PRCID,"-",2)
+4 WRITE !!,"FUND/BBFY/AO/ACC/CC/BOC",?40,$JUSTIFY("UNPAID PO",12),$JUSTIFY("UNRECON",12),$JUSTIFY("ACCRUAL",12)
+5 QUIT
+6 ;
+7 ;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 SET PRCRI(440.7)=$ORDER(^PRCH(440.7,"B",PRCID,0))
if PRCRI(440.7)
Begin DoDot:1
+6 DO DELETE^PRC0B1(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7))
+7 QUIT
End DoDot:1
+8 SET X=PRCID
SET X("DR")="1///^S X=""N"""
+9 DO ADD^PRC0B1(.X,.Y,"440.7;^PRCH(440.7,")
+10 SET PRCRI(440.7)=+Y
LOCK LOCK +^PRCH(440.7,PRCRI(440.7)):20
IF '$TEST
GOTO LOCK
+1 SET PRCB=$PIECE($$QTRDATE^PRC0D($PIECE(PRCA,"^",2),$PIECE(PRCA,"^",3)),"^",7)
+2 SET PRCDF=$PIECE($$QTRDATE^PRC0D($PIECE(PRCA,"^",2),1),"^",7)
SET PRCDE=$PIECE(PRCA,"^",8)+31
+3 DO 410
DO 4406
+4 LOCK -^PRCH(440.7,PRCRI(440.7))
+5 QUIT
+6 ;
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
+4 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)]"")
IF $PIECE(PRCC,"-",3)=$PIECE(PRCD,"-",4)
IF +$PIECE(PRCC,"-",5)=+$PIECE(PRCD,"-",5)
Begin DoDot:2
+5 SET A=$PIECE(^PRCS(410,PRCRI(410),3),"^",11)
SET PRCAMT=$PIECE(PRCE,"^",8)
SET PRCBBFY=$PIECE($$YEAR^PRC0C($EXTRACT(A,2,3)),"^")
+6 if +PRCAMT=0
QUIT
+7 SET PRCF=PRC("SITE")_"-"_$PIECE(PRCE,"^",5)
+8 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)-1<PRCDE
Begin DoDot:3
+9 SET PRCG=^PRC(442,PRCRI(442),0)
+10 SET A=$$ACC^PRC0C($PIECE(PRCD,"-"),$PIECE(PRCD,"-",4)_"^"_$PIECE(PRCD,"-",2)_"^"_PRCBBFY)
+11 if $PIECE(A,"^",6)>$$DATE^PRC0C(PRCDE,"I")
QUIT
+12 if $PIECE(A,"^",7)<$$DATE^PRC0C(PRCDF,"I")&($PIECE(A,"^",13)'="Y")
QUIT
+13 SET PRCRI(442.01)=$ORDER(^PRC(442,PRCRI(442),2,0))
if 'PRCRI(442.01)
QUIT
+14 SET PRCBOC=$PIECE(^PRC(442,PRCRI(442),2,PRCRI(442.01),0),"^",4)
SET PRCBOC=$PIECE(PRCBOC," ")
+15 SET B=$PIECE(A,"^",5)_"/"_$PIECE(A,"^",6)_"/"_$PIECE(A,"^")_"/"_$PIECE(A,"^",3)_"/"_$PIECE(PRCG,"^",5)_"/"_PRCBOC
+16 SET PRCAMT=PRCAMT-$PIECE($$FP^PRCH0A(PRCRI(442)),"^",2)
+17 DO AE4407(PRCRI(440.7),B,PRCAMT,1)
+18 QUIT
End DoDot:3
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
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=$GET(^PRCH(440.6,PRCRI(440.6),0))
SET B=$PIECE(A,"^",6)
SET C=^(5)
if B-1<PRCDE
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>$$DATE^PRC0C(PRCDE,"I")
QUIT
+9 if PRCBBEY<$$DATE^PRC0C(PRCDF,"I")&(B'="Y")
QUIT
+10 SET B=$PIECE(C,"^",1)_"/"_PRCBBFY_"/"_$PIECE(C,"^",5)_"/"_$TRANSLATE($PIECE(C,"^",2,4),"^","/")
+11 DO AE4407(PRCRI(440.7),B,$PIECE(A,"^",14),2)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
+15 ;prca = ri of file 440.7, prcb=account elements, prcc=amount, prcd=1 if order unpaid, 2=if unreconciled
AE4407(PRCA,PRCB,PRCC,PRCD) ;add/edit file 440.701
+1 NEW PRCDI,PRCRI
+2 NEW A,B,C,X,Y,Z
+3 SET PRCRI(440.7)=PRCA
+4 SET PRCDI="440.7;^PRCH(440.7,;"_PRCRI(440.7)_";50~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,"
+5 SET PRCRI(440.701)=$ORDER(^PRCH(440.7,PRCRI(440.7),50,"B",PRCB,0))
if 'PRCRI(440.701)
Begin DoDot:1
+6 SET X=PRCB
+7 DO ADD^PRC0B1(.X,.Y,PRCDI)
+8 SET PRCRI(440.701)=+Y
+9 DO EDIT^PRC0B(.X,PRCDI_";"_PRCRI(440.701),"5///"_$PIECE(PRCB,"/",5)_";6///"_$PIECE(PRCB,"/",6))
+10 QUIT
End DoDot:1
+11 SET PRCDI=PRCDI_";"_PRCRI(440.701)
+12 SET A=$PIECE(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),"^",PRCD+1)+PRCC
+13 DO EDIT^PRC0B(.X,PRCDI,PRCD_"////"_$JUSTIFY(A,"",2))
+14 QUIT
