36 lines
1.4 KiB
Mathematica
36 lines
1.4 KiB
Mathematica
PRCPUSAG ;WISC/RFJ-usage and receipts history ;02 Oct 91
|
|
;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
;
|
|
;
|
|
ADDUSAG(INVPT,ITEMDA,QTY,COST) ; add/update usage history
|
|
I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
|
|
N %,DATE
|
|
S DATE=$E(DT,1,5)
|
|
I '$D(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)) D
|
|
. N DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
|
|
. S:'$D(^PRCP(445,INVPT,1,ITEMDA,2,0)) ^(0)="^445.05A^^"
|
|
. S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",2,",(X,DINUM)=DATE,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
|
|
. D FILE^DICN
|
|
I '$D(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)) Q
|
|
L +^PRCP(445,INVPT,1,ITEMDA,2,DATE)
|
|
S %=^PRCP(445,INVPT,1,ITEMDA,2,DATE,0),$P(%,"^",2)=$P(%,"^",2)+QTY,$P(%,"^",3)=$J($P(%,"^",3)+COST,0,3),^(0)=%
|
|
L -^PRCP(445,INVPT,1,ITEMDA,2,DATE)
|
|
Q
|
|
;
|
|
;
|
|
RECEIPTS(INVPT,ITEMDA,QTY) ; add/update receipts history
|
|
I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
|
|
N %
|
|
I '$D(^PRCP(445,INVPT,1,ITEMDA,3,DT,0)) D
|
|
. S:'$D(^PRCP(445,INVPT,1,ITEMDA,3,0)) ^(0)="^445.06DA^^"
|
|
. N DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
|
|
. S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",3,",(X,DINUM)=DT,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
|
|
. D FILE^DICN
|
|
I '$D(^PRCP(445,INVPT,1,ITEMDA,3,DT,0)) Q
|
|
L +^PRCP(445,INVPT,1,ITEMDA,3,DT)
|
|
S $P(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)=$P(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)+QTY
|
|
L -^PRCP(445,INVPT,1,ITEMDA,3,DT)
|
|
Q
|