105 lines
4.4 KiB
Mathematica
105 lines
4.4 KiB
Mathematica
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
|