- 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