- PRCPUSA ;WISC/RFJ-utility program for updating inventory point ;30 Sep 92
- ;;5.1;IFCAP;**126**;Oct 20, 2000;Build 2
- ;Per VHA Directive 2004-038, this routine should not be modified.
- S X=$$UPDATE(.PRCP) I X'="" W !!,X Q
- K PRCP,X Q
- ;
- ;
- UPDATE(PRCPZ) ; start updating inventory point
- ;prcpz =
- ; i) = internal inventory point number
- ; item) = item number
- ; typ) = R or C for distribution
- ; = RC for receipts
- ; = U for usage
- ; = A for adjustment
- ; = P for physical counts
- ; qty) = quantity to add to on-hand
- ; com) = transaction register comments
- ; returns error message if unsuccessful or null if successful
- ;
- I '$D(^PRCP(445,+$G(PRCPZ("I")),0)) Q "Invalid inventory location"
- I '$D(^PRCP(445,PRCPZ("I"),4,+$G(DUZ),0)) Q "User does not have access to the inventory point"
- I '$D(^PRCP(445,PRCPZ("I"),1,+$G(PRCPZ("ITEM")),0)) Q "Item is not stored in inventory point"
- S:'$D(PRCPZ("TYP")) PRCPZ("TYP")="" I "RCAUP"'[PRCPZ("TYP") Q "Invalid transaction type '"_PRCPZ("TYP")_"'"
- S:'$D(PRCPZ("QTY")) PRCPZ("QTY")=0 I "AP"'[PRCPZ("TYP"),PRCPZ("QTY")=0 Q "Quantity cannot equal zero"
- I PRCPZ("TYP")="RC",PRCPZ("QTY")<0 Q "For receipts, quantity must be greater than zero"
- I (PRCPZ("TYP")="R"!(PRCPZ("TYP")="C"))&(PRCPZ("QTY")>0) Q "For distribution (Regular or Call-in), quantity must be less than zero"
- ;
- N ORDERNO,PRCPID,PRCPUSA,TOTCOST,VALUE,X,Y,Z
- S VALUE=$P(^PRCP(445,PRCPZ("I"),1,PRCPZ("ITEM"),0),"^",22)
- I VALUE=0,PRCPZ("TYP")="P" S VALUE=$P(^PRCP(445,PRCPZ("I"),1,PRCPZ("ITEM"),0),"^",15)
- S TOTCOST=$J(PRCPZ("QTY")*VALUE,0,2)
- ;
- I $P(^PRCP(445,PRCPZ("I"),0),"^",6)="Y" S ORDERNO=$$ORDERNO^PRCPUTRX(PRCPZ("I"))
- 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")=""
- D ITEM^PRCPUUIP(PRCPZ("I"),PRCPZ("ITEM"),PRCPZ("TYP"),+$G(ORDERNO),.PRCPUSA)
- Q ""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUSA 2064 printed Jan 18, 2025@03:17:33 Page 2
- PRCPUSA ;WISC/RFJ-utility program for updating inventory point ;30 Sep 92
- +1 ;;5.1;IFCAP;**126**;Oct 20, 2000;Build 2
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 SET X=$$UPDATE(.PRCP)
- IF X'=""
- WRITE !!,X
- QUIT
- +4 KILL PRCP,X
- QUIT
- +5 ;
- +6 ;
- UPDATE(PRCPZ) ; start updating inventory point
- +1 ;prcpz =
- +2 ; i) = internal inventory point number
- +3 ; item) = item number
- +4 ; typ) = R or C for distribution
- +5 ; = RC for receipts
- +6 ; = U for usage
- +7 ; = A for adjustment
- +8 ; = P for physical counts
- +9 ; qty) = quantity to add to on-hand
- +10 ; com) = transaction register comments
- +11 ; returns error message if unsuccessful or null if successful
- +12 ;
- +13 IF '$DATA(^PRCP(445,+$GET(PRCPZ("I")),0))
- QUIT "Invalid inventory location"
- +14 IF '$DATA(^PRCP(445,PRCPZ("I"),4,+$GET(DUZ),0))
- QUIT "User does not have access to the inventory point"
- +15 IF '$DATA(^PRCP(445,PRCPZ("I"),1,+$GET(PRCPZ("ITEM")),0))
- QUIT "Item is not stored in inventory point"
- +16 if '$DATA(PRCPZ("TYP"))
- SET PRCPZ("TYP")=""
- IF "RCAUP"'[PRCPZ("TYP")
- QUIT "Invalid transaction type '"_PRCPZ("TYP")_"'"
- +17 if '$DATA(PRCPZ("QTY"))
- SET PRCPZ("QTY")=0
- IF "AP"'[PRCPZ("TYP")
- IF PRCPZ("QTY")=0
- QUIT "Quantity cannot equal zero"
- +18 IF PRCPZ("TYP")="RC"
- IF PRCPZ("QTY")<0
- QUIT "For receipts, quantity must be greater than zero"
- +19 IF (PRCPZ("TYP")="R"!(PRCPZ("TYP")="C"))&(PRCPZ("QTY")>0)
- QUIT "For distribution (Regular or Call-in), quantity must be less than zero"
- +20 ;
- +21 NEW ORDERNO,PRCPID,PRCPUSA,TOTCOST,VALUE,X,Y,Z
- +22 SET VALUE=$PIECE(^PRCP(445,PRCPZ("I"),1,PRCPZ("ITEM"),0),"^",22)
- +23 IF VALUE=0
- IF PRCPZ("TYP")="P"
- SET VALUE=$PIECE(^PRCP(445,PRCPZ("I"),1,PRCPZ("ITEM"),0),"^",15)
- +24 SET TOTCOST=$JUSTIFY(PRCPZ("QTY")*VALUE,0,2)
- +25 ;
- +26 IF $PIECE(^PRCP(445,PRCPZ("I"),0),"^",6)="Y"
- SET ORDERNO=$$ORDERNO^PRCPUTRX(PRCPZ("I"))
- +27 KILL PRCPUSA
- SET PRCPUSA("QTY")=PRCPZ("QTY")
- SET PRCPUSA("INVVAL")=TOTCOST
- SET PRCPUSA("SELVAL")=TOTCOST
- SET PRCPUSA("REASON")="0:"_$GET(PRCPZ("COM"))
- SET PRCPUSA("NODUEIN")=1
- SET PRCPUSA("NODUEOUT")=1
- SET PRCPUSA("OTHERPT")=""
- +28 DO ITEM^PRCPUUIP(PRCPZ("I"),PRCPZ("ITEM"),PRCPZ("TYP"),+$GET(ORDERNO),.PRCPUSA)
- +29 QUIT ""