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 ---[H[J[2J[HXUBA 2475 printed Sep 23, 2025@19:45:09 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
