PRCPEILM ;WISC/RFJ-edit inventory items (list manager) ;01 Dec 93
V ;;5.1;IFCAP;**1,171**;Oct 20, 2000;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
EN ; called from protocol file from within another protocol
N CLREND,COLUMN,ITEMDA,LINE,PRCPINPT,PRCPDATA,PRCPTYPE
S PRCPINPT=PRCP("I"),PRCPTYPE=PRCP("DPTYPE")
F W !! S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),1,"","") Q:'ITEMDA D
. L +^PRCP(445,PRCPINPT,1,ITEMDA):1 I '$T D SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0) Q
. D ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Enter/Edit Inventory Item Data")
. D FULL^VALM1,EN^VALM("PRCP EDIT ITEMS"),FULL^VALM1 ;PRC*5.1*171 Clear screen protect area from PRCP EDIT ITEMS Listman call
. I $D(^PRCP(445,PRCPINPT,1,ITEMDA)) D BLDSEG^PRCPHLFM(3,ITEMDA,PRCPINPT) ; send supply station an update of any changes to the item
. D CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
. L -^PRCP(445,PRCPINPT,1,ITEMDA)
Q
;
;
HDR ; build header
S VALMHDR(1)="INVENTORY POINT: "_$$INVNAME^PRCPUX1(PRCPINPT)_" * * * IM#: "_ITEMDA_" * * *"
Q
;
;
INIT ; build array
K PRCPDATA,^TMP($J,"PRCPEILM")
D DIQ(".01:51")
D DESCRIP
D ISSUNITS^PRCPEIL0
D LEVELS^PRCPEIL0
D QUANTITY^PRCPEIL0
D COSTS^PRCPEIL0
D OUTSTRAN^PRCPEIL0
D SPECIAL^PRCPEIL0
I $P(^PRCP(445,PRCPINPT,0),"^",20)="D" D DRUGACCT^PRCPEIL0
D SOURCES^PRCPEIL0
S VALMCNT=45
Q
;
;
DESCRIP ; build descriptive array
S LINE=1,COLUMN=1,CLREND=80
D SET^PRCPEIL0("Descriptive",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
D SET^PRCPEIL0("-445",LINE,12,CLREND,.7)
D SET^PRCPEIL0("Description-441: "_$P($G(^PRC(441,ITEMDA,0)),"^",2),LINE+1,COLUMN,CLREND)
D SET^PRCPEIL0("NSN : "_$$NSN^PRCPUX1(ITEMDA),LINE+2,COLUMN,CLREND)
D SET^PRCPEIL0("Group Category ",LINE+3,COLUMN,CLREND,.5)
D SET^PRCPEIL0("Main Storage Lo",LINE+4,COLUMN,CLREND,5)
S X="",%=0 F S %=$O(^PRCP(445,PRCP("I"),1,ITEMDA,1,%)) Q:'% S X=X_$$STORELOC^PRCPESTO(%)_" " Q:$L(X)>240
D SET^PRCPEIL0("Add Storage Loc: "_X,LINE+5,COLUMN,CLREND)
S X=$S($D(^PRCP(445.7,ITEMDA)):"CASE CART",$D(^PRCP(445.8,ITEMDA)):"INSTRUMENT KIT",1:$S($$PURCHASE^PRCPU441(ITEMDA):"PURCHASABLE",1:"NOT PURCHASABLE"))
S X=$E(X_$J("",30),1,30)_$S($$REUSABLE^PRCPU441(ITEMDA):"REUSABLE",1:"")
D SET^PRCPEIL0("Type Of Item : "_X,LINE+6,COLUMN,CLREND)
D SET^PRCPEIL0("",LINE+7,COLUMN,CLREND)
Q
;
;
EXIT ; exit and clean up
K ^TMP($J,"PRCPEILM")
Q
;
;
DIQ(DR) ; diq call to retrieve data for dr fields
N D0,DA,DIC,DIQ,DIQ2
S DA(1)=PRCPINPT,DA=ITEMDA,DIQ(0)="E"
S DIC="^PRCP(445,"_PRCPINPT_",1,"
S DIQ="PRCPDATA" D EN^DIQ1
Q
;
;
CHECK() ; screen for manager access to option
; return 1 for access, 0 for no access
I $$KEY^PRCPUREP("PRCP"_$TR(PRCPTYPE,"WSP","W2")_" MGRKEY",DUZ) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPEILM 2837 printed Sep 23, 2025@19:49:40 Page 2
PRCPEILM ;WISC/RFJ-edit inventory items (list manager) ;01 Dec 93
V ;;5.1;IFCAP;**1,171**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
EN ; called from protocol file from within another protocol
+1 NEW CLREND,COLUMN,ITEMDA,LINE,PRCPINPT,PRCPDATA,PRCPTYPE
+2 SET PRCPINPT=PRCP("I")
SET PRCPTYPE=PRCP("DPTYPE")
+3 FOR
WRITE !!
SET ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),1,"","")
if 'ITEMDA
QUIT
Begin DoDot:1
+4 LOCK +^PRCP(445,PRCPINPT,1,ITEMDA):1
IF '$TEST
DO SHOWWHO^PRCPULOC(445,PRCPINPT_"-1",0)
QUIT
+5 DO ADD^PRCPULOC(445,PRCPINPT_"-1",0,"Enter/Edit Inventory Item Data")
+6 ;PRC*5.1*171 Clear screen protect area from PRCP EDIT ITEMS Listman call
DO FULL^VALM1
DO EN^VALM("PRCP EDIT ITEMS")
DO FULL^VALM1
+7 ; send supply station an update of any changes to the item
IF $DATA(^PRCP(445,PRCPINPT,1,ITEMDA))
DO BLDSEG^PRCPHLFM(3,ITEMDA,PRCPINPT)
+8 DO CLEAR^PRCPULOC(445,PRCPINPT_"-1",0)
+9 LOCK -^PRCP(445,PRCPINPT,1,ITEMDA)
End DoDot:1
+10 QUIT
+11 ;
+12 ;
HDR ; build header
+1 SET VALMHDR(1)="INVENTORY POINT: "_$$INVNAME^PRCPUX1(PRCPINPT)_" * * * IM#: "_ITEMDA_" * * *"
+2 QUIT
+3 ;
+4 ;
INIT ; build array
+1 KILL PRCPDATA,^TMP($JOB,"PRCPEILM")
+2 DO DIQ(".01:51")
+3 DO DESCRIP
+4 DO ISSUNITS^PRCPEIL0
+5 DO LEVELS^PRCPEIL0
+6 DO QUANTITY^PRCPEIL0
+7 DO COSTS^PRCPEIL0
+8 DO OUTSTRAN^PRCPEIL0
+9 DO SPECIAL^PRCPEIL0
+10 IF $PIECE(^PRCP(445,PRCPINPT,0),"^",20)="D"
DO DRUGACCT^PRCPEIL0
+11 DO SOURCES^PRCPEIL0
+12 SET VALMCNT=45
+13 QUIT
+14 ;
+15 ;
DESCRIP ; build descriptive array
+1 SET LINE=1
SET COLUMN=1
SET CLREND=80
+2 DO SET^PRCPEIL0("Descriptive",LINE,COLUMN,CLREND,0,IORVON,IORVOFF)
+3 DO SET^PRCPEIL0("-445",LINE,12,CLREND,.7)
+4 DO SET^PRCPEIL0("Description-441: "_$PIECE($GET(^PRC(441,ITEMDA,0)),"^",2),LINE+1,COLUMN,CLREND)
+5 DO SET^PRCPEIL0("NSN : "_$$NSN^PRCPUX1(ITEMDA),LINE+2,COLUMN,CLREND)
+6 DO SET^PRCPEIL0("Group Category ",LINE+3,COLUMN,CLREND,.5)
+7 DO SET^PRCPEIL0("Main Storage Lo",LINE+4,COLUMN,CLREND,5)
+8 SET X=""
SET %=0
FOR
SET %=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,1,%))
if '%
QUIT
SET X=X_$$STORELOC^PRCPESTO(%)_" "
if $LENGTH(X)>240
QUIT
+9 DO SET^PRCPEIL0("Add Storage Loc: "_X,LINE+5,COLUMN,CLREND)
+10 SET X=$SELECT($DATA(^PRCP(445.7,ITEMDA)):"CASE CART",$DATA(^PRCP(445.8,ITEMDA)):"INSTRUMENT KIT",1:$SELECT($$PURCHASE^PRCPU441(ITEMDA):"PURCHASABLE",1:"NOT PURCHASABLE"))
+11 SET X=$EXTRACT(X_$JUSTIFY("",30),1,30)_$SELECT($$REUSABLE^PRCPU441(ITEMDA):"REUSABLE",1:"")
+12 DO SET^PRCPEIL0("Type Of Item : "_X,LINE+6,COLUMN,CLREND)
+13 DO SET^PRCPEIL0("",LINE+7,COLUMN,CLREND)
+14 QUIT
+15 ;
+16 ;
EXIT ; exit and clean up
+1 KILL ^TMP($JOB,"PRCPEILM")
+2 QUIT
+3 ;
+4 ;
DIQ(DR) ; diq call to retrieve data for dr fields
+1 NEW D0,DA,DIC,DIQ,DIQ2
+2 SET DA(1)=PRCPINPT
SET DA=ITEMDA
SET DIQ(0)="E"
+3 SET DIC="^PRCP(445,"_PRCPINPT_",1,"
+4 SET DIQ="PRCPDATA"
DO EN^DIQ1
+5 QUIT
+6 ;
+7 ;
CHECK() ; screen for manager access to option
+1 ; return 1 for access, 0 for no access
+2 IF $$KEY^PRCPUREP("PRCP"_$TRANSLATE(PRCPTYPE,"WSP","W2")_" MGRKEY",DUZ)
QUIT 1
+3 QUIT 0
