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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUSAG 1431 printed Dec 13, 2024@02:16:23 Page 2
PRCPUSAG ;WISC/RFJ-usage and receipts history ;02 Oct 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ADDUSAG(INVPT,ITEMDA,QTY,COST) ; add/update usage history
+1 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))
QUIT
+2 NEW %,DATE
+3 SET DATE=$EXTRACT(DT,1,5)
+4 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0))
Begin DoDot:1
+5 NEW DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
+6 if '$DATA(^PRCP(445,INVPT,1,ITEMDA,2,0))
SET ^(0)="^445.05A^^"
+7 SET DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",2,"
SET (X,DINUM)=DATE
SET DA(1)=ITEMDA
SET DA(2)=INVPT
SET DIC(0)="L"
SET DLAYGO=445
+8 DO FILE^DICN
End DoDot:1
+9 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,2,DATE,0))
QUIT
+10 LOCK +^PRCP(445,INVPT,1,ITEMDA,2,DATE)
+11 SET %=^PRCP(445,INVPT,1,ITEMDA,2,DATE,0)
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+QTY
SET $PIECE(%,"^",3)=$JUSTIFY($PIECE(%,"^",3)+COST,0,3)
SET ^(0)=%
+12 LOCK -^PRCP(445,INVPT,1,ITEMDA,2,DATE)
+13 QUIT
+14 ;
+15 ;
RECEIPTS(INVPT,ITEMDA,QTY) ; add/update receipts history
+1 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,0))
QUIT
+2 NEW %
+3 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,3,DT,0))
Begin DoDot:1
+4 if '$DATA(^PRCP(445,INVPT,1,ITEMDA,3,0))
SET ^(0)="^445.06DA^^"
+5 NEW DA,DIC,D0,DD,DLAYGO,DINUM,X,Y
+6 SET DIC="^PRCP(445,"_INVPT_",1,"_ITEMDA_",3,"
SET (X,DINUM)=DT
SET DA(1)=ITEMDA
SET DA(2)=INVPT
SET DIC(0)="L"
SET DLAYGO=445
+7 DO FILE^DICN
End DoDot:1
+8 IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,3,DT,0))
QUIT
+9 LOCK +^PRCP(445,INVPT,1,ITEMDA,3,DT)
+10 SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)=$PIECE(^PRCP(445,INVPT,1,ITEMDA,3,DT,0),"^",2)+QTY
+11 LOCK -^PRCP(445,INVPT,1,ITEMDA,3,DT)
+12 QUIT
