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