- 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 Mar 13, 2025@21:41:03 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 ;
