| [613] | 1 | PRCPOPPP ;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 | ;
|
|---|
| 7 | SALE(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 | ;
|
|---|
| 36 | RECEIPT(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 | ;
|
|---|
| 75 | INVPT(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
|
|---|
