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