XUSEHRM2 ; BA/OAK - EHRM REVERSED LOCK - REPORTS; Jan 19, 2022@03:33:20
;;8.0;KERNEL;**758**;Jul 10, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified
Q
7 ;List Users Holding a Certain Key
N XUSKEY,XUSKEYN,XUSCSV
S XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ") I XUSKEY'>0 Q 0
W !
S XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format") I XUSCSV="^" Q 0
W !
D QUEUE7
Q
;--------------------------------------------------------------------
8 ;List Users who do not have a certain Program Replacement Key
N XUSKEY,XUSKEYN,XUSCSV
S XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ") I XUSKEY'>0 Q 0
W !
S XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format?") I XUSCSV="^" Q 0
W !
D QUEUE8
Q
;--------------------------------------------------------------------
9 ;List Options with a Replacement Program Key
N XUSKEY,XUSKEYN,XUSCSV
S XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ") I XUSKEY'>0 Q 0
W !
S XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format") I XUSCSV="^" Q 0
W !
D QUEUE9
Q
;------------------------------------------------------------------
10 ;List Options that do not have a Replacement Program Key
N XUSKEY,XUSKEYN,XUSCSV
S XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ") I XUSKEY'>0 Q 0
W !
S XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format") I XUSCSV="^" Q 0
W !
D QUEUE10
Q
;--------------------------------------------------------------------
REPORT9 ;loop through the OPTION file to check REVERSE/NEGATIVE LOCK
N XUOPTIEN,XUSDATA S XUOPTIEN=0
U IO
I XUSCSV>0 W !,"OPTION NAME|NEGATIVE LOCK|LOCK",!,"------------------------------"
I XUSCSV'>0 W !,"Option Name",?35,"Negative Lock",?60,"Lock",!,"------------",?35,"--------------",?60,"----"
F S XUOPTIEN=$O(^DIC(19,XUOPTIEN)) Q:XUOPTIEN'>0 D
. I $P($G(^DIC(19,XUOPTIEN,3)),"^")'=$P($G(^DIC(19.1,XUSKEY,0)),"^") Q
. D PRFMAT1(XUOPTIEN,XUSCSV,XUSKEY)
U IO D ^%ZISC
Q
;---------------------------------------------------------------------
REPORT10 ;loop through the OPTION file to check REVERSE/NEGATIVE LOCK
N XUOPTIEN,XUSDATA S XUOPTIEN=0
U IO
I XUSCSV>0 W !,"OPTION NAME|NEGATIVE LOCK|LOCK",!,"------------------------------"
I XUSCSV'>0 W !,"Option Name",?35,"Negative Lock",?60,"Lock",!,"------------",?35,"--------------",?60,"----"
F S XUOPTIEN=$O(^DIC(19,XUOPTIEN)) Q:XUOPTIEN'>0 D
. I $P($G(^DIC(19,XUOPTIEN,3)),"^")=$P($G(^DIC(19.1,XUSKEY,0)),"^") Q
. D PRFMAT1(XUOPTIEN,XUSCSV)
U IO D ^%ZISC
Q
;--------------------------------------------------------------------
QUEUE7 ;
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTSAVE("XUSKEY")="",ZTSAVE("XUSCSV")=""
. S ZTIO=ION,ZTRTN="REPORT7^XUSEHRM2",ZTDESC="Report users who have the Key "_XUSKEY
. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS
D REPORT7
Q
;--------------------------------------------------------------------
QUEUE8 ;
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTSAVE("XUSKEY")="",ZTSAVE("XUSCSV")=""
. S ZTIO=ION,ZTRTN="REPORT8^XUSEHRM2",ZTDESC="Report users who DO NOT have the Key "_XUSKEY
. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS
D REPORT8
Q
;-------------------------------------------------------------------
QUEUE9 ;
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTSAVE("XUSKEY")="",ZTSAVE("XUSCSV")=""
. S ZTIO=ION,ZTRTN="REPORT9^XUSEHRM2",ZTDESC="Report options those have REVERSE/NEGATIVE LOCK "_XUSKEY
. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS
D REPORT9
Q
;--------------------------------------------------------------------
QUEUE10 ;
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTSAVE("XUSKEY")="",ZTSAVE("XUSCSV")=""
. S ZTIO=ION,ZTRTN="REPORT10^XUSEHRM2",ZTDESC="Report options those DO NOT have REVERSE/NEGATIVE LOCK "_XUSKEY
. D ^%ZTLOAD W:$D(ZTSK) !,"Queued as Task "_ZTSK D HOME^%ZIS
D REPORT10
Q
;--------------------------------------------------------------------
REPORT7 ; loop through the NEW PERSON file to check users who have the Program Replacement Key
N XUS,XUSKEYN,XUNAME
S XUS=0
U IO
S XUSKEYN=$P($G(^DIC(19.1,XUSKEY,0)),"^")
I XUSCSV>0 W !,"NAME|DUZ|SEVICE/SECTION|PRIMARY MENU|LAST SIGN_ON"
F S XUS=$O(^VA(200,XUS)) Q:XUS'>0 D
. I +$D(^XUSEC(XUSKEYN,XUS))'>0 Q
. D PRFMAT(XUS,XUSCSV)
U IO D ^%ZISC
Q
;-------------------------------------------------------------------
REPORT8 ;loop through the NEW PERSON file to check users who DO NOT have the Program Replacement Key
N XUS,XUSKEYN,XUNAME
S XUS=0
U IO
S XUSKEYN=$P($G(^DIC(19.1,XUSKEY,0)),"^")
I XUSCSV>0 W !,"NAME|DUZ|SEVICE/SECTION|PRIMARY MENU|LAST SIGN_ON"
F S XUS=$O(^VA(200,XUS)) Q:XUS'>0 D
. I +$D(^XUSEC(XUSKEYN,XUS))>0 Q
. D PRFMAT(XUS,XUSCSV)
U IO D ^%ZISC
Q
;---------------------------------------------------------------------
PRFMAT(XUSERIEN,XUSCSV) ; PRINT OUT FORMAT FOR OPTIONS 7 AND 8
N XUSINFO,XUSERV,XUSPMN,XUSDTSN
U IO
S XUSINFO=$G(^VA(200,XUSERIEN,0)) I $P(XUSINFO,"^")="" Q
S XUSERV=$P($G(^VA(200,XUSERIEN,5)),"^") I XUSERV>0 S XUSERV=$P($G(^DIC(49,XUSERV,0)),"^")
S XUSPMN=$P($G(^VA(200,XUSERIEN,201)),"^") I XUSPMN>0 S XUSPMN=$P($G(^DIC(19,XUSPMN,0)),"^")
S XUSDTSN=$P($G(^VA(200,XUSERIEN,1.1)),"^")
S XUSDTSN=$$FMTE^XLFDT(XUSDTSN,"4D")
I XUSCSV>0 W !,$P(XUSINFO,"^"),"|",XUSERIEN,"|",XUSERV,"|",XUSPMN,"|",XUSDTSN
I XUSCSV'>0 W !,"NAME: ",$P(XUSINFO,"^"),?40,"DUZ :",XUSERIEN,!,"SERVICE/SECTION: ",XUSERV,?40,"PRIMARY MENU: ",XUSPMN,!,"LAST SIGN-ON: ",XUSDTSN,!
Q
;---------------------------------------------------------------------
PRFMAT1(XUOPIEN,XUSCSV,XUSKEY) ; PRINT OUT FORMAT FOR OPTIONS 9 AND 10
N XUSINFO,XUK,XUK1
U IO
S XUSINFO=$G(^DIC(19,XUOPIEN,0)) I $P(XUSINFO,"^")="" Q
S XUK=$P(XUSINFO,"^",5) I +XUK>0 S XUK=$P($G(^DIC(19.1,XUK,0)),"^")
S XUK1=$P($G(^DIC(19,XUOPIEN,3)),"^")
I XUSCSV>0 W !,$P(XUSINFO,"^"),"|",XUK1,"|",XUK
I XUSCSV'>0 W !,$P(XUSINFO,"^"),?35,XUK1,?60,XUK
Q
;-------------------------------------------------------------------------
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSEHRM2 6312 printed Sep 23, 2025@19:48:33 Page 2
XUSEHRM2 ; BA/OAK - EHRM REVERSED LOCK - REPORTS; Jan 19, 2022@03:33:20
+1 ;;8.0;KERNEL;**758**;Jul 10, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
7 ;List Users Holding a Certain Key
+1 NEW XUSKEY,XUSKEYN,XUSCSV
+2 SET XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ")
IF XUSKEY'>0
QUIT 0
+3 WRITE !
+4 SET XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format")
IF XUSCSV="^"
QUIT 0
+5 WRITE !
+6 DO QUEUE7
+7 QUIT
+8 ;--------------------------------------------------------------------
8 ;List Users who do not have a certain Program Replacement Key
+1 NEW XUSKEY,XUSKEYN,XUSCSV
+2 SET XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ")
IF XUSKEY'>0
QUIT 0
+3 WRITE !
+4 SET XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format?")
IF XUSCSV="^"
QUIT 0
+5 WRITE !
+6 DO QUEUE8
+7 QUIT
+8 ;--------------------------------------------------------------------
9 ;List Options with a Replacement Program Key
+1 NEW XUSKEY,XUSKEYN,XUSCSV
+2 SET XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ")
IF XUSKEY'>0
QUIT 0
+3 WRITE !
+4 SET XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format")
IF XUSCSV="^"
QUIT 0
+5 WRITE !
+6 DO QUEUE9
+7 QUIT
+8 ;------------------------------------------------------------------
10 ;List Options that do not have a Replacement Program Key
+1 NEW XUSKEY,XUSKEYN,XUSCSV
+2 SET XUSKEY=+$$ASKKEY^XUSEHRM1("Which Program Replacement Key do you want to check? ")
IF XUSKEY'>0
QUIT 0
+3 WRITE !
+4 SET XUSCSV=$$YN^XUSEHRM1("Do you want to save this in CSV (Excel) Format")
IF XUSCSV="^"
QUIT 0
+5 WRITE !
+6 DO QUEUE10
+7 QUIT
+8 ;--------------------------------------------------------------------
REPORT9 ;loop through the OPTION file to check REVERSE/NEGATIVE LOCK
+1 NEW XUOPTIEN,XUSDATA
SET XUOPTIEN=0
+2 USE IO
+3 IF XUSCSV>0
WRITE !,"OPTION NAME|NEGATIVE LOCK|LOCK",!,"------------------------------"
+4 IF XUSCSV'>0
WRITE !,"Option Name",?35,"Negative Lock",?60,"Lock",!,"------------",?35,"--------------",?60,"----"
+5 FOR
SET XUOPTIEN=$ORDER(^DIC(19,XUOPTIEN))
if XUOPTIEN'>0
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^DIC(19,XUOPTIEN,3)),"^")'=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
QUIT
+7 DO PRFMAT1(XUOPTIEN,XUSCSV,XUSKEY)
End DoDot:1
+8 USE IO
DO ^%ZISC
+9 QUIT
+10 ;---------------------------------------------------------------------
REPORT10 ;loop through the OPTION file to check REVERSE/NEGATIVE LOCK
+1 NEW XUOPTIEN,XUSDATA
SET XUOPTIEN=0
+2 USE IO
+3 IF XUSCSV>0
WRITE !,"OPTION NAME|NEGATIVE LOCK|LOCK",!,"------------------------------"
+4 IF XUSCSV'>0
WRITE !,"Option Name",?35,"Negative Lock",?60,"Lock",!,"------------",?35,"--------------",?60,"----"
+5 FOR
SET XUOPTIEN=$ORDER(^DIC(19,XUOPTIEN))
if XUOPTIEN'>0
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^DIC(19,XUOPTIEN,3)),"^")=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
QUIT
+7 DO PRFMAT1(XUOPTIEN,XUSCSV)
End DoDot:1
+8 USE IO
DO ^%ZISC
+9 QUIT
+10 ;--------------------------------------------------------------------
QUEUE7 ;
+1 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTSAVE("XUSKEY")=""
SET ZTSAVE("XUSCSV")=""
+4 SET ZTIO=ION
SET ZTRTN="REPORT7^XUSEHRM2"
SET ZTDESC="Report users who have the Key "_XUSKEY
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as Task "_ZTSK
DO HOME^%ZIS
End DoDot:1
QUIT
+6 DO REPORT7
+7 QUIT
+8 ;--------------------------------------------------------------------
QUEUE8 ;
+1 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTSAVE("XUSKEY")=""
SET ZTSAVE("XUSCSV")=""
+4 SET ZTIO=ION
SET ZTRTN="REPORT8^XUSEHRM2"
SET ZTDESC="Report users who DO NOT have the Key "_XUSKEY
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as Task "_ZTSK
DO HOME^%ZIS
End DoDot:1
QUIT
+6 DO REPORT8
+7 QUIT
+8 ;-------------------------------------------------------------------
QUEUE9 ;
+1 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTSAVE("XUSKEY")=""
SET ZTSAVE("XUSCSV")=""
+4 SET ZTIO=ION
SET ZTRTN="REPORT9^XUSEHRM2"
SET ZTDESC="Report options those have REVERSE/NEGATIVE LOCK "_XUSKEY
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as Task "_ZTSK
DO HOME^%ZIS
End DoDot:1
QUIT
+6 DO REPORT9
+7 QUIT
+8 ;--------------------------------------------------------------------
QUEUE10 ;
+1 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTSAVE("XUSKEY")=""
SET ZTSAVE("XUSCSV")=""
+4 SET ZTIO=ION
SET ZTRTN="REPORT10^XUSEHRM2"
SET ZTDESC="Report options those DO NOT have REVERSE/NEGATIVE LOCK "_XUSKEY
+5 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued as Task "_ZTSK
DO HOME^%ZIS
End DoDot:1
QUIT
+6 DO REPORT10
+7 QUIT
+8 ;--------------------------------------------------------------------
REPORT7 ; loop through the NEW PERSON file to check users who have the Program Replacement Key
+1 NEW XUS,XUSKEYN,XUNAME
+2 SET XUS=0
+3 USE IO
+4 SET XUSKEYN=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
+5 IF XUSCSV>0
WRITE !,"NAME|DUZ|SEVICE/SECTION|PRIMARY MENU|LAST SIGN_ON"
+6 FOR
SET XUS=$ORDER(^VA(200,XUS))
if XUS'>0
QUIT
Begin DoDot:1
+7 IF +$DATA(^XUSEC(XUSKEYN,XUS))'>0
QUIT
+8 DO PRFMAT(XUS,XUSCSV)
End DoDot:1
+9 USE IO
DO ^%ZISC
+10 QUIT
+11 ;-------------------------------------------------------------------
REPORT8 ;loop through the NEW PERSON file to check users who DO NOT have the Program Replacement Key
+1 NEW XUS,XUSKEYN,XUNAME
+2 SET XUS=0
+3 USE IO
+4 SET XUSKEYN=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
+5 IF XUSCSV>0
WRITE !,"NAME|DUZ|SEVICE/SECTION|PRIMARY MENU|LAST SIGN_ON"
+6 FOR
SET XUS=$ORDER(^VA(200,XUS))
if XUS'>0
QUIT
Begin DoDot:1
+7 IF +$DATA(^XUSEC(XUSKEYN,XUS))>0
QUIT
+8 DO PRFMAT(XUS,XUSCSV)
End DoDot:1
+9 USE IO
DO ^%ZISC
+10 QUIT
+11 ;---------------------------------------------------------------------
PRFMAT(XUSERIEN,XUSCSV) ; PRINT OUT FORMAT FOR OPTIONS 7 AND 8
+1 NEW XUSINFO,XUSERV,XUSPMN,XUSDTSN
+2 USE IO
+3 SET XUSINFO=$GET(^VA(200,XUSERIEN,0))
IF $PIECE(XUSINFO,"^")=""
QUIT
+4 SET XUSERV=$PIECE($GET(^VA(200,XUSERIEN,5)),"^")
IF XUSERV>0
SET XUSERV=$PIECE($GET(^DIC(49,XUSERV,0)),"^")
+5 SET XUSPMN=$PIECE($GET(^VA(200,XUSERIEN,201)),"^")
IF XUSPMN>0
SET XUSPMN=$PIECE($GET(^DIC(19,XUSPMN,0)),"^")
+6 SET XUSDTSN=$PIECE($GET(^VA(200,XUSERIEN,1.1)),"^")
+7 SET XUSDTSN=$$FMTE^XLFDT(XUSDTSN,"4D")
+8 IF XUSCSV>0
WRITE !,$PIECE(XUSINFO,"^"),"|",XUSERIEN,"|",XUSERV,"|",XUSPMN,"|",XUSDTSN
+9 IF XUSCSV'>0
WRITE !,"NAME: ",$PIECE(XUSINFO,"^"),?40,"DUZ :",XUSERIEN,!,"SERVICE/SECTION: ",XUSERV,?40,"PRIMARY MENU: ",XUSPMN,!,"LAST SIGN-ON: ",XUSDTSN,!
+10 QUIT
+11 ;---------------------------------------------------------------------
PRFMAT1(XUOPIEN,XUSCSV,XUSKEY) ; PRINT OUT FORMAT FOR OPTIONS 9 AND 10
+1 NEW XUSINFO,XUK,XUK1
+2 USE IO
+3 SET XUSINFO=$GET(^DIC(19,XUOPIEN,0))
IF $PIECE(XUSINFO,"^")=""
QUIT
+4 SET XUK=$PIECE(XUSINFO,"^",5)
IF +XUK>0
SET XUK=$PIECE($GET(^DIC(19.1,XUK,0)),"^")
+5 SET XUK1=$PIECE($GET(^DIC(19,XUOPIEN,3)),"^")
+6 IF XUSCSV>0
WRITE !,$PIECE(XUSINFO,"^"),"|",XUK1,"|",XUK
+7 IF XUSCSV'>0
WRITE !,$PIECE(XUSINFO,"^"),?35,XUK1,?60,XUK
+8 QUIT
+9 ;-------------------------------------------------------------------------
