PRCB1F ;WISC/PLT-IFCAP MONTHLY ACCRUAL ;8/6/21 10:46
V ;;5.1;IFCAP;**64,72,142,159,225**;Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
QUIT ;invalid entry
;
;ZTQPARAM=999 if from schedule option
EN ;monthly accrual
N PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCDES,PTCTD
N A,B,C
; S PRCQCD=1 ;over lapping days
G Q4:$G(ZTQPARAM)=999!$G(ZTQUEUED)
Q1 ;station
S PRCF("X")="AS" D ^PRCFSITE G:'% EXIT
S PRCRI(420)=+PRC("SITE"),PRCOPT=1
Q4 ;accrual for month/year
S A=$$DATE^PRC0C("T","E")
S PRCTD=$P(A,"^",4)_"/"_$E($P(A,"^",3),3,4)_"^"_$P(A,"^",7)_"^"_$P(A,"^",8)
S A=$$DATE^PRC0C($P(A,"^",4)_"/1/"_$P(A,"^",3),"E"),$P(PRCTD,"^",4,6)=$P(A,"^",4)_"/"_$E($P(A,"^",3),3,4)_"^"_$P(A,"^",7)_"^"_$P(A,"^",8)
S A=$$DATE^PRC0C($P(A,"^",8)-15,"H")
S A=$$DATE^PRC0C($P(A,"^",4)_"/1/"_$P(A,"^",3),"E"),$P(PRCTD,"^",7,9)=$P(A,"^",4)_"/"_$E($P(A,"^",3),3,4)_"^"_$P(A,"^",7)_"^"_$P(A,"^",8)
G SCHED:$G(ZTQPARAM)=999!$G(ZTQUEUED)
S E="O^4:7^K:X'?1.2N1""/""2N&(X'?1.2N1""/""4N)!(X<1!(X>12)) X",Y(1)="Enter an accrual month/year in format: MM/YY or MM/YYYY. For example: 9/96 or 9/1996"
D FT^PRC0A(.X,.Y,"For Accrual Month/Year",E,$P(PRCTD,"^"))
G:X["^"!(X="")!(Y'?1.2N1"/"2.4N) EXIT
S $P(Y,"/",2)=+$$YEAR^PRC0C($P(Y,"/",2)),$P(Y,"/")=$E(100+Y,2,3)
S PRCA=Y,A=$$DATE^PRC0C(PRCA,"E"),$P(PRCA,"^",2,999)=A W " Fiscal Month/Year: ",$P(PRCA,"^",10),"/",$P(PRCA,"^",2)
S $P(PRCA,"^",11)=$P(PRCA,"^",8)_"-"_PRC("SITE")
I $P(PRCA,"^",9)<$P(PRCTD,"^",9),$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0))<1 D EN^DDIOL("Accrual report for "_$P(PRCA,"^")_" is NOT in file.") G Q4
I $P(PRCTD,"^",6)<$P(PRCA,"^",9) D EN^DDIOL("Too early to accrue for "_$P(PRCA,"^")) G Q4
S $P(PRCA,"^",12)=0
Q40 S B="O^1:Compile/Print Monthly Accrual;2:Edit Monthly Accrual;3:Generate/Rebuild FMS SV-Document"
K X,Y S Y(1)="^W ""Enter an option number 1 to 3."""
D SC^PRC0A(.X,.Y,"Select Number",B,"")
S A=Y K X,Y
G Q4:A=""!(A["^")
S PRCOPT=+A
G Q45:PRCOPT=2,Q47:PRCOPT=3
I $O(^PRCH(440.6,"ST","N~",0)) D EN^DDIOL("Warning: An unregistered card exists in your file. Contact the P.C. Coordinator.")
I $P(PRCA,"^",9)'=$P(PRCTD,"^",6),$P(PRCA,"^",9)'=$P(PRCTD,"^",9) G Q5
S PRCRI(440.7)=$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0)) G Q5:'PRCRI(440.7)
S A=^PRCH(440.7,PRCRI(440.7),0),B=$P(A,"^",2),B=$E(B,4,5)_"/"_$E(B,6,7)_"/"_$E(B,2,3)_"@"_$E(B,9,10)_":"_($E(B,11)\1)_($E(B,12)\1)
D EN^DDIOL("The last compiling date is "_B)
D:$P(A,"^",6) EN^DDIOL("Warning: Recompiling will overwrite all edited accrual amounts")
Q41 D YN^PRC0A(.X,.Y,"Recompile Accrual Report:","O","NO")
I X["^" G Q4
L +^PRCH(440.7,PRCRI(440.7)):5 E W !,"Another user has this Accrual File open, please try later" G Q40
S $P(PRCA,"^",12)=Y G Q5
Q45 ;eidt accrual amount
I $P(PRCA,"^",9)'=$P(PRCTD,"^",6),$P(PRCA,"^",9)'=$P(PRCTD,"^",9) D EN^DDIOL("It is too late to edit accrual amounts") G Q4
S PRCRI(440.7)=$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0))
I 'PRCRI(440.7) D EN^DDIOL("You need to select Compile/Print option first") G Q40
L +^PRCH(440.7,PRCRI(440.7)):5 E W !,"Another user has this Accrual File open, please try later" G Q40
G Q5
;
Q47 ;generate sv-document
I $P(PRCA,"^",9)'=$P(PRCTD,"^",6),$P(PRCA,"^",9)'=$P(PRCTD,"^",9) D EN^DDIOL("It is too late to generate SV-documents") G Q4
S PRCRI(440.7)=$O(^PRCH(440.7,"B",$P(PRCA,"^",11),0))
I 'PRCRI(440.7) D EN^DDIOL("You need to select Compile/Print option first") G Q40
L +^PRCH(440.7,PRCRI(440.7)):5 E W !,"Another user has this Accrual File open, please try later" G Q40
S A=^PRCH(440.7,PRCRI(440.7),0) D:$P(A,"^",7)]""
. N GECSDATA
. S A=$P($P(A,"^",7),"/",2),X="SV-"_A D DATA^GECSSGET(X,0)
. I '$G(GECSDATA) D EN^DDIOL(PRCPT_" NOT found!") QUIT
. S PRCRI(2100.1)=GECSDATA,PRCID=GECSDATA(2100.1,PRCRI(2100.1),.01,"E")
. D EN^DDIOL(" "),EN^DDIOL($J("FMS Document: ",15)_PRCID)
. D EN^DDIOL($J("Description: ",15)_GECSDATA(2100.1,PRCRI(2100.1),4,"E"))
. D EN^DDIOL($J("Status: ",15)_GECSDATA(2100.1,PRCRI(2100.1),3,"E"))
. D EN^DDIOL($J("Created: ",15)_GECSDATA(2100.1,PRCRI(2100.1),2,"E"))
. QUIT
G Q5
Q5 D YN^PRC0A(.X,.Y,"Ready to "_$P("Compile/Print,Edit,Generate/Rebuild Document",",",PRCOPT),"O","NO")
I X["^"!(X="")!'Y G Q4
I PRCOPT=1 D ACCR G Q5X
L +^PRCH(440.7,PRCRI(440.7)):3 E W !,"Another user has this Accrual file open, please try later" G Q4
I PRCOPT=2 D EDIT
I PRCOPT=3 D
. D EN^DDIOL("Generating the monthly accrual FMS SV-Document")
. S PRCB=$P(^PRCH(440.7,PRCRI(440.7),0),"^",7)
. D SV^PRCB8B(.X,PRCRI(440.7)_"^"_PRCA,$TR(PRCB,"/","^"))
. I X>0 D EDIT^PRC0B(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7),"2///^S X=""N"";6////"_X)
. QUIT
Q5X I $G(PRCRI(440.7)) L -^PRCH(440.7,PRCRI(440.7)) ;PRC*5.1*159 insures previously compile file entry is unlocked when recompile is queued
; Generating YTD Accrual Extract immediately after generating SV txns
I PRCOPT=3 D
. N PRCX,PRCFY,PRCSTN
. S PRCX=$P(^PRCH(440.7,PRCRI(440.7),0),"^")
. S PRCFY=$E(PRCX,1,3)+1700 S:$E(PRCX,4,5)>9 PRCFY=PRCFY+1
. S PRCSTN=$P(PRCX,"-",2)
. D TASKED^PRCB1GE(PRCFY,PRCSTN)
. QUIT
D EN^DDIOL(" "),EN^DDIOL(" ") G Q4
;
EXIT QUIT
;
;
ACCR ;start accrual
N PRCDUZ
S PRCDUZ=DUZ
S ZTDESC="IFCAP Monthly Accrual for Month/Year: "_$P(PRCA,"^")
S PRCDES=ZTDESC
S ZTRTN="TMEN^PRCB1F1" F A="PRCOPT","PRCA","PRCTD","PRCDUZ","PRCDES","DUZ*" S ZTSAVE(A)=""
D ^PRCFQ
QUIT
;
EDIT ;edit accrual amount
N PRCDI
N A,B,X,Y
D EDIT^PRC0B(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7),"5///T")
Q21 D EN^DDIOL(" "),EN^DDIOL($TR($J("",78)," ","-")) S PRCDI="440.7;^PRCH(440.7,;"_PRCRI(440.7)_";1~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,"
D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEMOQ","Select Fund or FCP/PRJ (ACC) Code: ")
I Y<0!(X="") K X QUIT
K X S PRCRI(440.701)=+Y,PRCAED=$P(Y,"^",3)
S PRCDI=";^PRCH(440.7,;"_PRCRI(440.7)_"~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,;"_PRCRI(440.701)
S A=^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),B=$P(A,"^",2)-$P(A,"^",3)
D EN^DDIOL("Accrual Account: "_$P(A,"^",1))
D EN^DDIOL("Unpaid P.C.O Amount: "_$J($P(A,"^",2),0,2)_" Unreconciled Amount: "_$J($P(A,"^",3),0,2))
D EN^DDIOL("Calculated Accrual Amount: "_$J(B,0,2))
D EDIT^PRC0B(.X,PRCDI,"4;5;6")
G Q21
;
SCHED ;compiling for all stations
S Y=$P(PRCTD,"^",7),$P(Y,"/",2)=+$$YEAR^PRC0C($P(Y,"/",2)),$P(Y,"/")=$E(100+Y,2,3)
S PRCA=Y,A=$$DATE^PRC0C(PRCA,"E"),$P(PRCA,"^",2,999)=A
S PRCRI(420)=0
F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) S PRC("SITE")=$P($G(^PRC(420,PRCRI(420),0)),"^") I PRC("SITE") S $P(PRCA,"^",11)=$P(PRCA,"^",8)_"-"_PRC("SITE") D
. N PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA
. N A,B,C
. S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
. D ACCR^PRCB1F1(PRCA,PRCTD)
. QUIT
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1F 6870 printed Nov 22, 2024@17:10:28 Page 2
PRCB1F ;WISC/PLT-IFCAP MONTHLY ACCRUAL ;8/6/21 10:46
V ;;5.1;IFCAP;**64,72,142,159,225**;Oct 20, 2000;Build 3
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;ZTQPARAM=999 if from schedule option
EN ;monthly accrual
+1 NEW PRCA,PRCB,PRCQCD,PRCOPT,PRCRI,PRCDI,PRCDUZ,PRC,PRCDES,PTCTD
+2 NEW A,B,C
+3 ; S PRCQCD=1 ;over lapping days
+4 if $GET(ZTQPARAM)=999!$GET(ZTQUEUED)
GOTO Q4
Q1 ;station
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
GOTO EXIT
+2 SET PRCRI(420)=+PRC("SITE")
SET PRCOPT=1
Q4 ;accrual for month/year
+1 SET A=$$DATE^PRC0C("T","E")
+2 SET PRCTD=$PIECE(A,"^",4)_"/"_$EXTRACT($PIECE(A,"^",3),3,4)_"^"_$PIECE(A,"^",7)_"^"_$PIECE(A,"^",8)
+3 SET A=$$DATE^PRC0C($PIECE(A,"^",4)_"/1/"_$PIECE(A,"^",3),"E")
SET $PIECE(PRCTD,"^",4,6)=$PIECE(A,"^",4)_"/"_$EXTRACT($PIECE(A,"^",3),3,4)_"^"_$PIECE(A,"^",7)_"^"_$PIECE(A,"^",8)
+4 SET A=$$DATE^PRC0C($PIECE(A,"^",8)-15,"H")
+5 SET A=$$DATE^PRC0C($PIECE(A,"^",4)_"/1/"_$PIECE(A,"^",3),"E")
SET $PIECE(PRCTD,"^",7,9)=$PIECE(A,"^",4)_"/"_$EXTRACT($PIECE(A,"^",3),3,4)_"^"_$PIECE(A,"^",7)_"^"_$PIECE(A,"^",8)
+6 if $GET(ZTQPARAM)=999!$GET(ZTQUEUED)
GOTO SCHED
+7 SET E="O^4:7^K:X'?1.2N1""/""2N&(X'?1.2N1""/""4N)!(X<1!(X>12)) X"
SET Y(1)="Enter an accrual month/year in format: MM/YY or MM/YYYY. For example: 9/96 or 9/1996"
+8 DO FT^PRC0A(.X,.Y,"For Accrual Month/Year",E,$PIECE(PRCTD,"^"))
+9 if X["^"!(X="")!(Y'?1.2N1"/"2.4N)
GOTO EXIT
+10 SET $PIECE(Y,"/",2)=+$$YEAR^PRC0C($PIECE(Y,"/",2))
SET $PIECE(Y,"/")=$EXTRACT(100+Y,2,3)
+11 SET PRCA=Y
SET A=$$DATE^PRC0C(PRCA,"E")
SET $PIECE(PRCA,"^",2,999)=A
WRITE " Fiscal Month/Year: ",$PIECE(PRCA,"^",10),"/",$PIECE(PRCA,"^",2)
+12 SET $PIECE(PRCA,"^",11)=$PIECE(PRCA,"^",8)_"-"_PRC("SITE")
+13 IF $PIECE(PRCA,"^",9)<$PIECE(PRCTD,"^",9)
IF $ORDER(^PRCH(440.7,"B",$PIECE(PRCA,"^",11),0))<1
DO EN^DDIOL("Accrual report for "_$PIECE(PRCA,"^")_" is NOT in file.")
GOTO Q4
+14 IF $PIECE(PRCTD,"^",6)<$PIECE(PRCA,"^",9)
DO EN^DDIOL("Too early to accrue for "_$PIECE(PRCA,"^"))
GOTO Q4
+15 SET $PIECE(PRCA,"^",12)=0
Q40 SET B="O^1:Compile/Print Monthly Accrual;2:Edit Monthly Accrual;3:Generate/Rebuild FMS SV-Document"
+1 KILL X,Y
SET Y(1)="^W ""Enter an option number 1 to 3."""
+2 DO SC^PRC0A(.X,.Y,"Select Number",B,"")
+3 SET A=Y
KILL X,Y
+4 if A=""!(A["^")
GOTO Q4
+5 SET PRCOPT=+A
+6 if PRCOPT=2
GOTO Q45
if PRCOPT=3
GOTO Q47
+7 IF $ORDER(^PRCH(440.6,"ST","N~",0))
DO EN^DDIOL("Warning: An unregistered card exists in your file. Contact the P.C. Coordinator.")
+8 IF $PIECE(PRCA,"^",9)'=$PIECE(PRCTD,"^",6)
IF $PIECE(PRCA,"^",9)'=$PIECE(PRCTD,"^",9)
GOTO Q5
+9 SET PRCRI(440.7)=$ORDER(^PRCH(440.7,"B",$PIECE(PRCA,"^",11),0))
if 'PRCRI(440.7)
GOTO Q5
+10 SET A=^PRCH(440.7,PRCRI(440.7),0)
SET B=$PIECE(A,"^",2)
SET B=$EXTRACT(B,4,5)_"/"_$EXTRACT(B,6,7)_"/"_$EXTRACT(B,2,3)_"@"_$EXTRACT(B,9,10)_":"_($EXTRACT(B,11)\1)_($EXTRACT(B,12)\1)
+11 DO EN^DDIOL("The last compiling date is "_B)
+12 if $PIECE(A,"^",6)
DO EN^DDIOL("Warning: Recompiling will overwrite all edited accrual amounts")
Q41 DO YN^PRC0A(.X,.Y,"Recompile Accrual Report:","O","NO")
+1 IF X["^"
GOTO Q4
+2 LOCK +^PRCH(440.7,PRCRI(440.7)):5
IF '$TEST
WRITE !,"Another user has this Accrual File open, please try later"
GOTO Q40
+3 SET $PIECE(PRCA,"^",12)=Y
GOTO Q5
Q45 ;eidt accrual amount
+1 IF $PIECE(PRCA,"^",9)'=$PIECE(PRCTD,"^",6)
IF $PIECE(PRCA,"^",9)'=$PIECE(PRCTD,"^",9)
DO EN^DDIOL("It is too late to edit accrual amounts")
GOTO Q4
+2 SET PRCRI(440.7)=$ORDER(^PRCH(440.7,"B",$PIECE(PRCA,"^",11),0))
+3 IF 'PRCRI(440.7)
DO EN^DDIOL("You need to select Compile/Print option first")
GOTO Q40
+4 LOCK +^PRCH(440.7,PRCRI(440.7)):5
IF '$TEST
WRITE !,"Another user has this Accrual File open, please try later"
GOTO Q40
+5 GOTO Q5
+6 ;
Q47 ;generate sv-document
+1 IF $PIECE(PRCA,"^",9)'=$PIECE(PRCTD,"^",6)
IF $PIECE(PRCA,"^",9)'=$PIECE(PRCTD,"^",9)
DO EN^DDIOL("It is too late to generate SV-documents")
GOTO Q4
+2 SET PRCRI(440.7)=$ORDER(^PRCH(440.7,"B",$PIECE(PRCA,"^",11),0))
+3 IF 'PRCRI(440.7)
DO EN^DDIOL("You need to select Compile/Print option first")
GOTO Q40
+4 LOCK +^PRCH(440.7,PRCRI(440.7)):5
IF '$TEST
WRITE !,"Another user has this Accrual File open, please try later"
GOTO Q40
+5 SET A=^PRCH(440.7,PRCRI(440.7),0)
if $PIECE(A,"^",7)]""
Begin DoDot:1
+6 NEW GECSDATA
+7 SET A=$PIECE($PIECE(A,"^",7),"/",2)
SET X="SV-"_A
DO DATA^GECSSGET(X,0)
+8 IF '$GET(GECSDATA)
DO EN^DDIOL(PRCPT_" NOT found!")
QUIT
+9 SET PRCRI(2100.1)=GECSDATA
SET PRCID=GECSDATA(2100.1,PRCRI(2100.1),.01,"E")
+10 DO EN^DDIOL(" ")
DO EN^DDIOL($JUSTIFY("FMS Document: ",15)_PRCID)
+11 DO EN^DDIOL($JUSTIFY("Description: ",15)_GECSDATA(2100.1,PRCRI(2100.1),4,"E"))
+12 DO EN^DDIOL($JUSTIFY("Status: ",15)_GECSDATA(2100.1,PRCRI(2100.1),3,"E"))
+13 DO EN^DDIOL($JUSTIFY("Created: ",15)_GECSDATA(2100.1,PRCRI(2100.1),2,"E"))
+14 QUIT
End DoDot:1
+15 GOTO Q5
Q5 DO YN^PRC0A(.X,.Y,"Ready to "_$PIECE("Compile/Print,Edit,Generate/Rebuild Document",",",PRCOPT),"O","NO")
+1 IF X["^"!(X="")!'Y
GOTO Q4
+2 IF PRCOPT=1
DO ACCR
GOTO Q5X
+3 LOCK +^PRCH(440.7,PRCRI(440.7)):3
IF '$TEST
WRITE !,"Another user has this Accrual file open, please try later"
GOTO Q4
+4 IF PRCOPT=2
DO EDIT
+5 IF PRCOPT=3
Begin DoDot:1
+6 DO EN^DDIOL("Generating the monthly accrual FMS SV-Document")
+7 SET PRCB=$PIECE(^PRCH(440.7,PRCRI(440.7),0),"^",7)
+8 DO SV^PRCB8B(.X,PRCRI(440.7)_"^"_PRCA,$TRANSLATE(PRCB,"/","^"))
+9 IF X>0
DO EDIT^PRC0B(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7),"2///^S X=""N"";6////"_X)
+10 QUIT
End DoDot:1
Q5X ;PRC*5.1*159 insures previously compile file entry is unlocked when recompile is queued
IF $GET(PRCRI(440.7))
LOCK -^PRCH(440.7,PRCRI(440.7))
+1 ; Generating YTD Accrual Extract immediately after generating SV txns
+2 IF PRCOPT=3
Begin DoDot:1
+3 NEW PRCX,PRCFY,PRCSTN
+4 SET PRCX=$PIECE(^PRCH(440.7,PRCRI(440.7),0),"^")
+5 SET PRCFY=$EXTRACT(PRCX,1,3)+1700
if $EXTRACT(PRCX,4,5)>9
SET PRCFY=PRCFY+1
+6 SET PRCSTN=$PIECE(PRCX,"-",2)
+7 DO TASKED^PRCB1GE(PRCFY,PRCSTN)
+8 QUIT
End DoDot:1
+9 DO EN^DDIOL(" ")
DO EN^DDIOL(" ")
GOTO Q4
+10 ;
EXIT QUIT
+1 ;
+2 ;
ACCR ;start accrual
+1 NEW PRCDUZ
+2 SET PRCDUZ=DUZ
+3 SET ZTDESC="IFCAP Monthly Accrual for Month/Year: "_$PIECE(PRCA,"^")
+4 SET PRCDES=ZTDESC
+5 SET ZTRTN="TMEN^PRCB1F1"
FOR A="PRCOPT","PRCA","PRCTD","PRCDUZ","PRCDES","DUZ*"
SET ZTSAVE(A)=""
+6 DO ^PRCFQ
+7 QUIT
+8 ;
EDIT ;edit accrual amount
+1 NEW PRCDI
+2 NEW A,B,X,Y
+3 DO EDIT^PRC0B(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7),"5///T")
Q21 DO EN^DDIOL(" ")
DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))
SET PRCDI="440.7;^PRCH(440.7,;"_PRCRI(440.7)_";1~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,"
+1 DO LOOKUP^PRC0B(.X,.Y,PRCDI,"AEMOQ","Select Fund or FCP/PRJ (ACC) Code: ")
+2 IF Y<0!(X="")
KILL X
QUIT
+3 KILL X
SET PRCRI(440.701)=+Y
SET PRCAED=$PIECE(Y,"^",3)
+4 SET PRCDI=";^PRCH(440.7,;"_PRCRI(440.7)_"~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,;"_PRCRI(440.701)
+5 SET A=^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0)
SET B=$PIECE(A,"^",2)-$PIECE(A,"^",3)
+6 DO EN^DDIOL("Accrual Account: "_$PIECE(A,"^",1))
+7 DO EN^DDIOL("Unpaid P.C.O Amount: "_$JUSTIFY($PIECE(A,"^",2),0,2)_" Unreconciled Amount: "_$JUSTIFY($PIECE(A,"^",3),0,2))
+8 DO EN^DDIOL("Calculated Accrual Amount: "_$JUSTIFY(B,0,2))
+9 DO EDIT^PRC0B(.X,PRCDI,"4;5;6")
+10 GOTO Q21
+11 ;
SCHED ;compiling for all stations
+1 SET Y=$PIECE(PRCTD,"^",7)
SET $PIECE(Y,"/",2)=+$$YEAR^PRC0C($PIECE(Y,"/",2))
SET $PIECE(Y,"/")=$EXTRACT(100+Y,2,3)
+2 SET PRCA=Y
SET A=$$DATE^PRC0C(PRCA,"E")
SET $PIECE(PRCA,"^",2,999)=A
+3 SET PRCRI(420)=0
+4 FOR
SET PRCRI(420)=$ORDER(^PRC(420,PRCRI(420)))
if 'PRCRI(420)
QUIT
SET PRC("SITE")=$PIECE($GET(^PRC(420,PRCRI(420),0)),"^")
IF PRC("SITE")
SET $PIECE(PRCA,"^",11)=$PIECE(PRCA,"^",8)_"-"_PRC("SITE")
Begin DoDot:1
+5 NEW PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA
+6 NEW A,B,C
+7 SET PRCID=$PIECE(PRCA,"^",11)
SET PRC("SITE")=$PIECE(PRCID,"-",2)
+8 DO ACCR^PRCB1F1(PRCA,PRCTD)
+9 QUIT
End DoDot:1
+10 QUIT
