PRCPUUIP ;WISC/RFJ-utility update item prim to secondary ;08 Jul 92
;;5.1;IFCAP;**126**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
ITEM(INVPT,ITEMDA,TRANTYPE,ORDERNO,PRCPDATA) ; update inventory point item
;prcpdata =
; qty) = quantity to add to on-hand
; invval) = total inventory value
; selval) = total sales value
; otherpt) = other inventory point affected (for issues)
; reason) = reason (for adjustments)
; date) = date of transaction (optional)
; pkg) = packaging units on transaction register
; noduein) = do not decrement dueins if $data (optional)
; nodueout) = do not decrement dueouts if $data (optional)
;
;returns
; prcpid = transaction 445.2 da number
;
N %,COSTCNTR,DATE,ITEMDATA,PRCPUUIP,X,Y
D NOW^%DTC S DATE=%
I '$D(^PRCP(445.1,INVPT,1,ITEMDA,1,$E(DATE,1,5),0)) D BALANCE^PRCPUBAL(INVPT,ITEMDA,$E(DATE,1,5))
I $P($G(^PRCP(445,INVPT,0)),"^",6)="Y" D
. K PRCPUUIP F %="DATE","QTY","INVVAL","SELVAL","PKG","REF","2237PO","ISSUE","OTHERPT","REASON" I $D(PRCPDATA(%)) S PRCPUUIP(%)=PRCPDATA(%)
. K PRCPID D ADDTRAN^PRCPUTRX(INVPT,ITEMDA,TRANTYPE,ORDERNO,.PRCPUUIP) K PRCPUUIP S PRCPID=+$G(Y)
I '$D(^PRCP(445,INVPT,1,ITEMDA,0))&((TRANTYPE="R")!(TRANTYPE="C")) D Q
. ; update costcenter costs and quit
. ; use costcenter for primary since second do not have costcneters
. S COSTCNTR=$P($G(^PRCP(445,INVPT,0)),"^",7)
. I COSTCNTR D COSTCNTR^PRCPUCC(PRCPDATA("OTHERPT"),INVPT,COSTCNTR,-PRCPDATA("SELVAL"))
I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
L +^PRCP(445,INVPT,1,ITEMDA)
S ITEMDATA=^PRCP(445,INVPT,1,ITEMDA,0)
;
; RC=receipts
I TRANTYPE="RC" D
. D RECEIPTS^PRCPUSAG(INVPT,ITEMDA,PRCPDATA("QTY"))
. ; do not update dueins if "noduein" defined
. I '$D(PRCPDATA("NODUEIN")) D SETIN^PRCPUDUE(INVPT,ITEMDA,-PRCPDATA("QTY"))
. S $P(ITEMDATA,"^",15)=$J(PRCPDATA("INVVAL")/PRCPDATA("QTY"),0,3),$P(ITEMDATA,"^",3)=$E(DATE,1,7)
;
; R or C=distribution
I TRANTYPE="R"!(TRANTYPE="C") D
. D ADDUSAG^PRCPUSAG(INVPT,ITEMDA,-PRCPDATA("QTY"),-PRCPDATA("INVVAL"))
. ; use costcenter for primary since second do not have costcenters
. S COSTCNTR=$P($G(^PRCP(445,INVPT,0)),"^",7)
. I COSTCNTR D COSTCNTR^PRCPUCC(PRCPDATA("OTHERPT"),INVPT,COSTCNTR,-PRCPDATA("SELVAL"))
. ; do not update dueouts if "nodueout" defined
. I '$D(PRCPDATA("NODUEOUT")) D SETOUT^PRCPUDUE(INVPT,ITEMDA,PRCPDATA("QTY"))
;
; U=usage
I TRANTYPE="U" D
. D ADDUSAG^PRCPUSAG(INVPT,ITEMDA,-PRCPDATA("QTY"),-PRCPDATA("INVVAL"))
;
; update inventory item
I '$P(ITEMDATA,"^",27) S $P(ITEMDATA,"^",27)=$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2)
S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+PRCPDATA("QTY")
S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+PRCPDATA("INVVAL")
S $P(ITEMDATA,"^",22)=0,%=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19) I %>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/%,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
I TRANTYPE="P",$P(ITEMDATA,"^",22)=0 S $P(ITEMDATA,"^",22)=$P(ITEMDATA,"^",15)
S ^PRCP(445,INVPT,1,ITEMDA,0)=ITEMDATA
L -^PRCP(445,INVPT,1,ITEMDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUUIP 3214 printed Oct 16, 2024@18:17:13 Page 2
PRCPUUIP ;WISC/RFJ-utility update item prim to secondary ;08 Jul 92
+1 ;;5.1;IFCAP;**126**;Oct 20, 2000;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ITEM(INVPT,ITEMDA,TRANTYPE,ORDERNO,PRCPDATA) ; update inventory point item
+1 ;prcpdata =
+2 ; qty) = quantity to add to on-hand
+3 ; invval) = total inventory value
+4 ; selval) = total sales value
+5 ; otherpt) = other inventory point affected (for issues)
+6 ; reason) = reason (for adjustments)
+7 ; date) = date of transaction (optional)
+8 ; pkg) = packaging units on transaction register
+9 ; noduein) = do not decrement dueins if $data (optional)
+10 ; nodueout) = do not decrement dueouts if $data (optional)
+11 ;
+12 ;returns
+13 ; prcpid = transaction 445.2 da number
+14 ;
+15 NEW %,COSTCNTR,DATE,ITEMDATA,PRCPUUIP,X,Y
+16 DO NOW^%DTC
SET DATE=%
+17 IF '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,1,$EXTRACT(DATE,1,5),0))
DO BALANCE^PRCPUBAL(INVPT,ITEMDA,$EXTRACT(DATE,1,5))
+18 IF $PIECE($GET(^PRCP(445,INVPT,0)),"^",6)="Y"
Begin DoDot:1
+19 KILL PRCPUUIP
FOR %="DATE","QTY","INVVAL","SELVAL","PKG","REF","2237PO","ISSUE","OTHERPT","REASON"
IF $DATA(PRCPDATA(%))
SET PRCPUUIP(%)=PRCPDATA(%)
+20 KILL PRCPID
DO ADDTRAN^PRCPUTRX(INVPT,ITEMDA,TRANTYPE,ORDERNO,.PRCPUUIP)
KILL PRCPUUIP
SET PRCPID=+$GET(Y)
End DoDot:1
+21 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))&((TRANTYPE="R")!(TRANTYPE="C"))
Begin DoDot:1
+22 ; update costcenter costs and quit
+23 ; use costcenter for primary since second do not have costcneters
+24 SET COSTCNTR=$PIECE($GET(^PRCP(445,INVPT,0)),"^",7)
+25 IF COSTCNTR
DO COSTCNTR^PRCPUCC(PRCPDATA("OTHERPT"),INVPT,COSTCNTR,-PRCPDATA("SELVAL"))
End DoDot:1
QUIT
+26 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))
QUIT
+27 LOCK +^PRCP(445,INVPT,1,ITEMDA)
+28 SET ITEMDATA=^PRCP(445,INVPT,1,ITEMDA,0)
+29 ;
+30 ; RC=receipts
+31 IF TRANTYPE="RC"
Begin DoDot:1
+32 DO RECEIPTS^PRCPUSAG(INVPT,ITEMDA,PRCPDATA("QTY"))
+33 ; do not update dueins if "noduein" defined
+34 IF '$DATA(PRCPDATA("NODUEIN"))
DO SETIN^PRCPUDUE(INVPT,ITEMDA,-PRCPDATA("QTY"))
+35 SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(PRCPDATA("INVVAL")/PRCPDATA("QTY"),0,3)
SET $PIECE(ITEMDATA,"^",3)=$EXTRACT(DATE,1,7)
End DoDot:1
+36 ;
+37 ; R or C=distribution
+38 IF TRANTYPE="R"!(TRANTYPE="C")
Begin DoDot:1
+39 DO ADDUSAG^PRCPUSAG(INVPT,ITEMDA,-PRCPDATA("QTY"),-PRCPDATA("INVVAL"))
+40 ; use costcenter for primary since second do not have costcenters
+41 SET COSTCNTR=$PIECE($GET(^PRCP(445,INVPT,0)),"^",7)
+42 IF COSTCNTR
DO COSTCNTR^PRCPUCC(PRCPDATA("OTHERPT"),INVPT,COSTCNTR,-PRCPDATA("SELVAL"))
+43 ; do not update dueouts if "nodueout" defined
+44 IF '$DATA(PRCPDATA("NODUEOUT"))
DO SETOUT^PRCPUDUE(INVPT,ITEMDA,PRCPDATA("QTY"))
End DoDot:1
+45 ;
+46 ; U=usage
+47 IF TRANTYPE="U"
Begin DoDot:1
+48 DO ADDUSAG^PRCPUSAG(INVPT,ITEMDA,-PRCPDATA("QTY"),-PRCPDATA("INVVAL"))
End DoDot:1
+49 ;
+50 ; update inventory item
+51 IF '$PIECE(ITEMDATA,"^",27)
SET $PIECE(ITEMDATA,"^",27)=$JUSTIFY($PIECE(ITEMDATA,"^",7)*$PIECE(ITEMDATA,"^",22),0,2)
+52 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+PRCPDATA("QTY")
+53 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+PRCPDATA("INVVAL")
+54 SET $PIECE(ITEMDATA,"^",22)=0
SET %=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
IF %>0
SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/%,0,3)
IF $PIECE(ITEMDATA,"^",22)'>0
SET $PIECE(ITEMDATA,"^",22)=0
+55 IF TRANTYPE="P"
IF $PIECE(ITEMDATA,"^",22)=0
SET $PIECE(ITEMDATA,"^",22)=$PIECE(ITEMDATA,"^",15)
+56 SET ^PRCP(445,INVPT,1,ITEMDA,0)=ITEMDATA
+57 LOCK -^PRCP(445,INVPT,1,ITEMDA)
+58 QUIT
