PRCPSFSV ;WOIFO/RFJ,LKG-create fms sv adjustment code sheet ;7/8/05 10:11
;;5.1;IFCAP;**81,85**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
SV(INVPT,TRANID,TRANDATE,STACKDA) ; create fms sv document for adjustment
; tranid=transaction register id number
; pass trandate for optional FMS acctg period, otherwise it uses the
; transaction date
; pass stackda for regeneration of document
; loop transaction register for adjusted items
; variables required:
; prcpwbfy = whse beg fy ; prcpwfcp = whse fcp
; prcpwsta = whse station #
N ACCT,BFY,DATA,EFY,FUND,GECSFMS,INVCOST,LINE,LINEDOC,PRCPFMS,PRCPSEC1,REASON,SIGN,TABLE,TOTAL,TRANDA,XPROG
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
. I '$P(DATA,"^",5) Q
. S INVCOST=$P(DATA,"^",22) I 'INVCOST Q
. I 'TRANDATE S TRANDATE=$P(DATA,"^",3)
. S ACCT=$$ACCT1^PRCPUX1($P($$NSN^PRCPUX1($P(DATA,"^",5)),"-"))
. S REASON=+$P(DATA,"^",10) I 'REASON S REASON=+$G(^PRCP(445.2,TRANDA,1))
. S TOTAL=TOTAL+INVCOST
. S PRCPFMS(ACCT,REASON)=$G(PRCPFMS(ACCT,REASON))+INVCOST
. I PRCPFMS(ACCT,REASON)=0 K PRCPFMS(ACCT,REASON)
I '$D(PRCPFMS) Q
;
SVCOTS ;Entry point for SV from COTS inventory transaction
; set up document variables
; table=^^xprogram(fcp/prj)^^linefund^beginfy^endfy^^^job
S TABLE=$$ACC^PRC0C(PRCPWSTA,PRCPWFCP_"^"_$E(DT,2,3)_"^"_PRCPWBFY)
S XPROG=$P(TABLE,"^",3),FUND=$P(TABLE,"^",5),BFY=$E($P(TABLE,"^",6),3,4),EFY=$E($P(TABLE,"^",7),3,4)
I EFY=BFY S EFY=""
;
; build control segments in gcs
S PRCPSEC1=$$SEC1^PRC0C(PRCPWSTA) S:PRCPSEC1="" PRCPSEC1=10
I '$G(STACKDA) D CONTROL^GECSUFMS("I",PRCPWSTA,PRCPWSTA_TRANID,"SV",PRCPSEC1,0,"","Other adjustment tranid: "_TRANID)
I $G(STACKDA) D REBUILD^GECSUFM1(STACKDA,"I",PRCPSEC1,"","Rebuild of Other adjustment tranid: "_TRANID) S GECSFMS("DA")=STACKDA
D SETPARAM^GECSSDCT(GECSFMS("DA"),TRANID)
;
; build iv2 segment
S LINEDOC="SV2^"_$E(TRANDATE,2,3)_"^"_$E(TRANDATE,4,5)_"^"_$E(TRANDATE,6,7)
S $P(LINEDOC,"^",7)="E"
S $P(LINEDOC,"^",16)=$J($S(TOTAL<0:-TOTAL,1:TOTAL),0,2)
D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC_"^~")
;
; build line documents
S (ACCT,LINE)=0 F S ACCT=$O(PRCPFMS(ACCT)) Q:'ACCT S REASON="" F S REASON=$O(PRCPFMS(ACCT,REASON)) Q:REASON="" S INVCOST=PRCPFMS(ACCT,REASON) I INVCOST D
. S SIGN="I" I INVCOST<0 S INVCOST=-INVCOST,SIGN="D"
. S LINE=LINE+1
. S LINEDOC="LIN^~SVA^"_$E("000",$L(LINE)+1,3)_LINE_"^S"_$$TRANTYPE(REASON,ACCT)_"^"_BFY_"^"_EFY_"^"_FUND_"^^"_PRCPWSTA_"^^^^"_XPROG
. S $P(LINEDOC,"^",24)="220"
. S LINEDOC=LINEDOC_"^~SVB^"_$J(INVCOST,0,2)_"^"_SIGN_"^^G^~"
. D SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
;
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
D EN^DDIOL("FMS SV "_PRCPWSTA_TRANID_" document automatically "_$S($G(STACKDA):"RE-",1:"")_"transmitted.","","!?4")
Q
;
;
TRANTYPE(TYPE,ACCT) ; return transaction type based on type (1-7) and acct
; type=1:transfer stock to VAMC whse
; type=2:sale of stock to OGA
; type=3:transfer excess stock to GSA
; type=4:adjustment to stock valuation
; type=5:writeoff damaged stock
; type=6:transfer transportation to stock
; type=7:inventory refund adjustment
I TYPE=1 Q $S(ACCT=1:"A",ACCT=2:"B",ACCT=3:"C",ACCT=8:"D",ACCT=6:"N",1:0)
I TYPE=2 Q $S(ACCT=1:"E",ACCT=2:"F",ACCT=3:"G",ACCT=8:"H",ACCT=6:"N",1:0)
I TYPE=3 Q $S(ACCT=1:"J",ACCT=2:"J",ACCT=3:"J",ACCT=8:"J",ACCT=6:"N",1:0)
I TYPE=4 Q $S(ACCT=1:"M",ACCT=2:"N",ACCT=3:"N",ACCT=8:"N",ACCT=6:"N",1:0)
I TYPE=5 Q $S(ACCT=1:"M",ACCT=2:"N",ACCT=3:"N",ACCT=8:"N",ACCT=6:"N",1:0)
I TYPE=6 Q $S(ACCT=1:"Q",ACCT=2:"Q",ACCT=3:"Q",ACCT=8:"Q",ACCT=6:"N",1:0)
I TYPE=7 Q $S(ACCT=1:"U",ACCT=2:"U",ACCT=3:"U",ACCT=8:"U",ACCT=6:"N",1:0)
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSFSV 3933 printed Dec 13, 2024@02:15:47 Page 2
PRCPSFSV ;WOIFO/RFJ,LKG-create fms sv adjustment code sheet ;7/8/05 10:11
+1 ;;5.1;IFCAP;**81,85**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
SV(INVPT,TRANID,TRANDATE,STACKDA) ; create fms sv document for adjustment
+1 ; tranid=transaction register id number
+2 ; pass trandate for optional FMS acctg period, otherwise it uses the
+3 ; transaction date
+4 ; pass stackda for regeneration of document
+5 ; loop transaction register for adjusted items
+6 ; variables required:
+7 ; prcpwbfy = whse beg fy ; prcpwfcp = whse fcp
+8 ; prcpwsta = whse station #
+9 NEW ACCT,BFY,DATA,EFY,FUND,GECSFMS,INVCOST,LINE,LINEDOC,PRCPFMS,PRCPSEC1,REASON,SIGN,TABLE,TOTAL,TRANDA,XPROG
+10 KILL PRCPFMS
+11 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
+12 IF '$PIECE(DATA,"^",5)
QUIT
+13 SET INVCOST=$PIECE(DATA,"^",22)
IF 'INVCOST
QUIT
+14 IF 'TRANDATE
SET TRANDATE=$PIECE(DATA,"^",3)
+15 SET ACCT=$$ACCT1^PRCPUX1($PIECE($$NSN^PRCPUX1($PIECE(DATA,"^",5)),"-"))
+16 SET REASON=+$PIECE(DATA,"^",10)
IF 'REASON
SET REASON=+$GET(^PRCP(445.2,TRANDA,1))
+17 SET TOTAL=TOTAL+INVCOST
+18 SET PRCPFMS(ACCT,REASON)=$GET(PRCPFMS(ACCT,REASON))+INVCOST
+19 IF PRCPFMS(ACCT,REASON)=0
KILL PRCPFMS(ACCT,REASON)
End DoDot:1
+20 IF '$DATA(PRCPFMS)
QUIT
+21 ;
SVCOTS ;Entry point for SV from COTS inventory transaction
+1 ; set up document variables
+2 ; table=^^xprogram(fcp/prj)^^linefund^beginfy^endfy^^^job
+3 SET TABLE=$$ACC^PRC0C(PRCPWSTA,PRCPWFCP_"^"_$EXTRACT(DT,2,3)_"^"_PRCPWBFY)
+4 SET XPROG=$PIECE(TABLE,"^",3)
SET FUND=$PIECE(TABLE,"^",5)
SET BFY=$EXTRACT($PIECE(TABLE,"^",6),3,4)
SET EFY=$EXTRACT($PIECE(TABLE,"^",7),3,4)
+5 IF EFY=BFY
SET EFY=""
+6 ;
+7 ; build control segments in gcs
+8 SET PRCPSEC1=$$SEC1^PRC0C(PRCPWSTA)
if PRCPSEC1=""
SET PRCPSEC1=10
+9 IF '$GET(STACKDA)
DO CONTROL^GECSUFMS("I",PRCPWSTA,PRCPWSTA_TRANID,"SV",PRCPSEC1,0,"","Other adjustment tranid: "_TRANID)
+10 IF $GET(STACKDA)
DO REBUILD^GECSUFM1(STACKDA,"I",PRCPSEC1,"","Rebuild of Other adjustment tranid: "_TRANID)
SET GECSFMS("DA")=STACKDA
+11 DO SETPARAM^GECSSDCT(GECSFMS("DA"),TRANID)
+12 ;
+13 ; build iv2 segment
+14 SET LINEDOC="SV2^"_$EXTRACT(TRANDATE,2,3)_"^"_$EXTRACT(TRANDATE,4,5)_"^"_$EXTRACT(TRANDATE,6,7)
+15 SET $PIECE(LINEDOC,"^",7)="E"
+16 SET $PIECE(LINEDOC,"^",16)=$JUSTIFY($SELECT(TOTAL<0:-TOTAL,1:TOTAL),0,2)
+17 DO SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC_"^~")
+18 ;
+19 ; build line documents
+20 SET (ACCT,LINE)=0
FOR
SET ACCT=$ORDER(PRCPFMS(ACCT))
if 'ACCT
QUIT
SET REASON=""
FOR
SET REASON=$ORDER(PRCPFMS(ACCT,REASON))
if REASON=""
QUIT
SET INVCOST=PRCPFMS(ACCT,REASON)
IF INVCOST
Begin DoDot:1
+21 SET SIGN="I"
IF INVCOST<0
SET INVCOST=-INVCOST
SET SIGN="D"
+22 SET LINE=LINE+1
+23 SET LINEDOC="LIN^~SVA^"_$EXTRACT("000",$LENGTH(LINE)+1,3)_LINE_"^S"_$$TRANTYPE(REASON,ACCT)_"^"_BFY_"^"_EFY_"^"_FUND_"^^"_PRCPWSTA_"^^^^"_XPROG
+24 SET $PIECE(LINEDOC,"^",24)="220"
+25 SET LINEDOC=LINEDOC_"^~SVB^"_$JUSTIFY(INVCOST,0,2)_"^"_SIGN_"^^G^~"
+26 DO SETCS^GECSSTAA(GECSFMS("DA"),LINEDOC)
End DoDot:1
+27 ;
+28 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+29 DO EN^DDIOL("FMS SV "_PRCPWSTA_TRANID_" document automatically "_$SELECT($GET(STACKDA):"RE-",1:"")_"transmitted.","","!?4")
+30 QUIT
+31 ;
+32 ;
TRANTYPE(TYPE,ACCT) ; return transaction type based on type (1-7) and acct
+1 ; type=1:transfer stock to VAMC whse
+2 ; type=2:sale of stock to OGA
+3 ; type=3:transfer excess stock to GSA
+4 ; type=4:adjustment to stock valuation
+5 ; type=5:writeoff damaged stock
+6 ; type=6:transfer transportation to stock
+7 ; type=7:inventory refund adjustment
+8 IF TYPE=1
QUIT $SELECT(ACCT=1:"A",ACCT=2:"B",ACCT=3:"C",ACCT=8:"D",ACCT=6:"N",1:0)
+9 IF TYPE=2
QUIT $SELECT(ACCT=1:"E",ACCT=2:"F",ACCT=3:"G",ACCT=8:"H",ACCT=6:"N",1:0)
+10 IF TYPE=3
QUIT $SELECT(ACCT=1:"J",ACCT=2:"J",ACCT=3:"J",ACCT=8:"J",ACCT=6:"N",1:0)
+11 IF TYPE=4
QUIT $SELECT(ACCT=1:"M",ACCT=2:"N",ACCT=3:"N",ACCT=8:"N",ACCT=6:"N",1:0)
+12 IF TYPE=5
QUIT $SELECT(ACCT=1:"M",ACCT=2:"N",ACCT=3:"N",ACCT=8:"N",ACCT=6:"N",1:0)
+13 IF TYPE=6
QUIT $SELECT(ACCT=1:"Q",ACCT=2:"Q",ACCT=3:"Q",ACCT=8:"Q",ACCT=6:"N",1:0)
+14 IF TYPE=7
QUIT $SELECT(ACCT=1:"U",ACCT=2:"U",ACCT=3:"U",ACCT=8:"U",ACCT=6:"N",1:0)
+15 QUIT 0
