XUBA.m

XUBA ; BT/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 4/27/2010

 ;;8.0;KERNEL;**541**; July 10, 1995;Build 6

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 Q

 ;

PR ; entry point of the option LIST USERS NEED TO BE ASSIGNED NEW PERSON CLASSES

 N DIR,XUA541,Y S DIR("A")="Do you want to list active users only",DIR(0)="Y",DIR("B")="NO" D ^DIR

 S XUA541=$G(Y) I XUA541="^" Q

 W @IOF,! S %ZIS="MQ" D ^%ZIS G:POP EXIT

 I $D(IO("Q")) S ZTIO=ION,ZTRTN="PRNT^XUBA",ZTSAVE("XUA541")="",ZTDESC="LIST USERS NEED PERSON CLASSES" D ^%ZTLOAD D HOME^%ZIS

 I $D(ZTSK) W !,"Queued as task# ",ZTSK,!! D PAUSE G EXIT

 ;

PRNT ; print the report

 U IO D INPSC,LIST(XUA541)

 N XUI,XUC,XUPG,XUB S XUC=0,XUPG=1,XUB=0

 N XUPSUP D PGBK ;set value of the page break for devices

 D HDR  ;Header

 S XUI="" F  S XUI=$O(^TMP("XUINPSCN",$J,XUI)) Q:XUI=""  D

 . W !,$G(XUI),?20,$G(^TMP("XUINPSCN",$J,XUI))

 . S XUC=XUC+1

 . X XUPSUP ;page set up and break

 I XUB=1 Q

 W !!!,"Number of users: ",XUC

 I $E(IOST,1,2)="C-" W !! D PAUSE

 D EXIT

 Q

 ;

INPSC ;get all inactive Person Class from the PERSON CLASS FILE.

 N XUI,XUY,COUNT

 K ^TMP("XUINPSC",$J)

 S COUNT=$P($G(^USC(8932.1,0)),"^",4)

 F XUI=1:1:COUNT D

 . I $$GET3^XUPCF(XUI)="Inactive" S ^TMP("XUINPSC",$J,XUI)=$$GET5^XUPCF(XUI)

 Q

 ;

LIST(XUA541) ; get all users who need to be assigned a new Person Class.

 N XUI,XUY,XUV,XUIEN,%

 K ^TMP("XUINPSCN",$J)

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

 . I XUA541=1,'(+$$ACTIVE^XUSER(XUIEN)) Q

 . S XUY=+$$GET^XUA4A72(XUIEN) Q:XUY'>0

 . I $D(^TMP("XUINPSC",$J,XUY)) D

 . . N XUNAME S XUNAME=$E($P($G(^VA(200,XUIEN,0)),"^"),1,18)

 . . I XUNAME'="" S ^TMP("XUINPSCN",$J,XUNAME)=$E($P($$GET^XUA4A72(XUIEN),"^",1,2),1,60)

 Q

 ;

CLEAN ;clean the global

 K ^TMP("XUINPSC",$J)

 K ^TMP("XUINPSCN",$J)

 Q

 ;

PGBK ;page break

 S XUPSUP="I $Y>(IOSL-3) S XUPG=XUPG+1 W @IOF D HDR"

 I $E(IOST,1,2)="C-" S XUPSUP="I $Y>(IOSL-3) S XUPG=XUPG+1 D PAUSE I XUB'=1 W @IOF D HDR"

 Q

 ;

HDR ;

 W ?IOM-40,"Report on ",$$FMTE^XLFDT($$DT^XLFDT),"    Page ",$G(XUPG),!

 W !,"User name:",?20,"Currently has the inactive Person Class IEN^NAME:"

 W !,"----------",?20,"-------------------------------------------------"

 Q

 ;

