Routine: XUSMGR

XUSMGR ;SF-ISC/STAFF - SECURITY UTILITIES ROUTINE ; 7/15/03 7:03am

 ;;8.0;KERNEL;**263,258,314**;Jul 10, 1995

 W !!,"Use the MENU system",!! Q

X1 ;Old intro test edit

 N DIE,DA,DR

 W !!,"Please use menu option 'Inrtoductory text edit'" H 4 ;Sign-on intro text.

 S DIE="^XTV(8989.3,",DA=1,DR=240 D ^DIE Q

X6 ;Clear Terminal

 N %ZIS

 S %ZIS="QN" D ^%ZIS G:POP EX6 I '$D(^DISV("XU",IOS)) W !!,$C(7),"Terminal does not need to be cleared!!!",! G X6

 K ^DISV("XU",IOS),%ZIS W !,"Terminal has been CLEARED!!",!

EX6 D HOME^%ZIS Q

X8 ;Release user

 N DIC,DIR,J,X,Y,FDA,IEN,X1,X2,X3

X8A W !!,"This will clear the user from the list of currently sign-on users."

 W !,"And/or release from invalid sign on lock."

 S DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC S IEN=+Y G:Y<1 EX8

 S (X1,X2,X3)=0

 I $P($G(^VA(200,IEN,1.1)),"^",3) S X1=1

 I $P($G(^VA(200,IEN,1.1)),"^",5) S X2=1

 I $D(^XUSEC(0,"CUR",IEN)) S X3=1

 I '(X1+X2+X3) D  G X8

 . W !!,$C(7),"User is not currently recorded as being signed on the system!!!",!

 ;Show user info

 W !,"User: ",$P(Y,U,2)," is listed with the following connections."

 S J=0 F  S J=$O(^XUSEC(0,"CUR",IEN,J)) Q:J'>0  D

 . I '$D(^XUSEC(0,J,0)) K ^XUSEC(0,"CUR",IEN,J) Q

 . S X=^XUSEC(0,J,0)

 . W !,"Connected: ",$$FMTE^XLFDT(J,"1"),?39," Device: ",$P(X,U,2)

 . W !,?2,"   Node: ",$P(X,U,10),?39,"     IP: ",$S($L($P(X,U,11)):$P(X,U,11),1:$P(X,U,12))

. Q

 I $P(^VA(200,IEN,1.1),U,5) W !,"Locked out until ",$$FMTE^XLFDT($P(^VA(200,IEN,1.1),U,5))," because of too many invalid attempts."

 S DIR(0)="Y",DIR("A")="Release this user",DIR("B")="Yes" D ^DIR

 I 'Y G X8A

 S $P(^VA(200,IEN,1.1),"^",3)=0,$P(^VA(200,IEN,1.1),U,5)="" ;Clear flag,Lockout time

 S J=0 F  S J=$O(^XUSEC(0,"CUR",IEN,J)) Q:J'>0  D

 . S FDA(3.081,J_",",3)=$$NOW^XLFDT,FDA(3.081,J_",",16)=1 D UPDATE^DIE("","FDA")

 W !,"User is RELEASED!!",!

EX8 Q

