| 1 | PRCPUSAG ;WISC/RFJ-usage and receipts history ;02 Oct 91
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | ADDUSAG(INVPT,ITEMDA,QTY,COST) ; add/update usage history
|
|---|
| 8 | I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
|
|---|
| 9 | N %,DATE
|
|---|
| 10 | S DATE=$E(DT,1,5)
|
|---|
| 11 | I '$D(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)) D
|
|---|
| 12 | . N DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
|
|---|
| 13 | . S:'$D(^PRCP(445,INVPT,1,ITEMDA,2,0)) ^(0)="^445.05A^^"
|
|---|
| 14 | . S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",2,",(X,DINUM)=DATE,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
|
|---|
| 15 | . D FILE^DICN
|
|---|
| 16 | I '$D(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)) Q
|
|---|
| 17 | L +^PRCP(445,INVPT,1,ITEMDA,2,DATE)
|
|---|
| 18 | S %=^PRCP(445,INVPT,1,ITEMDA,2,DATE,0),$P(%,"^",2)=$P(%,"^",2)+QTY,$P(%,"^",3)=$J($P(%,"^",3)+COST,0,3),^(0)=%
|
|---|
| 19 | L -^PRCP(445,INVPT,1,ITEMDA,2,DATE)
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | ;
|
|---|
| 23 | RECEIPTS(INVPT,ITEMDA,QTY) ; add/update receipts history
|
|---|
| 24 | I '$D(^PRCP(445,INVPT,1,ITEMDA,0)) Q
|
|---|
| 25 | N %
|
|---|
| 26 | I '$D(^PRCP(445,INVPT,1,ITEMDA,3,DT,0)) D
|
|---|
| 27 | . S:'$D(^PRCP(445,INVPT,1,ITEMDA,3,0)) ^(0)="^445.06DA^^"
|
|---|
| 28 | . N DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
|
|---|
| 29 | . S DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",3,",(X,DINUM)=DT,DA(1)=ITEMDA,DA(2)=INVPT,DIC(0)="L",DLAYGO=445
|
|---|
| 30 | . D FILE^DICN
|
|---|
| 31 | I '$D(^PRCP(445,INVPT,1,ITEMDA,3,DT,0)) Q
|
|---|
| 32 | L +^PRCP(445,INVPT,1,ITEMDA,3,DT)
|
|---|
| 33 | S $P(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)=$P(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)+QTY
|
|---|
| 34 | L -^PRCP(445,INVPT,1,ITEMDA,3,DT)
|
|---|
| 35 | Q
|
|---|
