source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPP3.m@ 1638

Last change on this file since 1638 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
Line 
1PRCPOPP3 ;WISC/RFJ/DWA-case cart/instrument kit post (cont) ;27 Sep 93
2 ;;5.1;IFCAP;**41**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7POST ; post cc/ik items
8 N INVVALUE,ORDRDATA,PRCPOPP,QTYORDER,QTYPOST,QTYRET,QUANTITY,REUSABLE,UNITCOST
9 S CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM D
10 . ; if cc or ik item is on distribution order, sell ccik item from
11 . ; primary and update primary qty on-hand, dueouts, etc.
12 . I $D(^PRCP(445.3,ORDERDA,1,CCIKITEM,0)) S ORDRDATA=^(0) D
13 . . S QUANTITY=$P(ORDRDATA,"^",2),INVVALUE=$J(QUANTITY*$P(ORDRDATA,"^",3),0,2)
14 . . I 'QUANTITY D DELITEM^PRCPOPD(ORDERDA,CCIKITEM) Q
15 . . ; sell item from primary
16 . . K PRCPOPP
17 . . S (PRCPOPP("QTY"),PRCPOPP("DUEOUT"))=-QUANTITY,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
18 . . D SALE^PRCPOPPP(PRCPPRIM,CCIKITEM,PRCPPORD,.PRCPOPP)
19 . . ;
20 . . K PRCPOPP
21 . . S PRCPOPP("QTY")=QUANTITY*$P($$GETVEN^PRCPUVEN(PRCPSECO,CCIKITEM,PRCPPRIM_";PRCP(445,",1),"^",4),PRCPOPP("DUEIN")=-PRCPOPP("QTY"),PRCPOPP("INVVAL")=INVVALUE
22 . . I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
23 . . D RECEIPT^PRCPOPPP(PRCPSECO,CCIKITEM,PRCPSORD,.PRCPOPP)
24 . . ;
25 . . ; remove ccik item from order
26 . . ;D DELITEM^PRCPOPD(ORDERDA,CCIKITEM)
27 . ;
28 . ; post items in cc/ik
29 . S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA S %=^(ITEMDA) D
30 . . S QTYORDER=$P(%,"^"),QTYRET=$P(%,"^",2),QTYPOST=QTYORDER-QTYRET
31 . . S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
32 . . ; calculate inventory value of items sold
33 . . S %=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
34 . . S UNITCOST=$P(%,"^",15) I 'UNITCOST S UNITCOST=$P(%,"^",22)
35 . . S INVVALUE=$J(QTYPOST*UNITCOST,0,2)
36 . . D PRIMARY
37 . . D SECOND
38 Q
39 ;
40 ;
41PRIMARY ; sale of item from primary
42 ; if an item is an ik, sell it
43 ;I $D(^PRCP(445.8,ITEMDA)) D Q
44 ;. K PRCPOPP
45 ;. S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
46 ;. S PRCPOPP("REASON")="0:Instrument kit sold with case cart IM# "_CCIKITEM
47 ;. D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
48 ;
49 ; if item is reusable and was returned, do nothing
50 I REUSABLE,QTYPOST=0 Q
51 ;
52 ; if item is reusable and not returned, sell it
53 I REUSABLE D Q
54 . K PRCPOPP
55 . S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA
56 . S PRCPOPP("REASON")="0:Reusable item not returned in cc,ik IM# "_CCIKITEM
57 . D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
58 ;
59 ; disposable items
60 ; if item is disposable and not returned, show distribution
61 ; do not update primary invpt since it was updated during assembly
62 I QTYRET=0 D Q
63 . K PRCPOPP
64 . S PRCPOPP("QTY")=-QTYPOST,PRCPOPP("INVVAL")=-INVVALUE,PRCPOPP("OTHERPT")=PRCPSECO,PRCPOPP("ORDERDA")=ORDERDA,PRCPOPP("NOINVPT")=1
65 . D SALE^PRCPOPPP(PRCPPRIM,ITEMDA,PRCPPORD,.PRCPOPP)
66 ;
67 ; if disposable item is returned, add back to primary inventory
68 K PRCPOPP
69 S PRCPOPP("QTY")=QTYRET,PRCPOPP("INVVAL")=$J(QTYRET*UNITCOST,0,2)
70 S PRCPOPP("REASON")="0:Disposable item returned with cc,ik IM# "_CCIKITEM
71 D INVPT^PRCPOPPP(PRCPPRIM,ITEMDA,"S",PRCPPORD,.PRCPOPP)
72 Q
73 ;
74 ;
75SECOND ; receipt in secondary
76 ; if an item is an ik, receive it
77 I $D(^PRCP(445.8,ITEMDA)) D Q
78 . K PRCPOPP
79 . S PRCPOPP("QTY")=QTYPOST,PRCPOPP("INVVAL")=INVVALUE,PRCPOPP("OTHERPT")=PRCPPRIM
80 . I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
81 . S PRCPOPP("REASON")="0:Instrument kit sold with case cart IM# "_CCIKITEM
82 . D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
83 ;
84 ; if item is reusable and was returned, do nothing
85 I REUSABLE,QTYPOST=0 Q
86 ;
87 ; if item is reusable and not returned, receive it
88 I REUSABLE D Q
89 . K PRCPOPP
90 . S PRCPOPP("QTY")=QTYPOST,PRCPOPP("INVVAL")=INVVALUE,PRCPOPP("OTHERPT")=PRCPPRIM
91 . I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
92 . S PRCPOPP("REASON")="0:Reusable item not returned in cc,ik IM# "_CCIKITEM
93 . D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
94 ;
95 ; disposable items
96 ; if item is disposable and returned, do nothing
97 I QTYPOST=0 Q
98 ;
99 ; disposable items not returned
100 K PRCPOPP
101 S PRCPOPP("QTY")=QTYPOST,PRCPOPP("INVVAL")=INVVALUE,PRCPOPP("OTHERPT")=PRCPPRIM
102 I $G(PRCPPTDA) S PRCPOPP("PRCPPTDA")=+$G(PRCPPTDA)
103 D RECEIPT^PRCPOPPP(PRCPSECO,ITEMDA,PRCPSORD,.PRCPOPP)
104 Q
Note: See TracBrowser for help on using the repository browser.