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

PRCPUSAG.m

Go to the documentation of this file.
  1. PRCPUSAG ;WISC/RFJ-usage and receipts history ;02 Oct 91
  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. ADDUSAG(INVPT,ITEMDA,QTY,COST) ; add/update usage history
  1. I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
  1. N %,DATE
  1. S DATE=$E(DT,1,5)
  1. I '$D(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)) D
  1. . N DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
  1. . S:'$D(^PRCP(445,INVPT,1,ITEMDA,2,0)) ^(0)="^445.05A^^"
  1. . S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",2,",(X,DINUM)=DATE,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
  1. . D FILE^DICN
  1. I '$D(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)) Q
  1. L +^PRCP(445,INVPT,1,ITEMDA,2,DATE)
  1. S %=^PRCP(445,INVPT,1,ITEMDA,2,DATE,0),$P(%,"^",2)=$P(%,"^",2)+QTY,$P(%,"^",3)=$J($P(%,"^",3)+COST,0,3),^(0)=%
  1. L -^PRCP(445,INVPT,1,ITEMDA,2,DATE)
  1. Q
  1. ;
  1. ;
  1. RECEIPTS(INVPT,ITEMDA,QTY) ; add/update receipts history
  1. I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
  1. N %
  1. I '$D(^PRCP(445,INVPT,1,ITEMDA,3,DT,0)) D
  1. . S:'$D(^PRCP(445,INVPT,1,ITEMDA,3,0)) ^(0)="^445.06DA^^"
  1. . N DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
  1. . S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",3,",(X,DINUM)=DT,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
  1. . D FILE^DICN
  1. I '$D(^PRCP(445,INVPT,1,ITEMDA,3,DT,0)) Q
  1. L +^PRCP(445,INVPT,1,ITEMDA,3,DT)
  1. S $P(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)=$P(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)+QTY
  1. L -^PRCP(445,INVPT,1,ITEMDA,3,DT)
  1. Q