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

ASUL19EN.m

Go to the documentation of this file.
  1. ASUL19EN ; IHS/ITSC/LMH - ADD/EDIT USER TABLE #20 ;
  1. ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
  1. ;;Y2K/OK AEF/2970717
  1. ;
  1. ADD ;EP -- MAIN ENTRY POINT TO ADD NEW USER
  1. ;
  1. N ASUL,ASUL65,ASUOUT
  1. D INIT Q:$G(ASUOUT)
  1. F D A1 Q:$G(ASUOUT) W !
  1. W !
  1. Q:$G(ASUOUT)
  1. G ADD
  1. Q
  1. ;
  1. A1 ;EP -- PROMPT FOR USER - ADD NEW ONE IF NOT ONE
  1. ;
  1. ; User IEN must be calculated from 2 digit AREA_4 digit USER CODE
  1. ;
  1. N ASUAREA,ASUCODE,ASUIEN,ASUNAME,ASUPROG,ASUUSR,DA,DD,DIC,DIE,DINUM,DIR,DIRUT,DO,DR,DTOUT,DUOUT,DZ,X,Y,Z
  1. Q:'$G(ASUL(1,"AR","AP"))
  1. S ASUAREA=ASUL(1,"AR","AP")
  1. S DIR(0)="FAO^3:40",DIR("A")="Select User: "
  1. S DIR("?")="^D USRHLP^ASUL19EN"
  1. D ^DIR K DIR
  1. I $D(DTOUT)!($D(DUOUT))!($D(DIRUT)) S ASUOUT=1 Q
  1. S DIC="^ASUL(19,",DIC(0)="EMN"
  1. D ^DIC
  1. I $D(DTOUT)!($D(DUOUT)) G A1
  1. I Y>0 D E2(+Y) Q
  1. S ASUNAME=X
  1. S DIR(0)="YAO",DIR("A")="Are you adding '"_ASUNAME_"' as a new USER? "
  1. S DIR("B")="NO"
  1. D ^DIR K DIR
  1. I 'Y G A1
  1. I ASUNAME=+ASUNAME S ASUUSR=ASUNAME,ASUNAME=""
  1. I $G(ASUUSR)>0,$G(ASUUSR)'?6N W *7," ??" G A1
  1. D USRNAME I $G(ASUNAME)']"" G A1
  1. D USRPROG I $G(ASUPROG)']"" G A1
  1. D USRCODE I $G(ASUCODE)']"" G A1
  1. S Y=$E(ASUCODE,3) D TR^ASULALGO(.Y) I Y<0 G A1
  1. S ASUIEN=ASUAREA_$E(ASUCODE,1,2)_Y
  1. I '$G(ASUUSR) S ASUUSR=ASUIEN
  1. I ASUIEN'=ASUUSR W *7,!,"User codes do not match, try again." G A1
  1. I $D(^ASUL(19,ASUUSR)) W !,"User "_ASUIEN_" already exists in the ASUTBL USER file.",!,"Please check user codes and try again." G A1
  1. S ASUPROG=+ASUPROG
  1. K DD,DO
  1. S DIC="^ASUL(19,",(DA,DINUM)=ASUUSR,X=ASUNAME
  1. S DIC("DR")=".02////^S X=ASUAREA;.03////^S X=ASUPROG;1////^S X=ASUCODE"
  1. D FILE^DICN
  1. I Y'>0 W *7," ??" G A1
  1. W !,"User "_ASUUSR_" "_ASUNAME_" ADDED"
  1. D USR^ASULDIRR(ASUUSR)
  1. Q
  1. USRNAME ;----- PROMPT FOR USER NAME
  1. ;
  1. N DIR,X,Y
  1. S DIR(0)="FAO",DIR("A")="NAME: "
  1. I $G(ASUNAME)]"" S DIR("B")=ASUNAME
  1. D ^DIR
  1. I Y["^" S ASUNAME="" Q
  1. S ASUNAME=Y
  1. Q
  1. USRPROG ;----- PROMPT FOR USER PROGRAM CODE
  1. ;
  1. N DIR,X,Y
  1. S DIR(0)="PA^ASUL(22,:AEMQ"
  1. S DIR("A")="PROGRAM: "
  1. D ^DIR
  1. I Y'>0 S ASUPROG=""
  1. S ASUPROG=Y
  1. Q
  1. USRCODE ;----- PROMPT FOR USER CODE
  1. ;
  1. N DIR,X,Y
  1. S DIR(0)="FA^3:3^K:$E(X,1,2)'=$P($G(ASUPROG),U,2)!($E(X,3)'?1UN) X"
  1. S DIR("A")="CODE: "
  1. S DIR("?")="Enter 3 digit USER CODE, i.e., PROGRAM CODE + 1 digit EX: 800, 801, 80A"
  1. D ^DIR
  1. I Y["^" S ASUCODE="" Q
  1. S ASUCODE=Y
  1. Q
  1. USRHLP ;----- HELP FOR 'SELECT USER' PROMPT
  1. ;
  1. N D,DIC,DZ,X,Y
  1. S DIC="^ASUL(19,",DIC("S")="I $E(+Y,1,2)=$G(ASUL(1,""AR"",""AP""))"
  1. S DIC(0)="EMN",D="B",DZ="??"
  1. D DQ^DICQ
  1. Q
  1. EDIT ;EP -- EDIT EXISTING USER
  1. ;
  1. N ASUL,ASUL65,ASUOUT
  1. D INIT Q:$G(ASUOUT)
  1. F D E1 Q:$G(ASUOUT)
  1. Q:$G(ASUOUT)
  1. W !
  1. G EDIT
  1. Q
  1. E1 ;----- LOOK UP ENTRY
  1. ;
  1. N DA,DIC,X,Y
  1. S DIC="^ASUL(19,",DIC(0)="AEMQ",DIC("A")="Select User: "
  1. D ^DIC
  1. I Y'>0 S ASUOUT=1 Q
  1. S DA=+Y
  1. D E2(DA)
  1. W !
  1. G E1
  1. Q
  1. E2(DA) ;----- EDIT ENTRY
  1. ;
  1. N DIE,DR,X,Y
  1. K ASUL(19)
  1. D USR^ASULDIRR(DA)
  1. S DIE="^ASUL(19,",DR=.01
  1. D ^DIE
  1. Q
  1. INIT ;----- SET UP REQUIRED VARIABLES
  1. ;
  1. I '$D(DUZ(2)) W !?10,"DIVISION NOT SET, PLEASE SEE SITE MANAGER" S ASUOUT=1 Q
  1. I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
  1. I ASUL(1,"AR","AP")=65 S ASUL65=1
  1. D AREA
  1. Q
  1. AREA ;----- PROMPT USER FOR AREA
  1. ;
  1. Q:'$G(ASUL65)
  1. D FINDAREA^ASULARST
  1. I Y'>0 S ASUOUT=1
  1. Q