source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1F1.m@ 1608

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1PRCB1F1 ;WISC/PLT-PRCB1F continue ;9/17/96 16:33
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 #
8 ;prca data= ^1=accrual mm/yy, ^2...^10= date infor, ^11=.01 in file 440.7, ^12="Y" for recompiling
9 ;prctd=today's date infor.
10 ;prcdes = description
11TMEN ;accrual
12 N PRCB,PRCD,PRCE,PRCG,PRCDI,PRCRICB,PRCLOCK,PRCRI,PRCID,PRCAMT,PRCBOC,PRAMTP,PRCAMTR,PRCSUBT,PRCAMTA
13 N A,B,C
14 I $D(ZTQUEUED) D KILL^%ZTLOAD
15 S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
16 S PRCRI(440.7)=$O(^PRCH(440.7,"B",PRCID,0))
17 I $P(PRCA,"^",12)!'PRCRI(440.7) D ACCR(PRCA,PRCTD) S PRCRI(440.7)=$O(^PRCH(440.7,"B",PRCID,0)) QUIT:'PRCRI(440.7)
18REP ;start to print
19 D PAGE
20 S (PRCAMT,PRCAMTP,PRCAMTR,PRCAMTA)=0,(X,PRCSUBT,PRCRI)=""
21 F S PRCRI=$O(^PRCH(440.7,PRCRI(440.7),50,"B",PRCRI)) Q:PRCRI=""!(X["^") S PRCRI(440.701)=0 F S PRCRI(440.701)=$O(^PRCH(440.7,PRCRI(440.7),50,"B",PRCRI,PRCRI(440.701))) QUIT:'PRCRI(440.701) Q:X["^" D QUIT:X["^"
22 . S A=^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),B=$P(A,"^",2)-$P(A,"^",3),C="" I $P(A,"^",5)'="" S B=$P(A,"^",5),C="*",X=""
23 . QUIT:+$P(A,"^",2)=0&(+$P(A,"^",3)=0)&(+$P(A,"^",5)=0)
24 . I $P(PRCSUBT,"^")'=$P(A,"/",1,4) D S PRCSUBT=$P(A,"/",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 !,$P(A,"^"),?40,$J($P(A,"^",2),12,2),$J($P(A,"^",3),12,2),$J(B,12,2),C
31 . QUIT
32 D:$G(X)'["^"
33 . I PRCSUBT]"" W !," SUBTOTAL",?40,$J($P(PRCSUBT,"^",2),12,2),$J($P(PRCSUBT,"^",3),12,2),$J($P(PRCSUBT,"^",4),12,2),!
34 . W !!,"TOTAL",?40,$J(PRCAMTP,12,2),$J(PRCAMTR,12,2),$J(PRCAMTA,12,2)
35 . W !!,"Accrual amount followed by '*' means edited amount."
36 . 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,"")
37 . QUIT
38EXIT QUIT
39 ;
40PAGE N A
41 S A=$$DATE^PRC0C("T","E"),A=$P(A,"^",4)_"/"_$P(A,"^",5)_"/"_$P(A,"^",3)
42 W @IOF,!,"IFCAP Accrual Report for "_$P(PRCA,"^"),?50,"Printed on ",A
43 W !!,"Station: ",$P(PRCID,"-",2)
44 W !!,"FUND/BBFY/AO/ACC/CC/BOC",?40,$J("UNPAID PO",12),$J("UNRECON",12),$J("ACCRUAL",12)
45 QUIT
46 ;
47 ;prca = date data, prctd= current date data
48ACCR(PRCA,PRCTD) ;compiling accrual data
49 N PRC,PRCRI,PRCB,PRCC,PRCD,PRCE,PRCF,PRCG,PRCID,PRCDF,PRCDE,PRCAMT,PRCBOC,PRCBBFY,PRCBBEY
50 N A,B,C,X,Y
51 D:'$D(ZTQUEUED) EN^DDIOL("Compiling...")
52 S PRCID=$P(PRCA,"^",11),PRC("SITE")=$P(PRCID,"-",2)
53 S PRCRI(440.7)=$O(^PRCH(440.7,"B",PRCID,0)) D:PRCRI(440.7)
54 . D DELETE^PRC0B1(.X,"440.7;^PRCH(440.7,;"_PRCRI(440.7))
55 . QUIT
56 S X=PRCID,X("DR")="1///^S X=""N"""
57 D ADD^PRC0B1(.X,.Y,"440.7;^PRCH(440.7,")
58 S PRCRI(440.7)=+Y
59 S PRCB=$P($$QTRDATE^PRC0D($P(PRCA,"^",2),$P(PRCA,"^",3)),"^",7)
60 S PRCDF=$P($$QTRDATE^PRC0D($P(PRCA,"^",2),1),"^",7),PRCDE=$P(PRCA,"^",8)+31
61 D 410,4406
62 QUIT
63 ;
64410 ;compiling purchase card orders
65 S PRCRI=PRCB_"-"_PRC("SITE"),PRCC=PRCRI
66 F S PRCC=$O(^PRCS(410,"RB",PRCC)) QUIT:$P(PRCC,"-",1,2)'=PRCRI!'PRCC D
67 . S PRCRI(410)=0
68 . 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)]"") I $P(PRCC,"-",3)=$P(PRCD,"-",4),+$P(PRCC,"-",5)=+$P(PRCD,"-",5) D
69 .. S A=$P(^PRCS(410,PRCRI(410),3),"^",11),PRCAMT=$P(PRCE,"^",8),PRCBBFY=$P($$YEAR^PRC0C($E(A,2,3)),"^")
70 .. QUIT:+PRCAMT=0
71 .. S PRCF=PRC("SITE")_"-"_$P(PRCE,"^",5)
72 .. 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)-1<PRCDE
73 ... S PRCG=^PRC(442,PRCRI(442),0)
74 ... S A=$$ACC^PRC0C($P(PRCD,"-"),$P(PRCD,"-",4)_"^"_$P(PRCD,"-",2)_"^"_PRCBBFY)
75 ... QUIT:$P(A,"^",6)>$$DATE^PRC0C(PRCDE,"I")
76 ... QUIT:$P(A,"^",7)<$$DATE^PRC0C(PRCDF,"I")&($P(A,"^",13)'="Y")
77 ... S PRCRI(442.01)=$O(^PRC(442,PRCRI(442),2,0)) QUIT:'PRCRI(442.01)
78 ... S PRCBOC=$P(^PRC(442,PRCRI(442),2,PRCRI(442.01),0),"^",4),PRCBOC=$P(PRCBOC," ")
79 ... S B=$P(A,"^",5)_"/"_$P(A,"^",6)_"/"_$P(A,"^")_"/"_$P(A,"^",3)_"/"_$P(PRCG,"^",5)_"/"_PRCBOC
80 ... S PRCAMT=PRCAMT-$P($$FP^PRCH0A(PRCRI(442)),"^",2)
81 ... D AE4407(PRCRI(440.7),B,PRCAMT,1)
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<PRCDE
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>$$DATE^PRC0C(PRCDE,"I")
96 . QUIT:PRCBBEY<$$DATE^PRC0C(PRCDF,"I")&(B'="Y")
97 . S B=$P(C,"^",1)_"/"_PRCBBFY_"/"_$P(C,"^",5)_"/"_$TR($P(C,"^",2,4),"^","/")
98 . D AE4407(PRCRI(440.7),B,$P(A,"^",14),2)
99 . QUIT
100 QUIT
101 ;
102 ;prca = ri of file 440.7, prcb=account elements, prcc=amount, prcd=1 if order unpaid, 2=if unreconciled
103AE4407(PRCA,PRCB,PRCC,PRCD) ;add/edit file 440.701
104 N PRCDI,PRCRI
105 N A,B,C,X,Y,Z
106 S PRCRI(440.7)=PRCA
107 S PRCDI="440.7;^PRCH(440.7,;"_PRCRI(440.7)_";50~440.701;^PRCH(440.7,"_PRCRI(440.7)_",50,"
108 S PRCRI(440.701)=$O(^PRCH(440.7,PRCRI(440.7),50,"B",PRCB,0)) D:'PRCRI(440.701)
109 . S X=PRCB
110 . D ADD^PRC0B1(.X,.Y,PRCDI)
111 . S PRCRI(440.701)=+Y
112 . D EDIT^PRC0B(.X,PRCDI_";"_PRCRI(440.701),"5///"_$P(PRCB,"/",5)_";6///"_$P(PRCB,"/",6))
113 . QUIT
114 S PRCDI=PRCDI_";"_PRCRI(440.701)
115 S A=$P(^PRCH(440.7,PRCRI(440.7),50,PRCRI(440.701),0),"^",PRCD+1)+PRCC
116 D EDIT^PRC0B(.X,PRCDI,PRCD_"////"_$J(A,"",2))
117 QUIT
Note: See TracBrowser for help on using the repository browser.