source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1G1.m@ 824

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

initial load of WorldVistAEHR
File size: 5.3 KB
RevLine 
[613]1PRCB1G1 ;WISC/PLT/BGJ-PRCB1G continue ;12/2/97 14:03
2V ;;5.1;IFCAP;**44**;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 #
8 ;prca data=fiscal year, ^2=quarter, ^3=fisca year start year, ^4=fy start month, ^5=fy start day, ...
9 ;prctd data ^1= today's fiscal year, ^2=today's fy quarter
10 ;prcdes = description
11TMEN ;accrual
12 N PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA,PRCPND
13 N PRCDT
14 N A,B,C
15 I $D(ZTQUEUED) D KILL^%ZTLOAD
16 S PRCDT=DT,PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
17 S PRCPND=$P($$DT^PRC0B2($H,"H"),"^",4)
18 D ACCR(PRCA,PRCTD)
19REP ;start to print
20 D PAGE
21 S (PRCAMT,PRCAMTP,PRCAMTR,PRCAMTA)=0,PRCSUBT=""
22 S PRCRI="" F S PRCRI=$O(^TMP("PRCB",$J,PRCRI)) QUIT:PRCRI="" D QUIT:X["^"
23 . S A=^TMP("PRCB",$J,PRCRI,0),B=$P(A,"^",2)-$P(A,"^",3)
24 . I $P(PRCSUBT,"^")'=$P(PRCRI,"/",1,4) D S PRCSUBT=$P(PRCRI,"/",1,4)
25 .. 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),!
26 .. QUIT
27 . S PRCAMTP=$P(A,"^",2)+PRCAMTP,PRCAMTR=$P(A,"^",3)+PRCAMTR,PRCAMTA=B+PRCAMTA
28 . 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)
29 . 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
30 . W !,PRCRI,?40,$J($P(A,"^",2),12,2),$J($P(A,"^",3),12,2),$J(B,12,2)
31 . S PRCRI(9999)=PRC("SITE")_"-" F S PRCRI(9999)=$O(^TMP("PRCB",$J,PRCRI,PRCRI(9999))) QUIT:'PRCRI(9999) S X="" D QUIT:X["^"
32 .. 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
33 .. S A=^TMP("PRCB",$J,PRCRI,PRCRI(9999)),B=^PRC(442,+^(PRCRI(9999)),0),C=$G(^(1)),C=$P(C,"^",15),C=$E(C,4,5)_"/"_$E(C,6,7)_"/"_$E(C,2,3)
34 .. W !,?5,$P(B,"^"),?20,C,?40,$J($P(A,"^",2),12,2)
35 .. QUIT
36 . QUIT
37 D:$G(X)'["^"
38 . I PRCSUBT]"" W !," SUBTOTAL",?40,$J($P(PRCSUBT,"^",2),12,2),$J($P(PRCSUBT,"^",3),12,2),$J($P(PRCSUBT,"^",4),12,2),!
39 . W !!,"TOTAL",?40,$J(PRCAMTP,12,2),$J(PRCAMTR,12,2),$J(PRCAMTA,12,2)
40 . 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,"")
41 . QUIT
42EXIT QUIT
43 ;
44PAGE ;
45 W @IOF,!,"IFCAP YTD Detail Accrual Report for "_$P(PRCA,"^"),?50,"Printed on ",PRCPND
46 W !!,"Station: ",$P(PRCID,"-",2)
47 W !!,"FUND/BBFY/AO/ACC/CC/BOC",?40,$J("UNPAID PO",12),$J("UNRECON",12),$J("ACCRUAL",12)
48 QUIT
49 ;
50 ;prca = date data, prctd= current date data
51ACCR(PRCA,PRCTD) ;compiling accrual data
52 N PRC,PRCRI,PRCB,PRCC,PRCD,PRCE,PRCF,PRCG,PRCID,PRCDF,PRCDE,PRCAMT,PRCBOC,PRCBBFY,PRCBBEY
53 N A,B,C,X,Y
54 D:'$D(ZTQUEUED) EN^DDIOL("Compiling...")
55 S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
56 K ^TMP("PRCB",$J)
57 S PRCB=$P(PRCA,"^",7)
58 S PRCDF=+PRCA,PRCDE=+PRCA
59 D 410,4406
60 QUIT
61 ;
62410 ;compiling purchase card orders
63 S PRCRI=PRCB_"-"_PRC("SITE"),PRCC=PRCRI
64 F S PRCC=$O(^PRCS(410,"RB",PRCC)) QUIT:$P(PRCC,"-",1,2)'=PRCRI!'PRCC D
65 . 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)]"") D
66 .. ;Skip entry if txn # in RB x-ref does not match actual txn #
67 .. QUIT:$P(PRCC,"-",$L(PRCC,"-"))'=$P($P(PRCD,"^"),"-",$L($P(PRCD,"^"),"-"))
68 .. S A=$P(^PRCS(410,PRCRI(410),3),"^",11),PRCAMT=$P(PRCE,"^",8),PRCBBFY=$P($$YEAR^PRC0C($E(A,2,3)),"^")
69 .. QUIT:+PRCAMT=0
70 .. S PRCF=PRC("SITE")_"-"_$P(PRCE,"^",5)
71 .. 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)'>PRCDT
72 ... S PRCG=^PRC(442,PRCRI(442),0),PRCRI(9999)=$P(PRCG,"^") QUIT:$P($G(^(7)),"^",2)=40!($P($G(^(7)),"^",2)=41)
73 ... S A=$$ACC^PRC0C($P(PRCD,"-"),$P(PRCD,"-",4)_"^"_$P(PRCD,"-",2)_"^"_PRCBBFY)
74 ... QUIT:$P(A,"^",6)>PRCDE
75 ... QUIT:$P(A,"^",7)<PRCDF&($P(A,"^",13)'="Y")
76 ... S PRCRI(442.01)=$O(^PRC(442,PRCRI(442),2,0)) QUIT:'PRCRI(442.01)
77 ... S PRCBOC=$P(^PRC(442,PRCRI(442),2,PRCRI(442.01),0),"^",4),PRCBOC=$P(PRCBOC," ")
78 ... S B=$P(A,"^",5)_"/"_$P(A,"^",6)_"/"_$P(A,"^")_"/"_$P(A,"^",3)_"/"_$P(PRCG,"^",5)_"/"_PRCBOC
79 ... S PRCAMT=PRCAMT-$P($$FP^PRCH0A(PRCRI(442)),"^",2)
80 ... S ^TMP("PRCB",$J,B,PRCRI(9999))=PRCRI(442)_"^"_PRCAMT
81 ... S $P(^TMP("PRCB",$J,B,0),"^",2)=$P($G(^TMP("PRCB",$J,B,0)),"^",2)+PRCAMT
82 ... QUIT
83 .. QUIT
84 . QUIT
85 QUIT
86 ;
874406 ;compiling unreconciled records
88 N A,B,C,D,X,Y
89 S PRCRI="N"
90 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=^PRCH(440.6,PRCRI(440.6),0),B=$P(A,"^",6),C=^(5) D:B-1<PRCDT
91 . QUIT:PRC("SITE")-$P(A,"^",8)
92 . S PRCBBFY=$P($$YEAR^PRC0C($E($P(A,"^",11),2,3)),"^")
93 . S PRCBBEY=$P($$YEAR^PRC0C($E($P(A,"^",12),2,3)),"^")
94 . S B=$O(^PRCD(420.3,"B",$P(C,"^",1),"")) I B S B=$P(^PRCD(420.3,B,0),"^",8)
95 . QUIT:PRCBBFY>PRCDE
96 . QUIT:PRCBBEY<PRCDF&(B'="Y")
97 . S B=$P(C,"^",1)_"/"_PRCBBFY_"/"_$P(C,"^",5)_"/"_$TR($P(C,"^",2,4),"^","/")
98 . S $P(^TMP("PRCB",$J,B,0),"^",3)=$P($G(^TMP("PRCB",$J,B,0)),"^",3)+$P(A,"^",14)
99 . QUIT
100 QUIT
101 ;
Note: See TracBrowser for help on using the repository browser.