RMPR5NDL ;HIN/RVD-PROS INVENTORY DELETE UTILITY ;9/03/99
;;3.0;PROSTHETICS;**37,51**;Feb 09, 1996
;
; ODJ - patch 51 - 10/20/00 - implement requirement for dual RMPR
; manager signatories before deleting
; locations.
;
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT
LOC ;ask for Location.
W @IOF,!!,"Delete an Inventory Location.....",!
W !,"This option now requires the electronic signatures of 2 users"
W !,"holding the RMPRMANAGER key to be entered before a location"
W !,"will be deleted.",!
K DTOUT,DUOUT,DIC("B")
S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
S DIC="^RMPR(661.3,",DIC(0)="AEQM"
S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
G:$D(DTOUT)!$D(DUOUT)!(Y'>0) EXIT S (DA,RMLODA)=+Y
CHK D STOCK(RMLODA) ;check and display number&quantities of items
OSIG I '$$GETO(DUZ) G EXIT ;get other signature exit if not OK
ESIG I $D(XQUSER) D
. W !!,XQUSER," please..."
. Q
E D
. W !!,$P(^VA(200,DUZ,0),"^",1)," please..."
. Q
D SIG^XUSESIG G:X1="" EXIT ;get electronic sig. of main user
DEL ;delete a location
S DIR(0)="Y",DIR("B")="N"
W !
S DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "
D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !,"Nothing Deleted.." G EXIT
L +^RMPR(661.3,RMLODA):2
I '$T W !,"Record in use. Try again later..." G EXIT
I Y>0 S DIK="^RMPR(661.3,",DA=RMLODA D ^DIK W:'$D(^RMPR(661.3,RMLODA,0)) !,"Location is deleted!!!!" H 2
;
;
EXIT ;MAIN EXIT POINT
N RMPR,RMPRSITE D KILL^XUSCLEAN
Q
;
; Patch 51 - get electronic signatures from 2 RMPR managers in order
; to OK a delete
GETO(RMPRDUZ) ;
N RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS
W !!,"Pease ask another user with the RMPRMANAGER key to"
W !,"enter their user name and electronic signature.",!
S RMPROK=0
S RMPRKEYS("RMPRMANAGER")=""
S RMPRUSR1("DUZ")=RMPRDUZ
I $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'="" G GETOKX
S DUZ=RMPRUSR2("DUZ")
W !,RMPRUSR2("NAME")," please..."
D SIG^XUSESIG I X1="" G GETOKX
S RMPROK=1
GETOKX Q RMPROK
;
; Get 2nd User and ensure they have RMPRMANAGER key
GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;
N DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ
S DUZ=RMPRUSR1("DUZ")
USR2E K RMPRUSR2
S DIC="^VA(200,"
S DIC(0)="ABEQ"
S DIC("A")="Enter user name of 2nd manager:"
D ^DIC
I Y=-1 S RMPREXC="^" G USR2X
S RMPRUSR2("DUZ")=$P(Y,U,1)
;
; User 2 can't be same as user 1
I RMPRUSR2("DUZ")=RMPRUSR1("DUZ") D G USR2E
. W !,"The 2nd manager must be different to the manager logged on."
. Q
;
; User 2 must have defined security keys
S RMPRKEY=""
F S RMPRKEY=$O(RMPRKEYS(RMPRKEY)) Q:RMPRKEY="" Q:$D(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))
I RMPRKEY="" D G USR2E
. W !,"The 2nd manager does not have the correct security key set up."
. Q
;
; User 2 verified
S RMPRUSR2("NAME")=$P(Y,U,2)
S RMPREXC=""
USR2X Q RMPREXC
;
; Get number of HCPC items, quantity in stock and cost for location
STOCK(RMPRILOC) ;
N IEN1,IEN2,S,RMPRSTK
K RMPRSTK S RMPRSTK("ITEMS")=0
S IEN1=0
F S IEN1=$O(^RMPR(661.3,RMPRILOC,1,IEN1)) Q:'+IEN1 D
. S IEN2=0
. F S IEN2=$O(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2)) Q:'+IEN2 D
.. S RMPRSTK("ITEMS")=1+RMPRSTK("ITEMS")
.. S S=$G(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2,0))
.. S RMPRSTK("QOH")=$P(S,"^",2)+$G(RMPRSTK("QOH"))
.. S RMPRSTK("COST")=$P(S,"^",3)+$G(RMPRSTK("COST"))
.. Q
. Q
W !,"The above location contains "
W RMPRSTK("ITEMS")," types of items"
I RMPRSTK("ITEMS")=0 D
. W "."
. Q
E D
. W ", ",!,"with a total quantity of ",RMPRSTK("QOH")
. W " and cost of $",RMPRSTK("COST"),"."
. Q
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NDL 3748 printed Sep 23, 2025@20:09:24 Page 2
RMPR5NDL ;HIN/RVD-PROS INVENTORY DELETE UTILITY ;9/03/99
+1 ;;3.0;PROSTHETICS;**37,51**;Feb 09, 1996
+2 ;
+3 ; ODJ - patch 51 - 10/20/00 - implement requirement for dual RMPR
+4 ; manager signatories before deleting
+5 ; locations.
+6 ;
+7 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+8 SET X="NOW"
DO ^%DT
LOC ;ask for Location.
+1 WRITE @IOF,!!,"Delete an Inventory Location.....",!
+2 WRITE !,"This option now requires the electronic signatures of 2 users"
+3 WRITE !,"holding the RMPRMANAGER key to be entered before a location"
+4 WRITE !,"will be deleted.",!
+5 KILL DTOUT,DUOUT,DIC("B")
+6 SET DZ="??"
SET D="B"
SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
+7 SET DIC="^RMPR(661.3,"
SET DIC(0)="AEQM"
+8 SET D="B"
SET DIC("A")="Enter Pros Location: "
DO MIX^DIC1
+9 if $DATA(DTOUT)!$DATA(DUOUT)!(Y'>0)
GOTO EXIT
SET (DA,RMLODA)=+Y
CHK ;check and display number&quantities of items
DO STOCK(RMLODA)
OSIG ;get other signature exit if not OK
IF '$$GETO(DUZ)
GOTO EXIT
ESIG IF $DATA(XQUSER)
Begin DoDot:1
+1 WRITE !!,XQUSER," please..."
+2 QUIT
End DoDot:1
+3 IF '$TEST
Begin DoDot:1
+4 WRITE !!,$PIECE(^VA(200,DUZ,0),"^",1)," please..."
+5 QUIT
End DoDot:1
+6 ;get electronic sig. of main user
DO SIG^XUSESIG
if X1=""
GOTO EXIT
DEL ;delete a location
+1 SET DIR(0)="Y"
SET DIR("B")="N"
+2 WRITE !
+3 SET DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "
+4 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="^")!(Y=0)
WRITE !,"Nothing Deleted.."
GOTO EXIT
+5 LOCK +^RMPR(661.3,RMLODA):2
+6 IF '$TEST
WRITE !,"Record in use. Try again later..."
GOTO EXIT
+7 IF Y>0
SET DIK="^RMPR(661.3,"
SET DA=RMLODA
DO ^DIK
if '$DATA(^RMPR(661.3,RMLODA,0))
WRITE !,"Location is deleted!!!!"
HANG 2
+8 ;
+9 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
+2 QUIT
+3 ;
+4 ; Patch 51 - get electronic signatures from 2 RMPR managers in order
+5 ; to OK a delete
GETO(RMPRDUZ) ;
+1 NEW RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS
+2 WRITE !!,"Pease ask another user with the RMPRMANAGER key to"
+3 WRITE !,"enter their user name and electronic signature.",!
+4 SET RMPROK=0
+5 SET RMPRKEYS("RMPRMANAGER")=""
+6 SET RMPRUSR1("DUZ")=RMPRDUZ
+7 IF $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'=""
GOTO GETOKX
+8 SET DUZ=RMPRUSR2("DUZ")
+9 WRITE !,RMPRUSR2("NAME")," please..."
+10 DO SIG^XUSESIG
IF X1=""
GOTO GETOKX
+11 SET RMPROK=1
GETOKX QUIT RMPROK
+1 ;
+2 ; Get 2nd User and ensure they have RMPRMANAGER key
GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;
+1 NEW DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ
+2 SET DUZ=RMPRUSR1("DUZ")
USR2E KILL RMPRUSR2
+1 SET DIC="^VA(200,"
+2 SET DIC(0)="ABEQ"
+3 SET DIC("A")="Enter user name of 2nd manager:"
+4 DO ^DIC
+5 IF Y=-1
SET RMPREXC="^"
GOTO USR2X
+6 SET RMPRUSR2("DUZ")=$PIECE(Y,U,1)
+7 ;
+8 ; User 2 can't be same as user 1
+9 IF RMPRUSR2("DUZ")=RMPRUSR1("DUZ")
Begin DoDot:1
+10 WRITE !,"The 2nd manager must be different to the manager logged on."
+11 QUIT
End DoDot:1
GOTO USR2E
+12 ;
+13 ; User 2 must have defined security keys
+14 SET RMPRKEY=""
+15 FOR
SET RMPRKEY=$ORDER(RMPRKEYS(RMPRKEY))
if RMPRKEY=""
QUIT
if $DATA(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))
QUIT
+16 IF RMPRKEY=""
Begin DoDot:1
+17 WRITE !,"The 2nd manager does not have the correct security key set up."
+18 QUIT
End DoDot:1
GOTO USR2E
+19 ;
+20 ; User 2 verified
+21 SET RMPRUSR2("NAME")=$PIECE(Y,U,2)
+22 SET RMPREXC=""
USR2X QUIT RMPREXC
+1 ;
+2 ; Get number of HCPC items, quantity in stock and cost for location
STOCK(RMPRILOC) ;
+1 NEW IEN1,IEN2,S,RMPRSTK
+2 KILL RMPRSTK
SET RMPRSTK("ITEMS")=0
+3 SET IEN1=0
+4 FOR
SET IEN1=$ORDER(^RMPR(661.3,RMPRILOC,1,IEN1))
if '+IEN1
QUIT
Begin DoDot:1
+5 SET IEN2=0
+6 FOR
SET IEN2=$ORDER(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2))
if '+IEN2
QUIT
Begin DoDot:2
+7 SET RMPRSTK("ITEMS")=1+RMPRSTK("ITEMS")
+8 SET S=$GET(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2,0))
+9 SET RMPRSTK("QOH")=$PIECE(S,"^",2)+$GET(RMPRSTK("QOH"))
+10 SET RMPRSTK("COST")=$PIECE(S,"^",3)+$GET(RMPRSTK("COST"))
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 WRITE !,"The above location contains "
+14 WRITE RMPRSTK("ITEMS")," types of items"
+15 IF RMPRSTK("ITEMS")=0
Begin DoDot:1
+16 WRITE "."
+17 QUIT
End DoDot:1
+18 IF '$TEST
Begin DoDot:1
+19 WRITE ", ",!,"with a total quantity of ",RMPRSTK("QOH")
+20 WRITE " and cost of $",RMPRSTK("COST"),"."
+21 QUIT
End DoDot:1
+22 WRITE !
+23 QUIT
