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