Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPUSA

PRCPUSA.m

Go to the documentation of this file.
  1. PRCPUSA ;WISC/RFJ-utility program for updating inventory point ;30 Sep 92
  1. ;;5.1;IFCAP;**126**;Oct 20, 2000;Build 2
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. S X=$$UPDATE(.PRCP) I X'="" W !!,X Q
  1. K PRCP,X Q
  1. ;
  1. ;
  1. UPDATE(PRCPZ) ; start updating inventory point
  1. ;prcpz =
  1. ; i) = internal inventory point number
  1. ; item) = item number
  1. ; typ) = R or C for distribution
  1. ; = RC for receipts
  1. ; = U for usage
  1. ; = A for adjustment
  1. ; = P for physical counts
  1. ; qty) = quantity to add to on-hand
  1. ; com) = transaction register comments
  1. ; returns error message if unsuccessful or null if successful
  1. ;
  1. I '$D(^PRCP(445,+$G(PRCPZ("I")),0)) Q "Invalid inventory location"
  1. I '$D(^PRCP(445,PRCPZ("I"),4,+$G(DUZ),0)) Q "User does not have access to the inventory point"
  1. I '$D(^PRCP(445,PRCPZ("I"),1,+$G(PRCPZ("ITEM")),0)) Q "Item is not stored in inventory point"
  1. S:'$D(PRCPZ("TYP")) PRCPZ("TYP")="" I "RCAUP"'[PRCPZ("TYP") Q "Invalid transaction type '"_PRCPZ("TYP")_"'"
  1. S:'$D(PRCPZ("QTY")) PRCPZ("QTY")=0 I "AP"'[PRCPZ("TYP"),PRCPZ("QTY")=0 Q "Quantity cannot equal zero"
  1. I PRCPZ("TYP")="RC",PRCPZ("QTY")<0 Q "For receipts, quantity must be greater than zero"
  1. I (PRCPZ("TYP")="R"!(PRCPZ("TYP")="C"))&(PRCPZ("QTY")>0) Q "For distribution (Regular or Call-in), quantity must be less than zero"
  1. ;
  1. N ORDERNO,PRCPID,PRCPUSA,TOTCOST,VALUE,X,Y,Z
  1. S VALUE=$P(^PRCP(445,PRCPZ("I"),1,PRCPZ("ITEM"),0),"^",22)
  1. I VALUE=0,PRCPZ("TYP")="P" S VALUE=$P(^PRCP(445,PRCPZ("I"),1,PRCPZ("ITEM"),0),"^",15)
  1. S TOTCOST=$J(PRCPZ("QTY")*VALUE,0,2)
  1. ;
  1. I $P(^PRCP(445,PRCPZ("I"),0),"^",6)="Y" S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPZ("I"))
  1. K PRCPUSA S PRCPUSA("QTY")=PRCPZ("QTY"),PRCPUSA("INVVAL")=TOTCOST,PRCPUSA("SELVAL")=TOTCOST,PRCPUSA("REASON")="0:"_$G(PRCPZ("COM")),PRCPUSA("NODUEIN")=1,PRCPUSA("NODUEOUT")=1,PRCPUSA("OTHERPT")=""
  1. D ITEM^PRCPUUIP(PRCPZ("I"),PRCPZ("ITEM"),PRCPZ("TYP"),+$G(ORDERNO),.PRCPUSA)
  1. Q ""