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

PRCPWPP3.m

Go to the documentation of this file.
  1. PRCPWPP3 ;WISC/RFJ-primary receive issue book (receive) ;20 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. RECEIVE ; receive issue book
  1. D FULL^VALM1
  1. S VALMBCK="R"
  1. I '$O(^TMP($J,"PRCPWPPLPOST",0)) S VALMSG="THERE ARE NO ITEMS TO RECEIVE" Q
  1. ;
  1. N %,COSTCNTR,DRUGACCT,IBDATA,ITEMDA,ITEMDATA,LINEDA,PRCPFLAG,PRCPPORD,PRCPWPP3,QTYPOST,QUANTITY,TOTCOST,TOTLINES,UNITCOST,X
  1. ;
  1. 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)
  1. ;
  1. S XP="ARE YOU SURE YOU WANT TO RECEIVE THIS ISSUE BOOK"
  1. W ! I $$YN^PRCPUYN(1)'=1 Q
  1. L +^PRCP(445,PRCPINPT,1):5 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q
  1. D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Receive Issue Book")
  1. S PRCPPORD=$$ORDERNO^PRCPUTRX(PRCPINPT)
  1. S TOTLINES=0
  1. S LINEDA=0 F S LINEDA=$O(^TMP($J,"PRCPWPPLPOST",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. . S UNITCOST=$P(IBDATA,"^",7)
  1. . S TOTCOST=$J(QTYPOST*UNITCOST,0,2)
  1. . S TOTLINES=TOTLINES+1
  1. . ;
  1. . ; *** primary ***
  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,PRCPINPT,1,ITEMDA,0)) I ITEMDATA="" D Q
  1. . . S COSTCNTR=$P($G(^PRCP(445,PRCPINPT,0)),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
  1. . S QTYPOST=QTYPOST*$P($$GETVEN^PRCPUVEN(PRCPINPT,ITEMDA,PRCPPVNO,1),"^",4)
  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 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,PRCPINPT,1,ITEMDA,0)=ITEMDATA
  1. . ; remove due-in
  1. . D OUTST^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA,-QTYPOST)
  1. . ; receipt history
  1. . D RECEIPTS^PRCPUSAG(PRCPINPT,ITEMDA,QTYPOST)
  1. . ; distribution costs
  1. . S COSTCNTR=$P(^PRCP(445,PRCPINPT,0),"^",7) I COSTCNTR D COSTCNTR^PRCPUCC(PRCPINPT,PRCPWHSE,COSTCNTR,TOTCOST)
  1. . ; drug accountability
  1. . I $G(DRUGACCT) S %=+$P(ITEMDATA,"^",29) S:'% %=1 D EN^PSAGIP(PRCPINPT,ITEMDA,QTYPOST*%,PRCPDA,PRCPIBNM,"RC"_PRCPPORD,TOTCOST)
  1. . ; transaction register
  1. . I PRCPPORD D
  1. . . K PRCPWPP3
  1. . . S PRCPWPP3("QTY")=QTYPOST,(PRCPWPP3("INVVAL"),PRCPWPP3("SELVAL"))=TOTCOST,PRCPWPP3("2237PO")=PRCPIBNM,PRCPWPP3("OTHERPT")=PRCPWHSE
  1. . . D ADDTRAN^PRCPUTRX(PRCPINPT,ITEMDA,"RC",PRCPPORD,.PRCPWPP3)
  1. ;
  1. K VALMBCK
  1. ;
  1. I $G(DRUGACCT) D EX^PSAGIP
  1. K X S X(1)="TOTAL LINE ITEMS POSTED: "_TOTLINES D DISPLAY^PRCPUX2(1,40,.X)
  1. ;
  1. ; make issue book a final
  1. I $G(PRCPFINL) D
  1. . 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)
  1. . 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."
  1. . I $$YN^PRCPUYN(1)'=1 Q
  1. . 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
  1. . . D KILLTRAN^PRCPUTRA(PRCPINPT,ITEMDA,PRCPDA)
  1. ;
  1. D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
  1. L -^PRCP(445,PRCPINPT,1)
  1. ;
  1. I TOTLINES=0 Q:$G(PRCPFINL) S VALMSG="NO LINE ITEMS TO POST",VALMBCK="R" Q
  1. D R^PRCPUREP
  1. Q