PRCPWPP3 ;WISC/RFJ-primary receive issue book (receive) ;20 Jan 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
RECEIVE ; receive issue book
D FULL^VALM1
S VALMBCK="R"
I '$O(^TMP($J,"PRCPWPPLPOST",0)) S VALMSG="THERE ARE NO ITEMS TO RECEIVE" Q
;
N %,COSTCNTR,DRUGACCT,IBDATA,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWPP3,QTYPOST,QUANTITY,TOTCOST,TOTLINES,UNITCOST,X
;
I $P($G(^PRCP(445,PRCPINPT,0)),"^",20)="D" S X="PSAGIP" I $D(^%ZOSF("TEST")) X ^("TEST") I $T S DRUGACCT=1 K X S X(1)="NOTE: This is a DRUG ACCOUNTABILITY inventory point." D DISPLAY^PRCPUX2(1,79,.X)
;
S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS ISSUE BOOK"
W ! I $$YN^PRCPUYN(1)'=1 Q
L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q
D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Issue Book")
S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
S TOTLINES=0
S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPPLPOST",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
. S UNITCOST=$P(IBDATA,"^",7)
. S TOTCOST=$J(QTYPOST*UNITCOST,0,2)
. S TOTLINES=TOTLINES+1
. ;
. ; *** primary ***
. S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
. S ITEMDATA=$G(^PRCP(445,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" D Q
. . S COSTCNTR=$P($G(^PRCP(445,PRCPINPT,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
. S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRCPPVNO,1),"^",4)
. ; 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 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,PRCPINPT,1,ITEMDA,0)=ITEMDATA
. ; remove due-in
. D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA,-QTYPOST)
. ; receipt history
. D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST)
. ; distribution costs
. S COSTCNTR=$P(^PRCP(445,PRCPINPT,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
. ; drug accountability
. I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
. ; transaction register
. I PRCPPORD D
. . K PRCPWPP3
. . S PRCPWPP3("QTY")=QTYPOST,(PRCPWPP3("INVVAL"),PRCPWPP3("SELVAL"))=TOTCOST,PRCPWPP3("2237PO")=PRCPIBNM,PRCPWPP3("OTHERPT")=PRCPWHSE
. . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",PRCPPORD,.PRCPWPP3)
;
K VALMBCK
;
I $G(DRUGACCT) D EX^PSAGIP
K X S X(1)="TOTAL LINE ITEMS POSTED: "_TOTLINES D DISPLAY^PRCPUX2(1,40,.X)
;
; make issue book a final
I $G(PRCPFINL) D
. K X S X(1)="This issue book is a final. You have the option to remove all outstanding due-ins for this issue book." D DISPLAY^PRCPUX2(5,75,.X)
. S XP="Do you want to remove the due-ins for this issue book",XH="Enter YES to remove the due-ins, NO to leave the due-ins."
. I $$YN^PRCPUYN(1)'=1 Q
. S LINEDA=0 F S LINEDA=$O(^PRCS(410,PRCPDA,"IT",LINEDA)) Q:'LINEDA S ITEMDA=+$P(^(LINEDA,0),"^",5),QTYOUT=$P(^(0),"^",2)-$P(^(0),"^",13) I QTYOUT>0 D
. . D KILLTRAN^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA)
;
D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
L -^PRCP(445,PRCPINPT,1)
;
I TOTLINES=0 Q:$G(PRCPFINL) S VALMSG="NO LINE ITEMS TO POST",VALMBCK="R" Q
D R^PRCPUREP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPP3 3980 printed Sep 23, 2025@19:52:52 Page 2
PRCPWPP3 ;WISC/RFJ-primary receive issue book (receive) ;20 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 ;
RECEIVE ; receive issue book
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 IF '$ORDER(^TMP($JOB,"PRCPWPPLPOST",0))
SET VALMSG="THERE ARE NO ITEMS TO RECEIVE"
QUIT
+4 ;
+5 NEW %,COSTCNTR,DRUGACCT,IBDATA,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWPP3,QTYPOST,QUANTITY,TOTCOST,TOTLINES,UNITCOST,X
+6 ;
+7 IF $PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",20)="D"
SET X="PSAGIP"
IF $DATA(^%ZOSF("TEST"))
XECUTE ^("TEST")
IF $TEST
SET DRUGACCT=1
KILL X
SET X(1)="NOTE: This is a DRUG ACCOUNTABILITY inventory point."
DO DISPLAY^PRCPUX2(1,79,.X)
+8 ;
+9 SET XP="ARE YOU SURE YOU WANT TO RECEIVE THIS ISSUE BOOK"
+10 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+11 LOCK +^PRCP(445,PRCPINPT,1):5
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0)
QUIT
+12 DO ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Issue Book")
+13 SET PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
+14 SET TOTLINES=0
+15 SET LINEDA=0
FOR
SET LINEDA=$ORDER(^TMP($JOB,"PRCPWPPLPOST",LINEDA))
if 'LINEDA
QUIT
SET QTYPOST=^(LINEDA)
IF QTYPOST
Begin DoDot:1
+16 SET IBDATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
IF IBDATA=""
QUIT
+17 SET ITEMDA=+$PIECE(IBDATA,"^",5)
+18 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
IF ITEMDATA=""
QUIT
+19 SET UNITCOST=$PIECE(IBDATA,"^",7)
+20 SET TOTCOST=$JUSTIFY(QTYPOST*UNITCOST,0,2)
+21 SET TOTLINES=TOTLINES+1
+22 ;
+23 ; *** primary ***
+24 SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)=$PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",13)+QTYPOST
+25 SET ITEMDATA=$GET(^PRCP(445,PRCPINPT,1,ITEMDA,0))
IF ITEMDATA=""
Begin DoDot:2
+26 SET COSTCNTR=$PIECE($GET(^PRCP(445,PRCPINPT,0)),"^",7)
IF COSTCNTR
DO COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
End DoDot:2
QUIT
+27 SET QTYPOST=QTYPOST*$PIECE($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRCPPVNO,1),"^",4)
+28 ; update beginning balance
+29 IF '$DATA(^PRCP(445.1,PRCPINPT,1,ITEMDA,1,$EXTRACT(DT,1,5),0))
DO BALANCE^PRCPUBAL(PRCPINPT,ITEMDA,$EXTRACT(DT,1,5))
+30 ; update primary invpt
+31 SET $PIECE(ITEMDATA,"^",7)=$PIECE(ITEMDATA,"^",7)+QTYPOST
+32 SET $PIECE(ITEMDATA,"^",27)=$PIECE(ITEMDATA,"^",27)+TOTCOST
+33 ; update average cost
+34 SET $PIECE(ITEMDATA,"^",22)=0
SET QUANTITY=$PIECE(ITEMDATA,"^",7)
+35 IF QUANTITY
SET $PIECE(ITEMDATA,"^",22)=$JUSTIFY($PIECE(ITEMDATA,"^",27)/QUANTITY,0,3)
IF $PIECE(ITEMDATA,"^",22)'>0
SET $PIECE(ITEMDATA,"^",22)=0
+36 ; update last cost
+37 SET $PIECE(ITEMDATA,"^",15)=$JUSTIFY(TOTCOST/QTYPOST,0,3)
SET $PIECE(ITEMDATA,"^",3)=DT
+38 SET ^PRCP(445,PRCPINPT,1,ITEMDA,0)=ITEMDATA
+39 ; remove due-in
+40 DO OUTST^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA,-QTYPOST)
+41 ; receipt history
+42 DO RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST)
+43 ; distribution costs
+44 SET COSTCNTR=$PIECE(^PRCP(445,PRCPINPT,0),"^",7)
IF COSTCNTR
DO COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
+45 ; drug accountability
+46 IF $GET(DRUGACCT)
SET %=+$PIECE(ITEMDATA,"^",29)
if '%
SET %=1
DO EN^PSAGIP(PRCPINPT,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
+47 ; transaction register
+48 IF PRCPPORD
Begin DoDot:2
+49 KILL PRCPWPP3
+50 SET PRCPWPP3("QTY")=QTYPOST
SET (PRCPWPP3("INVVAL"),PRCPWPP3("SELVAL"))=TOTCOST
SET PRCPWPP3("2237PO")=PRCPIBNM
SET PRCPWPP3("OTHERPT")=PRCPWHSE
+51 DO ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",PRCPPORD,.PRCPWPP3)
End DoDot:2
End DoDot:1
+52 ;
+53 KILL VALMBCK
+54 ;
+55 IF $GET(DRUGACCT)
DO EX^PSAGIP
+56 KILL X
SET X(1)="TOTAL LINE ITEMS POSTED: "_TOTLINES
DO DISPLAY^PRCPUX2(1,40,.X)
+57 ;
+58 ; make issue book a final
+59 IF $GET(PRCPFINL)
Begin DoDot:1
+60 KILL X
SET X(1)="This issue book is a final. You have the option to remove all outstanding due-ins for this issue book."
DO DISPLAY^PRCPUX2(5,75,.X)
+61 SET XP="Do you want to remove the due-ins for this issue book"
SET XH="Enter YES to remove the due-ins, NO to leave the due-ins."
+62 IF $$YN^PRCPUYN(1)'=1
QUIT
+63 SET LINEDA=0
FOR
SET LINEDA=$ORDER(^PRCS(410,PRCPDA,"IT",LINEDA))
if 'LINEDA
QUIT
SET ITEMDA=+$PIECE(^(LINEDA,0),"^",5)
SET QTYOUT=$PIECE(^(0),"^",2)-$PIECE(^(0),"^",13)
IF QTYOUT>0
Begin DoDot:2
+64 DO KILLTRAN^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA)
End DoDot:2
End DoDot:1
+65 ;
+66 DO CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
+67 LOCK -^PRCP(445,PRCPINPT,1)
+68 ;
+69 IF TOTLINES=0
if $GET(PRCPFINL)
QUIT
SET VALMSG="NO LINE ITEMS TO POST"
SET VALMBCK="R"
QUIT
+70 DO R^PRCPUREP
+71 QUIT
