- 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 Feb 18, 2025@23:42:09 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