Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPAODI

PRCPAODI.m

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