source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPPP.m@ 1259

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1PRCPOPPP ;WISC/RFJ/DWA-move item from prim to seco to patient ;27 Sep 93
2 ;;5.1;IFCAP;**4,33**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7SALE(PRCPPRIM,ITEMDA,TRANORDR,PRCPOPPP) ; post item for primary sale
8 ; tranordr=transaction register #
9 ; prcpoppp("qty") = qty to sale (include minus for sale)
10 ; prcpoppp("invval") = inv value sold (include minus for sale)
11 ; prcpoppp("orderda")= ien of ordernumber in 445.3 (used for type)
12 ; prcpoppp("otherpt") = inv pt sold to
13 ; prcpoppp("dueout") = dueout qty to add (- to subtract)
14 ; prcpoppp("reason") = 0:reason for transaction register
15 ; prcpoppp("noinvpt") = set to 1 to prevent from updating invpt
16 ; locks to inventory pt prcpprim need to be applied before entry
17 ;
18 ; distribution costs
19 N COSTCNTR,TYPE
20 ; use costcenter for primary since secondaries do not have costcenters
21 S COSTCNTR=$P($G(^PRCP(445,PRCPPRIM,0)),"^",7)
22 I COSTCNTR,$G(PRCPOPPP("OTHERPT")) D COSTCNTR^PRCPUCC(PRCPOPPP("OTHERPT"),PRCPPRIM,COSTCNTR,-PRCPOPPP("INVVAL"))
23 ;
24 ; usage
25 D ADDUSAG^PRCPUSAG(PRCPPRIM,ITEMDA,-PRCPOPPP("QTY"),-PRCPOPPP("INVVAL"))
26 ;
27 ; if prcpoppp("noinvpt"), do not update inventory point
28 I $G(PRCPOPPP("NOINVPT")) Q
29 ;
30 ; update begin balance, inventory point, transaction register
31 S TYPE=$P($G(^PRCP(445.3,+$G(PRCPOPPP("ORDERDA")),0)),"^",8) I TYPE="" S TYPE="R"
32 D INVPT(PRCPPRIM,ITEMDA,TYPE,TRANORDR,.PRCPOPPP)
33 Q
34 ;
35 ;
36RECEIPT(PRCPSECO,ITEMDA,TRANORDR,PRCPOPPP) ; receive items
37 ; tranordr=transaction register #
38 ; prcpoppp("qty") = qty to receive
39 ; prcpoppp("invval") = inv value received
40 ; prcpoppp("otherpt") = inv pt received from
41 ; prcpoppp("duein") = duein qty to add (- to subtract)
42 ; prcpoppp("reason") = 0:reason for transaction register
43 ; for patient distributions:
44 ; prcpoppp("prcpptda") = ptr to file 446.1 (patient distribution)
45 ; locks to inventory pt prcpseco need to be applied before entry
46 ;
47 ; receipt history
48 D RECEIPTS^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"))
49 ;
50 ; update inventory point
51 D INVPT(PRCPSECO,ITEMDA,"RC",TRANORDR,.PRCPOPPP)
52 ;
53 ; if no patient quit
54 I '$G(PRCPOPPP("PRCPPTDA")) Q
55 ;
56 ; sale to patient
57 ;
58 ; usage
59 D ADDUSAG^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"),PRCPOPPP("INVVAL"))
60 ;
61 ; take out of inventory point
62 N COST,QTY,Y
63 S QTY=PRCPOPPP("QTY"),COST=PRCPOPPP("INVVAL")
64 S PRCPOPPP("QTY")=-QTY,(PRCPOPPP("INVVAL"),PRCPOPPP("SELVAL"))=-COST
65 K PRCPOPPP("OTHERPT"),PRCPOPPP("DUEIN")
66 S Y=PRCPPTDA D DD^%DT
67 S PRCPOPPP("REASON")="0:Distribution to patient ("_Y_")"
68 D INVPT(PRCPSECO,ITEMDA,"R",TRANORDR,.PRCPOPPP)
69 ;
70 ; distribute to patient
71 D DISTITEM^PRCPUPAT(PRCPPTDA,ITEMDA,QTY,COST)
72 Q
73 ;
74 ;
75INVPT(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,PRCPOPPP) ; update inventory point data
76 ; trantype=type of transaction; tranordr=transaction register #
77 ; prcpoppp("qty") = qty to add to inventory point
78 ; prcpoppp("invval") = value to add to inventory point
79 ; prcpoppp("otherpt") = inv pt sold to (for transaction register)
80 ; prcpoppp("dueout") = qty to add to dueout
81 ; prcpoppp("duein") = qty to add to duein
82 ; prcpoppp("reason") = 0:reason for transaction register
83 ; locks to inventory pt prcpinpt need to be applied before entry
84 ;
85 N ITEMDATA,QUANTITY
86 S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
87 ;
88 ; update beginning balance
89 I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
90 ;
91 ; make sure inventory value has been set to qty*unitcost
92 I '$P(ITEMDATA,"^",27) S $P(ITEMDATA,"^",27)=$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2)
93 S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+PRCPOPPP("QTY")
94 S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+PRCPOPPP("INVVAL")
95 ;
96 ; update average cost
97 S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
98 I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
99 S:TRANTYPE="RC" $P(ITEMDATA,"^",3)=DT
100 S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
101 ;
102 ; update dueout and duein
103 I $G(PRCPOPPP("DUEOUT"))<0 D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEOUT"))
104 I $G(PRCPOPPP("DUEIN"))<0 D SETIN^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEIN"))
105 ;
106 ;
107 ; transaction register
108 S PRCPOPPP("SELVAL")=PRCPOPPP("INVVAL")
109 I TRANORDR D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,.PRCPOPPP)
110 Q
Note: See TracBrowser for help on using the repository browser.