PRCPSFIV ;WOIFO/RFJ,LKG-create fms iv issues code sheet ;4/27/05 14:08
;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
IV(INVPT,TRANID,TRANNO,TRANDATE,STACKDA) ; create fms iv document
; tranid=transaction register id number; tranno=ib number (from 410)
; trandate=optional FMS acctg period, otherwise it uses the
; transaction date
; pass stackda for regeneration of document
; loop transaction register for posted items
; variables required:
; prcpwsta = whse station #; prcppsta = buyer station #
; prcpwfcp = whse fcp ; prcppfcp = buyer fcp
; prcpwbfy = whse beg fy ; prcppbfy = buyer beg fy
N ACCT,BUYBFY,BUYEFY,BUYFUND,BUYJOB,BUYLINE,BUYTABLE,BUYXPROG,COSTCNTR,DATA,FMSLINE,GECSFMS,INVCOST,LINEDA,LINEDOC,PRCPDA,PRCPFMOD,PRCPFMS,PRCPSEC1,PROFIT,PROFLINE
N SELBFY,SELEFY,SELFUND,SELLCOST,SELLINE,SELTABLE,SELXPROG,SIGN,SUBACCT,TOTAL,TRANDA,VOUCHER
S PRCPDA=$O(^PRCS(410,"B",TRANNO,0)) I 'PRCPDA Q
I $D(^PRCS(410,PRCPDA,"IT","FMSLINE")) S PRCPFMOD=1
K PRCPFMS
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
. S LINEDA=+$P(DATA,"^",24) I 'LINEDA Q
. I 'TRANDATE S TRANDATE=$P(DATA,"^",3)
. D FINDLINE^PRCPSFU0(PRCPDA,LINEDA)
. ; invcost and sellcost is minus when coming out of the whse
. ; inventory point. fms is positive when coming out of the whse.
. S INVCOST=-$P(DATA,"^",22),SELLCOST=-$P(DATA,"^",23)
. S PROFIT=SELLCOST-INVCOST
. ; total is total of unsigned amounts on all lines
. S TOTAL=TOTAL+SELLCOST
. I '$D(PRCPFMS(FMSLINE)) S PRCPFMS(FMSLINE)=ACCT_"^"_SUBACCT
. S $P(PRCPFMS(FMSLINE),"^",3)=$P(PRCPFMS(FMSLINE),"^",3)+INVCOST
. S $P(PRCPFMS(FMSLINE),"^",4)=$P(PRCPFMS(FMSLINE),"^",4)+PROFIT
I '$D(PRCPFMS) Q
IVCOTS ;Entry Point for building IV for COTS inventory transaction
; set up document variables
S COSTCNTR=$P($G(^PRCS(410,PRCPDA,3)),"^",3),COSTCNTR=$S($D(^PRCD(420.1,+COSTCNTR,0)):$P(^(0),"^"),1:COSTCNTR)
S VOUCHER=$P($G(^PRCS(410,PRCPDA,445)),"^") S VOUCHER=$E(VOUCHER_"00000",1,6)
; seller=whse
; table=^^xprogram(fcp/prj)^^linefund^beginfy^endfy^^^job
S SELTABLE=$$ACC^PRC0C(PRCPWSTA,PRCPWFCP_"^"_$P(TRANNO,"-",2)_"^"_PRCPWBFY)
S SELXPROG=$P(SELTABLE,"^",3),SELFUND=$P(SELTABLE,"^",5),SELBFY=$E($P(SELTABLE,"^",6),3,4),SELEFY=$E($P(SELTABLE,"^",7),3,4)
I SELEFY=SELBFY S SELEFY=""
; buyer
S BUYTABLE=$$ACC^PRC0C(PRCPPSTA,PRCPPFCP_"^"_$P(TRANNO,"-",2)_"^"_PRCPPBFY)
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)
I BUYEFY=BUYBFY S BUYEFY=""
;
; build control segments in gcs
S PRCPSEC1=$$SEC1^PRC0C(PRCPWSTA) S:PRCPSEC1="" PRCPSEC1=10
I '$G(STACKDA) D CONTROL^GECSUFMS("I",PRCPWSTA,PRCPWSTA_VOUCHER,"IV",PRCPSEC1,+$G(PRCPFMOD),"Y","post issue book: "_TRANNO_" tranid: "_TRANID)
I $G(STACKDA) D REBUILD^GECSUFM1(STACKDA,"I",PRCPSEC1,"Y","Rebuild post issue book: "_TRANNO_" tranid: "_TRANID) S GECSFMS("DA")=STACKDA
D SETPARAM^GECSSDCT(GECSFMS("DA"),TRANID)
;
; build iv2 segment
S LINEDOC="IV2^"_$E(TRANDATE,2,3)_"^"_$E(TRANDATE,4,5)_"^"_$E(TRANDATE,6,7)
S $P(LINEDOC,"^",9)=$S($D(GECSFMS("BAT")):"M",1:"E")
S $P(LINEDOC,"^",21)=$E($TR($P(TRANNO,"-",2,5),"-"),1,12)
S $P(LINEDOC,"^",22)=$J($S(TOTAL<0:-TOTAL,1:TOTAL),0,2)
D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC_"^~")
;
; build line documents
S LINEDA=0 F S LINEDA=$O(PRCPFMS(LINEDA)) Q:'LINEDA S DATA=PRCPFMS(LINEDA) D
. S ACCT=$P(DATA,"^"),SUBACCT=$P(DATA,"^",2),INVCOST=$P(DATA,"^",3),PROFIT=$P(DATA,"^",4)
. S SIGN="I" I INVCOST<0 S INVCOST=-INVCOST,SIGN="D"
. 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)_"^^"
. S BUYLINE="^"_BUYBFY_"^"_BUYEFY_"^"_BUYFUND_"^"_PRCPPSTA_"^^"_$E(COSTCNTR,1,4)_"00^"_$E(COSTCNTR,5,6)_"^"_BUYXPROG_"^"_SUBACCT_"^~"
. S LINEDOC=SELLINE_BUYLINE_"IVB^01^~"
. I INVCOST D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
. I 'PROFIT Q
. ; create profit line
. S SIGN="I" I PROFIT<0 S PROFIT=-PROFIT,SIGN="D"
. S PROFLINE=LINEDA+1
. 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)_"^^"
. S BUYLINE="^"_BUYBFY_"^"_BUYEFY_"^"_BUYFUND_"^"_PRCPPSTA_"^^"_$E(COSTCNTR,1,4)_"00^"_$E(COSTCNTR,5,6)_"^"_BUYXPROG_"^"_SUBACCT_"^~"
. S LINEDOC=SELLINE_BUYLINE_"IVB^01^~"
. D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
;
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
D EN^DDIOL("FMS IV "_$S($D(GECSFMS("BAT")):"MODIFICATION ",1:"")_PRCPWSTA_VOUCHER_" document automatically "_$S($G(STACKDA):"RE-",1:"")_"transmitted.","","!?4")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSFIV 5054 printed Jan 18, 2025@03:16:56 Page 2
PRCPSFIV ;WOIFO/RFJ,LKG-create fms iv issues code sheet ;4/27/05 14:08
+1 ;;5.1;IFCAP;**81**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
IV(INVPT,TRANID,TRANNO,TRANDATE,STACKDA) ; create fms iv document
+1 ; tranid=transaction register id number; tranno=ib number (from 410)
+2 ; trandate=optional FMS acctg period, otherwise it uses the
+3 ; transaction date
+4 ; pass stackda for regeneration of document
+5 ; loop transaction register for posted items
+6 ; variables required:
+7 ; prcpwsta = whse station #; prcppsta = buyer station #
+8 ; prcpwfcp = whse fcp ; prcppfcp = buyer fcp
+9 ; prcpwbfy = whse beg fy ; prcppbfy = buyer beg fy
+10 NEW ACCT,BUYBFY,BUYEFY,BUYFUND,BUYJOB,BUYLINE,BUYTABLE,BUYXPROG,COSTCNTR,DATA,FMSLINE,GECSFMS,INVCOST,LINEDA,LINEDOC,PRCPDA,PRCPFMOD,PRCPFMS,PRCPSEC1,PROFIT,PROFLINE
+11 NEW SELBFY,SELEFY,SELFUND,SELLCOST,SELLINE,SELTABLE,SELXPROG,SIGN,SUBACCT,TOTAL,TRANDA,VOUCHER
+12 SET PRCPDA=$ORDER(^PRCS(410,"B",TRANNO,0))
IF 'PRCPDA
QUIT
+13 IF $DATA(^PRCS(410,PRCPDA,"IT","FMSLINE"))
SET PRCPFMOD=1
+14 KILL PRCPFMS
+15 SET (TRANDA,TOTAL)=0
FOR
SET TRANDA=$ORDER(^PRCP(445.2,"T",INVPT,TRANID,TRANDA))
if 'TRANDA
QUIT
SET DATA=$GET(^PRCP(445.2,TRANDA,0))
IF DATA'=""
Begin DoDot:1
+16 SET LINEDA=+$PIECE(DATA,"^",24)
IF 'LINEDA
QUIT
+17 IF 'TRANDATE
SET TRANDATE=$PIECE(DATA,"^",3)
+18 DO FINDLINE^PRCPSFU0(PRCPDA,LINEDA)
+19 ; invcost and sellcost is minus when coming out of the whse
+20 ; inventory point. fms is positive when coming out of the whse.
+21 SET INVCOST=-$PIECE(DATA,"^",22)
SET SELLCOST=-$PIECE(DATA,"^",23)
+22 SET PROFIT=SELLCOST-INVCOST
+23 ; total is total of unsigned amounts on all lines
+24 SET TOTAL=TOTAL+SELLCOST
+25 IF '$DATA(PRCPFMS(FMSLINE))
SET PRCPFMS(FMSLINE)=ACCT_"^"_SUBACCT
+26 SET $PIECE(PRCPFMS(FMSLINE),"^",3)=$PIECE(PRCPFMS(FMSLINE),"^",3)+INVCOST
+27 SET $PIECE(PRCPFMS(FMSLINE),"^",4)=$PIECE(PRCPFMS(FMSLINE),"^",4)+PROFIT
End DoDot:1
+28 IF '$DATA(PRCPFMS)
QUIT
IVCOTS ;Entry Point for building IV for COTS inventory transaction
+1 ; set up document variables
+2 SET COSTCNTR=$PIECE($GET(^PRCS(410,PRCPDA,3)),"^",3)
SET COSTCNTR=$SELECT($DATA(^PRCD(420.1,+COSTCNTR,0)):$PIECE(^(0),"^"),1:COSTCNTR)
+3 SET VOUCHER=$PIECE($GET(^PRCS(410,PRCPDA,445)),"^")
SET VOUCHER=$EXTRACT(VOUCHER_"00000",1,6)
+4 ; seller=whse
+5 ; table=^^xprogram(fcp/prj)^^linefund^beginfy^endfy^^^job
+6 SET SELTABLE=$$ACC^PRC0C(PRCPWSTA,PRCPWFCP_"^"_$PIECE(TRANNO,"-",2)_"^"_PRCPWBFY)
+7 SET SELXPROG=$PIECE(SELTABLE,"^",3)
SET SELFUND=$PIECE(SELTABLE,"^",5)
SET SELBFY=$EXTRACT($PIECE(SELTABLE,"^",6),3,4)
SET SELEFY=$EXTRACT($PIECE(SELTABLE,"^",7),3,4)
+8 IF SELEFY=SELBFY
SET SELEFY=""
+9 ; buyer
+10 SET BUYTABLE=$$ACC^PRC0C(PRCPPSTA,PRCPPFCP_"^"_$PIECE(TRANNO,"-",2)_"^"_PRCPPBFY)
+11 SET BUYXPROG=$PIECE(BUYTABLE,"^",3)
SET BUYFUND=$PIECE(BUYTABLE,"^",5)
SET BUYBFY=$EXTRACT($PIECE(BUYTABLE,"^",6),3,4)
SET BUYEFY=$EXTRACT($PIECE(BUYTABLE,"^",7),3,4)
SET BUYJOB=$PIECE(BUYTABLE,"^",10)
+12 IF BUYEFY=BUYBFY
SET BUYEFY=""
+13 ;
+14 ; build control segments in gcs
+15 SET PRCPSEC1=$$SEC1^PRC0C(PRCPWSTA)
if PRCPSEC1=""
SET PRCPSEC1=10
+16 IF '$GET(STACKDA)
DO CONTROL^GECSUFMS("I",PRCPWSTA,PRCPWSTA_VOUCHER,"IV",PRCPSEC1,+$GET(PRCPFMOD),"Y","post issue book: "_TRANNO_" tranid: "_TRANID)
+17 IF $GET(STACKDA)
DO REBUILD^GECSUFM1(STACKDA,"I",PRCPSEC1,"Y","Rebuild post issue book: "_TRANNO_" tranid: "_TRANID)
SET GECSFMS("DA")=STACKDA
+18 DO SETPARAM^GECSSDCT(GECSFMS("DA"),TRANID)
+19 ;
+20 ; build iv2 segment
+21 SET LINEDOC="IV2^"_$EXTRACT(TRANDATE,2,3)_"^"_$EXTRACT(TRANDATE,4,5)_"^"_$EXTRACT(TRANDATE,6,7)
+22 SET $PIECE(LINEDOC,"^",9)=$SELECT($DATA(GECSFMS("BAT")):"M",1:"E")
+23 SET $PIECE(LINEDOC,"^",21)=$EXTRACT($TRANSLATE($PIECE(TRANNO,"-",2,5),"-"),1,12)
+24 SET $PIECE(LINEDOC,"^",22)=$JUSTIFY($SELECT(TOTAL<0:-TOTAL,1:TOTAL),0,2)
+25 DO SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC_"^~")
+26 ;
+27 ; build line documents
+28 SET LINEDA=0
FOR
SET LINEDA=$ORDER(PRCPFMS(LINEDA))
if 'LINEDA
QUIT
SET DATA=PRCPFMS(LINEDA)
Begin DoDot:1
+29 SET ACCT=$PIECE(DATA,"^")
SET SUBACCT=$PIECE(DATA,"^",2)
SET INVCOST=$PIECE(DATA,"^",3)
SET PROFIT=$PIECE(DATA,"^",4)
+30 SET SIGN="I"
IF INVCOST<0
SET INVCOST=-INVCOST
SET SIGN="D"
+31 SET SELLINE="LIN^~IVA^"_$EXTRACT("000",$LENGTH(LINEDA)+1,3)_LINEDA_"^"_$JUSTIFY(INVCOST,0,2)_"^"_SIGN_"^^"_SELBFY_"^"_SELEFY_"^"_SELFUND_"^"_PRCPWSTA_"^^^^"_SELXPROG_"^^^^SFCS^^^0"_$SELECT(ACCT=1:4,ACCT=2:6,ACCT=8:2,1:8)_"^^"
+32 SET BUYLINE="^"_BUYBFY_"^"_BUYEFY_"^"_BUYFUND_"^"_PRCPPSTA_"^^"_$EXTRACT(COSTCNTR,1,4)_"00^"_$EXTRACT(COSTCNTR,5,6)_"^"_BUYXPROG_"^"_SUBACCT_"^~"
+33 SET LINEDOC=SELLINE_BUYLINE_"IVB^01^~"
+34 IF INVCOST
DO SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
+35 IF 'PROFIT
QUIT
+36 ; create profit line
+37 SET SIGN="I"
IF PROFIT<0
SET PROFIT=-PROFIT
SET SIGN="D"
+38 SET PROFLINE=LINEDA+1
+39 SET SELLINE="LIN^~IVA^"_$EXTRACT("000",$LENGTH(PROFLINE)+1,3)_PROFLINE_"^"_$JUSTIFY(PROFIT,0,2)_"^"_SIGN_"^^"_SELBFY_"^"_SELEFY_"^"_SELFUND_"^"_PRCPWSTA_"^^^^"_SELXPROG_"^^^^SFPR^^^0"_($SELECT(ACCT=1:4,ACCT=2:6,ACCT=8:2,1:8)+1)_"^^"
+40 SET BUYLINE="^"_BUYBFY_"^"_BUYEFY_"^"_BUYFUND_"^"_PRCPPSTA_"^^"_$EXTRACT(COSTCNTR,1,4)_"00^"_$EXTRACT(COSTCNTR,5,6)_"^"_BUYXPROG_"^"_SUBACCT_"^~"
+41 SET LINEDOC=SELLINE_BUYLINE_"IVB^01^~"
+42 DO SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
End DoDot:1
+43 ;
+44 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+45 DO EN^DDIOL("FMS IV "_$SELECT($DATA(GECSFMS("BAT")):"MODIFICATION ",1:"")_PRCPWSTA_VOUCHER_" document automatically "_$SELECT($GET(STACKDA):"RE-",1:"")_"transmitted.","","!?4")
+46 QUIT
