PRCPSMSD ;WISC/RFJ-delete inventory item ;21 Oct 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 PRCP("DPTYPE")'="W" W !,"THIS OPTION SHOULD ONLY BE USED BY THE WAREHOUSE INVENTORY POINT." Q
I $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2 W !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION." Q
N %,%DT,COUNT,ITEMDA,PRCPFLAG,STRING,X,Y
S IOP="HOME" D ^%ZIS K IOP,^TMP($J,"DELETE"),^TMP($J,"STRING")
F W !! S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") Q:'$G(ITEMDA) S %=$G(^PRC(441,+ITEMDA,0)) D
. K ^TMP($J,"DELETE",ITEMDA) I $P(%,"^",5)="" W !,"ITEM DOES NOT HAVE AN NSN!" Q
. D DELETE^PRCPSMS0(ITEMDA) I STRING("ID")="" W !,"UNABLE TO CREATE CODE SHEET!" Q
. S XP=" ARE YOU SURE YOU WANT TO DELETE THIS ITEM FROM ISMS",XH=" ENTER 'YES' TO MARK THIS ITEM FOR DELETION FROM ISMS."
. W !! I $$YN^PRCPUYN(1)'=1 Q
. S ^TMP($J,"DELETE",ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$P(%,"^",5),^TMP($J,"DELETE",ITEMDA,"CS")=STRING("ID") W !,"CS: ",STRING("ID")
I ITEMDA["^" D Q Q
I '$O(^TMP($J,"DELETE",0)) W !,"NO ITEMS SELECTED." D Q Q
W @IOF,!,"YOU HAVE SELECTED THE FOLLOWING ITEMS TO DELETE:" S ITEMDA=0,COUNT=1 F S ITEMDA=$O(^TMP($J,"DELETE",ITEMDA)) Q:'ITEMDA!($D(PRCPFLAG)) S %=^(ITEMDA) D
. W !,ITEMDA,?7,$E($P(%,"^"),1,50),?60,$P(%,"^",2) S ^TMP($J,"STRING",COUNT)=^TMP($J,"DELETE",ITEMDA,"CS"),COUNT=COUNT+1 I $Y>(IOSL-5) D P^PRCPUREP
I $D(PRCPFLAG) D Q Q
I '$O(^TMP($J,"STRING",0)) W !!,"NO CODE SHEETS CREATED." D Q Q
S XP="*** ARE YOU SURE YOU WANT TO CREATE THE ISMS TRANSACTION",XP(1)=" AND TRANSMIT IT TO AUSTIN",XH="ENTER 'YES' TO CREATE THE ISMS TRANSACTION AND TRANSMIT IT TO AUSTIN",XH(1)="ENTER 'NO' OR '^' TO EXIT."
W !! I $$YN^PRCPUYN(1)'=1 D Q Q
D CODESHT^PRCPSMGO(PRC("SITE"),"IVD","")
Q K ^TMP($J,"DELETE"),^TMP($J,"STRING") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSMSD 1937 printed Dec 13, 2024@02:15:59 Page 2
PRCPSMSD ;WISC/RFJ-delete inventory item ;21 Oct 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 PRCP("DPTYPE")'="W"
WRITE !,"THIS OPTION SHOULD ONLY BE USED BY THE WAREHOUSE INVENTORY POINT."
QUIT
+5 IF $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2
WRITE !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION."
QUIT
+6 NEW %,%DT,COUNT,ITEMDA,PRCPFLAG,STRING,X,Y
+7 SET IOP="HOME"
DO ^%ZIS
KILL IOP,^TMP($JOB,"DELETE"),^TMP($JOB,"STRING")
+8 FOR
WRITE !!
SET ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","")
if '$GET(ITEMDA)
QUIT
SET %=$GET(^PRC(441,+ITEMDA,0))
Begin DoDot:1
+9 KILL ^TMP($JOB,"DELETE",ITEMDA)
IF $PIECE(%,"^",5)=""
WRITE !,"ITEM DOES NOT HAVE AN NSN!"
QUIT
+10 DO DELETE^PRCPSMS0(ITEMDA)
IF STRING("ID")=""
WRITE !,"UNABLE TO CREATE CODE SHEET!"
QUIT
+11 SET XP=" ARE YOU SURE YOU WANT TO DELETE THIS ITEM FROM ISMS"
SET XH=" ENTER 'YES' TO MARK THIS ITEM FOR DELETION FROM ISMS."
+12 WRITE !!
IF $$YN^PRCPUYN(1)'=1
QUIT
+13 SET ^TMP($JOB,"DELETE",ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$PIECE(%,"^",5)
SET ^TMP($JOB,"DELETE",ITEMDA,"CS")=STRING("ID")
WRITE !,"CS: ",STRING("ID")
End DoDot:1
+14 IF ITEMDA["^"
DO Q
QUIT
+15 IF '$ORDER(^TMP($JOB,"DELETE",0))
WRITE !,"NO ITEMS SELECTED."
DO Q
QUIT
+16 WRITE @IOF,!,"YOU HAVE SELECTED THE FOLLOWING ITEMS TO DELETE:"
SET ITEMDA=0
SET COUNT=1
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"DELETE",ITEMDA))
if 'ITEMDA!($DATA(PRCPFLAG))
QUIT
SET %=^(ITEMDA)
Begin DoDot:1
+17 WRITE !,ITEMDA,?7,$EXTRACT($PIECE(%,"^"),1,50),?60,$PIECE(%,"^",2)
SET ^TMP($JOB,"STRING",COUNT)=^TMP($JOB,"DELETE",ITEMDA,"CS")
SET COUNT=COUNT+1
IF $Y>(IOSL-5)
DO P^PRCPUREP
End DoDot:1
+18 IF $DATA(PRCPFLAG)
DO Q
QUIT
+19 IF '$ORDER(^TMP($JOB,"STRING",0))
WRITE !!,"NO CODE SHEETS CREATED."
DO Q
QUIT
+20 SET XP="*** ARE YOU SURE YOU WANT TO CREATE THE ISMS TRANSACTION"
SET XP(1)=" AND TRANSMIT IT TO AUSTIN"
SET XH="ENTER 'YES' TO CREATE THE ISMS TRANSACTION AND TRANSMIT IT TO AUSTIN"
SET XH(1)="ENTER 'NO' OR '^' TO EXIT."
+21 WRITE !!
IF $$YN^PRCPUYN(1)'=1
DO Q
QUIT
+22 DO CODESHT^PRCPSMGO(PRC("SITE"),"IVD","")
Q KILL ^TMP($JOB,"DELETE"),^TMP($JOB,"STRING")
QUIT
