PRCPEILM ;WISC/RFJ-edit inventory items (list manager) ;01 Dec 93
V ;;5.1;IFCAP;**1,171,244**;Oct 20, 2000;Build 9
;Per VHA Directive 2004-038, this routine should not be modified.
;
; This routine provides the core functionalities for editing inventory
; items within a list manager setup (ListManager). It allows users to
; interactively select and edit items by providing protocols for managing
; descriptive information, issue units, levels, quantities, costs, due-ins,
; special parameters, procurement sources, and drug accountability parameters.
; The routine also includes necessary functions to handle exiting and
; cleaning up temporary data.
;
; Key Entry Points:
; EN - Entry point for the routine, typically from a protocol.
; HDR - Builds the header displayed in the List Manager.
; INIT - Initializes and builds the display array for the List Manager.
; DESCRIP - Builds the descriptive portion of the display array.
; EXIT - Cleans up temporary data at exit.
; DIQ - Retrieves data for specified fields using FileMan.
; CHECK - Screens for manager access to the option.
;
; Integration Control Registrations (ICRs)
; ICR #10116 - FULL^VALM1
; ICR #10103 - $$FMTE^XLFDT
; ICR #10141 - EN^DDIOL
; ICR #10101 - DIC/DIQ^DIC
; ICR #10063 - DDGLIBR^DIALOG
; ICR #10075 - L +^DIC(1)
;
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):DILOCKTM 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) ; 244 - Replace NSN with ABC Classification
D SET^PRCPEIL0("Group Category ",LINE+2,COLUMN,CLREND,.5)
D SET^PRCPEIL0("ABC Classification",LINE+3,COLUMN,CLREND,.45) ; 244 - Replace NSN with ABC Classification
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 4213 printed Jan 29, 2026@15:12:08 Page 2
PRCPEILM ;WISC/RFJ-edit inventory items (list manager) ;01 Dec 93
V ;;5.1;IFCAP;**1,171,244**;Oct 20, 2000;Build 9
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ; This routine provides the core functionalities for editing inventory
+4 ; items within a list manager setup (ListManager). It allows users to
+5 ; interactively select and edit items by providing protocols for managing
+6 ; descriptive information, issue units, levels, quantities, costs, due-ins,
+7 ; special parameters, procurement sources, and drug accountability parameters.
+8 ; The routine also includes necessary functions to handle exiting and
+9 ; cleaning up temporary data.
+10 ;
+11 ; Key Entry Points:
+12 ; EN - Entry point for the routine, typically from a protocol.
+13 ; HDR - Builds the header displayed in the List Manager.
+14 ; INIT - Initializes and builds the display array for the List Manager.
+15 ; DESCRIP - Builds the descriptive portion of the display array.
+16 ; EXIT - Cleans up temporary data at exit.
+17 ; DIQ - Retrieves data for specified fields using FileMan.
+18 ; CHECK - Screens for manager access to the option.
+19 ;
+20 ; Integration Control Registrations (ICRs)
+21 ; ICR #10116 - FULL^VALM1
+22 ; ICR #10103 - $$FMTE^XLFDT
+23 ; ICR #10141 - EN^DDIOL
+24 ; ICR #10101 - DIC/DIQ^DIC
+25 ; ICR #10063 - DDGLIBR^DIALOG
+26 ; ICR #10075 - L +^DIC(1)
+27 ;
+28 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):DILOCKTM
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 ;D SET^PRCPEIL0("NSN : "_$$NSN^PRCPUX1(ITEMDA),LINE+2,COLUMN,CLREND) ; 244 - Replace NSN with ABC Classification
+6 DO SET^PRCPEIL0("Group Category ",LINE+2,COLUMN,CLREND,.5)
+7 ; 244 - Replace NSN with ABC Classification
DO SET^PRCPEIL0("ABC Classification",LINE+3,COLUMN,CLREND,.45)
+8 DO SET^PRCPEIL0("Main Storage Lo",LINE+4,COLUMN,CLREND,5)
+9 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
+10 DO SET^PRCPEIL0("Add Storage Loc: "_X,LINE+5,COLUMN,CLREND)
+11 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"))
+12 SET X=$EXTRACT(X_$JUSTIFY("",30),1,30)_$SELECT($$REUSABLE^PRCPU441(ITEMDA):"REUSABLE",1:"")
+13 DO SET^PRCPEIL0("Type Of Item : "_X,LINE+6,COLUMN,CLREND)
+14 DO SET^PRCPEIL0("",LINE+7,COLUMN,CLREND)
+15 QUIT
+16 ;
+17 ;
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
