- 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 Apr 23, 2025@18:22:26 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
