PRCB1E2 ;WISC/PLT-PRCB1E continue ;3/4/97 15:59
V ;;5.1;IFCAP;;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 #, ^2=yyyy-q, ^3=station #, ^4=cp ri
;prcdes = description
;
;prca = prcopt, prcb=fund control point ri
CPBAL(PRCA,PRCB) ;carry forward cp ballance
N PRC,PRCRI,PRCC,PRCD,PRCCOM
N A,B,C,X,Y,Z,DA
S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB
S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")
QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2) ;last qtr always open
S A=$P(PRCOPT,"^",2),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
L +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5
E S PRC("MSG")="Note: Carry forward from "_$P(PRC("CP")," ")_" failed. File locked by another user." D EN^DDIOL(PRC("MSG")) QUIT
S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))
L -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)
QUIT:A=""
S PRCCOM=$P(A,"^",1+PRC("QTR"))
I +PRCCOM=0 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" adjusted with $"_$J(PRCCOM,0,2)_"."
;zero out from CP quarter balances
S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
D EN1^PRCSUT3 S PRC("TXNTO")=X D EN2^PRCSUT3 S PRCRI(410)=DA
I 'PRCRI(410) S PRC("MSG")="Note: CP balance adjust 'to' fails for "_$P(PRC("CP")," ")_" $"_$J(PRCCOM,10,2) D EN^DDIOL(PRC("MSG")) G MM
S A="1///A;40////"_DUZ_";449////"_$P(PRCA,"^",5)_";450////O;25.5////Y;24////QTRADJ;26///T"
D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)
;adjust new CP quarter balance
S PRCCOM=-PRCCOM
S A=$P(PRCOPT,"^",7),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
D EN1^PRCSUT3 S PRC("TXNFR")=X D EN2^PRCSUT3 S PRCRI(410)=DA
I 'PRCRI(410) S PRC("MSG")="Note: CP balance adjust 'from' fails for "_$P(PRC("CP")," ")_" $"_$J(PRCCOM,10,2) D EN^DDIOL(PRC("MSG")) G MM
S A="1///A;40////"_DUZ_";449////"_$P(PRCA,"^",6)_";450////O;25.5////Y;24////QTRADJ;26///T"
D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)
S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" adjusted with $"_$J(PRCCOM,0,2)_"."
MM D EN^DDIOL($J($P(PRC("CP")," "),8)_" "_$E($P(PRC("CP")," ",2,999)_$J("",40),1,40)_" (ADJ) $"_$J(PRCCOM,0,2)) D:+PRCCOM'=0
. N A,B,X,Y,XMY
. D NAMES^PRCBBUL
. S X(1)=PRC("MSG")
. D:$O(XMY("")) MM^PRC0B2(PRCDES,"X(",.XMY)
. QUIT
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1E2 2919 printed Apr 09, 2024@21:14:30 Page 2
PRCB1E2 ;WISC/PLT-PRCB1E continue ;3/4/97 15:59
V ;;5.1;IFCAP;;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 #, ^2=yyyy-q, ^3=station #, ^4=cp ri
+6 ;prcdes = description
+7 ;
+8 ;prca = prcopt, prcb=fund control point ri
CPBAL(PRCA,PRCB) ;carry forward cp ballance
+1 NEW PRC,PRCRI,PRCC,PRCD,PRCCOM
+2 NEW A,B,C,X,Y,Z,DA
+3 SET PRC("SITE")=$PIECE(PRCA,"^",3)
SET PRCRI(420)=+PRC("SITE")
SET PRCRI(420.01)=+PRCB
+4 SET PRC("CP")=$PIECE($GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
+5 SET PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$PIECE(PRCA,"^",2)_"^"_"F")
+6 ;last qtr always open
if $PIECE(PRCA,"^",5)'<$PIECE(PRCC,"^",2)
QUIT
+7 SET A=$PIECE(PRCOPT,"^",2)
SET PRC("FY")=$EXTRACT(A,3,4)
SET PRC("QTR")=$PIECE(A,"-",2)
+8 LOCK +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5
+9 IF '$TEST
SET PRC("MSG")="Note: Carry forward from "_$PIECE(PRC("CP")," ")_" failed. File locked by another user."
DO EN^DDIOL(PRC("MSG"))
QUIT
+10 SET A=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))
+11 LOCK -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)
+12 if A=""
QUIT
+13 SET PRCCOM=$PIECE(A,"^",1+PRC("QTR"))
+14 IF +PRCCOM=0
SET PRC("MSG")=PRC("CP")_" Qtr "_$EXTRACT($PIECE(PRCOPT,"^",2),3,999)_" adjusted with $"_$JUSTIFY(PRCCOM,0,2)_"."
+15 ;zero out from CP quarter balances
+16 SET A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
+17 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")
+18 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+19 DO EN1^PRCSUT3
SET PRC("TXNTO")=X
DO EN2^PRCSUT3
SET PRCRI(410)=DA
+20 IF 'PRCRI(410)
SET PRC("MSG")="Note: CP balance adjust 'to' fails for "_$PIECE(PRC("CP")," ")_" $"_$JUSTIFY(PRCCOM,10,2)
DO EN^DDIOL(PRC("MSG"))
GOTO MM
+21 SET A="1///A;40////"_DUZ_";449////"_$PIECE(PRCA,"^",5)_";450////O;25.5////Y;24////QTRADJ;26///T"
+22 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
+23 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)
+24 ;adjust new CP quarter balance
+25 SET PRCCOM=-PRCCOM
+26 SET A=$PIECE(PRCOPT,"^",7)
SET PRC("FY")=$EXTRACT(A,3,4)
SET PRC("QTR")=$PIECE(A,"-",2)
+27 SET A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
+28 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")
+29 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+30 DO EN1^PRCSUT3
SET PRC("TXNFR")=X
DO EN2^PRCSUT3
SET PRCRI(410)=DA
+31 IF 'PRCRI(410)
SET PRC("MSG")="Note: CP balance adjust 'from' fails for "_$PIECE(PRC("CP")," ")_" $"_$JUSTIFY(PRCCOM,10,2)
DO EN^DDIOL(PRC("MSG"))
GOTO MM
+32 SET A="1///A;40////"_DUZ_";449////"_$PIECE(PRCA,"^",6)_";450////O;25.5////Y;24////QTRADJ;26///T"
+33 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
+34 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)
+35 SET PRC("MSG")=PRC("CP")_" Qtr "_$EXTRACT($PIECE(PRCOPT,"^",2),3,999)_" adjusted with $"_$JUSTIFY(PRCCOM,0,2)_"."
MM DO EN^DDIOL($JUSTIFY($PIECE(PRC("CP")," "),8)_" "_$EXTRACT($PIECE(PRC("CP")," ",2,999)_$JUSTIFY("",40),1,40)_" (ADJ) $"_$JUSTIFY(PRCCOM,0,2))
if +PRCCOM'=0
Begin DoDot:1
+1 NEW A,B,X,Y,XMY
+2 DO NAMES^PRCBBUL
+3 SET X(1)=PRC("MSG")
+4 if $ORDER(XMY(""))
DO MM^PRC0B2(PRCDES,"X(",.XMY)
+5 QUIT
End DoDot:1
+6 QUIT
