- 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
