PRCPUSA.m

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 ---PRCPUSA   2064     printed  Jun 11, 2024@21:45:08                                                                                                                                                                                                     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 ""