PRCPOPP3 ;WISC/RFJ/DWA-case cart/instrument kit post (cont) ;27 Sep 93
;;5.1;IFCAP;**41**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
POST ; post cc/ik items
N INVVALUE,ORDRDATA,PRCPOPP,QTYORDER,QTYPOST,QTYRET,QUANTITY,REUSABLE,UNITCOST
S CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM D
. ; if cc or ik item is on distribution order, sell ccik item from
. ; primary and update primary qty on-hand, dueouts, etc.
. I $D(^PRCP(445.3,ORDERDA,1,CCIKITEM,0)) S ORDRDATA=^(0) D
. . S QUANTITY=$P(ORDRDATA,"^",2),INVVALUE=$J(QUANTITY*$P(ORDRDATA,"^",3),0,2)
. . I 'QUANTITY D DELITEM^PRCPOPD(ORDERDA,CCIKITEM) Q
. . ; sell item from primary
. . K PRCPOPP
. . S (PRCPOPP("QTY"),PRCPOPP("DUEOUT"))=-QUANTITY,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
. . D SALE^PRCPOPPP(PRCPPRIM,CCIKITEM,PRCPPORD,.PRCPOPP)
. . ;
. . K PRCPOPP
. . S PRCPOPP("QTY")=QUANTITY*$P($$GETVEN^PRCPUVEN(PRCPSECO,CCIKITEM,PRCPPRIM_";PRCP(445,",1),"^",4),PRCPOPP("DUEIN")=-PRCPOPP("QTY"),PRCPOPP("INVVAL")=INVVALUE
. . I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
. . D RECEIPT^PRCPOPPP(PRCPSECO,CCIKITEM,PRCPSORD,.PRCPOPP)
. . ;
. . ; remove ccik item from order
. . ;D DELITEM^PRCPOPD(ORDERDA,CCIKITEM)
. ;
. ; post items in cc/ik
. S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA S %=^(ITEMDA) D
. . S QTYORDER=$P(%,"^"),QTYRET=$P(%,"^",2),QTYPOST=QTYORDER-QTYRET
. . S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
. . ; calculate inventory value of items sold
. . S %=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
. . S UNITCOST=$P(%,"^",15) I 'UNITCOST S UNITCOST=$P(%,"^",22)
. . S INVVALUE=$J(QTYPOST*UNITCOST,0,2)
. . D PRIMARY
. . D SECOND
Q
;
;
PRIMARY ; sale of item from primary
; if an item is an ik, sell it
;I $D(^PRCP(445.8,ITEMDA)) D Q
;. K PRCPOPP
;. S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
;. S PRCPOPP("REASON")="0:Instrument kit sold with case cart IM# "_CCIKITEM
;. D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
;
; if item is reusable and was returned, do nothing
I REUSABLE,QTYPOST=0 Q
;
; if item is reusable and not returned, sell it
I REUSABLE D Q
. K PRCPOPP
. S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
. S PRCPOPP("REASON")="0:Reusable item not returned in cc,ik IM# "_CCIKITEM
. D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
;
; disposable items
; if item is disposable and not returned, show distribution
; do not update primary invpt since it was updated during assembly
I QTYRET=0 D Q
. K PRCPOPP
. S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA,PRCPOPP("NOINVPT")=1
. D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
;
; if disposable item is returned, add back to primary inventory
K PRCPOPP
S PRCPOPP("QTY")=QTYRET,PRCPOPP("INVVAL")=$J(QTYRET*UNITCOST,0,2)
S PRCPOPP("REASON")="0:Disposable item returned with cc,ik IM# "_CCIKITEM
D INVPT^PRCPOPPP(PRCPPRIM,ITEMDA,"S",PRCPPORD,.PRCPOPP)
Q
;
;
SECOND ; receipt in secondary
; if an item is an ik, receive it
I $D(^PRCP(445.8,ITEMDA)) D Q
. K PRCPOPP
. S PRCPOPP("QTY")=QTYPOST,PRCPOPP("INVVAL")=INVVALUE,PRCPOPP("OTHERPT")=PRCPPRIM
. I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
. S PRCPOPP("REASON")="0:Instrument kit sold with case cart IM# "_CCIKITEM
. D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
;
; if item is reusable and was returned, do nothing
I REUSABLE,QTYPOST=0 Q
;
; if item is reusable and not returned, receive it
I REUSABLE D Q
. K PRCPOPP
. S PRCPOPP("QTY")=QTYPOST,PRCPOPP("INVVAL")=INVVALUE,PRCPOPP("OTHERPT")=PRCPPRIM
. I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
. S PRCPOPP("REASON")="0:Reusable item not returned in cc,ik IM# "_CCIKITEM
. D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
;
; disposable items
; if item is disposable and returned, do nothing
I QTYPOST=0 Q
;
; disposable items not returned
K PRCPOPP
S PRCPOPP("QTY")=QTYPOST,PRCPOPP("INVVAL")=INVVALUE,PRCPOPP("OTHERPT")=PRCPPRIM
I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPP3 4619 printed Oct 16, 2024@18:15:01 Page 2
PRCPOPP3 ;WISC/RFJ/DWA-case cart/instrument kit post (cont) ;27 Sep 93
+1 ;;5.1;IFCAP;**41**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
POST ; post cc/ik items
+1 NEW INVVALUE,ORDRDATA,PRCPOPP,QTYORDER,QTYPOST,QTYRET,QUANTITY,REUSABLE,UNITCOST
+2 SET CCIKITEM=0
FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM))
if 'CCIKITEM
QUIT
Begin DoDot:1
+3 ; if cc or ik item is on distribution order, sell ccik item from
+4 ; primary and update primary qty on-hand, dueouts, etc.
+5 IF $DATA(^PRCP(445.3,ORDERDA,1,CCIKITEM,0))
SET ORDRDATA=^(0)
Begin DoDot:2
+6 SET QUANTITY=$PIECE(ORDRDATA,"^",2)
SET INVVALUE=$JUSTIFY(QUANTITY*$PIECE(ORDRDATA,"^",3),0,2)
+7 IF 'QUANTITY
DO DELITEM^PRCPOPD(ORDERDA,CCIKITEM)
QUIT
+8 ; sell item from primary
+9 KILL PRCPOPP
+10 SET (PRCPOPP("QTY"),PRCPOPP("DUEOUT"))=-QUANTITY
SET PRCPOPP("INVVAL")=-INVVALUE
SET PRCPOPP("OTHERPT")=PRCPSECO
SET PRCPOPP("ORDERDA")=ORDERDA
+11 DO SALE^PRCPOPPP(PRCPPRIM,CCIKITEM,PRCPPORD,.PRCPOPP)
+12 ;
+13 KILL PRCPOPP
+14 SET PRCPOPP("QTY")=QUANTITY*$PIECE($$GETVEN^PRCPUVEN(PRCPSECO,CCIKITEM,PRCPPRIM_";PRCP(445,",1),"^",4)
SET PRCPOPP("DUEIN")=-PRCPOPP("QTY")
SET PRCPOPP("INVVAL")=INVVALUE
+15 IF $GET(PRCPPTDA)
SET PRCPOPP("PRCPPTDA")=+$GET(PRCPPTDA)
+16 DO RECEIPT^PRCPOPPP(PRCPSECO,CCIKITEM,PRCPSORD,.PRCPOPP)
+17 ;
+18 ; remove ccik item from order
+19 ;D DELITEM^PRCPOPD(ORDERDA,CCIKITEM)
End DoDot:2
+20 ;
+21 ; post items in cc/ik
+22 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
if 'ITEMDA
QUIT
SET %=^(ITEMDA)
Begin DoDot:2
+23 SET QTYORDER=$PIECE(%,"^")
SET QTYRET=$PIECE(%,"^",2)
SET QTYPOST=QTYORDER-QTYRET
+24 SET REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
+25 ; calculate inventory value of items sold
+26 SET %=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
+27 SET UNITCOST=$PIECE(%,"^",15)
IF 'UNITCOST
SET UNITCOST=$PIECE(%,"^",22)
+28 SET INVVALUE=$JUSTIFY(QTYPOST*UNITCOST,0,2)
+29 DO PRIMARY
+30 DO SECOND
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
+33 ;
PRIMARY ; sale of item from primary
+1 ; if an item is an ik, sell it
+2 ;I $D(^PRCP(445.8,ITEMDA)) D Q
+3 ;. K PRCPOPP
+4 ;. S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
+5 ;. S PRCPOPP("REASON")="0:Instrument kit sold with case cart IM# "_CCIKITEM
+6 ;. D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
+7 ;
+8 ; if item is reusable and was returned, do nothing
+9 IF REUSABLE
IF QTYPOST=0
QUIT
+10 ;
+11 ; if item is reusable and not returned, sell it
+12 IF REUSABLE
Begin DoDot:1
+13 KILL PRCPOPP
+14 SET PRCPOPP("QTY")=-QTYPOST
SET PRCPOPP("INVVAL")=-INVVALUE
SET PRCPOPP("OTHERPT")=PRCPSECO
SET PRCPOPP("ORDERDA")=ORDERDA
+15 SET PRCPOPP("REASON")="0:Reusable item not returned in cc,ik IM# "_CCIKITEM
+16 DO SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
End DoDot:1
QUIT
+17 ;
+18 ; disposable items
+19 ; if item is disposable and not returned, show distribution
+20 ; do not update primary invpt since it was updated during assembly
+21 IF QTYRET=0
Begin DoDot:1
+22 KILL PRCPOPP
+23 SET PRCPOPP("QTY")=-QTYPOST
SET PRCPOPP("INVVAL")=-INVVALUE
SET PRCPOPP("OTHERPT")=PRCPSECO
SET PRCPOPP("ORDERDA")=ORDERDA
SET PRCPOPP("NOINVPT")=1
+24 DO SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
End DoDot:1
QUIT
+25 ;
+26 ; if disposable item is returned, add back to primary inventory
+27 KILL PRCPOPP
+28 SET PRCPOPP("QTY")=QTYRET
SET PRCPOPP("INVVAL")=$JUSTIFY(QTYRET*UNITCOST,0,2)
+29 SET PRCPOPP("REASON")="0:Disposable item returned with cc,ik IM# "_CCIKITEM
+30 DO INVPT^PRCPOPPP(PRCPPRIM,ITEMDA,"S",PRCPPORD,.PRCPOPP)
+31 QUIT
+32 ;
+33 ;
SECOND ; receipt in secondary
+1 ; if an item is an ik, receive it
+2 IF $DATA(^PRCP(445.8,ITEMDA))
Begin DoDot:1
+3 KILL PRCPOPP
+4 SET PRCPOPP("QTY")=QTYPOST
SET PRCPOPP("INVVAL")=INVVALUE
SET PRCPOPP("OTHERPT")=PRCPPRIM
+5 IF $GET(PRCPPTDA)
SET PRCPOPP("PRCPPTDA")=+$GET(PRCPPTDA)
+6 SET PRCPOPP("REASON")="0:Instrument kit sold with case cart IM# "_CCIKITEM
+7 DO RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
End DoDot:1
QUIT
+8 ;
+9 ; if item is reusable and was returned, do nothing
+10 IF REUSABLE
IF QTYPOST=0
QUIT
+11 ;
+12 ; if item is reusable and not returned, receive it
+13 IF REUSABLE
Begin DoDot:1
+14 KILL PRCPOPP
+15 SET PRCPOPP("QTY")=QTYPOST
SET PRCPOPP("INVVAL")=INVVALUE
SET PRCPOPP("OTHERPT")=PRCPPRIM
+16 IF $GET(PRCPPTDA)
SET PRCPOPP("PRCPPTDA")=+$GET(PRCPPTDA)
+17 SET PRCPOPP("REASON")="0:Reusable item not returned in cc,ik IM# "_CCIKITEM
+18 DO RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
End DoDot:1
QUIT
+19 ;
+20 ; disposable items
+21 ; if item is disposable and returned, do nothing
+22 IF QTYPOST=0
QUIT
+23 ;
+24 ; disposable items not returned
+25 KILL PRCPOPP
+26 SET PRCPOPP("QTY")=QTYPOST
SET PRCPOPP("INVVAL")=INVVALUE
SET PRCPOPP("OTHERPT")=PRCPPRIM
+27 IF $GET(PRCPPTDA)
SET PRCPOPP("PRCPPTDA")=+$GET(PRCPPTDA)
+28 DO RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
+29 QUIT
