PRCPAODI ;WOIFO/CC-enter/edit On-Demand users ; 2/8/07 4:15pm
;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
ENT ;
I '$$KEY^PRCPUREP("PRCPODI",DUZ) D EN^DDIOL("You are not authorized to make managers On-Demand Users.") Q
;
N %,D,DIC,PRCF,PRCP,PRCPIN,PRCPINPT,PRCPMAN,PRCPNAME,X,Y
;
; Prompt for user
USER S DIC="^VA(200,",DIC(0)="AEQMOZ",DIC("A")="INVENTORY POINT MANAGER: ",D="B"
D IX^DIC
K DIC,D I Y<0 Q
S PRCPMAN=+Y
L +^PRCPAODI(PRCPMAN):0 I $T=0 D EN^DDIOL(">>File in Use. Please try again later.") W ! G USER
;
; Verify user is active
S X=$$GET1^DIQ(200,PRCPMAN_",","9.2","I") ; termination date
I X,X'>DT D EN^DDIOL(">>This user has been terminated and cannot be selected.") W ! D EXIT G USER
; Verify user has primary and/or secondary manager key
S PRCPMAN(1)=0,PRCPMAN(2)=0
S PRCPMAN(1)=$$KEY^PRCPUREP("PRCP MGRKEY",PRCPMAN)
S PRCPMAN(2)=$$KEY^PRCPUREP("PRCP2 MGRKEY",PRCPMAN)
I 'PRCPMAN(1),'PRCPMAN(2),'$O(^PRCP(445,"AJ",PRCPMAN,"")) D EN^DDIOL(">>User must be a manager of a Primary or Secondary Inventory Point") W ! D EXIT G USER
;
; Display ODI access to primary points
S PRCPNAME=$$GET1^DIQ(200,PRCPMAN_",",".01")
W ! D CHKPM
;
; Prompt for Site
S %=0 F I="FY","PARAM","PER","QTR","SITE" S %=1 Q
I % S PRCF("X")="S" D ^PRCFSITE I '$G(PRC("SITE")) K PRC,PRCP G EXIT
;
; Prompt for inventory point
IP S DIC="^PRCP(445,",DIC(0)="AEQMOZ"
S DIC("S")="I +^(0)=PRC(""SITE"")"
S DIC("A")="SELECT INVENTORY POINT: "
S D="C",PRCPPRIV=1
D IX^DIC K PRCPPRIV,D,DIC
I Y<0 G EXIT
S PRCP("I")=Y Q:'$G(PRCP("I"))
S PRCPINPT=$P(PRCP("I"),"^",2)
S PRCP("DPTYPE")=$P(^PRCP(445,+PRCP("I"),0),U,3)
I PRCP("DPTYPE")="W" D EN^DDIOL(" >>The warehouse has no On-Demand items - needs no On-Demand User.") W ! G IP
;
D INIT(+PRCP("I"))
;
;Process Users that don't qualify
I 'PRCPMAN(3) D D:PRCP("DPTYPE")="P" CHKDP G IP
. D EN^DDIOL(">>"_PRCPNAME_" is not a "_PRCPMAN(3)_" of this inventory point")
. ; if user is not in node 9, give message - not added
. I 'PRCPIN D EN^DDIOL(" and therefore cannot be an On-Demand User") W !
. ; delete if user is set up in node 9 - show 'deleted'
. I PRCPIN D Q
. . D DEL(+PRCP("I"),PRCPIN) ; Delete entry
. . D EN^DDIOL(">>Removed as On-Demand User for: "_PRCPINPT) W !
;
; If user is already On-Demand, ask if they should be removed???
I PRCPIN D G IP
. D ASK(2,+PRCP("I"),PRCPMAN)
. I PRCP("DPTYPE")="P" D CHKDP
;
; Ask if user should be added to IP's list of On-Demand users
D ASK(1,+PRCP("I"),PRCPMAN)
I PRCP("DPTYPE")="P" D CHKDP
G IP
;
Q
;
; Does user qualify?
INIT(PRCPINP) ;PRCPINP=inventory point being checked
S PRCPMAN(3)=1 ; assume user is OK
; Verify user has manager key for type of IP selected
I PRCP("DPTYPE")="P",'PRCPMAN(1) S PRCPMAN(3)="manager"
I PRCP("DPTYPE")="S",'PRCPMAN(2) S PRCPMAN(3)="manager"
; Verify user is a user of that IP
I '$D(^PRCP(445,+PRCPINP,4,PRCPMAN)) D
. I PRCPMAN(3)=1 S PRCPMAN(3)="user" Q
. S PRCPMAN(3)="manager nor user"
;
; set flag if user is already in list
S PRCPIN=""
S PRCPIN=$O(^PRCP(445,+PRCPINP,9,"B",PRCPMAN,PRCPIN))
Q
;
DEL(PRCPINP,PRCPUSER) ; delete On-Demand authorization
; also called from PRCPXTRM for user termination from VISTA
;
; PRCPINP inventory point from which user is being removed
; PRCPUSER ien of user in the list
;
N DA,DIK
S DIK="^PRCP(445,"_PRCPINP_",9,",DA(1)=+PRCPINP,DA=+PRCPUSER D ^DIK
Q
;
ADD(PRCPINP,PRCPUSER) ; Add user to On-Demand Users
;
; PRCPINP
; PRCPUSER
;
; save user in On-Demand Users list
N PRCPIEN,PRCPARRY,PRCPREC
S PRCPREC(1)=+PRCPMAN ; dinumed file
S PRCPIEN="+1,"_+PRCPINP_","
S PRCPARRY(445.027,PRCPIEN,.01)=+PRCPMAN
D UPDATE^DIE("","PRCPARRY","PRCPREC")
Q
;
; Find all distribution points
CHKDP N PRCPIN,PRCPIP,PRCPDA,PRCPDX,PRCPNM,FLAG,X
D EN^DDIOL("Checking distribution points for "_PRCPINPT_"...") W !
S PRCPIP=0,FLAG=1
S PRCP("DPTYPE")="S"
F S PRCPIP=$O(^PRCP(445,+PRCP("I"),2,PRCPIP)) Q:'+PRCPIP D
. S PRCPNM=$$INVNAME^PRCPUX1(PRCPIP),X=$P(PRCPNM,"-",2,99)
. I $E(X,1,12)="***INACTIVE_" Q ; IP not active
. I $P($G(^PRCP(445,PRCPIP,0)),"^",3)'="S" Q
. S FLAG=0 D INIT(PRCPIP)
. I 'PRCPMAN(3) D Q
. . I PRCPIN S PRCPDX(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN Q
. S PRCPDA(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN
;
I FLAG=1 D EN^DDIOL("There are no distribution points on this primary") W ! Q
;
; check for IPs where the user is On-Demand
I $O(PRCPDA("")) D
. N PRCPD,X S PRCPD=""
. D EN^DDIOL(PRCPNAME_" is a User and Manager on the following Inventory Points:") W !
. F S PRCPD=$O(PRCPDA(PRCPD)) Q:'PRCPD D
. . S X=$P(PRCPDA(PRCPD),"^",2)
. . S X=X_$E(" ",$L(X),35)
. . S X=X_$S($P(PRCPDA(PRCPD),"^",3):"On-Demand User",1:"Not On-Demand User")
. . D EN^DDIOL(X)
. W !
;
I $O(PRCPDX("")) D REMOVE(.PRCPDX)
;
I '$O(PRCPDA("")),'$O(PRCPDX("")) D W !
. I PRCPMAN(2)'=1 D EN^DDIOL(PRCPNAME_" is not a manager of any distribution point") Q
. D EN^DDIOL(PRCPNAME_" is not a user of the distribution points found")
;
ASK(PRCPOPT,PRCPIPT,PRCPUSER) ; Should user's authorization be removed?
;
; PRCPOPT 1 if add , 2 if delete
; PRCPIPT Inventory Point ien
; PRCPUSER DUZ of User
;
N CNT,DIR,DIRUT,DIROUT,DTOUT,DUOUT,I,X,PRCPDP
S CNT=1,PRCPDP="",X=""
S DIR(0)="Y"
S DIR("A")="Add as an On-Demand User"
I PRCPOPT=2 S DIR("A")="Remove as an On-Demand User"
D ^DIR K DIR
I Y=0!$D(DTOUT)!$D(DUOUT) S X=" <<not added>>" S:PRCPOPT=2 X=" <<not removed>>" D EN^DDIOL(X) W ! Q
; IF YES, LOOP THROUGH AND DELETE USER FROM ALL
I Y=1 D
. I PRCPOPT=2 D
. . D DEL(PRCPIPT,PRCPIN)
. . D EN^DDIOL(" <<Removed>>") W !
. I PRCPOPT=1 D
. . D ADD(PRCPIPT,PRCPUSER)
. . I $D(^TMP("DIERR",$J)) D EN^DDIOL(" <<Unable to Add - possible system problems>>") W ! Q
. . D EN^DDIOL(" <<Added>>") W !
Q
;
REMOVE(PRCPDX) ; Auto remove ODI authorization
I $O(PRCPDX("")) D
. N PRCPD,X S PRCPD=""
. D EN^DDIOL("On-Demand Access was removed from the following:") W !
. F S PRCPD=$O(PRCPDX(PRCPD)) Q:'PRCPD D
. . D DEL(PRCPD,$P(PRCPDX(PRCPD),"^",3))
. . S X=$P(PRCPDX(PRCPD),"^",2) D EN^DDIOL(X)
. W !
Q
;
CHKPM ; DISPLAY IPs User can access
N PRCPIN,PRCPIP,FLAG,PRCPDX,PRCPNM
S PRCPIP="",FLAG="",PRCP("DPTYPE")="P"
F S PRCPIP=$O(^PRCP(445,"AC","P",PRCPIP)) Q:'PRCPIP D
. I '$O(^PRCP(445,PRCPIP,9,"B",PRCPMAN,"")) Q
. D INIT(PRCPIP)
. S PRCPNM=$$INVNAME^PRCPUX1(PRCPIP),X=$P(PRCPNM,"-",2,99)
. I $E(X,1,12)="***INACTIVE_" Q ; IP not active
. I 'PRCPMAN(3) D Q
. . I PRCPIN S PRCPDX(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN Q
. I 'FLAG S FLAG=1 D EN^DDIOL(PRCPNAME_" is an On-Demand User in these Primary Inventory Points:")
. D EN^DDIOL(PRCPNM)
I $O(PRCPDX("")) W ! D REMOVE(.PRCPDX)
I 'FLAG D EN^DDIOL(">>"_PRCPNAME_" is not an On-Demand User in any Primary Inventory Point")
W !
Q
;
EXIT L -^PRCPAODI(PRCPMAN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAODI 7089 printed Oct 16, 2024@18:13:31 Page 2
PRCPAODI ;WOIFO/CC-enter/edit On-Demand users ; 2/8/07 4:15pm
+1 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
ENT ;
+1 IF '$$KEY^PRCPUREP("PRCPODI",DUZ)
DO EN^DDIOL("You are not authorized to make managers On-Demand Users.")
QUIT
+2 ;
+3 NEW %,D,DIC,PRCF,PRCP,PRCPIN,PRCPINPT,PRCPMAN,PRCPNAME,X,Y
+4 ;
+5 ; Prompt for user
USER SET DIC="^VA(200,"
SET DIC(0)="AEQMOZ"
SET DIC("A")="INVENTORY POINT MANAGER: "
SET D="B"
+1 DO IX^DIC
+2 KILL DIC,D
IF Y<0
QUIT
+3 SET PRCPMAN=+Y
+4 LOCK +^PRCPAODI(PRCPMAN):0
IF $TEST=0
DO EN^DDIOL(">>File in Use. Please try again later.")
WRITE !
GOTO USER
+5 ;
+6 ; Verify user is active
+7 ; termination date
SET X=$$GET1^DIQ(200,PRCPMAN_",","9.2","I")
+8 IF X
IF X'>DT
DO EN^DDIOL(">>This user has been terminated and cannot be selected.")
WRITE !
DO EXIT
GOTO USER
+9 ; Verify user has primary and/or secondary manager key
+10 SET PRCPMAN(1)=0
SET PRCPMAN(2)=0
+11 SET PRCPMAN(1)=$$KEY^PRCPUREP("PRCP MGRKEY",PRCPMAN)
+12 SET PRCPMAN(2)=$$KEY^PRCPUREP("PRCP2 MGRKEY",PRCPMAN)
+13 IF 'PRCPMAN(1)
IF 'PRCPMAN(2)
IF '$ORDER(^PRCP(445,"AJ",PRCPMAN,""))
DO EN^DDIOL(">>User must be a manager of a Primary or Secondary Inventory Point")
WRITE !
DO EXIT
GOTO USER
+14 ;
+15 ; Display ODI access to primary points
+16 SET PRCPNAME=$$GET1^DIQ(200,PRCPMAN_",",".01")
+17 WRITE !
DO CHKPM
+18 ;
+19 ; Prompt for Site
+20 SET %=0
FOR I="FY","PARAM","PER","QTR","SITE"
SET %=1
QUIT
+21 IF %
SET PRCF("X")="S"
DO ^PRCFSITE
IF '$GET(PRC("SITE"))
KILL PRC,PRCP
GOTO EXIT
+22 ;
+23 ; Prompt for inventory point
IP SET DIC="^PRCP(445,"
SET DIC(0)="AEQMOZ"
+1 SET DIC("S")="I +^(0)=PRC(""SITE"")"
+2 SET DIC("A")="SELECT INVENTORY POINT: "
+3 SET D="C"
SET PRCPPRIV=1
+4 DO IX^DIC
KILL PRCPPRIV,D,DIC
+5 IF Y<0
GOTO EXIT
+6 SET PRCP("I")=Y
if '$GET(PRCP("I"))
QUIT
+7 SET PRCPINPT=$PIECE(PRCP("I"),"^",2)
+8 SET PRCP("DPTYPE")=$PIECE(^PRCP(445,+PRCP("I"),0),U,3)
+9 IF PRCP("DPTYPE")="W"
DO EN^DDIOL(" >>The warehouse has no On-Demand items - needs no On-Demand User.")
WRITE !
GOTO IP
+10 ;
+11 DO INIT(+PRCP("I"))
+12 ;
+13 ;Process Users that don't qualify
+14 IF 'PRCPMAN(3)
Begin DoDot:1
+15 DO EN^DDIOL(">>"_PRCPNAME_" is not a "_PRCPMAN(3)_" of this inventory point")
+16 ; if user is not in node 9, give message - not added
+17 IF 'PRCPIN
DO EN^DDIOL(" and therefore cannot be an On-Demand User")
WRITE !
+18 ; delete if user is set up in node 9 - show 'deleted'
+19 IF PRCPIN
Begin DoDot:2
+20 ; Delete entry
DO DEL(+PRCP("I"),PRCPIN)
+21 DO EN^DDIOL(">>Removed as On-Demand User for: "_PRCPINPT)
WRITE !
End DoDot:2
QUIT
End DoDot:1
if PRCP("DPTYPE")="P"
DO CHKDP
GOTO IP
+22 ;
+23 ; If user is already On-Demand, ask if they should be removed???
+24 IF PRCPIN
Begin DoDot:1
+25 DO ASK(2,+PRCP("I"),PRCPMAN)
+26 IF PRCP("DPTYPE")="P"
DO CHKDP
End DoDot:1
GOTO IP
+27 ;
+28 ; Ask if user should be added to IP's list of On-Demand users
+29 DO ASK(1,+PRCP("I"),PRCPMAN)
+30 IF PRCP("DPTYPE")="P"
DO CHKDP
+31 GOTO IP
+32 ;
+33 QUIT
+34 ;
+35 ; Does user qualify?
INIT(PRCPINP) ;PRCPINP=inventory point being checked
+1 ; assume user is OK
SET PRCPMAN(3)=1
+2 ; Verify user has manager key for type of IP selected
+3 IF PRCP("DPTYPE")="P"
IF 'PRCPMAN(1)
SET PRCPMAN(3)="manager"
+4 IF PRCP("DPTYPE")="S"
IF 'PRCPMAN(2)
SET PRCPMAN(3)="manager"
+5 ; Verify user is a user of that IP
+6 IF '$DATA(^PRCP(445,+PRCPINP,4,PRCPMAN))
Begin DoDot:1
+7 IF PRCPMAN(3)=1
SET PRCPMAN(3)="user"
QUIT
+8 SET PRCPMAN(3)="manager nor user"
End DoDot:1
+9 ;
+10 ; set flag if user is already in list
+11 SET PRCPIN=""
+12 SET PRCPIN=$ORDER(^PRCP(445,+PRCPINP,9,"B",PRCPMAN,PRCPIN))
+13 QUIT
+14 ;
DEL(PRCPINP,PRCPUSER) ; delete On-Demand authorization
+1 ; also called from PRCPXTRM for user termination from VISTA
+2 ;
+3 ; PRCPINP inventory point from which user is being removed
+4 ; PRCPUSER ien of user in the list
+5 ;
+6 NEW DA,DIK
+7 SET DIK="^PRCP(445,"_PRCPINP_",9,"
SET DA(1)=+PRCPINP
SET DA=+PRCPUSER
DO ^DIK
+8 QUIT
+9 ;
ADD(PRCPINP,PRCPUSER) ; Add user to On-Demand Users
+1 ;
+2 ; PRCPINP
+3 ; PRCPUSER
+4 ;
+5 ; save user in On-Demand Users list
+6 NEW PRCPIEN,PRCPARRY,PRCPREC
+7 ; dinumed file
SET PRCPREC(1)=+PRCPMAN
+8 SET PRCPIEN="+1,"_+PRCPINP_","
+9 SET PRCPARRY(445.027,PRCPIEN,.01)=+PRCPMAN
+10 DO UPDATE^DIE("","PRCPARRY","PRCPREC")
+11 QUIT
+12 ;
+13 ; Find all distribution points
CHKDP NEW PRCPIN,PRCPIP,PRCPDA,PRCPDX,PRCPNM,FLAG,X
+1 DO EN^DDIOL("Checking distribution points for "_PRCPINPT_"...")
WRITE !
+2 SET PRCPIP=0
SET FLAG=1
+3 SET PRCP("DPTYPE")="S"
+4 FOR
SET PRCPIP=$ORDER(^PRCP(445,+PRCP("I"),2,PRCPIP))
if '+PRCPIP
QUIT
Begin DoDot:1
+5 SET PRCPNM=$$INVNAME^PRCPUX1(PRCPIP)
SET X=$PIECE(PRCPNM,"-",2,99)
+6 ; IP not active
IF $EXTRACT(X,1,12)="***INACTIVE_"
QUIT
+7 IF $PIECE($GET(^PRCP(445,PRCPIP,0)),"^",3)'="S"
QUIT
+8 SET FLAG=0
DO INIT(PRCPIP)
+9 IF 'PRCPMAN(3)
Begin DoDot:2
+10 IF PRCPIN
SET PRCPDX(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN
QUIT
End DoDot:2
QUIT
+11 SET PRCPDA(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN
End DoDot:1
+12 ;
+13 IF FLAG=1
DO EN^DDIOL("There are no distribution points on this primary")
WRITE !
QUIT
+14 ;
+15 ; check for IPs where the user is On-Demand
+16 IF $ORDER(PRCPDA(""))
Begin DoDot:1
+17 NEW PRCPD,X
SET PRCPD=""
+18 DO EN^DDIOL(PRCPNAME_" is a User and Manager on the following Inventory Points:")
WRITE !
+19 FOR
SET PRCPD=$ORDER(PRCPDA(PRCPD))
if 'PRCPD
QUIT
Begin DoDot:2
+20 SET X=$PIECE(PRCPDA(PRCPD),"^",2)
+21 SET X=X_$EXTRACT(" ",$LENGTH(X),35)
+22 SET X=X_$SELECT($PIECE(PRCPDA(PRCPD),"^",3):"On-Demand User",1:"Not On-Demand User")
+23 DO EN^DDIOL(X)
End DoDot:2
+24 WRITE !
End DoDot:1
+25 ;
+26 IF $ORDER(PRCPDX(""))
DO REMOVE(.PRCPDX)
+27 ;
+28 IF '$ORDER(PRCPDA(""))
IF '$ORDER(PRCPDX(""))
Begin DoDot:1
+29 IF PRCPMAN(2)'=1
DO EN^DDIOL(PRCPNAME_" is not a manager of any distribution point")
QUIT
+30 DO EN^DDIOL(PRCPNAME_" is not a user of the distribution points found")
End DoDot:1
WRITE !
+31 ;
ASK(PRCPOPT,PRCPIPT,PRCPUSER) ; Should user's authorization be removed?
+1 ;
+2 ; PRCPOPT 1 if add , 2 if delete
+3 ; PRCPIPT Inventory Point ien
+4 ; PRCPUSER DUZ of User
+5 ;
+6 NEW CNT,DIR,DIRUT,DIROUT,DTOUT,DUOUT,I,X,PRCPDP
+7 SET CNT=1
SET PRCPDP=""
SET X=""
+8 SET DIR(0)="Y"
+9 SET DIR("A")="Add as an On-Demand User"
+10 IF PRCPOPT=2
SET DIR("A")="Remove as an On-Demand User"
+11 DO ^DIR
KILL DIR
+12 IF Y=0!$DATA(DTOUT)!$DATA(DUOUT)
SET X=" <<not added>>"
if PRCPOPT=2
SET X=" <<not removed>>"
DO EN^DDIOL(X)
WRITE !
QUIT
+13 ; IF YES, LOOP THROUGH AND DELETE USER FROM ALL
+14 IF Y=1
Begin DoDot:1
+15 IF PRCPOPT=2
Begin DoDot:2
+16 DO DEL(PRCPIPT,PRCPIN)
+17 DO EN^DDIOL(" <<Removed>>")
WRITE !
End DoDot:2
+18 IF PRCPOPT=1
Begin DoDot:2
+19 DO ADD(PRCPIPT,PRCPUSER)
+20 IF $DATA(^TMP("DIERR",$JOB))
DO EN^DDIOL(" <<Unable to Add - possible system problems>>")
WRITE !
QUIT
+21 DO EN^DDIOL(" <<Added>>")
WRITE !
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
REMOVE(PRCPDX) ; Auto remove ODI authorization
+1 IF $ORDER(PRCPDX(""))
Begin DoDot:1
+2 NEW PRCPD,X
SET PRCPD=""
+3 DO EN^DDIOL("On-Demand Access was removed from the following:")
WRITE !
+4 FOR
SET PRCPD=$ORDER(PRCPDX(PRCPD))
if 'PRCPD
QUIT
Begin DoDot:2
+5 DO DEL(PRCPD,$PIECE(PRCPDX(PRCPD),"^",3))
+6 SET X=$PIECE(PRCPDX(PRCPD),"^",2)
DO EN^DDIOL(X)
End DoDot:2
+7 WRITE !
End DoDot:1
+8 QUIT
+9 ;
CHKPM ; DISPLAY IPs User can access
+1 NEW PRCPIN,PRCPIP,FLAG,PRCPDX,PRCPNM
+2 SET PRCPIP=""
SET FLAG=""
SET PRCP("DPTYPE")="P"
+3 FOR
SET PRCPIP=$ORDER(^PRCP(445,"AC","P",PRCPIP))
if 'PRCPIP
QUIT
Begin DoDot:1
+4 IF '$ORDER(^PRCP(445,PRCPIP,9,"B",PRCPMAN,""))
QUIT
+5 DO INIT(PRCPIP)
+6 SET PRCPNM=$$INVNAME^PRCPUX1(PRCPIP)
SET X=$PIECE(PRCPNM,"-",2,99)
+7 ; IP not active
IF $EXTRACT(X,1,12)="***INACTIVE_"
QUIT
+8 IF 'PRCPMAN(3)
Begin DoDot:2
+9 IF PRCPIN
SET PRCPDX(PRCPIP)=1_"^"_PRCPNM_"^"_PRCPIN
QUIT
End DoDot:2
QUIT
+10 IF 'FLAG
SET FLAG=1
DO EN^DDIOL(PRCPNAME_" is an On-Demand User in these Primary Inventory Points:")
+11 DO EN^DDIOL(PRCPNM)
End DoDot:1
+12 IF $ORDER(PRCPDX(""))
WRITE !
DO REMOVE(.PRCPDX)
+13 IF 'FLAG
DO EN^DDIOL(">>"_PRCPNAME_" is not an On-Demand User in any Primary Inventory Point")
+14 WRITE !
+15 QUIT
+16 ;
EXIT LOCK -^PRCPAODI(PRCPMAN)
+1 QUIT
