ASUL19IT ; IHS/ITSC/LMH -INPUT TRANSFORM USER TABLE 19 ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
;This routine is the File Man Input transform for SAMS table 19 -
;User Code table
I $G(DA)?6N D USR^ASULDIRR(DA) Q:$D(ASUL(19))
I '$D(DUZ(2)) K X W !?10,"DUZ(2) must be set so Area Accounting Point can be determined" Q
I '$D(ASUL(1,"AR","AP")) D SETAREA^ASULARST
I $D(DIC(0)) S DIC(0)=$TR(DIC(0),"Q") S:DIC(0)'["A" DIC(0)="A"_DIC(0)
S X=$G(DIX)
N DIC,DIE
EN2 ;EP; DIC ALREADY SET
N DIK,DIR,DR
S X=$G(X)
I X']"" D ASUL19RC G:$D(DIRUT) X G:'$D(X) X I Y>0 S DA=+Y,X=ASUL(19,"USR","NM") G X
I $D(DA) I $D(^ASUL(19,+DA,0)) I DA?6N,$E(DA,1,2)=ASUL(1,"AR","AP") D NMIT Q
I $D(ASUL(19,"USR","E#")) I ASUL(19,"USR","E#")?6N S X=ASUL(19,"USR","E#")
I X?2N.1AN D
.S DA=X,ASUL(19,"USR")=X D USR^ASULALGO(.DA) Q:DA'?4N
.S (ASUL(19,"USR","E#"),X,DA)=ASUL(1,"AR","AP")_DA Q
I X?4N D
.S DA=X,(ASUL(19,"USR","E#"),X,DA)=ASUL(1,"AR","AP")_DA Q
I X?6N D Q:$D(X) G:$D(DTOUT) ERR G:$D(DUOUT) ERR G X
.S DA=X
.I '$G(^ASUL(22,+($E(X,3,4)),0)) D Q
..W !?10,$E(DA,3,4)," Is not a valid Program - first 2 characters of USER CODE must be valid Program"
..D HELP D ERR
.I $E(DA,1,2)'=ASUL(1,"AR","AP") D Q
..W !?10,$E(DA,1,2)," Is not Accounting Point you are signed on as, which is: ",ASUL(1,"AR","AP")
..D HELP D ERR
.I $D(^ASUL(19,DA,0)) D Q ;Record found for DA
..S ASUL(19,"USR","E#")=DA,ASUL(19,"USR","NM")=$P(^ASUL(19,DA,0),U),ASUL(19,"USR")=$P(^ASUL(19,DA,1),U)
.S ASUL(19,"USR","E#")=DA
.I '$G(ASUL(19,"USR")) D Q:'$D(X)
..S ASUL19=$E(DA,3,5) D IEN^ASULALGO(.ASUL19)
..I Y<0 W !?10,"Can't compute USER code for IEN:",DA D ERR Q
..S ASUL(19,"USR")=ASUL19 K ASUL19 ;Convert IEN back to USER code
.D NAME ;Read a name for USER code
.Q:'$D(X) Q:$D(DTOUT) Q:$D(DUOUT)
.D FILE
E D
.I X'?1A.ANP D ERR Q
.S ASUL(19,"USR","NM")=X,ASUL(19,"USR","E#")=""
.F S ASUL(19,"USR","E#")=$O(^ASUL(19,"B",ASUL(19,"USR","NM"),ASUL(19,"USR","E#"))) Q:$E(ASUL(19,"USR","E#"),1,2)=ASUL(1,"AR","AP") Q:ASUL(19,"USR","E#")']""
.Q:ASUL(19,"USR","E#")]"" ;USER name found
.S DIR(0)="Y",DIR("A")="Do you want to add a new User "_ASUL(19,"USR","NM") D ^DIR
.D:$D(DIRUT) ERR D:('Y) ERR D:$D(DUOUT) ERR D:$D(DTOUT) ERR Q:'$D(X)
.D ASUL19RC D:'$D(ASUL(19,"USR","E#")) ERR D:ASUL(19,"USR","E#")']"" ERR Q:'$D(X)
G:$D(DIRUT) ERR G:'$D(X) ERR G:X']"" ERR G:$D(DTOUT) ERR G:$D(DUOUT) ERR G:$D(DIRUT) ERR
X ;
S DA=ASUL(19,"USR","E#"),X=ASUL(19,"USR","NM")
I '$D(ASUL("REQ")) K ASUL(19),ASUL(22)
Q
NAME ;
S DIR(0)="Y",DIR("A")="Do you want to add a new User "_ASUL(19,"USR") D ^DIR
I $D(DIRUT)!('Y) K X Q
READNAME ;EP ;READ USER NAME
S DIR(0)="F^3:30",DIR("A")="ENTER "_ASUL(19,"USR")_" USER NAME",DIR("?")="Name may be 3 to 30 characters long"
S:$G(ASUL(19,"USR","NM"))]"" DIR("B")=$G(ASUL(19,"USR","NM"))
D ^DIR
G:$D(DTOUT) ERR G:$D(DUOUT) ERR G:X']"" ERR
S ASUL(19,"USR","NM")=X
Q
NMIT ;EP ; INPUT TRANSFORM FOR NAME (.01) FIELD
K:$L(X)<3!($L(X)>40)!(X'?3AN.APN) X
Q
CDIT ;EP;;USER CODE INPUT TRANSFORM FOR FILEMAN
N Z S Z=DA D IEN^ASULALGO(.Z) K:X'=Z X Q
ARIT ;EP;;AREA POINTER INPUT TRANSFORM FOR FILEMAN
N Z S Z=$E(DA,1,2) K:X'=Z X Q
PGIT ;EP;;PROGRAM POINTER INPUT TRANSFORM FOR FILEMAN
N Z S X=+X,Z=+($E(DA,3,4)) K:X'=Z X Q
FILE ;
S DIE=9002039.19
W !?10,"Adding entry in User Table (19)"
W !?15," CODE: ",ASUL(19,"USR")
W !?15," NAME: ",ASUL(19,"USR","NM")
W !?15," PROGRAM: ",ASUL(22,"PGM","NM")
W !?15," AREA: ",ASUL(1,"AR","NM")
S DR=".01///"_ASUL(19,"USR","NM")_";.02///"_ASUL(1,"AR","AP")_";.03///"_ASUL(22,"PGM","E#")_";1///"_ASUL(19,"USR")
S $P(^ASUL(19,0),U,4)=$P(^ASUL(19,0),U,4)+1
S $P(^ASUL(19,0),U,3)=ASUL(19,"USR","E#")
S (DA,D0)=ASUL(19,"USR","E#") K DD D ^DIE K X
Q
ERR ;
K X,DUOUT,DTOUT,ASUL(19),ASUL(22)
Q
DIC ;EP; SET DIC
N DIC,DIE
S (DIE,DIC)="^ASUL(19,",DIC(0)="EALM",DIC("W")="W "" "" W:$D(^(1)) "" "",,$P(^(1),U)" D EN2
Q
HELP ;HELP INPUT USER TABLE 19
W !?5,"You may only access User table entries for the Area you are signed"
W !?5,"in to SAMS with. This is determined using the setting of DUZ(2)"
W !?5,"which is set when you sign in to SAMS. If you wish to change Areas,"
W !?5,"you must sign out of SAMS and then sign back in to SAMS selecting the"
W !?5,"appropriate DIVISION (area). If when you sign in to SAMS you are not"
W !?5,"prompted for a DIVISION, then you are automatically signed on as a"
W !?5,"specific Area and are restricted to that Area."
W !!?5,"You will be asked for the User Code or User Name for the entry you wish"
W !?5,"to Access. If an entry for that User does not exist, you will also be asked"
W !?5,"for the User Name or User Code (whichever has not already been enterd)"
W !?5,"so that a new entry may be added. Once an entry has been added to the"
W !?5,"table, only the NAME field may be changed. To change any other field,"
W !?5,"you must delete the entry and re-enter it with the changes. Deletions"
W !?5,"however, may only be done by those with specific access keys."
Q
ASUL19RC ;EP;WITH LOCAL ARRAY KILL
K ASUL(19)
READUSR ;Get User to be processed
N DIR
S DIR(0)="FAO^2:6^K:X'?2N.1AN X"
S DIR("A")=" ENTER USER CODE"
I $D(ASUL(19,"USR","NM")) S DIR("A")=DIR("A")_" FOR "_ASUL(19,"USR","NM")
S DIR("A")=DIR("A")_" : "
S DIR("?")="^D HLPUSADD^ASUL19RC"
S DIR("??")="^D HLPUSLST^ASUL19RC"
D ^DIR S:$D(DUOUT) ASUL(19,"USR")="" Q:$D(DIROUT) Q:$D(DUOUT) Q:$D(DTOUT)
S ASUL(19,"USR")=X
D USR^ASULDIRR(.X)
I Y<0 D
.W !?5,"No entry in User Table (19) for Usr Code ",ASUL(19,"USR")
.W " ",$G(ASUL(19,"USR","NM")),!?10," for area ",ASUL(1,"AR","NM")," - ",ASUL(1,"AR","AP")
.I Y=-1 D
..K DIR S DIR(0)="Y",DIR("A")="Do you want to add one" D ^DIR
..I Y D READNAME^ASUL19IT Q:Y<0 S X=ASUL(19,"USR","E#"),X(1)=ASUL(19,"USR","NM") D USR^ASULDIRA(.X)
E D
.W " ",$G(ASUL(19,"USR","NM"))
Q
HLPUSLST ;
N DIC,DIR,DO
S DIC="^ASUL(19,",DIC("S")="I $P(^(0),U,2)=ASUL(1,""AR"",""E#"")"
S DIC(0)="MEI",D="B",DZ="??" D DQ^DICQ
S (DIR("B"),DIR(0))="Y",DIR("A")="Want to see valid Program Codes?" D ^DIR
I Y D HLPPGLST
Q
HLPPGLST ;
N DIC,DO
S DIC="^ASUL(22,"
S DIC(0)="MEI",D="B",DZ="??" D DQ^DICQ
Q
HLPUSADD ;
W !,"For the User to be added, Enter either:"
W !?10,"3 digit User code (first 2 must equal valid Program code)"
W !?10,"?? to see a list of current entries in the User Table"
W !?10,"Enter '^' or <enter> to end session of User entry update"
Q
ASUL19IT ; IHS/ITSC/LMH -INPUT TRANSFORM USER TABLE 19 ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
+2 ;This routine is the File Man Input transform for SAMS table 19 -
+3 ;User Code table
+4 IF $GET(DA)?6N
DO USR^ASULDIRR(DA)
IF $DATA(ASUL(19))
QUIT
+5 IF '$DATA(DUZ(2))
KILL X
WRITE !?10,"DUZ(2) must be set so Area Accounting Point can be determined"
QUIT
+6 IF '$DATA(ASUL(1,"AR","AP"))
DO SETAREA^ASULARST
+7 IF $DATA(DIC(0))
SET DIC(0)=$TRANSLATE(DIC(0),"Q")
IF DIC(0)'["A"
SET DIC(0)="A"_DIC(0)
+8 SET X=$GET(DIX)
+9 NEW DIC,DIE
EN2 ;EP; DIC ALREADY SET
+1 NEW DIK,DIR,DR
+2 SET X=$GET(X)
+3 IF X']""
DO ASUL19RC
IF $DATA(DIRUT)
GOTO X
IF '$DATA(X)
GOTO X
IF Y>0
SET DA=+Y
SET X=ASUL(19,"USR","NM")
GOTO X
+4 IF $DATA(DA)
IF $DATA(^ASUL(19,+DA,0))
IF DA?6N
IF $EXTRACT(DA,1,2)=ASUL(1,"AR","AP")
DO NMIT
QUIT
+5 IF $DATA(ASUL(19,"USR","E#"))
IF ASUL(19,"USR","E#")?6N
SET X=ASUL(19,"USR","E#")
+6 IF X?2N.1AN
Begin DoDot:1
+7 SET DA=X
SET ASUL(19,"USR")=X
DO USR^ASULALGO(.DA)
IF DA'?4N
QUIT
+8 SET (ASUL(19,"USR","E#"),X,DA)=ASUL(1,"AR","AP")_DA
QUIT
End DoDot:1
+9 IF X?4N
Begin DoDot:1
+10 SET DA=X
SET (ASUL(19,"USR","E#"),X,DA)=ASUL(1,"AR","AP")_DA
QUIT
End DoDot:1
+11 IF X?6N
Begin DoDot:1
+12 SET DA=X
+13 IF '$GET(^ASUL(22,+($EXTRACT(X,3,4)),0))
Begin DoDot:2
+14 WRITE !?10,$EXTRACT(DA,3,4)," Is not a valid Program - first 2 characters of USER CODE must be valid Program"
+15 DO HELP
DO ERR
End DoDot:2
QUIT
+16 IF $EXTRACT(DA,1,2)'=ASUL(1,"AR","AP")
Begin DoDot:2
+17 WRITE !?10,$EXTRACT(DA,1,2)," Is not Accounting Point you are signed on as, which is: ",ASUL(1,"AR","AP")
+18 DO HELP
DO ERR
End DoDot:2
QUIT
+19 ;Record found for DA
IF $DATA(^ASUL(19,DA,0))
Begin DoDot:2
+20 SET ASUL(19,"USR","E#")=DA
SET ASUL(19,"USR","NM")=$PIECE(^ASUL(19,DA,0),U)
SET ASUL(19,"USR")=$PIECE(^ASUL(19,DA,1),U)
End DoDot:2
QUIT
+21 SET ASUL(19,"USR","E#")=DA
+22 IF '$GET(ASUL(19,"USR"))
Begin DoDot:2
+23 SET ASUL19=$EXTRACT(DA,3,5)
DO IEN^ASULALGO(.ASUL19)
+24 IF Y<0
WRITE !?10,"Can't compute USER code for IEN:",DA
DO ERR
QUIT
+25 ;Convert IEN back to USER code
SET ASUL(19,"USR")=ASUL19
KILL ASUL19
End DoDot:2
IF '$DATA(X)
QUIT
+26 ;Read a name for USER code
DO NAME
+27 IF '$DATA(X)
QUIT
IF $DATA(DTOUT)
QUIT
IF $DATA(DUOUT)
QUIT
+28 DO FILE
End DoDot:1
IF $DATA(X)
QUIT
IF $DATA(DTOUT)
GOTO ERR
IF $DATA(DUOUT)
GOTO ERR
GOTO X
+29 IF '$TEST
Begin DoDot:1
+30 IF X'?1A.ANP
DO ERR
QUIT
+31 SET ASUL(19,"USR","NM")=X
SET ASUL(19,"USR","E#")=""
+32 FOR
SET ASUL(19,"USR","E#")=$ORDER(^ASUL(19,"B",ASUL(19,"USR","NM"),ASUL(19,"USR","E#")))
IF $EXTRACT(ASUL(19,"USR","E#"),1,2)=ASUL(1,"AR","AP")
QUIT
IF ASUL(19,"USR","E#")']""
QUIT
+33 ;USER name found
IF ASUL(19,"USR","E#")]""
QUIT
+34 SET DIR(0)="Y"
SET DIR("A")="Do you want to add a new User "_ASUL(19,"USR","NM")
DO ^DIR
+35 IF $DATA(DIRUT)
DO ERR
IF ('Y)
DO ERR
IF $DATA(DUOUT)
DO ERR
IF $DATA(DTOUT)
DO ERR
IF '$DATA(X)
QUIT
+36 DO ASUL19RC
IF '$DATA(ASUL(19,"USR","E#"))
DO ERR
IF ASUL(19,"USR","E#")']""
DO ERR
IF '$DATA(X)
QUIT
End DoDot:1
+37 IF $DATA(DIRUT)
GOTO ERR
IF '$DATA(X)
GOTO ERR
IF X']""
GOTO ERR
IF $DATA(DTOUT)
GOTO ERR
IF $DATA(DUOUT)
GOTO ERR
IF $DATA(DIRUT)
GOTO ERR
X ;
+1 SET DA=ASUL(19,"USR","E#")
SET X=ASUL(19,"USR","NM")
+2 IF '$DATA(ASUL("REQ"))
KILL ASUL(19),ASUL(22)
+3 QUIT
NAME ;
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to add a new User "_ASUL(19,"USR")
DO ^DIR
+2 IF $DATA(DIRUT)!('Y)
KILL X
QUIT
READNAME ;EP ;READ USER NAME
+1 SET DIR(0)="F^3:30"
SET DIR("A")="ENTER "_ASUL(19,"USR")_" USER NAME"
SET DIR("?")="Name may be 3 to 30 characters long"
+2 IF $GET(ASUL(19,"USR","NM"))]""
SET DIR("B")=$GET(ASUL(19,"USR","NM"))
+3 DO ^DIR
+4 IF $DATA(DTOUT)
GOTO ERR
IF $DATA(DUOUT)
GOTO ERR
IF X']""
GOTO ERR
+5 SET ASUL(19,"USR","NM")=X
+6 QUIT
NMIT ;EP ; INPUT TRANSFORM FOR NAME (.01) FIELD
+1 IF $LENGTH(X)<3!($LENGTH(X)>40)!(X'?3AN.APN)
KILL X
+2 QUIT
CDIT ;EP;;USER CODE INPUT TRANSFORM FOR FILEMAN
+1 NEW Z
SET Z=DA
DO IEN^ASULALGO(.Z)
IF X'=Z
KILL X
QUIT
ARIT ;EP;;AREA POINTER INPUT TRANSFORM FOR FILEMAN
+1 NEW Z
SET Z=$EXTRACT(DA,1,2)
IF X'=Z
KILL X
QUIT
PGIT ;EP;;PROGRAM POINTER INPUT TRANSFORM FOR FILEMAN
+1 NEW Z
SET X=+X
SET Z=+($EXTRACT(DA,3,4))
IF X'=Z
KILL X
QUIT
FILE ;
+1 SET DIE=9002039.19
+2 WRITE !?10,"Adding entry in User Table (19)"
+3 WRITE !?15," CODE: ",ASUL(19,"USR")
+4 WRITE !?15," NAME: ",ASUL(19,"USR","NM")
+5 WRITE !?15," PROGRAM: ",ASUL(22,"PGM","NM")
+6 WRITE !?15," AREA: ",ASUL(1,"AR","NM")
+7 SET DR=".01///"_ASUL(19,"USR","NM")_";.02///"_ASUL(1,"AR","AP")_";.03///"_ASUL(22,"PGM","E#")_";1///"_ASUL(19,"USR")
+8 SET $PIECE(^ASUL(19,0),U,4)=$PIECE(^ASUL(19,0),U,4)+1
+9 SET $PIECE(^ASUL(19,0),U,3)=ASUL(19,"USR","E#")
+10 SET (DA,D0)=ASUL(19,"USR","E#")
KILL DD
DO ^DIE
KILL X
+11 QUIT
ERR ;
+1 KILL X,DUOUT,DTOUT,ASUL(19),ASUL(22)
+2 QUIT
DIC ;EP; SET DIC
+1 NEW DIC,DIE
+2 SET (DIE,DIC)="^ASUL(19,"
SET DIC(0)="EALM"
SET DIC("W")="W "" "" W:$D(^(1)) "" "",,$P(^(1),U)"
DO EN2
+3 QUIT
HELP ;HELP INPUT USER TABLE 19
+1 WRITE !?5,"You may only access User table entries for the Area you are signed"
+2 WRITE !?5,"in to SAMS with. This is determined using the setting of DUZ(2)"
+3 WRITE !?5,"which is set when you sign in to SAMS. If you wish to change Areas,"
+4 WRITE !?5,"you must sign out of SAMS and then sign back in to SAMS selecting the"
+5 WRITE !?5,"appropriate DIVISION (area). If when you sign in to SAMS you are not"
+6 WRITE !?5,"prompted for a DIVISION, then you are automatically signed on as a"
+7 WRITE !?5,"specific Area and are restricted to that Area."
+8 WRITE !!?5,"You will be asked for the User Code or User Name for the entry you wish"
+9 WRITE !?5,"to Access. If an entry for that User does not exist, you will also be asked"
+10 WRITE !?5,"for the User Name or User Code (whichever has not already been enterd)"
+11 WRITE !?5,"so that a new entry may be added. Once an entry has been added to the"
+12 WRITE !?5,"table, only the NAME field may be changed. To change any other field,"
+13 WRITE !?5,"you must delete the entry and re-enter it with the changes. Deletions"
+14 WRITE !?5,"however, may only be done by those with specific access keys."
+15 QUIT
ASUL19RC ;EP;WITH LOCAL ARRAY KILL
+1 KILL ASUL(19)
READUSR ;Get User to be processed
+1 NEW DIR
+2 SET DIR(0)="FAO^2:6^K:X'?2N.1AN X"
+3 SET DIR("A")=" ENTER USER CODE"
+4 IF $DATA(ASUL(19,"USR","NM"))
SET DIR("A")=DIR("A")_" FOR "_ASUL(19,"USR","NM")
+5 SET DIR("A")=DIR("A")_" : "
+6 SET DIR("?")="^D HLPUSADD^ASUL19RC"
+7 SET DIR("??")="^D HLPUSLST^ASUL19RC"
+8 DO ^DIR
IF $DATA(DUOUT)
SET ASUL(19,"USR")=""
IF $DATA(DIROUT)
QUIT
IF $DATA(DUOUT)
QUIT
IF $DATA(DTOUT)
QUIT
+9 SET ASUL(19,"USR")=X
+10 DO USR^ASULDIRR(.X)
+11 IF Y<0
Begin DoDot:1
+12 WRITE !?5,"No entry in User Table (19) for Usr Code ",ASUL(19,"USR")
+13 WRITE " ",$GET(ASUL(19,"USR","NM")),!?10," for area ",ASUL(1,"AR","NM")," - ",ASUL(1,"AR","AP")
+14 IF Y=-1
Begin DoDot:2
+15 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to add one"
DO ^DIR
+16 IF Y
DO READNAME^ASUL19IT
IF Y<0
QUIT
SET X=ASUL(19,"USR","E#")
SET X(1)=ASUL(19,"USR","NM")
DO USR^ASULDIRA(.X)
End DoDot:2
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 WRITE " ",$GET(ASUL(19,"USR","NM"))
End DoDot:1
+19 QUIT
HLPUSLST ;
+1 NEW DIC,DIR,DO
+2 SET DIC="^ASUL(19,"
SET DIC("S")="I $P(^(0),U,2)=ASUL(1,""AR"",""E#"")"
+3 SET DIC(0)="MEI"
SET D="B"
SET DZ="??"
DO DQ^DICQ
+4 SET (DIR("B"),DIR(0))="Y"
SET DIR("A")="Want to see valid Program Codes?"
DO ^DIR
+5 IF Y
DO HLPPGLST
+6 QUIT
HLPPGLST ;
+1 NEW DIC,DO
+2 SET DIC="^ASUL(22,"
+3 SET DIC(0)="MEI"
SET D="B"
SET DZ="??"
DO DQ^DICQ
+4 QUIT
HLPUSADD ;
+1 WRITE !,"For the User to be added, Enter either:"
+2 WRITE !?10,"3 digit User code (first 2 must equal valid Program code)"
+3 WRITE !?10,"?? to see a list of current entries in the User Table"
+4 WRITE !?10,"Enter '^' or <enter> to end session of User entry update"
+5 QUIT
