25 lines
1.9 KiB
Mathematica
25 lines
1.9 KiB
Mathematica
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
|