source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1E2.m@ 1068

Last change on this file since 1068 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 2.8 KB
Line 
1PRCB1E2 ;WISC/PLT-PRCB1E continue ;3/4/97 15:59
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ;prcduz - user id #
7 ;prcopt data ^1=option #, ^2=yyyy-q, ^3=station #, ^4=cp ri
8 ;prcdes = description
9 ;
10 ;prca = prcopt, prcb=fund control point ri
11CPBAL(PRCA,PRCB) ;carry forward cp ballance
12 N PRC,PRCRI,PRCC,PRCD,PRCCOM
13 N A,B,C,X,Y,Z,DA
14 S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB
15 S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
16 S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")
17 QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2) ;last qtr always open
18 S A=$P(PRCOPT,"^",2),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
19 L +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5
20 E S PRC("MSG")="Note: Carry forward from "_$P(PRC("CP")," ")_" failed. File locked by another user." D EN^DDIOL(PRC("MSG")) QUIT
21 S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))
22 L -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)
23 QUIT:A=""
24 S PRCCOM=$P(A,"^",1+PRC("QTR"))
25 I +PRCCOM=0 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" adjusted with $"_$J(PRCCOM,0,2)_"."
26 ;zero out from CP quarter balances
27 S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
28 S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
29 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
30 D EN1^PRCSUT3 S PRC("TXNTO")=X D EN2^PRCSUT3 S PRCRI(410)=DA
31 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
32 S A="1///A;40////"_DUZ_";449////"_$P(PRCA,"^",5)_";450////O;25.5////Y;24////QTRADJ;26///T"
33 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
34 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)
35 ;adjust new CP quarter balance
36 S PRCCOM=-PRCCOM
37 S A=$P(PRCOPT,"^",7),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
38 S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
39 S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
40 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
41 D EN1^PRCSUT3 S PRC("TXNFR")=X D EN2^PRCSUT3 S PRCRI(410)=DA
42 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
43 S A="1///A;40////"_DUZ_";449////"_$P(PRCA,"^",6)_";450////O;25.5////Y;24////QTRADJ;26///T"
44 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
45 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)
46 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" adjusted with $"_$J(PRCCOM,0,2)_"."
47MM 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
48 . N A,B,X,Y,XMY
49 . D NAMES^PRCBBUL
50 . S X(1)=PRC("MSG")
51 . D:$O(XMY("")) MM^PRC0B2(PRCDES,"X(",.XMY)
52 . QUIT
53 QUIT
Note: See TracBrowser for help on using the repository browser.