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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPL4 4419 printed Sep 23, 2025@19:52:47 Page 2
PRCPWPL4 ;WISC/RFJ-whse post issue book (post cont) ;13 Jan 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
POST ; post issue book
+1 SET TOTLINES=0
+2 SET (TOTLINES,TOTALINV,TOTALSAL)=0
+3 SET LINEDA=0
FOR
SET LINEDA=$ORDER(^TMP($JOB,"PRCPWPLMPOST",LINEDA))
if 'LINEDA
QUIT
SET QTYPOST=^(LINEDA)
IF QTYPOST
Begin DoDot:1
+4 SET IBDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
IF IBDATA=""
QUIT
+5 SET ITEMDA=+$PIECE(IBDATA,"^",5)
+6 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
IF ITEMDATA=""
QUIT
+7 ; do not post qty < 0
+8 IF QTYPOST>$PIECE(ITEMDATA,"^",7)
SET QTYPOST=+$PIECE(ITEMDATA,"^",7)
+9 IF 'QTYPOST
QUIT
+10 SET UNITCOST=$PIECE(ITEMDATA,"^",22)
if $PIECE(ITEMDATA,"^",15)>UNITCOST
SET UNITCOST=$PIECE(ITEMDATA,"^",15)
if $PIECE(IBDATA,"^",7)>UNITCOST
SET UNITCOST=$PIECE(IBDATA,"^",7)
+11 SET TOTCOST=$JUSTIFY(QTYPOST*UNITCOST,0,2)
SET INVCOST=$JUSTIFY(QTYPOST*$PIECE(ITEMDATA,"^",22),0,2)
+12 SET TOTALSAL=TOTALSAL+TOTCOST
SET TOTALINV=TOTALINV+INVCOST
+13 SET TOTLINES=TOTLINES+1
+14 ;
+15 ; *** whse ***
+16 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",12)+QTYPOST
+17 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",7)=UNITCOST
+18 ; update totals posted
+19 SET %=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,445))
+20 SET $PIECE(%,"^",3)=$PIECE(%,"^",3)+QTYPOST
SET $PIECE(%,"^",4)=$PIECE(%,"^",4)+INVCOST
SET $PIECE(%,"^",5)=$PIECE(%,"^",5)+TOTCOST
+21 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,445),"^",3,5)=$PIECE(%,"^",3,5)
+22 ; update beginning balance
+23 IF '$DATA(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
DO BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$EXTRACT(DT,1,5))
+24 ; update whse invpt
+25 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)-QTYPOST
+26 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)-INVCOST
+27 ; update average cost
+28 SET $PIECE(ITEMDATA,"^",22)=0
SET QUANTITY=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
+29 IF QUANTITY>0
SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
IF $PIECE(ITEMDATA,"^",22)'>0
SET $PIECE(ITEMDATA,"^",22)=0
+30 SET ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
+31 DO SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYPOST)
+32 ; usage
+33 DO ADDUSAG^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST,INVCOST)
+34 ; transaction register
+35 KILL PRCPWPL3,Y
+36 SET PRCPWPL3("QTY")=-QTYPOST
SET PRCPWPL3("INVVAL")=-INVCOST
SET PRCPWPL3("SELVAL")=-TOTCOST
SET PRCPWPL3("2237PO")=PRCPIBNM
SET PRCPWPL3("REF")=PRCPORD
SET PRCPWPL3("OTHERPT")=PRCPPRIM
+37 IF $GET(CANTEEN)
SET PRCPWPL3("REASON")="0:2:ISSUE to CANTEEN"
+38 DO ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"R",PRCPWORD,.PRCPWPL3)
+39 ; set line number in transaction register
+40 IF $DATA(^PRCP(445.2,+$GET(Y),0))
SET $PIECE(^(0),"^",24)=LINEDA
+41 ;
+42 ;
+43 ; *** primary ***
+44 IF 'PRCPFPRI
QUIT
+45 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
+46 SET ITEMDATA=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
IF ITEMDATA=""
Begin DoDot:2
+47 SET COSTCNTR=$PIECE($GET(^PRCP(445,PRCPPRIM,0)),"^",7)
IF COSTCNTR
DO COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
End DoDot:2
QUIT
+48 SET QTYPOST=QTYPOST*$PIECE($$GETVEN^PRCPUVEN(PRCPPRIM,ITEMDA,PRCPPVNO,1),"^",4)
+49 ; update beginning balance
+50 IF '$DATA(^PRCP(445.1,PRCPPRIM,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
DO BALANCE^PRCPUBAL(PRCPPRIM,ITEMDA,$EXTRACT(DT,1,5))
+51 ; update primary invpt
+52 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+QTYPOST
+53 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+TOTCOST
+54 ; update average cost
+55 SET $PIECE(ITEMDATA,"^",22)=0
SET QUANTITY=$PIECE(ITEMDATA,"^",7)
+56 IF QUANTITY
SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
IF $PIECE(ITEMDATA,"^",22)'>0
SET $PIECE(ITEMDATA,"^",22)=0
+57 ; update last cost
+58 SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(TOTCOST/QTYPOST,0,3)
SET $PIECE(ITEMDATA,"^",3)=DT
+59 SET ^PRCP(445,PRCPPRIM,1,ITEMDA,0)=ITEMDATA
+60 ; remove due-in
+61 DO OUTST^PRCPUTRA(PRCPPRIM,ITEMDA,PRCPDA,-QTYPOST)
+62 ; receipt history
+63 DO RECEIPTS^PRCPUSAG(PRCPPRIM,ITEMDA,QTYPOST)
+64 ; distribution costs
+65 SET COSTCNTR=$PIECE(^PRCP(445,PRCPPRIM,0),"^",7)
IF COSTCNTR
DO COSTCNTR^PRCPUCC(PRCPPRIM,PRCPINPT,COSTCNTR,TOTCOST)
+66 ; drug accountability
+67 IF $GET(DRUGACCT)
SET %=+$PIECE(ITEMDATA,"^",29)
if '%
SET %=1
DO EN^PSAGIP(PRCPPRIM,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
+68 ; transaction register
+69 IF PRCPPORD
Begin DoDot:2
+70 KILL PRCPWPL3
+71 SET PRCPWPL3("QTY")=QTYPOST
SET (PRCPWPL3("INVVAL"),PRCPWPL3("SELVAL"))=TOTCOST
SET PRCPWPL3("2237PO")=PRCPIBNM
SET PRCPWPL3("REF")=PRCPORD
SET PRCPWPL3("OTHERPT")=PRCPINPT
+72 DO ADDTRAN^PRCPUTRX(PRCPPRIM,ITEMDA,"RC",PRCPPORD,.PRCPWPL3)
End DoDot:2
End DoDot:1
+73 ;
+74 DO ENDPOST^PRCPWPL5
+75 QUIT