PAUSE ;

 W !,"Press RETURN to continue or '^' to exit: " R XUB:DTIME

 I '$T S XUI="zzzzzzzzz"

 I XUB["^" S XUI="zzzzzzzzz",XUB=1

 Q

 ;

EXIT ;

 D CLEAN

 D ^%ZISC

 K %ZIS,ZTDESC,ZTSK,ZTIO,ZTRTN,ZTSAVE

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XUBA   2475     printed  Feb 18, 2025@23:35:26                                                                                                                                                                                                        Page 2

XUBA      ; BT/BP - LIST USERS HAVE INACTIVE PERSON CLASSES; 4/27/2010

 +1       ;;8.0;KERNEL;**541**; July 10, 1995;Build 6

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3        QUIT 

 +4       ;

PR        ; entry point of the option LIST USERS NEED TO BE ASSIGNED NEW PERSON CLASSES

 +1        NEW DIR,XUA541,Y

           SET DIR("A")="Do you want to list active users only"

           SET DIR(0)="Y"

           SET DIR("B")="NO"

           DO ^DIR

 +2        SET XUA541=$GET(Y)

           IF XUA541="^"

               QUIT 

 +3        WRITE @IOF,!

           SET %ZIS="MQ"

           DO ^%ZIS

           if POP

               GOTO EXIT

 +4        IF $DATA(IO("Q"))

               SET ZTIO=ION

               SET ZTRTN="PRNT^XUBA"

               SET ZTSAVE("XUA541")=""

               SET ZTDESC="LIST USERS NEED PERSON CLASSES"

               DO ^%ZTLOAD

               DO HOME^%ZIS

 +5        IF $DATA(ZTSK)

               WRITE !,"Queued as task# ",ZTSK,!!

               DO PAUSE

               GOTO EXIT

 +6       ;

PRNT      ; print the report

 +1        USE IO

           DO INPSC

           DO LIST(XUA541)

 +2        NEW XUI,XUC,XUPG,XUB

           SET XUC=0

           SET XUPG=1

           SET XUB=0

 +3       ;set value of the page break for devices

           NEW XUPSUP

           DO PGBK

 +4       ;Header

           DO HDR

 +5        SET XUI=""

           FOR 

               SET XUI=$ORDER(^TMP("XUINPSCN",$JOB,XUI))

               if XUI=""

                   QUIT 

               Begin DoDot:1

 +6                WRITE !,$GET(XUI),?20,$GET(^TMP("XUINPSCN",$JOB,XUI))

 +7                SET XUC=XUC+1

 +8       ;page set up and break

                   XECUTE XUPSUP

               End DoDot:1

 +9        IF XUB=1

               QUIT 

 +10       WRITE !!!,"Number of users: ",XUC

 +11       IF $EXTRACT(IOST,1,2)="C-"

               WRITE !!

               DO PAUSE

 +12       DO EXIT

 +13       QUIT 

 +14      ;

INPSC     ;get all inactive Person Class from the PERSON CLASS FILE.

 +1        NEW XUI,XUY,COUNT

 +2        KILL ^TMP("XUINPSC",$JOB)

 +3        SET COUNT=$PIECE($GET(^USC(8932.1,0)),"^",4)

 +4        FOR XUI=1:1:COUNT

               Begin DoDot:1

 +5                IF $$GET3^XUPCF(XUI)="Inactive"

                       SET ^TMP("XUINPSC",$JOB,XUI)=$$GET5^XUPCF(XUI)

               End DoDot:1

 +6        QUIT 

 +7       ;

LIST(XUA541) ; get all users who need to be assigned a new Person Class.

 +1        NEW XUI,XUY,XUV,XUIEN,%

 +2        KILL ^TMP("XUINPSCN",$JOB)

 +3        SET XUIEN=0

           FOR 

               SET XUIEN=$ORDER(^VA(200,XUIEN))

               if XUIEN'>0

                   QUIT 

               Begin DoDot:1

 +4                IF XUA541=1

                       IF '(+$$ACTIVE^XUSER(XUIEN))

                           QUIT 

 +5                SET XUY=+$$GET^XUA4A72(XUIEN)

                   if XUY'>0

                       QUIT 

 +6                IF $DATA(^TMP("XUINPSC",$JOB,XUY))

                       Begin DoDot:2

 +7                        NEW XUNAME

                           SET XUNAME=$EXTRACT($PIECE($GET(^VA(200,XUIEN,0)),"^"),1,18)

 +8                        IF XUNAME'=""

                               SET ^TMP("XUINPSCN",$JOB,XUNAME)=$EXTRACT($PIECE($$GET^XUA4A72(XUIEN),"^",1,2),1,60)

                       End DoDot:2

               End DoDot:1

 +9        QUIT 

 +10      ;

CLEAN     ;clean the global

 +1        KILL ^TMP("XUINPSC",$JOB)

 +2        KILL ^TMP("XUINPSCN",$JOB)

 +3        QUIT 

 +4       ;

PGBK      ;page break

 +1        SET XUPSUP="I $Y>(IOSL-3) S XUPG=XUPG+1 W @IOF D HDR"

 +2        IF $EXTRACT(IOST,1,2)="C-"

               SET XUPSUP="I $Y>(IOSL-3) S XUPG=XUPG+1 D PAUSE I XUB'=1 W @IOF D HDR"

 +3        QUIT 

 +4       ;

HDR       ;

 +1        WRITE ?IOM-40,"Report on ",$$FMTE^XLFDT($$DT^XLFDT),"    Page ",$GET(XUPG),!

 +2        WRITE !,"User name:",?20,"Currently has the inactive Person Class IEN^NAME:"

 +3        WRITE !,"----------",?20,"-------------------------------------------------"

 +4        QUIT 

 +5       ;

PAUSE     ;

 +1        WRITE !,"Press RETURN to continue or '^' to exit: "

           READ XUB:DTIME

 +2        IF '$TEST

               SET XUI="zzzzzzzzz"

 +3        IF XUB["^"

               SET XUI="zzzzzzzzz"

               SET XUB=1

 +4        QUIT 

 +5       ;

EXIT      ;

 +1        DO CLEAN

 +2        DO ^%ZISC

 +3        KILL %ZIS,ZTDESC,ZTSK,ZTIO,ZTRTN,ZTSAVE

 +4        QUIT