PRCPE441 ;WISC/RFJ-enter edit master item file ;10 Dec 91
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
I $P($G(^PRCP(445,PRCP("I"),0)),"^",20)'="S" K X S X(1)="ONLY 'SPD' INVENTORY POINTS MAY ACCESS THIS OPTION SINCE THE FIELDS EDITABLE UNDER THIS OPTION ONLY PERTAIN TO CASE CARTS AND INSTRUMENT KITS." Q
I '$$KEY^PRCPUREP("PRCP"_$TR(PRCP("DPTYPE"),"WSP","W2")_" MGRKEY",DUZ) W !,"YOU MUST BE AN INVENTORY MANAGER BEFORE YOU CAN USE THIS OPTION." Q
N %,D0,DA,DI,DIC,DIE,DQ,DR,ITEMDA,X,Y
K X S X(1)="Only items stored in the "_PRCP("IN")_" are selectable." W ! D DISPLAY^PRCPUX2(1,40,.X)
F S ITEMDA=$$MASTITEM^PRCPUITM("I $D(^PRCP(445,PRCP(""I""),1,+Y,0))") Q:'ITEMDA D W !
. S (DIC,DIE)="^PRC(441,",DA=ITEMDA,DR=".06" D ^DIE
. S DR=$S($P($G(^PRC(441,ITEMDA,0)),"^",6)="S":"23///@",1:23) D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPE441 925 printed Dec 13, 2024@02:13:30 Page 2
PRCPE441 ;WISC/RFJ-enter edit master item file ;10 Dec 91
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 IF $PIECE($GET(^PRCP(445,PRCP("I"),0)),"^",20)'="S"
KILL X
SET X(1)="ONLY 'SPD' INVENTORY POINTS MAY ACCESS THIS OPTION SINCE THE FIELDS EDITABLE UNDER THIS OPTION ONLY PERTAIN TO CASE CARTS AND INSTRUMENT KITS."
QUIT
+5 IF '$$KEY^PRCPUREP("PRCP"_$TRANSLATE(PRCP("DPTYPE"),"WSP","W2")_" MGRKEY",DUZ)
WRITE !,"YOU MUST BE AN INVENTORY MANAGER BEFORE YOU CAN USE THIS OPTION."
QUIT
+6 NEW %,D0,DA,DI,DIC,DIE,DQ,DR,ITEMDA,X,Y
+7 KILL X
SET X(1)="Only items stored in the "_PRCP("IN")_" are selectable."
WRITE !
DO DISPLAY^PRCPUX2(1,40,.X)
+8 FOR
SET ITEMDA=$$MASTITEM^PRCPUITM("I $D(^PRCP(445,PRCP(""I""),1,+Y,0))")
if 'ITEMDA
QUIT
Begin DoDot:1
+9 SET (DIC,DIE)="^PRC(441,"
SET DA=ITEMDA
SET DR=".06"
DO ^DIE
+10 SET DR=$SELECT($PIECE($GET(^PRC(441,ITEMDA,0)),"^",6)="S":"23///@",1:23)
DO ^DIE
End DoDot:1
WRITE !
+11 QUIT
