source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1E1.m@ 1427

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

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1PRCB1E1 ;WISC/PLT/BGJ-PRCB1E continue ;1/8/97 12:55
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
9TMEN ;carry forward
10 N PRCA,PRCB,PRCD,PRCE,PRCDI,PRCRICB,PRCLOCK,PRCRI
11 N A,B,C
12 I $D(ZTQUEUED) D KILL^%ZTLOAD
13 ;from quarter, prcopt data ^5=from qtr bd, ^6=to qtr bd, ^7=to fy (yyyy)-qtr
14 I $P(PRCOPT,"^",2)'?4N1"-"1N D EN^DDIOL("CARRY FORWARD FAILS WITH WRONG YEAR FORMAT.") QUIT
15 S A=$P(PRCOPT,"^",2),A=$$QTRDATE^PRC0D(+A,$P(A,"-",2))
16 S $P(PRCOPT,"^",5)=$P(A,"^",7)
17 ;to quarter
18 S A=$$DATE^PRC0C($P(A,"^",8)+100,"H"),A=$$QTRDATE^PRC0D(+A,$P(A,"^",2))
19 S $P(PRCOPT,"^",6)=$P(A,"^",7),$P(PRCOPT,"^",7)=$P(A,"^")_"-"_$P(A,"^",2)
20 S PRCDES=PRCDES_" to "_$E($P(PRCOPT,"^",7),3,999)
21 D EN^DDIOL(PRCDES)
22 S A=$$DATE^PRC0C("T","E"),A=$P(A,"^",4)_"/"_$P(A,"^",5)_"/"_$P(A,"^",3)
23 S PRC("SITE")=$P(PRCOPT,"^",3)
24 D EN^DDIOL("Station: "_PRC("SITE")_" Printed on "_A)
25 S B=3 D ICLOCK^PRC0B("^PRCS(410,"""_PRCOPT_""",",.B)
26 I 'B D EN^DDIOL(" Another Carry Forward job is running, try later!") QUIT
27 I $P(PRCOPT,"^")=3 D FCPBAL(PRCOPT,$P(PRCOPT,"^",4)),CPBAL^PRCB1E2(PRCOPT,$P(PRCOPT,"^",4)) I 1
28 E I $P(PRCOPT,"^")=1,$P(PRCOPT,"^",2)["-4",$P(^PRC(411,PRC("SITE"),0),"^",25)'="Y" D EN^DDIOL("The outstanding requests are not carried forward to the new fiscal year.") I 1
29 E S PRCRI(420.01)=0 F S PRCRI(420.01)=$O(^PRC(420,+PRC("SITE"),1,PRCRI(420.01))) Q:PRCRI(420.01)>9998!'PRCRI(420.01) S PRCD=$G(^(PRCRI(420.01),0)) I PRCD]"",'$P(PRCD,"^",19) D
30 . D:"1"[$P(PRCOPT,"^") FCPUOB(PRCOPT,+PRCD)
31 . D:"2"[$P(PRCOPT,"^") FCPBAL(PRCOPT,+PRCD),CPBAL^PRCB1E2(PRCOPT,+PRCD)
32 . QUIT
33 I "1"[$P(PRCOPT,"^"),$P(^PRC(420,+PRC("SITE"),0),"^",9)<$P(PRCOPT,"^",6) D EDIT^PRC0B(.X,"420;^PRC(420,;"_(+PRC("SITE")),"9////"_$P(PRCOPT,"^",6),"SL")
34 D DCLOCK^PRC0B("^PRCS(410,"""_PRCOPT_""",")
35 D EN^DDIOL("End of Report at "_$$NOW^PRC5A)
36EXIT QUIT
37 ;
38 ;prca = prcopt, prcb=fund control point ri
39FCPUOB(PRCA,PRCB) ;carry forward all unobligated request to new quarte and
40 N PRC,PRCRI,PRCC,PRCD,PRCE,PRCF,PRCG
41 N A,B,C,X,Y
42 S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB
43 S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
44 S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")
45 QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2) ;last qtr always open
46 S PRCD=$P(PRCA,"^",5)_"-"_PRC("SITE")_"-"_$P(PRC("CP")," ")_"-",PRCE=PRCD_"~"
47 F S PRCD=$O(^PRCS(410,"RB",PRCD)) QUIT:PRCD]PRCE!'PRCD S PRCRI(410)=$O(^(PRCD,"")) I PRCRI(410) D
48 . S PRCF=$G(^PRCS(410,PRCRI(410),0)),PRCG=$P(PRCF,"^",12),PRCH=-$P($G(^(4)),"^",8)
49 .;credit back the approved requests committed charge
50 . I PRCG="A" S B=$P(PRCA,"^",2) D EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_$E(B,3,4)_"^"_$P(B,"-",2)_"^"_PRCH,"C")
51 . I "EA"[PRCG D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"449////"_$P(PRCA,"^",6),"LS")
52 .;if approved charge to new quarter
53 . I PRCG="A" S B=$P(PRCA,"^",7) D EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_$E(B,3,4)_"^"_$P(B,"-",2)_"^"_-PRCH,"C")
54 . I "EA"[PRCG W !,$P(PRCF,"^",1),?20,$S(PRCG="E":"ENTERED",1:"APPROVED")
55 . QUIT
56 QUIT
57 ;
58 ;prca = prcopt, prcb=fund control point ri
59FCPBAL(PRCA,PRCB) ;carry forward cp ballance
60 N PRC,PRCRI,PRCC,PRCD,PRCCOM,PRCOBL
61 N A,B,C,X,Y,Z,DA
62 S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB
63 S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
64 S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")
65 QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2) ;last qtr always open
66 S A=$P(PRCOPT,"^",2),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
67 L +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5
68 E S PRC("MSG")="Note: Carry forward from "_$P(PRC("CP")," ")_" failed. File locked by another user." D EN^DDIOL(PRC("MSG")) QUIT
69 S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))
70 L -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)
71 QUIT:A=""
72 S PRCCOM=-$P(A,"^",1+PRC("QTR")),PRCOBL=-$P(A,"^",5+PRC("QTR"))
73 I +PRCOBL=0 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" closed. $"_$J(PRCOBL,0,2)_" carried forward."
74 ;zero out from quarte balances
75 S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
76 S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
77 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
78 D EN1^PRCSUT3 S PRC("TXNTO")=X D EN2^PRCSUT3 S PRCRI(410)=$G(DA)
79 I 'PRCRI(410) S PRC("MSG")="Note: Carry forward 'to' fails for "_$P(PRC("CP")," ")_" $"_$J(PRCOBL,10,2) D EN^DDIOL(PRC("MSG")) G MM
80 S A="1///C;40////^S X=PRCDUZ;42////^S X=PRCDUZ;449////"_$P(PRCA,"^",5)_";450////O;35////"_PRCOBL_";24////"_"TO "_$E($P(PRCA,"^",7),3,999)
81 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
82 ;carry forward from qtr balances to new quarter
83 S PRCOBL=-PRCOBL
84 S A=$P(PRCOPT,"^",7),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
85 S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
86 S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
87 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
88 D EN1^PRCSUT3 S PRC("TXNFR")=X D EN2^PRCSUT3 S PRCRI(410)=$G(DA)
89 I 'PRCRI(410) S PRC("MSG")="Note: Carry forward 'from' fails for "_$P(PRC("CP")," ")_" $"_$J(PRCOBL,10,2) D EN^DDIOL(PRC("MSG")) G MM
90 S A="1///C;40////^S X=PRCDUZ;42////^S X=PRCDUZ;449////"_$P(PRCA,"^",6)_";450////O;35////"_PRCOBL_";24////"_"FROM "_$E($P(PRCA,"^",2),3,999)
91 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
92 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" closed. $"_$J(PRCOBL,0,2)_" carried forward."
93MM D EN^DDIOL($J($P(PRC("CP")," "),8)_" "_$E($P(PRC("CP")," ",2,999)_$J("",40),1,40)_" (CEI) $"_$J(PRCOBL,0,2)) D:+PRCOBL'=0
94 . N A,B,X,Y,XMY
95 . D NAMES^PRCBBUL
96 . S X(1)=PRC("MSG")
97 . D:$O(XMY("")) MM^PRC0B2(PRCDES,"X(",.XMY)
98 . QUIT
99 QUIT
Note: See TracBrowser for help on using the repository browser.