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

PRCPWPL4.m

Go to the documentation of this file.
  1. PRCPWPL4 ;WISC/RFJ-whse post issue book (post cont) ;13 Jan 94
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. POST ; post issue book
  1. S TOTLINES=0
  1. S (TOTLINES,TOTALINV,TOTALSAL)=0
  1. S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPLMPOST",LINEDA)) Q:'LINEDA S QTYPOST=^(LINEDA) I QTYPOST D
  1. . S IBDATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I IBDATA="" Q
  1. . S ITEMDA=+$P(IBDATA,"^",5)
  1. . S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" Q
  1. . ; do not post qty < 0
  1. . I QTYPOST>$P(ITEMDATA,"^",7) S QTYPOST=+$P(ITEMDATA,"^",7)
  1. . I 'QTYPOST Q
  1. . S UNITCOST=$P(ITEMDATA,"^",22) S:$P(ITEMDATA,"^",15)>UNITCOST UNITCOST=$P(ITEMDATA,"^",15) S:$P(IBDATA,"^",7)>UNITCOST UNITCOST=$P(IBDATA,"^",7)
  1. . S TOTCOST=$J(QTYPOST*UNITCOST,0,2),INVCOST=$J(QTYPOST*$P(ITEMDATA,"^",22),0,2)
  1. . S TOTALSAL=TOTALSAL+TOTCOST,TOTALINV=TOTALINV+INVCOST
  1. . S TOTLINES=TOTLINES+1
  1. . ;
  1. . ; *** whse ***
  1. . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)+QTYPOST
  1. . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",7)=UNITCOST
  1. . ; update totals posted
  1. . S %=$G(^PRCS(410,PRCPDA,"IT",LINEDA,445))
  1. . S $P(%,"^",3)=$P(%,"^",3)+QTYPOST,$P(%,"^",4)=$P(%,"^",4)+INVCOST,$P(%,"^",5)=$P(%,"^",5)+TOTCOST
  1. . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$P(%,"^",3,5)
  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. . ; update whse invpt
  1. . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)-QTYPOST
  1. . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)-INVCOST
  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 ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
  1. . D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYPOST)
  1. . ; usage
  1. . D ADDUSAG^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST,INVCOST)
  1. . ; transaction register
  1. . K PRCPWPL3,Y
  1. . S PRCPWPL3("QTY")=-QTYPOST,PRCPWPL3("INVVAL")=-INVCOST,PRCPWPL3("SELVAL")=-TOTCOST,PRCPWPL3("2237PO")=PRCPIBNM,PRCPWPL3("REF")=PRCPORD,PRCPWPL3("OTHERPT")=PRCPPRIM
  1. . I $G(CANTEEN) S PRCPWPL3("REASON")="0:2:ISSUE to CANTEEN"
  1. . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"R",PRCPWORD,.PRCPWPL3)
  1. . ; set line number in transaction register
  1. . I $D(^PRCP(445.2,+$G(Y),0)) S $P(^(0),"^",24)=LINEDA
  1. . ;
  1. . ;
  1. . ; *** primary ***
  1. . I 'PRCPFPRI Q
  1. . S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
  1. . S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)) I ITEMDATA="" D Q
  1. . . S COSTCNTR=$P($G(^PRCP(445,PRCPPRIM,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
  1. . S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPPRIM,ITEMDA,PRCPPVNO,1),"^",4)
  1. . ; update beginning balance
  1. . I '$D(^PRCP(445.1,PRCPPRIM,1,ITEMDA,1,$E(DT,1,5),0)) D BALANCE^PRCPUBAL(PRCPPRIM,ITEMDA,$E(DT,1,5))
  1. . ; update primary invpt
  1. . S $P(ITEMDATA,"^",7)=$P(ITEMDATA,"^",7)+QTYPOST
  1. . S $P(ITEMDATA,"^",27)=$P(ITEMDATA,"^",27)+TOTCOST
  1. . ; update average cost
  1. . S $P(ITEMDATA,"^",22)=0,QUANTITY=$P(ITEMDATA,"^",7)
  1. . I QUANTITY S $P(ITEMDATA,"^",22)=$J($P(ITEMDATA,"^",27)/QUANTITY,0,3) I $P(ITEMDATA,"^",22)'>0 S $P(ITEMDATA,"^",22)=0
  1. . ; update last cost
  1. . S $P(ITEMDATA,"^",15)=$J(TOTCOST/QTYPOST,0,3),$P(ITEMDATA,"^",3)=DT
  1. . S ^PRCP(445,PRCPPRIM,1,ITEMDA,0)=ITEMDATA
  1. . ; remove due-in
  1. . D OUTST^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA,-QTYPOST)
  1. . ; receipt history
  1. . D RECEIPTS^PRCPUSAG(PRCPPRIM,ITEMDA,QTYPOST)
  1. . ; distribution costs
  1. . S COSTCNTR=$P(^PRCP(445,PRCPPRIM,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
  1. . ; drug accountability
  1. . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPPRIM,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
  1. . ; transaction register
  1. . I PRCPPORD D
  1. . . K PRCPWPL3
  1. . . S PRCPWPL3("QTY")=QTYPOST,(PRCPWPL3("INVVAL"),PRCPWPL3("SELVAL"))=TOTCOST,PRCPWPL3("2237PO")=PRCPIBNM,PRCPWPL3("REF")=PRCPORD,PRCPWPL3("OTHERPT")=PRCPINPT
  1. . . D ADDTRAN^PRCPUTRX(PRCPPRIM,ITEMDA,"RC",PRCPPORD,.PRCPWPL3)
  1. ;
  1. D ENDPOST^PRCPWPL5
  1. Q