source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSFIV.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1PRCPSFIV ;WOIFO/RFJ,LKG-create fms iv issues code sheet ;4/27/05 14:08
2 ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7IV(INVPT,TRANID,TRANNO,TRANDATE,STACKDA) ; create fms iv document
8 ; tranid=transaction register id number; tranno=ib number (from 410)
9 ; trandate=optional FMS acctg period, otherwise it uses the
10 ; transaction date
11 ; pass stackda for regeneration of document
12 ; loop transaction register for posted items
13 ; variables required:
14 ; prcpwsta = whse station #; prcppsta = buyer station #
15 ; prcpwfcp = whse fcp ; prcppfcp = buyer fcp
16 ; prcpwbfy = whse beg fy ; prcppbfy = buyer beg fy
17 N ACCT,BUYBFY,BUYEFY,BUYFUND,BUYJOB,BUYLINE,BUYTABLE,BUYXPROG,COSTCNTR,DATA,FMSLINE,GECSFMS,INVCOST,LINEDA,LINEDOC,PRCPDA,PRCPFMOD,PRCPFMS,PRCPSEC1,PROFIT,PROFLINE
18 N SELBFY,SELEFY,SELFUND,SELLCOST,SELLINE,SELTABLE,SELXPROG,SIGN,SUBACCT,TOTAL,TRANDA,VOUCHER
19 S PRCPDA=$O(^PRCS(410,"B",TRANNO,0)) I 'PRCPDA Q
20 I $D(^PRCS(410,PRCPDA,"IT","FMSLINE")) S PRCPFMOD=1
21 K PRCPFMS
22 S (TRANDA,TOTAL)=0 F S TRANDA=$O(^PRCP(445.2,"T",INVPT,TRANID,TRANDA)) Q:'TRANDA S DATA=$G(^PRCP(445.2,TRANDA,0)) I DATA'="" D
23 . S LINEDA=+$P(DATA,"^",24) I 'LINEDA Q
24 . I 'TRANDATE S TRANDATE=$P(DATA,"^",3)
25 . D FINDLINE^PRCPSFU0(PRCPDA,LINEDA)
26 . ; invcost and sellcost is minus when coming out of the whse
27 . ; inventory point. fms is positive when coming out of the whse.
28 . S INVCOST=-$P(DATA,"^",22),SELLCOST=-$P(DATA,"^",23)
29 . S PROFIT=SELLCOST-INVCOST
30 . ; total is total of unsigned amounts on all lines
31 . S TOTAL=TOTAL+SELLCOST
32 . I '$D(PRCPFMS(FMSLINE)) S PRCPFMS(FMSLINE)=ACCT_"^"_SUBACCT
33 . S $P(PRCPFMS(FMSLINE),"^",3)=$P(PRCPFMS(FMSLINE),"^",3)+INVCOST
34 . S $P(PRCPFMS(FMSLINE),"^",4)=$P(PRCPFMS(FMSLINE),"^",4)+PROFIT
35 I '$D(PRCPFMS) Q
36IVCOTS ;Entry Point for building IV for COTS inventory transaction
37 ; set up document variables
38 S COSTCNTR=$P($G(^PRCS(410,PRCPDA,3)),"^",3),COSTCNTR=$S($D(^PRCD(420.1,+COSTCNTR,0)):$P(^(0),"^"),1:COSTCNTR)
39 S VOUCHER=$P($G(^PRCS(410,PRCPDA,445)),"^") S VOUCHER=$E(VOUCHER_"00000",1,6)
40 ; seller=whse
41 ; table=^^xprogram(fcp/prj)^^linefund^beginfy^endfy^^^job
42 S SELTABLE=$$ACC^PRC0C(PRCPWSTA,PRCPWFCP_"^"_$P(TRANNO,"-",2)_"^"_PRCPWBFY)
43 S SELXPROG=$P(SELTABLE,"^",3),SELFUND=$P(SELTABLE,"^",5),SELBFY=$E($P(SELTABLE,"^",6),3,4),SELEFY=$E($P(SELTABLE,"^",7),3,4)
44 I SELEFY=SELBFY S SELEFY=""
45 ; buyer
46 S BUYTABLE=$$ACC^PRC0C(PRCPPSTA,PRCPPFCP_"^"_$P(TRANNO,"-",2)_"^"_PRCPPBFY)
47 S BUYXPROG=$P(BUYTABLE,"^",3),BUYFUND=$P(BUYTABLE,"^",5),BUYBFY=$E($P(BUYTABLE,"^",6),3,4),BUYEFY=$E($P(BUYTABLE,"^",7),3,4),BUYJOB=$P(BUYTABLE,"^",10)
48 I BUYEFY=BUYBFY S BUYEFY=""
49 ;
50 ; build control segments in gcs
51 S PRCPSEC1=$$SEC1^PRC0C(PRCPWSTA) S:PRCPSEC1="" PRCPSEC1=10
52 I '$G(STACKDA) D CONTROL^GECSUFMS("I",PRCPWSTA,PRCPWSTA_VOUCHER,"IV",PRCPSEC1,+$G(PRCPFMOD),"Y","post issue book: "_TRANNO_" tranid: "_TRANID)
53 I $G(STACKDA) D REBUILD^GECSUFM1(STACKDA,"I",PRCPSEC1,"Y","Rebuild post issue book: "_TRANNO_" tranid: "_TRANID) S GECSFMS("DA")=STACKDA
54 D SETPARAM^GECSSDCT(GECSFMS("DA"),TRANID)
55 ;
56 ; build iv2 segment
57 S LINEDOC="IV2^"_$E(TRANDATE,2,3)_"^"_$E(TRANDATE,4,5)_"^"_$E(TRANDATE,6,7)
58 S $P(LINEDOC,"^",9)=$S($D(GECSFMS("BAT")):"M",1:"E")
59 S $P(LINEDOC,"^",21)=$E($TR($P(TRANNO,"-",2,5),"-"),1,12)
60 S $P(LINEDOC,"^",22)=$J($S(TOTAL<0:-TOTAL,1:TOTAL),0,2)
61 D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC_"^~")
62 ;
63 ; build line documents
64 S LINEDA=0 F S LINEDA=$O(PRCPFMS(LINEDA)) Q:'LINEDA S DATA=PRCPFMS(LINEDA) D
65 . S ACCT=$P(DATA,"^"),SUBACCT=$P(DATA,"^",2),INVCOST=$P(DATA,"^",3),PROFIT=$P(DATA,"^",4)
66 . S SIGN="I" I INVCOST<0 S INVCOST=-INVCOST,SIGN="D"
67 . S SELLINE="LIN^~IVA^"_$E("000",$L(LINEDA)+1,3)_LINEDA_"^"_$J(INVCOST,0,2)_"^"_SIGN_"^^"_SELBFY_"^"_SELEFY_"^"_SELFUND_"^"_PRCPWSTA_"^^^^"_SELXPROG_"^^^^SFCS^^^0"_$S(ACCT=1:4,ACCT=2:6,ACCT=8:2,1:8)_"^^"
68 . S BUYLINE="^"_BUYBFY_"^"_BUYEFY_"^"_BUYFUND_"^"_PRCPPSTA_"^^"_$E(COSTCNTR,1,4)_"00^"_$E(COSTCNTR,5,6)_"^"_BUYXPROG_"^"_SUBACCT_"^~"
69 . S LINEDOC=SELLINE_BUYLINE_"IVB^01^~"
70 . I INVCOST D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
71 . I 'PROFIT Q
72 . ; create profit line
73 . S SIGN="I" I PROFIT<0 S PROFIT=-PROFIT,SIGN="D"
74 . S PROFLINE=LINEDA+1
75 . S SELLINE="LIN^~IVA^"_$E("000",$L(PROFLINE)+1,3)_PROFLINE_"^"_$J(PROFIT,0,2)_"^"_SIGN_"^^"_SELBFY_"^"_SELEFY_"^"_SELFUND_"^"_PRCPWSTA_"^^^^"_SELXPROG_"^^^^SFPR^^^0"_($S(ACCT=1:4,ACCT=2:6,ACCT=8:2,1:8)+1)_"^^"
76 . S BUYLINE="^"_BUYBFY_"^"_BUYEFY_"^"_BUYFUND_"^"_PRCPPSTA_"^^"_$E(COSTCNTR,1,4)_"00^"_$E(COSTCNTR,5,6)_"^"_BUYXPROG_"^"_SUBACCT_"^~"
77 . S LINEDOC=SELLINE_BUYLINE_"IVB^01^~"
78 . D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
79 ;
80 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
81 D EN^DDIOL("FMS IV "_$S($D(GECSFMS("BAT")):"MODIFICATION ",1:"")_PRCPWSTA_VOUCHER_" document automatically "_$S($G(STACKDA):"RE-",1:"")_"transmitted.","","!?4")
82 Q
Note: See TracBrowser for help on using the repository browser.