source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPP3.m

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