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

ACRFONE.m

Go to the documentation of this file.
  1. ACRFONE ;IHS/OIRM/DSD/THL,AEF - CHECK FOR MULTIPLE DEPARTMENT ACCOUNTS FOR USER; [ 11/01/2001 9:44 AM ]
  1. ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
  1. ;;ROUTINE TO CHECK IF USER HAD ACCESS TO MULTIPLE DEPARTMENT ACCOUNTS
  1. EN D EN1
  1. EXIT K ACRJ,ACRX
  1. Q
  1. EN1 D EN11
  1. I ACRJ>1 K ACRONE Q
  1. I ACRJ=1 D Q
  1. .S (DA,ACRZDA,ACRFDNO)=ACRONE
  1. .S ACRFDNA=$P(^ACRLOCB(ACRONE,0),U)
  1. .S ACRCANDA=$P(^ACRLOCB(ACRONE,"DT"),U,9)
  1. .S ACRGREF=$P($P(ACRDATA1,";;",3),"(")
  1. .S ACRY=$P(ACRDATA1,";;",2)
  1. .D EN^ACRFDTP2
  1. W !!,*7,"You have not been given access to any accounts."
  1. W !,"You must have access to at least one account to do data entry."
  1. W !,"Ask your systems operator for assistance."
  1. D PAUSE^ACRFWARN
  1. S ACRQUIT=""
  1. Q
  1. EN11 S (ACRX,ACRJ)=0
  1. F S ACRX=$O(^ACRLOCB("SEC",DUZ,ACRX)) Q:'ACRX!(ACRJ>1)!$D(ACRQUIT)!$D(ACROUT) D:$D(^ACRLOCB(ACRX,0))
  1. .S:$P(^ACRLOCB(ACRX,0),U,8)="O" ACRJ=ACRJ+1
  1. .S ACRONE=ACRX
  1. Q