source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSAG.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.4 KB
Line 
1PRCPUSAG ;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 ;
7ADDUSAG(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 ;
23RECEIPTS(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
Note: See TracBrowser for help on using the repository browser.