XU8P497A ;BP/BT - UPDATE PERSON CLASS FILE; 4/7/2008
;;8.0;KERNEL;**497**;July 10, 1995;Build 5
;;"Per VHA Directive 2004-038, this routine should not be modified."
;
EN ;
N XU1,XU2,XUPCIEN,XUDATA
F XU1=1:1:1 S XUDATA=$P($T(INAC+XU1),";",3,99) D
. F XU2=1:1 S XUPCIEN=$P(XUDATA,";",XU2) Q:XUPCIEN="$END$" D CHCK
Q
INAC ;;
;;187;247;353;515;517;519;522;$END$
;;$END$;;
;;
;;
LOOP N XUIEN,XUIEN2,XUEXDA,XUDIUSR,XUACTIVE,XUACONLY,%
W !,"This report will run immediately (no device asked)."
W !,"Users may turn 'screen capture' for this report."
R !,"Do you want to list active users only? NO// ",%:20 Q:'$T
S %=$TR($E(%),"YyNn","1100") I %="^" Q
W !
K ^TMP("XU8P497")
S XUIEN=0 F S XUIEN=$O(^VA(200,XUIEN)) Q:XUIEN'>0 D
. I %=1,'(+$$ACTIVE^XUSER(XUIEN)) Q
. S XUACTIVE=$P($$ACTIVE^XUSER(XUIEN),"^",2)
. S XUDIUSR=XUACTIVE
. D EN
D PRNT
Q
CHCK ;
I '$D(^VA(200,XUIEN,"USC1","B",XUPCIEN)) Q
S XUIEN2=$O(^VA(200,XUIEN,"USC1","B",XUPCIEN,"A"),-1)
S XUEXDA=$P($G(^VA(200,XUIEN,"USC1",XUIEN2,0)),"^",3)
I ('XUEXDA)!(XUEXDA>DT) D
. S ^TMP("XU8P497",$J,XUPCIEN,XUIEN)=$P($G(^VA(200,XUIEN,0)),"^",1)_"^"_XUDIUSR
Q
PRNT ;
N XUI,XUY,XUV,XUCOUNT,XUC S XUC=0
S XUI=0 F S XUI=$O(^TMP("XU8P497",$J,XUI)) Q:XUI'>0 D
. S XUV=$G(^USC(8932.1,XUI,0))
. W !,"PERSON CLASS ID: ",XUI,?28," NAME: ",$E($P(XUV,"^",1),1,40)
. W !," VA CODE: ",$P(XUV,"^",6),?28,"X12 CODE: ",$P(XUV,"^",7)
. S XUCOUNT=0
. W !!,"User Name",?34,"Status"
. S XUY=0 F S XUY=$O(^TMP("XU8P497",$J,XUI,XUY)) Q:XUY'>0 D
. . W !,?2,$P($G(^TMP("XU8P497",$J,XUI,XUY)),"^"),?36,$P($G(^TMP("XU8P497",$J,XUI,XUY)),"^",2)
. . S XUCOUNT=XUCOUNT+1
. W !!,?10,"Number of users: ",XUCOUNT
. W !,"------------------------------"
. S XUC=XUC+1
I XUC=0 W !,"No users found. You are done!"
I XUC>0 W !!," Please check and assign replacement Person Classes",!," for users listed on this report."
D ^%ZISC
Q
;
PRINT ;
N XUI,XUY,XUC S (XUI,XUC)=0
W !,"This report will run immediately (no device asked)."
W !,"Users may turn 'screen capture' for this report."
R !,"Enter any key to continue ",XUY:10 Q:'$T
F S XUI=$O(^TMP("XU8P497",$J,XUI)) Q:XUI'>0 D
. W !,$G(^TMP("XU8P497",$J,XUI)) S XUC=XUC+1
I XUC=0 W !!,"No replacement Person Class is assigned for users."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8P497A 2329 printed Oct 16, 2024@18:08:44 Page 2
XU8P497A ;BP/BT - UPDATE PERSON CLASS FILE; 4/7/2008
+1 ;;8.0;KERNEL;**497**;July 10, 1995;Build 5
+2 ;;"Per VHA Directive 2004-038, this routine should not be modified."
+3 ;
EN ;
+1 NEW XU1,XU2,XUPCIEN,XUDATA
+2 FOR XU1=1:1:1
SET XUDATA=$PIECE($TEXT(INAC+XU1),";",3,99)
Begin DoDot:1
+3 FOR XU2=1:1
SET XUPCIEN=$PIECE(XUDATA,";",XU2)
if XUPCIEN="$END$"
QUIT
DO CHCK
End DoDot:1
+4 QUIT
INAC ;;
+1 ;;187;247;353;515;517;519;522;$END$
+2 ;;$END$;;
+3 ;;
+4 ;;
LOOP NEW XUIEN,XUIEN2,XUEXDA,XUDIUSR,XUACTIVE,XUACONLY,%
+1 WRITE !,"This report will run immediately (no device asked)."
+2 WRITE !,"Users may turn 'screen capture' for this report."
+3 READ !,"Do you want to list active users only? NO// ",%:20
if '$TEST
QUIT
+4 SET %=$TRANSLATE($EXTRACT(%),"YyNn","1100")
IF %="^"
QUIT
+5 WRITE !
+6 KILL ^TMP("XU8P497")
+7 SET XUIEN=0
FOR
SET XUIEN=$ORDER(^VA(200,XUIEN))
if XUIEN'>0
QUIT
Begin DoDot:1
+8 IF %=1
IF '(+$$ACTIVE^XUSER(XUIEN))
QUIT
+9 SET XUACTIVE=$PIECE($$ACTIVE^XUSER(XUIEN),"^",2)
+10 SET XUDIUSR=XUACTIVE
+11 DO EN
End DoDot:1
+12 DO PRNT
+13 QUIT
CHCK ;
+1 IF '$DATA(^VA(200,XUIEN,"USC1","B",XUPCIEN))
QUIT
+2 SET XUIEN2=$ORDER(^VA(200,XUIEN,"USC1","B",XUPCIEN,"A"),-1)
+3 SET XUEXDA=$PIECE($GET(^VA(200,XUIEN,"USC1",XUIEN2,0)),"^",3)
+4 IF ('XUEXDA)!(XUEXDA>DT)
Begin DoDot:1
+5 SET ^TMP("XU8P497",$JOB,XUPCIEN,XUIEN)=$PIECE($GET(^VA(200,XUIEN,0)),"^",1)_"^"_XUDIUSR
End DoDot:1
+6 QUIT
PRNT ;
+1 NEW XUI,XUY,XUV,XUCOUNT,XUC
SET XUC=0
+2 SET XUI=0
FOR
SET XUI=$ORDER(^TMP("XU8P497",$JOB,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+3 SET XUV=$GET(^USC(8932.1,XUI,0))
+4 WRITE !,"PERSON CLASS ID: ",XUI,?28," NAME: ",$EXTRACT($PIECE(XUV,"^",1),1,40)
+5 WRITE !," VA CODE: ",$PIECE(XUV,"^",6),?28,"X12 CODE: ",$PIECE(XUV,"^",7)
+6 SET XUCOUNT=0
+7 WRITE !!,"User Name",?34,"Status"
+8 SET XUY=0
FOR
SET XUY=$ORDER(^TMP("XU8P497",$JOB,XUI,XUY))
if XUY'>0
QUIT
Begin DoDot:2
+9 WRITE !,?2,$PIECE($GET(^TMP("XU8P497",$JOB,XUI,XUY)),"^"),?36,$PIECE($GET(^TMP("XU8P497",$JOB,XUI,XUY)),"^",2)
+10 SET XUCOUNT=XUCOUNT+1
End DoDot:2
+11 WRITE !!,?10,"Number of users: ",XUCOUNT
+12 WRITE !,"------------------------------"
+13 SET XUC=XUC+1
End DoDot:1
+14 IF XUC=0
WRITE !,"No users found. You are done!"
+15 IF XUC>0
WRITE !!," Please check and assign replacement Person Classes",!," for users listed on this report."
+16 DO ^%ZISC
+17 QUIT
+18 ;
PRINT ;
+1 NEW XUI,XUY,XUC
SET (XUI,XUC)=0
+2 WRITE !,"This report will run immediately (no device asked)."
+3 WRITE !,"Users may turn 'screen capture' for this report."
+4 READ !,"Enter any key to continue ",XUY:10
if '$TEST
QUIT
+5 FOR
SET XUI=$ORDER(^TMP("XU8P497",$JOB,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+6 WRITE !,$GET(^TMP("XU8P497",$JOB,XUI))
SET XUC=XUC+1
End DoDot:1
+7 IF XUC=0
WRITE !!,"No replacement Person Class is assigned for users."
+8 QUIT
