- 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 Jan 18, 2025@03:13:58 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