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

PRCPOPU.m

Go to the documentation of this file.
  1. PRCPOPU ;WISC/RFJ,DWA-distibution order utilities ;27 Sep 93
  1. ;;5.1;IFCAP;**27**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. VARIABLE ; set up order variables for orderda
  1. N DFN,VADM,VAERR
  1. S PRCPORD(0)=$G(^PRCP(445.3,ORDERDA,0)),PRCPORD(2)=$G(^PRCP(445.3,ORDERDA,2))
  1. S PRCPPRIM=+$P(PRCPORD(0),"^",2),PRCPSECO=+$P(PRCPORD(0),"^",3),PRCPPAT=+$P(PRCPORD(2),"^")
  1. S $P(PRCPORD(0),"^",2)=$$INVNAME^PRCPUX1(PRCPPRIM)
  1. S $P(PRCPORD(0),"^",3)=$$INVNAME^PRCPUX1(PRCPSECO)
  1. S DFN=PRCPPAT I $$VERSION^XPDUTL("DG") D DEM^VADPT
  1. S $P(PRCPORD(2),"^")=$G(VADM(1))
  1. Q
  1. ;
  1. ;
  1. DUEOUTIN(PRCPPRIM,PRCPSECO,ITEMDA,QTY,PRINT) ;
  1. ; update the primary prcpprim itemda dueouts by qty (- to subtract);
  1. ; update the secondary prcpseco itemda dueins by qty*conv
  1. ; print=1 to display message
  1. N %
  1. ;
  1. I PRINT W !!,"<*> Updating DUE-OUTS in primary ",$$INVNAME^PRCPUX1(PRCPPRIM),?60," by ",QTY
  1. D SETOUT^PRCPUDUE(PRCPPRIM,ITEMDA,QTY)
  1. ;
  1. S QTY=QTY*$P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4)
  1. I PRINT W !,"<*> Updating DUE-INS in secondary ",$$INVNAME^PRCPUX1(PRCPSECO),?60," by ",QTY
  1. D SETIN^PRCPUDUE(PRCPSECO,ITEMDA,QTY)
  1. Q
  1. ;
  1. ;
  1. STATUS(ORDERDA) ; return status of order
  1. N %
  1. S %=$P($G(^PRCP(445.3,+ORDERDA,0)),"^",6) I %'="" S %=$P($P($P(^DD(445.3,5,0),"^",3),%_":",2),";")
  1. I %="" S %="<< NOT RELEASED >>"
  1. Q %
  1. ;
  1. ;
  1. TYPE(ORDERDA) ; return type of order
  1. N %
  1. S %=$P($G(^PRCP(445.3,+ORDERDA,0)),"^",8) I %'="" S %=$P($P($P(^DD(445.3,3.5,0),"^",3),%_":",2),";")
  1. I %="" S %="<< NO TYPE >>"
  1. Q %