PRCPUUIW ;WISC/RFJ-utility update item whse to prim ;08 Jul 92
;;5.1;IFCAP;**221**;4/21/95;Build 14
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*221 If Total Inventory Value is zero DO NOT
; recalulate Onhand*Avg Price which cause
; doubling of of adjustment entered for
; Total Inventory Value
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
; 2237po) = 2237 or purchase order number
; ref) = reference number
; otherpt) = other inventory point affected (for issues)
; reason) = reason (for adjustments)
; reasoncode)= reason code for other adjustments
; date) = date of transaction (optional)
; tranda) = transaction number for removing due-ins
; pkg) = packaging units on transaction register
; drugacct) = update drug accountability
;
;returns
; prcpid = transaction 445.2 da number
;
N %,COSTCNTR,DATE,INVTYPE,ITEMDATA,PRCPUUIW,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 PRCPUUIW F %="DATE","QTY","INVVAL","SELVAL","PKG","REF","2237PO","ISSUE","OTHERPT","REASON","REASONCODE" I $D(PRCPDATA(%)) S PRCPUUIW(%)=PRCPDATA(%)
. K PRCPID D ADDTRAN^PRCPUTRX(INVPT,ITEMDA,TRANTYPE,ORDERNO,.PRCPUUIW) K PRCPUUIW S PRCPID=+$G(Y)
S INVTYPE=$P(^PRCP(445,INVPT,0),"^",3)
I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
L +^PRCP(445,INVPT,1,ITEMDA):$G(DILOCKTM,5)
S ITEMDATA=^PRCP(445,INVPT,1,ITEMDA,0)
; purchase order
I PRCPDATA("2237PO")'="",$P(PRCPDATA("2237PO"),"-",3)="" D
. I PRCPDATA("QTY") D RECEIPTS^PRCPUSAG(INVPT,ITEMDA,PRCPDATA("QTY"))
;
; 2237 issue
I $P(PRCPDATA("2237PO"),"-",3)'="" D
. I INVTYPE="W" D
. . D ADDUSAG^PRCPUSAG(INVPT,ITEMDA,-PRCPDATA("QTY"),-PRCPDATA("INVVAL"))
. . I TRANTYPE="R" D SETOUT^PRCPUDUE(INVPT,ITEMDA,PRCPDATA("QTY"))
. I INVTYPE="P" D
. . D RECEIPTS^PRCPUSAG(INVPT,ITEMDA,PRCPDATA("QTY"))
. . S COSTCNTR=$P($G(^PRCP(445,INVPT,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(INVPT,PRCPDATA("OTHERPT"),COSTCNTR,PRCPDATA("SELVAL"))
; update drug accountability
I INVTYPE="P",$G(PRCPDATA("DRUGACCT")) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(INVPT,ITEMDA,PRCPDATA("QTY")*%,$G(PRCPDATA("TRANDA")),PRCPDATA("2237PO"),TRANTYPE_ORDERNO,PRCPDATA("INVVAL"))
; update inventory item
;I '$P(ITEMDATA,"^",27) S $P(ITEMDATA,"^",27)=$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2) ;PRC*5.1*221 comment out calc
S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+PRCPDATA("QTY")
I $D(PRCPDATA("ISSUE")) S $P(ITEMDATA,"^",19)=$P(ITEMDATA,"^",19)-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 TRANTYPE="RC",$G(PRCPDATA("TRANDA")) D OUTST^PRCPUTRA(INVPT,ITEMDA,PRCPDATA("TRANDA"),-PRCPDATA("QTY"))
I TRANTYPE="RC",PRCPDATA("QTY") S $P(ITEMDATA,"^",15)=$J(PRCPDATA("INVVAL")/PRCPDATA("QTY"),0,3),$P(ITEMDATA,"^",3)=$E(DATE,1,7)
I PRCPDATA("2237PO")'="",$P(PRCPDATA("2237PO"),"-",3)="",INVTYPE="W",$D(^PRC(441,ITEMDA,2,+$O(^PRC(440,"AC","S",0)),0)) S $P(^(0),"^",2)=$S($P(ITEMDATA,"^",15)>$P(ITEMDATA,"^",22):$P(ITEMDATA,"^",15),1:$P(ITEMDATA,"^",22))
S ^PRCP(445,INVPT,1,ITEMDA,0)=ITEMDATA
L -^PRCP(445,INVPT,1,ITEMDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUUIW 3611 printed Oct 16, 2024@18:17:14 Page 2
PRCPUUIW ;WISC/RFJ-utility update item whse to prim ;08 Jul 92
+1 ;;5.1;IFCAP;**221**;4/21/95;Build 14
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;PRC*5.1*221 If Total Inventory Value is zero DO NOT
+5 ; recalulate Onhand*Avg Price which cause
+6 ; doubling of of adjustment entered for
+7 ; Total Inventory Value
+8 QUIT
+9 ;
+10 ;
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 ; 2237po) = 2237 or purchase order number
+6 ; ref) = reference number
+7 ; otherpt) = other inventory point affected (for issues)
+8 ; reason) = reason (for adjustments)
+9 ; reasoncode)= reason code for other adjustments
+10 ; date) = date of transaction (optional)
+11 ; tranda) = transaction number for removing due-ins
+12 ; pkg) = packaging units on transaction register
+13 ; drugacct) = update drug accountability
+14 ;
+15 ;returns
+16 ; prcpid = transaction 445.2 da number
+17 ;
+18 NEW %,COSTCNTR,DATE,INVTYPE,ITEMDATA,PRCPUUIW,X,Y
+19 DO NOW^%DTC
SET DATE=%
+20 IF '$DATA(^PRCP(445.1,INVPT,1,ITEMDA,1,$EXTRACT(DATE,1,5),0))
DO BALANCE^PRCPUBAL(INVPT,ITEMDA,$EXTRACT(DATE,1,5))
+21 IF $PIECE($GET(^PRCP(445,INVPT,0)),"^",6)="Y"
Begin DoDot:1
+22 KILL PRCPUUIW
FOR %="DATE","QTY","INVVAL","SELVAL","PKG","REF","2237PO","ISSUE","OTHERPT","REASON","REASONCODE"
IF $DATA(PRCPDATA(%))
SET PRCPUUIW(%)=PRCPDATA(%)
+23 KILL PRCPID
DO ADDTRAN^PRCPUTRX(INVPT,ITEMDA,TRANTYPE,ORDERNO,.PRCPUUIW)
KILL PRCPUUIW
SET PRCPID=+$GET(Y)
End DoDot:1
+24 SET INVTYPE=$PIECE(^PRCP(445,INVPT,0),"^",3)
+25 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))
QUIT
+26 LOCK +^PRCP(445,INVPT,1,ITEMDA):$GET(DILOCKTM,5)
+27 SET ITEMDATA=^PRCP(445,INVPT,1,ITEMDA,0)
+28 ; purchase order
+29 IF PRCPDATA("2237PO")'=""
IF $PIECE(PRCPDATA("2237PO"),"-",3)=""
Begin DoDot:1
+30 IF PRCPDATA("QTY")
DO RECEIPTS^PRCPUSAG(INVPT,ITEMDA,PRCPDATA("QTY"))
End DoDot:1
+31 ;
+32 ; 2237 issue
+33 IF $PIECE(PRCPDATA("2237PO"),"-",3)'=""
Begin DoDot:1
+34 IF INVTYPE="W"
Begin DoDot:2
+35 DO ADDUSAG^PRCPUSAG(INVPT,ITEMDA,-PRCPDATA("QTY"),-PRCPDATA("INVVAL"))
+36 IF TRANTYPE="R"
DO SETOUT^PRCPUDUE(INVPT,ITEMDA,PRCPDATA("QTY"))
End DoDot:2
+37 IF INVTYPE="P"
Begin DoDot:2
+38 DO RECEIPTS^PRCPUSAG(INVPT,ITEMDA,PRCPDATA("QTY"))
+39 SET COSTCNTR=$PIECE($GET(^PRCP(445,INVPT,0)),"^",7)
IF COSTCNTR
DO COSTCNTR^PRCPUCC(INVPT,PRCPDATA("OTHERPT"),COSTCNTR,PRCPDATA("SELVAL"))
End DoDot:2
End DoDot:1
+40 ; update drug accountability
+41 IF INVTYPE="P"
IF $GET(PRCPDATA("DRUGACCT"))
SET %=+$PIECE(ITEMDATA,"^",29)
if '%
SET %=1
DO EN^PSAGIP(INVPT,ITEMDA,PRCPDATA("QTY")*%,$GET(PRCPDATA("TRANDA")),PRCPDATA("2237PO"),TRANTYPE_ORDERNO,PRCPDATA("INVVAL"))
+42 ; update inventory item
+43 ;I '$P(ITEMDATA,"^",27) S $P(ITEMDATA,"^",27)=$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2) ;PRC*5.1*221 comment out calc
+44 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+PRCPDATA("QTY")
+45 IF $DATA(PRCPDATA("ISSUE"))
SET $PIECE(ITEMDATA,"^",19)=$PIECE(ITEMDATA,"^",19)-PRCPDATA("QTY")
+46 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+PRCPDATA("INVVAL")
+47 SET $PIECE(ITEMDATA,"^",22)=0
SET %=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
IF %>0
SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/%,0,3)
+48 IF TRANTYPE="RC"
IF $GET(PRCPDATA("TRANDA"))
DO OUTST^PRCPUTRA(INVPT,ITEMDA,PRCPDATA("TRANDA"),-PRCPDATA("QTY"))
+49 IF TRANTYPE="RC"
IF PRCPDATA("QTY")
SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(PRCPDATA("INVVAL")/PRCPDATA("QTY"),0,3)
SET $PIECE(ITEMDATA,"^",3)=$EXTRACT(DATE,1,7)
+50 IF PRCPDATA("2237PO")'=""
IF $PIECE(PRCPDATA("2237PO"),"-",3)=""
IF INVTYPE="W"
IF $DATA(^PRC(441,ITEMDA,2,+$ORDER(^PRC(440,"AC","S",0)),0))
SET $PIECE(^(0),"^",2)=$SELECT($PIECE(ITEMDATA,"^",15)>$PIECE(ITEMDATA,"^",22):$PIECE(ITEMDATA,"^",15),1:$PIECE(ITEMDATA,"^",22))
+51 SET ^PRCP(445,INVPT,1,ITEMDA,0)=ITEMDATA
+52 LOCK -^PRCP(445,INVPT,1,ITEMDA)
+53 QUIT
