RMPRPIFD ;PHX/RFM,RGB-DELETE ISSUE FROM STOCK ;8/27/07 07:27
;;3.0;PROSTHETICS;**139,163**;Feb 09, 1996;Build 9
; RVD #61 - phase III of PIP enhancement.
;
;Per VHA Directive 2004-038, this routine should not be modified.
DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
K DIR N ITEMIEN,RITEM,ITEMCK,ITEMSTA,ITEMLOC
S DIR("A")="Are you sure you want to DELETE this entry",DIR("B")="N",DIR(0)="Y"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G EXIT
I Y'=1 G CO^RMPRPIYE
;
DEL1A ;ASK IF INACTIVE ITEM
S ITEMSTA=$P(R1(0),U,10),ITEMLOC=$P(R1(1),U,5)
DEL1B S ITEMIEN=$O(^RMPR(661.11,"ASHI",ITEMSTA,$P(RMIT,"-"),$P(RMIT,"-",2),0))
;Patch RMPR*3.0*163 prevents user from deleting a previous issue if the HCPCS item has been removed
I ITEMIEN="" D G EXIT
. W !!," *** Scanned HCPCS has been deleted from HCPCS Item Master (ASHI). CANNOT delete previous issue." R X:4 W !
D G:ITEMCK=0 EXIT G:ITEMCK=1 DEL2
. S ITEMCK=0,RITEM=^RMPR(661.11,ITEMIEN,0)
. I $P(RITEM,U,9)'=1 S ITEMCK=1 Q
. S DIR("A")="Scanned item is inactive, reactivate?",DIR("B")="N",DIR(0)="Y"
. D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) S ITEMCK=0 Q
. I Y'=1 S ITEMCK=1 Q
. S $P(^RMPR(661.11,ITEMIEN,0),U,9)=0,$P(^RMPR(661.11,ITEMIEN,0),U,10)="",ITEMCK=2
;ask to reset ROP to zero
S DIR("A")="Scanned item Is now ACTIVE, set ROP to zero?",DIR("B")="N",DIR(0)="Y"
D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G DEL2
I Y'=1 G DEL2
I 'ITEMSTA!'ITEMLOC G DEL2
S ITEMLOC=$P($G(^RMPR(661.6,ITEMLOC,0)),U,14) G:'ITEMLOC DEL2
S ITEMIEN=$O(^RMPR(661.4,"ASLHI",ITEMSTA,ITEMLOC,$P(RMIT,"-"),$P(RMIT,"-",2),0)) G:'ITEMIEN DEL2
S $P(^RMPR(661.4,ITEMIEN,0),U,4)=0
;
DEL2 ;call API for returning item to PIP
K RITEM,ITEMCK,ITEMIEN,ITEMSTA,ITEMLOC
S (RMCHK,RMERPCE)=0
S RMI68=$P($G(^RMPR(660,RMPRIEN,10)),U,1) I RMI68>0 D I RMERPCE W !!,"** STOCK ISSUE DELETE ABORTED",!! G EXIT
.S RMCHK=$$DEL^RMPRPCED(RMPRIEN)
.I RMCHK'=0 W !!,"*** ERROR in PCE DELETE, Please notify your IRM..660 IEN = ",RMPRIEN,!! S RMERPCE=1 H 3
S RMPR60("IEN")=RMPRIEN
S RMCHK=$$DEL^RMPRPIU3(.RMPR60)
I $G(RMCHK) W !,"*** Error in API RMPRPIU3, ERROR = ",RMCHK,!,"*** Please inform your IRM !!",! G EXIT
;
W $C(7),!?10,"Deleted..." H 1
EXIT ;KILL VARIABLES AND EXIT ROUTINE
I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN)
K ^TMP($J) N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIFD 2376 printed Oct 16, 2024@18:36:47 Page 2
RMPRPIFD ;PHX/RFM,RGB-DELETE ISSUE FROM STOCK ;8/27/07 07:27
+1 ;;3.0;PROSTHETICS;**139,163**;Feb 09, 1996;Build 9
+2 ; RVD #61 - phase III of PIP enhancement.
+3 ;
+4 ;Per VHA Directive 2004-038, this routine should not be modified.
DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
+1 KILL DIR
NEW ITEMIEN,RITEM,ITEMCK,ITEMSTA,ITEMLOC
+2 SET DIR("A")="Are you sure you want to DELETE this entry"
SET DIR("B")="N"
SET DIR(0)="Y"
+3 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
GOTO EXIT
+4 IF Y'=1
GOTO CO^RMPRPIYE
+5 ;
DEL1A ;ASK IF INACTIVE ITEM
+1 SET ITEMSTA=$PIECE(R1(0),U,10)
SET ITEMLOC=$PIECE(R1(1),U,5)
DEL1B SET ITEMIEN=$ORDER(^RMPR(661.11,"ASHI",ITEMSTA,$PIECE(RMIT,"-"),$PIECE(RMIT,"-",2),0))
+1 ;Patch RMPR*3.0*163 prevents user from deleting a previous issue if the HCPCS item has been removed
+2 IF ITEMIEN=""
Begin DoDot:1
+3 WRITE !!," *** Scanned HCPCS has been deleted from HCPCS Item Master (ASHI). CANNOT delete previous issue."
READ X:4
WRITE !
End DoDot:1
GOTO EXIT
+4 Begin DoDot:1
+5 SET ITEMCK=0
SET RITEM=^RMPR(661.11,ITEMIEN,0)
+6 IF $PIECE(RITEM,U,9)'=1
SET ITEMCK=1
QUIT
+7 SET DIR("A")="Scanned item is inactive, reactivate?"
SET DIR("B")="N"
SET DIR(0)="Y"
+8 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
SET ITEMCK=0
QUIT
+9 IF Y'=1
SET ITEMCK=1
QUIT
+10 SET $PIECE(^RMPR(661.11,ITEMIEN,0),U,9)=0
SET $PIECE(^RMPR(661.11,ITEMIEN,0),U,10)=""
SET ITEMCK=2
End DoDot:1
if ITEMCK=0
GOTO EXIT
if ITEMCK=1
GOTO DEL2
+11 ;ask to reset ROP to zero
+12 SET DIR("A")="Scanned item Is now ACTIVE, set ROP to zero?"
SET DIR("B")="N"
SET DIR(0)="Y"
+13 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
GOTO DEL2
+14 IF Y'=1
GOTO DEL2
+15 IF 'ITEMSTA!'ITEMLOC
GOTO DEL2
+16 SET ITEMLOC=$PIECE($GET(^RMPR(661.6,ITEMLOC,0)),U,14)
if 'ITEMLOC
GOTO DEL2
+17 SET ITEMIEN=$ORDER(^RMPR(661.4,"ASLHI",ITEMSTA,ITEMLOC,$PIECE(RMIT,"-"),$PIECE(RMIT,"-",2),0))
if 'ITEMIEN
GOTO DEL2
+18 SET $PIECE(^RMPR(661.4,ITEMIEN,0),U,4)=0
+19 ;
DEL2 ;call API for returning item to PIP
+1 KILL RITEM,ITEMCK,ITEMIEN,ITEMSTA,ITEMLOC
+2 SET (RMCHK,RMERPCE)=0
+3 SET RMI68=$PIECE($GET(^RMPR(660,RMPRIEN,10)),U,1)
IF RMI68>0
Begin DoDot:1
+4 SET RMCHK=$$DEL^RMPRPCED(RMPRIEN)
+5 IF RMCHK'=0
WRITE !!,"*** ERROR in PCE DELETE, Please notify your IRM..660 IEN = ",RMPRIEN,!!
SET RMERPCE=1
HANG 3
End DoDot:1
IF RMERPCE
WRITE !!,"** STOCK ISSUE DELETE ABORTED",!!
GOTO EXIT
+6 SET RMPR60("IEN")=RMPRIEN
+7 SET RMCHK=$$DEL^RMPRPIU3(.RMPR60)
+8 IF $GET(RMCHK)
WRITE !,"*** Error in API RMPRPIU3, ERROR = ",RMCHK,!,"*** Please inform your IRM !!",!
GOTO EXIT
+9 ;
+10 WRITE $CHAR(7),!?10,"Deleted..."
HANG 1
EXIT ;KILL VARIABLES AND EXIT ROUTINE
+1 IF $GET(RMPRIEN)
IF $DATA(^RMPR(660,RMPRIEN))
LOCK -^RMPR(660,RMPRIEN)
+2 KILL ^TMP($JOB)
NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+3 QUIT
+4 ;