SCPURG ;Purge sign-on log

 S XUDT=$$HTFM^XLFDT($H-30) I $O(^XUSEC(0,0))'>0 G SCEXIT

 S DIK="^XUSEC(0," F DA=0:0 S DA=$O(^XUSEC(0,DA)) Q:(DA'>0)!(DA>XUDT)  D ^DIK

SCEXIT K DIK,DA,XUDT,X1,X2 Q

IXKEY ;Re-Index the New Person file Key sub-file

 N DA,DIK,ACT

 W:'$D(ZTQUEUED) !,"Starting"

 ;we only want to reindex the "AC" x-ref

 S DIK(1)=".01^AC"

 ;loop through New Person file and index entries

 F DA(1)=0:0 S DA(1)=$O(^VA(200,DA(1))) Q:DA(1)'>0  D

 .;skip inactive person

 .;Q:$P($G(^VA(200,DA(1),0)),"^",11)

 .S ACT=+$$ACTIVE^XUSER(DA(1))

 .I ACT'=1 Q

 .;global root for multiple

 .S DIK="^VA(200,DA(1),51,"

 .;reindex

 .D ENALL^DIK W:'(DA(1)#50) "."

.;

 W:'$D(ZTQUEUED) !,"Done"

 ;the old codes

 ;W:'$D(ZTQUEUED) !,"Starting "

 ;S DIK="^VA(200,DA(1),51,",DIK(1)=".01^1^2^3^4"

 ;F DA(1)=0:0 S DA(1)=$O(^VA(200,DA(1))) Q:DA(1)'>0  D ENALL^DIK W:'(DA(1)#50) "."

 ;W:'$D(ZTQUEUED) !,"Done"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSMGR   2804     printed  Mar 13, 2025@21:17:30                                                                                                                                                                                                      Page 2

XUSMGR    ;SF-ISC/STAFF - SECURITY UTILITIES ROUTINE ; 7/15/03 7:03am

 +1       ;;8.0;KERNEL;**263,258,314**;Jul 10, 1995

 +2        WRITE !!,"Use the MENU system",!!

           QUIT

X1        ;Old intro test edit

 +1        NEW DIE,DA,DR

 +2       ;Sign-on intro text.

           WRITE !!,"Please use menu option 'Inrtoductory text edit'"

           HANG 4

 +3        SET DIE="^XTV(8989.3,"

           SET DA=1

           SET DR=240

           DO ^DIE

           QUIT

 +4       ;

X6        ;Clear Terminal

 +1        NEW %ZIS

 +2        SET %ZIS="QN"

           DO ^%ZIS

           if POP

               GOTO EX6

           IF '$DATA(^DISV("XU",IOS))

               WRITE !!,$CHAR(7),"Terminal does not need to be cleared!!!",!

               GOTO X6

 +3        KILL ^DISV("XU",IOS),%ZIS

           WRITE !,"Terminal has been CLEARED!!",!

EX6        DO HOME^%ZIS

           QUIT

 +1       ;

X8        ;Release user

 +1        NEW DIC,DIR,J,X,Y,FDA,IEN,X1,X2,X3

X8A        WRITE !!,"This will clear the user from the list of currently sign-on users."

 +1        WRITE !,"And/or release from invalid sign on lock."

 +2        SET DIC="^VA(200,"

           SET DIC(0)="AEMQ"

           DO ^DIC

           SET IEN=+Y

           if Y<1

               GOTO EX8

 +3        SET (X1,X2,X3)=0

 +4        IF $PIECE($GET(^VA(200,IEN,1.1)),"^",3)

               SET X1=1

 +5        IF $PIECE($GET(^VA(200,IEN,1.1)),"^",5)

               SET X2=1

 +6        IF $DATA(^XUSEC(0,"CUR",IEN))

               SET X3=1

 +7        IF '(X1+X2+X3)

               Begin DoDot:1

 +8                WRITE !!,$CHAR(7),"User is not currently recorded as being signed on the system!!!",!

               End DoDot:1

               GOTO X8

 +9       ;Show user info

 +10       WRITE !,"User: ",$PIECE(Y,U,2)," is listed with the following connections."

 +11       SET J=0

FOR

               SET J=$ORDER(^XUSEC(0,"CUR",IEN,J))

               if J'>0

                   QUIT

               Begin DoDot:1

 +12               IF '$DATA(^XUSEC(0,J,0))

                       KILL ^XUSEC(0,"CUR",IEN,J)

                       QUIT

 +13               SET X=^XUSEC(0,J,0)

 +14               WRITE !,"Connected: ",$$FMTE^XLFDT(J,"1"),?39," Device: ",$PIECE(X,U,2)

 +15               WRITE !,?2,"   Node: ",$PIECE(X,U,10),?39,"     IP: ",$SELECT($LENGTH($PIECE(X,U,11)):$PIECE(X,U,11),1:$PIECE(X,U,12))

 +16               QUIT

               End DoDot:1

 +17       IF $PIECE(^VA(200,IEN,1.1),U,5)

               WRITE !,"Locked out until ",$$FMTE^XLFDT($PIECE(^VA(200,IEN,1.1),U,5))," because of too many invalid attempts."

 +18      ;

 +19       SET DIR(0)="Y"

           SET DIR("A")="Release this user"

           SET DIR("B")="Yes"

           DO ^DIR

 +20       IF 'Y

               GOTO X8A

 +21      ;Clear flag,Lockout time

           SET $PIECE(^VA(200,IEN,1.1),"^",3)=0

           SET $PIECE(^VA(200,IEN,1.1),U,5)=""

 +22       SET J=0

FOR

               SET J=$ORDER(^XUSEC(0,"CUR",IEN,J))

               if J'>0

                   QUIT

               Begin DoDot:1

 +23               SET FDA(3.081,J_",",3)=$$NOW^XLFDT

                   SET FDA(3.081,J_",",16)=1

                   DO UPDATE^DIE("","FDA")

               End DoDot:1

 +24       WRITE !,"User is RELEASED!!",!

EX8        QUIT

 +1       ;

SCPURG    ;Purge sign-on log

 +1        SET XUDT=$$HTFM^XLFDT($HOROLOG-30)

           IF $ORDER(^XUSEC(0,0))'>0

               GOTO SCEXIT

 +2        SET DIK="^XUSEC(0,"

           FOR DA=0:0

               SET DA=$ORDER(^XUSEC(0,DA))

               if (DA'>0)!(DA>XUDT)

                   QUIT

               DO ^DIK

SCEXIT     KILL DIK,DA,XUDT,X1,X2

           QUIT

IXKEY     ;Re-Index the New Person file Key sub-file

 +1        NEW DA,DIK,ACT

 +2        if '$DATA(ZTQUEUED)

               WRITE !,"Starting"

 +3       ;we only want to reindex the "AC" x-ref

 +4        SET DIK(1)=".01^AC"

 +5       ;loop through New Person file and index entries

 +6        FOR DA(1)=0:0

               SET DA(1)=$ORDER(^VA(200,DA(1)))

               if DA(1)'>0

                   QUIT

               Begin DoDot:1

 +7       ;skip inactive person

 +8       ;Q:$P($G(^VA(200,DA(1),0)),"^",11)

 +9                SET ACT=+$$ACTIVE^XUSER(DA(1))

 +10               IF ACT'=1

                       QUIT

 +11      ;global root for multiple

 +12               SET DIK="^VA(200,DA(1),51,"

 +13      ;reindex

 +14               DO ENALL^DIK

                   if '(DA(1)#50)

                       WRITE "."

 +15      ;

               End DoDot:1

 +16       if '$DATA(ZTQUEUED)

               WRITE !,"Done"

 +17      ;

 +18      ;the old codes

 +19      ;W:'$D(ZTQUEUED) !,"Starting "

 +20      ;S DIK="^VA(200,DA(1),51,",DIK(1)=".01^1^2^3^4"

 +21      ;F DA(1)=0:0 S DA(1)=$O(^VA(200,DA(1))) Q:DA(1)'>0  D ENALL^DIK W:'(DA(1)#50) "."

 +22      ;W:'$D(ZTQUEUED) !,"Done"

 +23       QUIT

XUSMGR.m