PRCPOPPP ;WISC/RFJ/DWA-move item from prim to seco to patient ;27 Sep 93
;;5.1;IFCAP;**4,33,200**;Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
Q
;
;PRC*5.1*200 Check when posting inventory distribution to
; secondary IP that the qty and cost are not
; affected when Perpetual flag = "N"
;
SALE(PRCPPRIM,ITEMDA,TRANORDR,PRCPOPPP) ; post item for primary sale
; tranordr=transaction register #
; prcpoppp("qty") = qty to sale (include minus for sale)
; prcpoppp("invval") = inv value sold (include minus for sale)
; prcpoppp("orderda")= ien of ordernumber in 445.3 (used for type)
; prcpoppp("otherpt") = inv pt sold to
; prcpoppp("dueout") = dueout qty to add (- to subtract)
; prcpoppp("reason") = 0:reason for transaction register
; prcpoppp("noinvpt") = set to 1 to prevent from updating invpt
; locks to inventory pt prcpprim need to be applied before entry
;
; distribution costs
N COSTCNTR,TYPE
; use costcenter for primary since secondaries do not have costcenters
S COSTCNTR=$P($G(^PRCP(445,PRCPPRIM,0)),"^",7)
I COSTCNTR,$G(PRCPOPPP("OTHERPT")) D COSTCNTR^PRCPUCC(PRCPOPPP("OTHERPT"),PRCPPRIM,COSTCNTR,-PRCPOPPP("INVVAL"))
;
; usage
D ADDUSAG^PRCPUSAG(PRCPPRIM,ITEMDA,-PRCPOPPP("QTY"),-PRCPOPPP("INVVAL"))
;
; if prcpoppp("noinvpt"), do not update inventory point
I $G(PRCPOPPP("NOINVPT")) Q
;
; update begin balance, inventory point, transaction register
S TYPE=$P($G(^PRCP(445.3,+$G(PRCPOPPP("ORDERDA")),0)),"^",8) I TYPE="" S TYPE="R"
D INVPT(PRCPPRIM,ITEMDA,TYPE,TRANORDR,.PRCPOPPP)
Q
;
;
RECEIPT(PRCPSECO,ITEMDA,TRANORDR,PRCPOPPP) ; receive items
; tranordr=transaction register #
; prcpoppp("qty") = qty to receive
; prcpoppp("invval") = inv value received
; prcpoppp("otherpt") = inv pt received from
; prcpoppp("duein") = duein qty to add (- to subtract)
; prcpoppp("reason") = 0:reason for transaction register
; for patient distributions:
; prcpoppp("prcpptda") = ptr to file 446.1 (patient distribution)
; locks to inventory pt prcpseco need to be applied before entry
;
; receipt history
D RECEIPTS^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"))
;
; update inventory point
D INVPT(PRCPSECO,ITEMDA,"RC",TRANORDR,.PRCPOPPP)
;
; if no patient quit
I '$G(PRCPOPPP("PRCPPTDA")) Q
;
; sale to patient
;
; usage
D ADDUSAG^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"),PRCPOPPP("INVVAL"))
;
; take out of inventory point
N COST,QTY,Y
S QTY=PRCPOPPP("QTY"),COST=PRCPOPPP("INVVAL")
S PRCPOPPP("QTY")=-QTY,(PRCPOPPP("INVVAL"),PRCPOPPP("SELVAL"))=-COST
K PRCPOPPP("OTHERPT"),PRCPOPPP("DUEIN")
S Y=PRCPPTDA D DD^%DT
S PRCPOPPP("REASON")="0:Distribution to patient ("_Y_")"
D INVPT(PRCPSECO,ITEMDA,"R",TRANORDR,.PRCPOPPP)
;
; distribute to patient
D DISTITEM^PRCPUPAT(PRCPPTDA,ITEMDA,QTY,COST)
Q
;
;
INVPT(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,PRCPOPPP) ; update inventory point data
; trantype=type of transaction; tranordr=transaction register #
; prcpoppp("qty") = qty to add to inventory point
; prcpoppp("invval") = value to add to inventory point
; prcpoppp("otherpt") = inv pt sold to (for transaction register)
; prcpoppp("dueout") = qty to add to dueout
; prcpoppp("duein") = qty to add to duein
; prcpoppp("reason") = 0:reason for transaction register
; locks to inventory pt prcpinpt need to be applied before entry
;
N ITEMDATA,QUANTITY
I $P(^PRCP(445,PRCPINPT,0),"^",2)="N",$P(^PRCP(445,PRCPINPT,0),"^",3)="S" S PRCPOPPP("QTY")=0,PRCPOPPP("INVVAL")=0 ;PRC*5.1*200
S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
;
; update beginning balance
I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
;
; make sure inventory value has been set to qty*unitcost
I '$P(ITEMDATA,"^",27) S $P(ITEMDATA,"^",27)=$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2)
S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+PRCPOPPP("QTY")
S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+PRCPOPPP("INVVAL")
;
; update average cost
S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
S:TRANTYPE="RC" $P(ITEMDATA,"^",3)=DT
S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
;
; update dueout and duein
I $G(PRCPOPPP("DUEOUT"))<0 D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEOUT"))
I $G(PRCPOPPP("DUEIN"))<0 D SETIN^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEIN"))
;
;
; transaction register
S PRCPOPPP("SELVAL")=PRCPOPPP("INVVAL")
I TRANORDR D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,.PRCPOPPP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPPP 4791 printed Sep 23, 2025@19:50:23 Page 2
PRCPOPPP ;WISC/RFJ/DWA-move item from prim to seco to patient ;27 Sep 93
+1 ;;5.1;IFCAP;**4,33,200**;Oct 20, 2000;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;PRC*5.1*200 Check when posting inventory distribution to
+6 ; secondary IP that the qty and cost are not
+7 ; affected when Perpetual flag = "N"
+8 ;
SALE(PRCPPRIM,ITEMDA,TRANORDR,PRCPOPPP) ; post item for primary sale
+1 ; tranordr=transaction register #
+2 ; prcpoppp("qty") = qty to sale (include minus for sale)
+3 ; prcpoppp("invval") = inv value sold (include minus for sale)
+4 ; prcpoppp("orderda")= ien of ordernumber in 445.3 (used for type)
+5 ; prcpoppp("otherpt") = inv pt sold to
+6 ; prcpoppp("dueout") = dueout qty to add (- to subtract)
+7 ; prcpoppp("reason") = 0:reason for transaction register
+8 ; prcpoppp("noinvpt") = set to 1 to prevent from updating invpt
+9 ; locks to inventory pt prcpprim need to be applied before entry
+10 ;
+11 ; distribution costs
+12 NEW COSTCNTR,TYPE
+13 ; use costcenter for primary since secondaries do not have costcenters
+14 SET COSTCNTR=$PIECE($GET(^PRCP(445,PRCPPRIM,0)),"^",7)
+15 IF COSTCNTR
IF $GET(PRCPOPPP("OTHERPT"))
DO COSTCNTR^PRCPUCC(PRCPOPPP("OTHERPT"),PRCPPRIM,COSTCNTR,-PRCPOPPP("INVVAL"))
+16 ;
+17 ; usage
+18 DO ADDUSAG^PRCPUSAG(PRCPPRIM,ITEMDA,-PRCPOPPP("QTY"),-PRCPOPPP("INVVAL"))
+19 ;
+20 ; if prcpoppp("noinvpt"), do not update inventory point
+21 IF $GET(PRCPOPPP("NOINVPT"))
QUIT
+22 ;
+23 ; update begin balance, inventory point, transaction register
+24 SET TYPE=$PIECE($GET(^PRCP(445.3,+$GET(PRCPOPPP("ORDERDA")),0)),"^",8)
IF TYPE=""
SET TYPE="R"
+25 DO INVPT(PRCPPRIM,ITEMDA,TYPE,TRANORDR,.PRCPOPPP)
+26 QUIT
+27 ;
+28 ;
RECEIPT(PRCPSECO,ITEMDA,TRANORDR,PRCPOPPP) ; receive items
+1 ; tranordr=transaction register #
+2 ; prcpoppp("qty") = qty to receive
+3 ; prcpoppp("invval") = inv value received
+4 ; prcpoppp("otherpt") = inv pt received from
+5 ; prcpoppp("duein") = duein qty to add (- to subtract)
+6 ; prcpoppp("reason") = 0:reason for transaction register
+7 ; for patient distributions:
+8 ; prcpoppp("prcpptda") = ptr to file 446.1 (patient distribution)
+9 ; locks to inventory pt prcpseco need to be applied before entry
+10 ;
+11 ; receipt history
+12 DO RECEIPTS^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"))
+13 ;
+14 ; update inventory point
+15 DO INVPT(PRCPSECO,ITEMDA,"RC",TRANORDR,.PRCPOPPP)
+16 ;
+17 ; if no patient quit
+18 IF '$GET(PRCPOPPP("PRCPPTDA"))
QUIT
+19 ;
+20 ; sale to patient
+21 ;
+22 ; usage
+23 DO ADDUSAG^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"),PRCPOPPP("INVVAL"))
+24 ;
+25 ; take out of inventory point
+26 NEW COST,QTY,Y
+27 SET QTY=PRCPOPPP("QTY")
SET COST=PRCPOPPP("INVVAL")
+28 SET PRCPOPPP("QTY")=-QTY
SET (PRCPOPPP("INVVAL"),PRCPOPPP("SELVAL"))=-COST
+29 KILL PRCPOPPP("OTHERPT"),PRCPOPPP("DUEIN")
+30 SET Y=PRCPPTDA
DO DD^%DT
+31 SET PRCPOPPP("REASON")="0:Distribution to patient ("_Y_")"
+32 DO INVPT(PRCPSECO,ITEMDA,"R",TRANORDR,.PRCPOPPP)
+33 ;
+34 ; distribute to patient
+35 DO DISTITEM^PRCPUPAT(PRCPPTDA,ITEMDA,QTY,COST)
+36 QUIT
+37 ;
+38 ;
INVPT(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,PRCPOPPP) ; update inventory point data
+1 ; trantype=type of transaction; tranordr=transaction register #
+2 ; prcpoppp("qty") = qty to add to inventory point
+3 ; prcpoppp("invval") = value to add to inventory point
+4 ; prcpoppp("otherpt") = inv pt sold to (for transaction register)
+5 ; prcpoppp("dueout") = qty to add to dueout
+6 ; prcpoppp("duein") = qty to add to duein
+7 ; prcpoppp("reason") = 0:reason for transaction register
+8 ; locks to inventory pt prcpinpt need to be applied before entry
+9 ;
+10 NEW ITEMDATA,QUANTITY
+11 ;PRC*5.1*200
IF $PIECE(^PRCP(445,PRCPINPT,0),"^",2)="N"
IF $PIECE(^PRCP(445,PRCPINPT,0),"^",3)="S"
SET PRCPOPPP("QTY")=0
SET PRCPOPPP("INVVAL")=0
+12 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
IF ITEMDATA=""
QUIT
+13 ;
+14 ; update beginning balance
+15 IF '$DATA(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
DO BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$EXTRACT(DT,1,5))
+16 ;
+17 ; make sure inventory value has been set to qty*unitcost
+18 IF '$PIECE(ITEMDATA,"^",27)
SET $PIECE(ITEMDATA,"^",27)=$JUSTIFY($PIECE(ITEMDATA,"^",7)*$PIECE(ITEMDATA,"^",22),0,2)
+19 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+PRCPOPPP("QTY")
+20 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+PRCPOPPP("INVVAL")
+21 ;
+22 ; update average cost
+23 SET $PIECE(ITEMDATA,"^",22)=0
SET QUANTITY=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
+24 IF QUANTITY>0
SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
IF $PIECE(ITEMDATA,"^",22)'>0
SET $PIECE(ITEMDATA,"^",22)=0
+25 if TRANTYPE="RC"
SET $PIECE(ITEMDATA,"^",3)=DT
+26 SET ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
+27 ;
+28 ; update dueout and duein
+29 IF $GET(PRCPOPPP("DUEOUT"))<0
DO SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEOUT"))
+30 IF $GET(PRCPOPPP("DUEIN"))<0
DO SETIN^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEIN"))
+31 ;
+32 ;
+33 ; transaction register
+34 SET PRCPOPPP("SELVAL")=PRCPOPPP("INVVAL")
+35 IF TRANORDR
DO ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,.PRCPOPPP)
+36 QUIT
