- 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 Apr 23, 2025@18:30:29 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
