Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPOPPP

PRCPOPPP.m

Go to the documentation of this file. 
  1. PRCPOPPP ;WISC/RFJ/DWA-move item from prim to seco to patient ;27 Sep 93
  1.  ;;5.1;IFCAP;**4,33,200**;Oct 20, 2000;Build 3
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  Q
  1.  ;
  1.  ;PRC*5.1*200 Check when posting inventory distribution to
  1.  ;            secondary IP that the qty and cost are not
  1.  ;            affected when Perpetual flag = "N"
  1.  ;
  1. SALE(PRCPPRIM,ITEMDA,TRANORDR,PRCPOPPP) ;  post item for primary sale
  1.  ;  tranordr=transaction register #
  1.  ;  prcpoppp("qty") = qty to sale (include minus for sale)
  1.  ;  prcpoppp("invval") = inv value sold (include minus for sale)
  1.  ;  prcpoppp("orderda")= ien of ordernumber in 445.3 (used for type)
  1.  ;  prcpoppp("otherpt") = inv pt sold to
  1.  ;  prcpoppp("dueout") = dueout qty to add (- to subtract)
  1.  ;  prcpoppp("reason") = 0:reason for transaction register
  1.  ;  prcpoppp("noinvpt") = set to 1 to prevent from updating invpt
  1.  ;  locks to inventory pt prcpprim need to be applied before entry
  1.  ;
  1.  ;  distribution costs
  1.  N COSTCNTR,TYPE
  1.  ;  use costcenter for primary since secondaries do not have costcenters
  1.  S COSTCNTR=$P($G(^PRCP(445,PRCPPRIM,0)),"^",7)
  1.  I COSTCNTR,$G(PRCPOPPP("OTHERPT")) D COSTCNTR^PRCPUCC(PRCPOPPP("OTHERPT"),PRCPPRIM,COSTCNTR,-PRCPOPPP("INVVAL"))
  1.  ;
  1.  ;  usage
  1.  D ADDUSAG^PRCPUSAG(PRCPPRIM,ITEMDA,-PRCPOPPP("QTY"),-PRCPOPPP("INVVAL"))
  1.  ;
  1.  ;  if prcpoppp("noinvpt"), do not update inventory point
  1.  I $G(PRCPOPPP("NOINVPT")) Q
  1.  ;
  1.  ;  update begin balance, inventory point, transaction register
  1.  S TYPE=$P($G(^PRCP(445.3,+$G(PRCPOPPP("ORDERDA")),0)),"^",8) I TYPE="" S TYPE="R"
  1.  D INVPT(PRCPPRIM,ITEMDA,TYPE,TRANORDR,.PRCPOPPP)
  1.  Q
  1.  ;
  1.  ;
  1. RECEIPT(PRCPSECO,ITEMDA,TRANORDR,PRCPOPPP) ;  receive items
  1.  ;  tranordr=transaction register #
  1.  ;  prcpoppp("qty") = qty to receive
  1.  ;  prcpoppp("invval") = inv value received
  1.  ;  prcpoppp("otherpt") = inv pt received from
  1.  ;  prcpoppp("duein") = duein qty to add (- to subtract)
  1.  ;  prcpoppp("reason") = 0:reason for transaction register
  1.  ;    for patient distributions:
  1.  ;  prcpoppp("prcpptda") = ptr to file 446.1 (patient distribution)
  1.  ;  locks to inventory pt prcpseco need to be applied before entry
  1.  ;
  1.  ;  receipt history
  1.  D RECEIPTS^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"))
  1.  ;
  1.  ;  update inventory point
  1.  D INVPT(PRCPSECO,ITEMDA,"RC",TRANORDR,.PRCPOPPP)
  1.  ;
  1.  ;  if no patient quit
  1.  I '$G(PRCPOPPP("PRCPPTDA")) Q
  1.  ;
  1.  ;  sale to patient
  1.  ;
  1.  ;  usage
  1.  D ADDUSAG^PRCPUSAG(PRCPSECO,ITEMDA,PRCPOPPP("QTY"),PRCPOPPP("INVVAL"))
  1.  ;
  1.  ;  take out of inventory point
  1.  N COST,QTY,Y
  1.  S QTY=PRCPOPPP("QTY"),COST=PRCPOPPP("INVVAL")
  1.  S PRCPOPPP("QTY")=-QTY,(PRCPOPPP("INVVAL"),PRCPOPPP("SELVAL"))=-COST
  1.  K PRCPOPPP("OTHERPT"),PRCPOPPP("DUEIN")
  1.  S Y=PRCPPTDA D DD^%DT
  1.  S PRCPOPPP("REASON")="0:Distribution to patient ("_Y_")"
  1.  D INVPT(PRCPSECO,ITEMDA,"R",TRANORDR,.PRCPOPPP)
  1.  ;
  1.  ;  distribute to patient
  1.  D DISTITEM^PRCPUPAT(PRCPPTDA,ITEMDA,QTY,COST)
  1.  Q
  1.  ;
  1.  ;
  1. INVPT(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,PRCPOPPP) ;  update inventory point data
  1.  ;  trantype=type of transaction; tranordr=transaction register #
  1.  ;  prcpoppp("qty") = qty to add to inventory point
  1.  ;  prcpoppp("invval") = value to add to inventory point
  1.  ;  prcpoppp("otherpt") = inv pt sold to (for transaction register)
  1.  ;  prcpoppp("dueout") = qty to add to dueout
  1.  ;  prcpoppp("duein")  = qty to add to duein
  1.  ;  prcpoppp("reason") = 0:reason for transaction register
  1.  ;  locks to inventory pt prcpinpt need to be applied before entry
  1.  ;
  1.  N ITEMDATA,QUANTITY
  1.  I $P(^PRCP(445,PRCPINPT,0),"^",2)="N",$P(^PRCP(445,PRCPINPT,0),"^",3)="S" S PRCPOPPP("QTY")=0,PRCPOPPP("INVVAL")=0    ;PRC*5.1*200
  1.  S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
  1.  ;
  1.  ;  update beginning balance
  1.  I '$D(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$E(DT,1,5))
  1.  ;
  1.  ;  make sure inventory value has been set to qty*unitcost
  1.  I '$P(ITEMDATA,"^",27) S $P(ITEMDATA,"^",27)=$J($P(ITEMDATA,"^",7)*$P(ITEMDATA,"^",22),0,2)
  1.  S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+PRCPOPPP("QTY")
  1.  S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+PRCPOPPP("INVVAL")
  1.  ;
  1.  ;  update average cost
  1.  S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
  1.  I QUANTITY>0 S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
  1.  S:TRANTYPE="RC" $P(ITEMDATA,"^",3)=DT
  1.  S ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
  1.  ;
  1.  ;  update dueout and duein
  1.  I $G(PRCPOPPP("DUEOUT"))<0 D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEOUT"))
  1.  I $G(PRCPOPPP("DUEIN"))<0 D SETIN^PRCPUDUE(PRCPINPT,ITEMDA,PRCPOPPP("DUEIN"))
  1.  ;
  1.  ;
  1.  ;  transaction register
  1.  S PRCPOPPP("SELVAL")=PRCPOPPP("INVVAL")
  1.  I TRANORDR D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,TRANTYPE,TRANORDR,.PRCPOPPP)
  1.  Q