XQ55SPEC ; SEA/JLI - SEARCH FOR USERS WITH ACCESS TO 'OR CPRS GUI CHART' ;1/29/08 15:02
;;8.0;KERNEL;**483**;Jul 10, 1995;Build 15
;;Per VHA Directive 2004-038, this routine should not be modified
;
; ROUTINE XQ55 modified to be run from a server option to identify all
; users with access to the OR CPRS GUI CHART option
;
INIT ;
N XQDT,XQERR,XQISO,XQCOMMNT,XQQUIET,XQLINES,XQOUTPUT,XQPA,XQTOTUSR,XQSELUSR
N XQMAIL,XQIRM
N DIFROM ; THIS, IF PRESENT, PREVENTS MAIL FROM GOING OUT DURING INSTALLATION
S XQMAIL("VAITFOExecLeads@domain.ext")=""
S XQDSH="-------------------------------------------------------------------------------"
D ^XQDATE S XQDT=%Y S XQERR="",XQCOMMNT="",XQQUIET=1,XQLINES=0,XQOUTPUT=$NA(^TMP("XQ55SPEC",$J))
S XQTOTUSR=0,XQSELUSR=0
S XQISO=+$$GET1^DIQ(8989.3,"1,",321.01,"I") D
. I +XQISO'>0 S XQERR="NO ENTRY FOR SITE ISO IN FILE 8989.3" Q
. I '$$ACTIVE^XUSER(+XQISO) S XQERR="SITE ISO ENTRY IS NOT AN ACTIVE USER" S XQISO=0
. Q
S XQIRM=+$$GET1^DIQ(8989.3,"1,",321.02,"I") D
. I +XQIRM'>0,XQERR'="" S XQERR=XQERR_" - NO ENTRY FOR IRM CHIEF IN FILE 8989.3" Q
. I +XQIRM'>0 S XQERR=XQERR_"NO ENTRY FOR IRM CHIEF IN FILE 8989.3"
. I '$$ACTIVE^XUSER(+XQIRM) S XQERR=XQERR_$S(XQERR'="":" - ",1:"")_"SITE IRM CHIEF ENTRY IS NOT AN ACTIVE USER" S XQIRM=0 I +XQISO'>0 Q
. S:+XQISO'>0 XQCOMMNT=XQERR_" - SENDING TO SITE IRM CHIEF INSTEAD" S XQERR=""
. Q
OPT S Y=$$FIND1^DIC(19,"","","OR CPRS GUI CHART") S XQOPT=+Y I XQOPT'>0 S XQERR=XQERR_" - COULD NOT FIND 'OR CPRS GUI CHART' OPTION IN OPTION FILE" G NOOPT
MPAT S XQMP=1 ; FORCE listing of paths
K ^TMP($J),XQR,XQP,@XQOUTPUT
S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"' ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0 ;080115
LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1
G LOOP2
Q
TREE S X(L)=$O(^DIC(19,"AD",XQD,X(L))) Q:X(L)'>0 S K=X(L) G:$D(XQR(K)) TREE S XQR(K)=""
TREE1 ;
S Y(0)=^DIC(19,K,0) G:$L($P(Y(0),U,3)) TREE S:$L($P(Y(0),U,6)) XQK(L)=$P(Y(0),U,6) S XQA(L)=K I $P(Y(0),U,16) S XQRV(L)=^DIC(19,K,3)
D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE
Q:L=1 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE
Q
SETGLO ;
S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_","
S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_","
S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_","
S XQA=XQA_XQOPT,J=0 S:$D(^TMP($J,K,0)) J=^(0) S J=J+1,^(0)=J,^TMP($J,K,J)=XQK_U_XQA_U_XQRV
Q
LOOP2 ;
S XQPA(0)=0,XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS
D USERS1 ; 080115 - add in options from the common menu
F I=0:0 S I=$O(^VA(200,I)) Q:I'>0 I $$ACTIVE^XUSER(I) S XQTOTUSR=XQTOTUSR+1
G LOOP3
USERS ;
S XQU=0 F S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU
Q
;
USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu
N XUCOMMON
S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0))
S XQP=0 F S XQP=$O(^TMP($J,XQP)) Q:XQP="" S XQN=^TMP($J,XQP,0) F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $P($P(^TMP($J,XQP,J),U,2),",")=XUCOMMON D
. S XQU=0,XQPS="(C)" F S XQU=$O(^VA(200,XQU)) Q:XQU'>0 I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU),$$KEYCHECK() S II=1 D SETU
Q
;
EACHU ;
S II=1
F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $$KEYCHECK() D SETU ; 080115
Q
;
KEYCHECK() ; 080115 extracted common code
; returns 1 if user has access to the option, 0 if the user does not have access
S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1
I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0
S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1
I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0
Q XQGO
;
SETU ;
S XQPA=$P(^TMP($J,XQP,J),U,2)
I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I
S XQPA(0,XQPA(XQPA),"CNT")=$G(XQPA(0,XQPA(XQPA),"CNT"))+1
S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115
S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA
Q
LOOP3 ;
I $O(^TMP($J,0,0))="" D G MUS
. N XMY M XMY=XQMAIL S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)=""
. S XQLINES=XQLINES+1,@XQOUTPUT@(1)="** NO USERS CAN ACCESS THIS OPTION **"
. D SEND("SUMMARY",$E(XQOUTPUT,1,$L(XQOUTPUT)-1)_",",.XMY)
. Q
;
N XQTEXT,XMY
S XQTEXT=$E(XQOUTPUT,1,$L(XQOUTPUT)-1)_","
S XQU=0,XQWRITE=0 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU
D SUMMARY M XMY=XQMAIL S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)="" D SEND("SUMMARY",XQTEXT,.XMY)
D SUMMARY1
I (+XQISO>0)!(+XQIRM>0) D
. D HDR
. S XQU=0,XQWRITE=1 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU
. K XMY S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)="" D SEND("DETAILED",XQTEXT,.XMY)
I (+XQISO'>0)&(+XQIRM'>0) D NOISO
G MUS
HDR ;
F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
S XQTAB=(76-$L(XQHDR))/2,XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("?"_XQTAB,XQHDR))
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES),XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("USER NAME","?27","LAST ON","?37","PRIMARY MENU",$S(XQMP:"?63",1:""),$S(XQMP:"PATH(S)",1:"")))
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE($E(XQDSH,1,25),"?27",$E(XQDSH,1,8),"?37",$E(XQDSH,1,$S(XQMP:24,1:40)),$S(XQMP:"?63",1:""),$S(XQMP:$E(XQDSH,1,14),1:"")))
Q
;
WRITEOUT(GLOBAL,LINES,DATALINE) ; GLOBAL CLOSED REF TO GLOBAL
S LINES=LINES+1,@GLOBAL@(LINES)=$G(DATALINE)
Q LINES
;
SETLINE(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,ARG9,ARG10) ;
N LINE,I,VAR,VAR1
S LINE=""
F I=1:1:10 S VAR="ARG"_I X "S VAR1=$G(@VAR)" S:$E(VAR1)="?" VAR1=$$SPACES(LINE,VAR1) S LINE=LINE_VAR1
Q LINE
;
SPACES(LINE,SPACNUM) ;
N CURLEN,SPACLINE,NSPACES
S CURLEN=$L(LINE),SPACLINE=""
S NSPACES=$E(SPACNUM,2,99)-CURLEN
S $P(SPACLINE," ",NSPACES)=" "
Q SPACLINE
;
PRTU ;
N LINE,J,JJ,K,LINE
S LINE=""
S J=$P(XQU,U,2),K="" S:$D(^VA(200,J,1.1)) K=$P(^(1.1),"^") S:$L(K) K=$E(K,4,5)_"/"_$E(K,6,7)_"/"_$E(K,2,3) S LINE=$$SETLINE($E($P(XQU,U,1),1,27),"?27",K)
I $D(^VA(200,J,201)) S K=+^(201) I K>0,$D(^DIC(19,K,0)) S LINE=$$SETLINE(LINE,"?37",$E($P(^(0),U,1),1,24))
I XQMP D
. S LINE=$$SETLINE(LINE,"?63","")
. S JJ=$O(^TMP($J,0,XQU,"A"),-1)
. F II=1:1:JJ I $G(^TMP($J,0,XQU,II)) S LINE=LINE_$$SETLINE(^TMP($J,0,XQU,II),$S(II'=JJ:",",1:"")) ; 080115
. Q
S:XQWRITE XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,LINE)
Q
SUMMARY ;
N I,K,N,LINE
S I="" F S I=$O(^TMP($J,0,I)) Q:I="" S XQSELUSR=XQSELUSR+1
;
I '$$PROD^XUPROD(1) D
. F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("?25","*** TEST ACCOUNT DATA ***"))
. F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
. Q
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("'OR CPRS GUI CHART' DISTRIBUTION ANALYSIS FOR: "))
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES," "_$$STATION())
F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
I XQERR'="" S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQERR),XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
I XQCOMMNT'="" S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQCOMMNT),XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQSELUSR_" USERS WITH ACCESS TO 'OR CPRS GUI CHART'")
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQTOTUSR_" ACTIVE USERS TOTAL")
Q
SUMMARY1 ;
F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE($E(XQDSH,1,27)," MENU PATH(S) ",$E(XQDSH,1,29)))
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"PATH INSTANCES MENU PATH")
F I=1:1:XQPA(0) S K=XQPA(0,I) S LINE=$$SETLINE(I,".","?6",XQPA(0,I,"CNT"),"?18") D
. F N=1:1 S:'$L($P(K,",",N)) XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,LINE) Q:'$L($P(K,",",N)) S:N>1 LINE=$$SETLINE(LINE," ... ") S LINE=$$SETLINE(LINE,$P(^DIC(19,$P(K,",",N),0),U,1))
. Q
I XQSCD S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"(S) - secondary menu pathway")
I XQCOM S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"(C) - COMMON (XUCOMMAND) menu pathway")
Q
;
SEND(MSGTYPE,XMTEXT,XMY) ;
N XMSUB,XMDUZ
S XMSUB=MSGTYPE_" 'GUI CHART' DATA FOR "_$$STATION()
I '$$PROD^XUPROD(1) S XMSUB="** TEST ** "_XMSUB
S XMDUZ=0.5
D ^XMD
Q
;
NOOPT ;
N XMSUB,XMDUZ,XMY,XQMSG,XMTEXT
S XQMSG(1)=XQERR
S XMSUB="ERROR 'GUI CHART' DATA FOR "_$$STATION()
S XMTEXT="XQMSG("
M XMY=XQMAIL S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)=""
S XMDUZ=0.5 D ^XMD
G MUS
;
NOISO ;
N XMSUB,XMDUZ,XMY,XQMSG,XQGROUP,XMTEXT
S XQMSG(1)="There is no valid entry in file 8989.3 for fields 321.01 OR 321.02"
S XQMSG(2)=""
S XQMSG(3)="Please correct this since the data is necessary to send a detailed"
S XQMSG(4)="report to the local Information Security Officer."
S XQMSG(5)=""
S XQMSG(6)="Thank you"
S XMSUB="ERROR 'GUI CHART' DATA FOR "_$$STATION()
S XMTEXT="XQMSG("
M XMY=XQMAIL
S XQGROUP=$$FIND1^DIC(3.8,"","","PATCHES")
I XQGROUP'>0 S XQGROUP=$$FIND1^DIC(3.8,"","","PATCH")
I XQGROUP>0 S XQGROUP=$$GET1^DIQ(3.8,XQGROUP_",",.01),XMY("G."_XQGROUP)=""
S XMDUZ=0.5 D ^XMD
Q
;
STATION() ;
Q $$GET1^DIQ(4.2,(+^XTV(8989.3,1,0))_",",.01)_" ("_$$GET1^DIQ(4.2,(+^XTV(8989.3,1,0))_",",5.5)_")"
;
MUS ;
OUT ;
KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX
K DIC,I,II,JJ,L,POP,Y
K D,DG,D0,D1,D2,DICR,DIW,XMDUN,XMZ,XQCOM,XQTAB,XQWRITE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ55SPEC 9537 printed Sep 23, 2025@19:40:57 Page 2
XQ55SPEC ; SEA/JLI - SEARCH FOR USERS WITH ACCESS TO 'OR CPRS GUI CHART' ;1/29/08 15:02
+1 ;;8.0;KERNEL;**483**;Jul 10, 1995;Build 15
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 ; ROUTINE XQ55 modified to be run from a server option to identify all
+5 ; users with access to the OR CPRS GUI CHART option
+6 ;
INIT ;
+1 NEW XQDT,XQERR,XQISO,XQCOMMNT,XQQUIET,XQLINES,XQOUTPUT,XQPA,XQTOTUSR,XQSELUSR
+2 NEW XQMAIL,XQIRM
+3 ; THIS, IF PRESENT, PREVENTS MAIL FROM GOING OUT DURING INSTALLATION
NEW DIFROM
+4 SET XQMAIL("VAITFOExecLeads@domain.ext")=""
+5 SET XQDSH="-------------------------------------------------------------------------------"
+6 DO ^XQDATE
SET XQDT=%Y
SET XQERR=""
SET XQCOMMNT=""
SET XQQUIET=1
SET XQLINES=0
SET XQOUTPUT=$NAME(^TMP("XQ55SPEC",$JOB))
+7 SET XQTOTUSR=0
SET XQSELUSR=0
+8 SET XQISO=+$$GET1^DIQ(8989.3,"1,",321.01,"I")
Begin DoDot:1
+9 IF +XQISO'>0
SET XQERR="NO ENTRY FOR SITE ISO IN FILE 8989.3"
QUIT
+10 IF '$$ACTIVE^XUSER(+XQISO)
SET XQERR="SITE ISO ENTRY IS NOT AN ACTIVE USER"
SET XQISO=0
+11 QUIT
End DoDot:1
+12 SET XQIRM=+$$GET1^DIQ(8989.3,"1,",321.02,"I")
Begin DoDot:1
+13 IF +XQIRM'>0
IF XQERR'=""
SET XQERR=XQERR_" - NO ENTRY FOR IRM CHIEF IN FILE 8989.3"
QUIT
+14 IF +XQIRM'>0
SET XQERR=XQERR_"NO ENTRY FOR IRM CHIEF IN FILE 8989.3"
+15 IF '$$ACTIVE^XUSER(+XQIRM)
SET XQERR=XQERR_$SELECT(XQERR'="":" - ",1:"")_"SITE IRM CHIEF ENTRY IS NOT AN ACTIVE USER"
SET XQIRM=0
IF +XQISO'>0
QUIT
+16 if +XQISO'>0
SET XQCOMMNT=XQERR_" - SENDING TO SITE IRM CHIEF INSTEAD"
SET XQERR=""
+17 QUIT
End DoDot:1
OPT SET Y=$$FIND1^DIC(19,"","","OR CPRS GUI CHART")
SET XQOPT=+Y
IF XQOPT'>0
SET XQERR=XQERR_" - COULD NOT FIND 'OR CPRS GUI CHART' OPTION IN OPTION FILE"
GOTO NOOPT
MPAT ; FORCE listing of paths
SET XQMP=1
+1 KILL ^TMP($JOB),XQR,XQP,@XQOUTPUT
+2 ;080115
SET K=^DIC(19,XQOPT,0)
SET XQHDR="Access to '"_$PIECE(K,U,2)_"' ["_$PIECE(K,U,1)_"]"
SET XQSCD=0
SET XQCOM=0
LOOP1 SET K=XQOPT
SET (L,X(0))=0
SET XQD=K
KILL XQR,XQA,XQK,XQRV
SET XQR(K)=""
IF '$LENGTH($PIECE(^DIC(19,K,0),U,3))
DO TREE1
+1 GOTO LOOP2
+2 QUIT
TREE SET X(L)=$ORDER(^DIC(19,"AD",XQD,X(L)))
if X(L)'>0
QUIT
SET K=X(L)
if $DATA(XQR(K))
GOTO TREE
SET XQR(K)=""
TREE1 ;
+1 SET Y(0)=^DIC(19,K,0)
if $LENGTH($PIECE(Y(0),U,3))
GOTO TREE
if $LENGTH($PIECE(Y(0),U,6))
SET XQK(L)=$PIECE(Y(0),U,6)
SET XQA(L)=K
IF $PIECE(Y(0),U,16)
SET XQRV(L)=^DIC(19,K,3)
+2 DO SETGLO
SET L=L+1
SET X(L)=0
SET (XQD,XQD(L))=K
DO TREE
+3 if L=1
QUIT
KILL XQR(XQD(L))
SET L=L-1
KILL XQA(L),XQK(L),XQRV(L)
SET XQD=XQD(L)
GOTO TREE
+4 QUIT
SETGLO ;
+1 SET XQK=""
FOR I=L:-1:0
IF $DATA(XQK(I))
IF $LENGTH(XQK(I))
SET XQK=XQK_XQK(I)_","
+2 SET XQRV=""
FOR I=L:-1:0
IF $DATA(XQRV(I))
IF $LENGTH(XQRV(I))
SET XQRV=XQRV_XQRV(I)_","
+3 SET XQA=""
FOR I=L:-1:1
IF $DATA(XQA(I))
SET XQA=XQA_XQA(I)_","
+4 SET XQA=XQA_XQOPT
SET J=0
if $DATA(^TMP($JOB,K,0))
SET J=^(0)
SET J=J+1
SET ^(0)=J
SET ^TMP($JOB,K,J)=XQK_U_XQA_U_XQRV
+5 QUIT
LOOP2 ;
+1 SET XQPA(0)=0
SET XQP=0
FOR
SET XQP=$ORDER(^TMP($JOB,XQP))
if XQP=""
QUIT
SET XQN=^TMP($JOB,XQP,0)
SET XQPS="AP"
DO USERS
SET XQPS="AD"
DO USERS
+2 ; 080115 - add in options from the common menu
DO USERS1
+3 FOR I=0:0
SET I=$ORDER(^VA(200,I))
if I'>0
QUIT
IF $$ACTIVE^XUSER(I)
SET XQTOTUSR=XQTOTUSR+1
+4 GOTO LOOP3
USERS ;
+1 SET XQU=0
FOR
SET XQU=$ORDER(^VA(200,XQPS,XQP,XQU))
if XQU'>0
QUIT
IF $DATA(^VA(200,XQU,.1))
IF +$$ACTIVE^XUSER(XQU)
DO EACHU
+2 QUIT
+3 ;
USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu
+1 NEW XUCOMMON
+2 SET XUCOMMON=$ORDER(^DIC(19,"B","XUCOMMAND",0))
+3 SET XQP=0
FOR
SET XQP=$ORDER(^TMP($JOB,XQP))
if XQP=""
QUIT
SET XQN=^TMP($JOB,XQP,0)
FOR J=1:1:XQN
if '$DATA(^TMP($JOB,XQP,J))
QUIT
IF $PIECE($PIECE(^TMP($JOB,XQP,J),U,2),",")=XUCOMMON
Begin DoDot:1
+4 SET XQU=0
SET XQPS="(C)"
FOR
SET XQU=$ORDER(^VA(200,XQU))
if XQU'>0
QUIT
IF $DATA(^VA(200,XQU,.1))
IF +$$ACTIVE^XUSER(XQU)
IF $$KEYCHECK()
SET II=1
DO SETU
End DoDot:1
+5 QUIT
+6 ;
EACHU ;
+1 SET II=1
+2 ; 080115
FOR J=1:1:XQN
if '$DATA(^TMP($JOB,XQP,J))
QUIT
IF $$KEYCHECK()
DO SETU
+3 QUIT
+4 ;
KEYCHECK() ; 080115 extracted common code
+1 ; returns 1 if user has access to the option, 0 if the user does not have access
+2 SET XQK=$PIECE(^TMP($JOB,XQP,J),U,1)
SET XX=$LENGTH(XQK,",")-1
SET XQGO=1
+3 IF XX
FOR X=1:1:XX
SET Y=$PIECE(XQK,",",X)
IF Y'=""
IF ('$DATA(^XUSEC(Y,XQU)))
SET XQGO=0
+4 SET XQK=$PIECE(^TMP($JOB,XQP,J),U,3)
SET XX=$LENGTH(XQK,",")-1
+5 IF XX
FOR X=1:1:XX
SET Y=$PIECE(XQK,",",X)
IF Y'=""
IF ($DATA(^XUSEC(Y,XQU)))
SET XQGO=0
+6 QUIT XQGO
+7 ;
SETU ;
+1 SET XQPA=$PIECE(^TMP($JOB,XQP,J),U,2)
+2 IF '$DATA(XQPA(XQPA))
SET I=XQPA(0)+1
SET XQPA(0)=I
SET XQPA(0,I)=XQPA
SET XQPA(XQPA)=I
+3 SET XQPA(0,XQPA(XQPA),"CNT")=$GET(XQPA(0,XQPA(XQPA),"CNT"))+1
+4 ; 080115
SET XQPA=XQPA(XQPA)
if XQPS="AD"
SET XQPA=XQPA_"(S)"
SET XQSCD=1
if XQPS="(C)"
SET XQPA=XQPA_"(C)"
SET XQCOM=1
+5 SET I=$PIECE(^VA(200,XQU,0),U,1)_U_XQU
if $DATA(^TMP($JOB,0,I))
SET II=$ORDER(^TMP($JOB,0,I,"A"),-1)+1
SET ^TMP($JOB,0,I,II)=XQPA
+6 QUIT
LOOP3 ;
+1 IF $ORDER(^TMP($JOB,0,0))=""
Begin DoDot:1
+2 NEW XMY
MERGE XMY=XQMAIL
if +XQISO>0
SET XMY(+XQISO)=""
if +XQIRM>0
SET XMY(+XQIRM)=""
+3 SET XQLINES=XQLINES+1
SET @XQOUTPUT@(1)="** NO USERS CAN ACCESS THIS OPTION **"
+4 DO SEND("SUMMARY",$EXTRACT(XQOUTPUT,1,$LENGTH(XQOUTPUT)-1)_",",.XMY)
+5 QUIT
End DoDot:1
GOTO MUS
+6 ;
+7 NEW XQTEXT,XMY
+8 SET XQTEXT=$EXTRACT(XQOUTPUT,1,$LENGTH(XQOUTPUT)-1)_","
+9 SET XQU=0
SET XQWRITE=0
FOR
SET XQU=$ORDER(^TMP($JOB,0,XQU))
if XQU=""
QUIT
DO PRTU
+10 DO SUMMARY
MERGE XMY=XQMAIL
if +XQISO>0
SET XMY(+XQISO)=""
if +XQIRM>0
SET XMY(+XQIRM)=""
DO SEND("SUMMARY",XQTEXT,.XMY)
+11 DO SUMMARY1
+12 IF (+XQISO>0)!(+XQIRM>0)
Begin DoDot:1
+13 DO HDR
+14 SET XQU=0
SET XQWRITE=1
FOR
SET XQU=$ORDER(^TMP($JOB,0,XQU))
if XQU=""
QUIT
DO PRTU
+15 KILL XMY
if +XQISO>0
SET XMY(+XQISO)=""
if +XQIRM>0
SET XMY(+XQIRM)=""
DO SEND("DETAILED",XQTEXT,.XMY)
End DoDot:1
+16 IF (+XQISO'>0)&(+XQIRM'>0)
DO NOISO
+17 GOTO MUS
HDR ;
+1 FOR I=1:1:4
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+2 SET XQTAB=(76-$LENGTH(XQHDR))/2
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("?"_XQTAB,XQHDR))
+3 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+4 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("USER NAME","?27","LAST ON","?37","PRIMARY MENU",$SELECT(XQMP:"?63",1:""),$SELECT(XQMP:"PATH(S)",1:"")))
+5 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE($EXTRACT(XQDSH,1,25),"?27",$EXTRACT(XQDSH,1,8),"?37",$EXTRACT(XQDSH,1,$SELECT(XQMP:24,1:40)),$SELECT(XQMP:"?63",1:""),$SELECT(XQMP:$EXTRACT(XQDSH,1,14),1:"")))
+6 QUIT
+7 ;
WRITEOUT(GLOBAL,LINES,DATALINE) ; GLOBAL CLOSED REF TO GLOBAL
+1 SET LINES=LINES+1
SET @GLOBAL@(LINES)=$GET(DATALINE)
+2 QUIT LINES
+3 ;
SETLINE(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,ARG9,ARG10) ;
+1 NEW LINE,I,VAR,VAR1
+2 SET LINE=""
+3 FOR I=1:1:10
SET VAR="ARG"_I
XECUTE "S VAR1=$G(@VAR)"
if $EXTRACT(VAR1)="?"
SET VAR1=$$SPACES(LINE,VAR1)
SET LINE=LINE_VAR1
+4 QUIT LINE
+5 ;
SPACES(LINE,SPACNUM) ;
+1 NEW CURLEN,SPACLINE,NSPACES
+2 SET CURLEN=$LENGTH(LINE)
SET SPACLINE=""
+3 SET NSPACES=$EXTRACT(SPACNUM,2,99)-CURLEN
+4 SET $PIECE(SPACLINE," ",NSPACES)=" "
+5 QUIT SPACLINE
+6 ;
PRTU ;
+1 NEW LINE,J,JJ,K,LINE
+2 SET LINE=""
+3 SET J=$PIECE(XQU,U,2)
SET K=""
if $DATA(^VA(200,J,1.1))
SET K=$PIECE(^(1.1),"^")
if $LENGTH(K)
SET K=$EXTRACT(K,4,5)_"/"_$EXTRACT(K,6,7)_"/"_$EXTRACT(K,2,3)
SET LINE=$$SETLINE($EXTRACT($PIECE(XQU,U,1),1,27),"?27",K)
+4 IF $DATA(^VA(200,J,201))
SET K=+^(201)
IF K>0
IF $DATA(^DIC(19,K,0))
SET LINE=$$SETLINE(LINE,"?37",$EXTRACT($PIECE(^(0),U,1),1,24))
+5 IF XQMP
Begin DoDot:1
+6 SET LINE=$$SETLINE(LINE,"?63","")
+7 SET JJ=$ORDER(^TMP($JOB,0,XQU,"A"),-1)
+8 ; 080115
FOR II=1:1:JJ
IF $GET(^TMP($JOB,0,XQU,II))
SET LINE=LINE_$$SETLINE(^TMP($JOB,0,XQU,II),$SELECT(II'=JJ:",",1:""))
+9 QUIT
End DoDot:1
+10 if XQWRITE
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,LINE)
+11 QUIT
SUMMARY ;
+1 NEW I,K,N,LINE
+2 SET I=""
FOR
SET I=$ORDER(^TMP($JOB,0,I))
if I=""
QUIT
SET XQSELUSR=XQSELUSR+1
+3 ;
+4 IF '$$PROD^XUPROD(1)
Begin DoDot:1
+5 FOR I=1:1:4
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("?25","*** TEST ACCOUNT DATA ***"))
+6 FOR I=1:1:4
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+7 QUIT
End DoDot:1
+8 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("'OR CPRS GUI CHART' DISTRIBUTION ANALYSIS FOR: "))
+9 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES," "_$$STATION())
+10 FOR I=1:1:4
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+11 IF XQERR'=""
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQERR)
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+12 IF XQCOMMNT'=""
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQCOMMNT)
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+13 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQSELUSR_" USERS WITH ACCESS TO 'OR CPRS GUI CHART'")
+14 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQTOTUSR_" ACTIVE USERS TOTAL")
+15 QUIT
SUMMARY1 ;
+1 FOR I=1:1:4
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+2 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE($EXTRACT(XQDSH,1,27)," MENU PATH(S) ",$EXTRACT(XQDSH,1,29)))
+3 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
+4 SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"PATH INSTANCES MENU PATH")
+5 FOR I=1:1:XQPA(0)
SET K=XQPA(0,I)
SET LINE=$$SETLINE(I,".","?6",XQPA(0,I,"CNT"),"?18")
Begin DoDot:1
+6 FOR N=1:1
if '$LENGTH($PIECE(K,",",N))
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,LINE)
if '$LENGTH($PIECE(K,",",N))
QUIT
if N>1
SET LINE=$$SETLINE(LINE," ... ")
SET LINE=$$SETLINE(LINE,$PIECE(^DIC(19,$PIECE(K,",",N),0),U,1))
+7 QUIT
End DoDot:1
+8 IF XQSCD
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"(S) - secondary menu pathway")
+9 IF XQCOM
SET XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"(C) - COMMON (XUCOMMAND) menu pathway")
+10 QUIT
+11 ;
SEND(MSGTYPE,XMTEXT,XMY) ;
+1 NEW XMSUB,XMDUZ
+2 SET XMSUB=MSGTYPE_" 'GUI CHART' DATA FOR "_$$STATION()
+3 IF '$$PROD^XUPROD(1)
SET XMSUB="** TEST ** "_XMSUB
+4 SET XMDUZ=0.5
+5 DO ^XMD
+6 QUIT
+7 ;
NOOPT ;
+1 NEW XMSUB,XMDUZ,XMY,XQMSG,XMTEXT
+2 SET XQMSG(1)=XQERR
+3 SET XMSUB="ERROR 'GUI CHART' DATA FOR "_$$STATION()
+4 SET XMTEXT="XQMSG("
+5 MERGE XMY=XQMAIL
if +XQISO>0
SET XMY(+XQISO)=""
if +XQIRM>0
SET XMY(+XQIRM)=""
+6 SET XMDUZ=0.5
DO ^XMD
+7 GOTO MUS
+8 ;
NOISO ;
+1 NEW XMSUB,XMDUZ,XMY,XQMSG,XQGROUP,XMTEXT
+2 SET XQMSG(1)="There is no valid entry in file 8989.3 for fields 321.01 OR 321.02"
+3 SET XQMSG(2)=""
+4 SET XQMSG(3)="Please correct this since the data is necessary to send a detailed"
+5 SET XQMSG(4)="report to the local Information Security Officer."
+6 SET XQMSG(5)=""
+7 SET XQMSG(6)="Thank you"
+8 SET XMSUB="ERROR 'GUI CHART' DATA FOR "_$$STATION()
+9 SET XMTEXT="XQMSG("
+10 MERGE XMY=XQMAIL
+11 SET XQGROUP=$$FIND1^DIC(3.8,"","","PATCHES")
+12 IF XQGROUP'>0
SET XQGROUP=$$FIND1^DIC(3.8,"","","PATCH")
+13 IF XQGROUP>0
SET XQGROUP=$$GET1^DIQ(3.8,XQGROUP_",",.01)
SET XMY("G."_XQGROUP)=""
+14 SET XMDUZ=0.5
DO ^XMD
+15 QUIT
+16 ;
STATION() ;
+1 QUIT $$GET1^DIQ(4.2,(+^XTV(8989.3,1,0))_",",.01)_" ("_$$GET1^DIQ(4.2,(+^XTV(8989.3,1,0))_",",5.5)_")"
+2 ;
MUS ;
OUT ;
KILL KILL XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX
+1 KILL DIC,I,II,JJ,L,POP,Y
+2 KILL D,DG,D0,D1,D2,DICR,DIW,XMDUN,XMZ,XQCOM,XQTAB,XQWRITE
+3 QUIT
