- 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 Feb 18, 2025@23:42:46 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