source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55SPEC.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 9.1 KB
Line 
1XQ55SPEC ; SEA/JLI - SEARCH FOR USERS WITH ACCESS TO 'OR CPRS GUI CHART' ;1/29/08 15:02
2 ;;8.0;KERNEL;**483**;Jul 10, 1995;Build 15
3 ;;Per VHA Directive 2004-038, this routine should not be modified
4 ;
5 ; ROUTINE XQ55 modified to be run from a server option to identify all
6 ; users with access to the OR CPRS GUI CHART option
7 ;
8INIT ;
9 N XQDT,XQERR,XQISO,XQCOMMNT,XQQUIET,XQLINES,XQOUTPUT,XQPA,XQTOTUSR,XQSELUSR
10 N XQMAIL,XQIRM
11 N DIFROM ; THIS, IF PRESENT, PREVENTS MAIL FROM GOING OUT DURING INSTALLATION
12 S XQMAIL("VAITFOExecLeads@va.gov")=""
13 S XQDSH="-------------------------------------------------------------------------------"
14 D ^XQDATE S XQDT=%Y S XQERR="",XQCOMMNT="",XQQUIET=1,XQLINES=0,XQOUTPUT=$NA(^TMP("XQ55SPEC",$J))
15 S XQTOTUSR=0,XQSELUSR=0
16 S XQISO=+$$GET1^DIQ(8989.3,"1,",321.01,"I") D
17 . I +XQISO'>0 S XQERR="NO ENTRY FOR SITE ISO IN FILE 8989.3" Q
18 . I '$$ACTIVE^XUSER(+XQISO) S XQERR="SITE ISO ENTRY IS NOT AN ACTIVE USER" S XQISO=0
19 . Q
20 S XQIRM=+$$GET1^DIQ(8989.3,"1,",321.02,"I") D
21 . I +XQIRM'>0,XQERR'="" S XQERR=XQERR_" - NO ENTRY FOR IRM CHIEF IN FILE 8989.3" Q
22 . I +XQIRM'>0 S XQERR=XQERR_"NO ENTRY FOR IRM CHIEF IN FILE 8989.3"
23 . 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
24 . S:+XQISO'>0 XQCOMMNT=XQERR_" - SENDING TO SITE IRM CHIEF INSTEAD" S XQERR=""
25 . Q
26OPT 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
27MPAT S XQMP=1 ; FORCE listing of paths
28 K ^TMP($J),XQR,XQP,@XQOUTPUT
29 S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"' ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0 ;080115
30LOOP1 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
31 G LOOP2
32 Q
33TREE 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)=""
34TREE1 ;
35 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)
36 D SETGLO S L=L+1,X(L)=0,(XQD,XQD(L))=K D TREE
37 Q:L=1 K XQR(XQD(L)) S L=L-1 K XQA(L),XQK(L),XQRV(L) S XQD=XQD(L) G TREE
38 Q
39SETGLO ;
40 S XQK="" F I=L:-1:0 I $D(XQK(I)),$L(XQK(I)) S XQK=XQK_XQK(I)_","
41 S XQRV="" F I=L:-1:0 I $D(XQRV(I)),$L(XQRV(I)) S XQRV=XQRV_XQRV(I)_","
42 S XQA="" F I=L:-1:1 I $D(XQA(I)) S XQA=XQA_XQA(I)_","
43 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
44 Q
45LOOP2 ;
46 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
47 D USERS1 ; 080115 - add in options from the common menu
48 F I=0:0 S I=$O(^VA(200,I)) Q:I'>0 I $$ACTIVE^XUSER(I) S XQTOTUSR=XQTOTUSR+1
49 G LOOP3
50USERS ;
51 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
52 Q
53 ;
54USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu
55 N XUCOMMON
56 S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0))
57 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
58 . 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
59 Q
60 ;
61EACHU ;
62 S II=1
63 F J=1:1:XQN Q:'$D(^TMP($J,XQP,J)) I $$KEYCHECK() D SETU ; 080115
64 Q
65 ;
66KEYCHECK() ; 080115 extracted common code
67 ; returns 1 if user has access to the option, 0 if the user does not have access
68 S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1
69 I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0
70 S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1
71 I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0
72 Q XQGO
73 ;
74SETU ;
75 S XQPA=$P(^TMP($J,XQP,J),U,2)
76 I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I
77 S XQPA(0,XQPA(XQPA),"CNT")=$G(XQPA(0,XQPA(XQPA),"CNT"))+1
78 S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115
79 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
80 Q
81LOOP3 ;
82 I $O(^TMP($J,0,0))="" D G MUS
83 . N XMY M XMY=XQMAIL S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)=""
84 . S XQLINES=XQLINES+1,@XQOUTPUT@(1)="** NO USERS CAN ACCESS THIS OPTION **"
85 . D SEND("SUMMARY",$E(XQOUTPUT,1,$L(XQOUTPUT)-1)_",",.XMY)
86 . Q
87 ;
88 N XQTEXT,XMY
89 S XQTEXT=$E(XQOUTPUT,1,$L(XQOUTPUT)-1)_","
90 S XQU=0,XQWRITE=0 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU
91 D SUMMARY M XMY=XQMAIL S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)="" D SEND("SUMMARY",XQTEXT,.XMY)
92 D SUMMARY1
93 I (+XQISO>0)!(+XQIRM>0) D
94 . D HDR
95 . S XQU=0,XQWRITE=1 F S XQU=$O(^TMP($J,0,XQU)) Q:XQU="" D PRTU
96 . K XMY S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)="" D SEND("DETAILED",XQTEXT,.XMY)
97 I (+XQISO'>0)&(+XQIRM'>0) D NOISO
98 G MUS
99HDR ;
100 F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
101 S XQTAB=(76-$L(XQHDR))/2,XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("?"_XQTAB,XQHDR))
102 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES),XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
103 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("USER NAME","?27","LAST ON","?37","PRIMARY MENU",$S(XQMP:"?63",1:""),$S(XQMP:"PATH(S)",1:"")))
104 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:"")))
105 Q
106 ;
107WRITEOUT(GLOBAL,LINES,DATALINE) ; GLOBAL CLOSED REF TO GLOBAL
108 S LINES=LINES+1,@GLOBAL@(LINES)=$G(DATALINE)
109 Q LINES
110 ;
111SETLINE(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,ARG9,ARG10) ;
112 N LINE,I,VAR,VAR1
113 S LINE=""
114 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
115 Q LINE
116 ;
117SPACES(LINE,SPACNUM) ;
118 N CURLEN,SPACLINE,NSPACES
119 S CURLEN=$L(LINE),SPACLINE=""
120 S NSPACES=$E(SPACNUM,2,99)-CURLEN
121 S $P(SPACLINE," ",NSPACES)=" "
122 Q SPACLINE
123 ;
124PRTU ;
125 N LINE,J,JJ,K,LINE
126 S LINE=""
127 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)
128 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))
129 I XQMP D
130 . S LINE=$$SETLINE(LINE,"?63","")
131 . S JJ=$O(^TMP($J,0,XQU,"A"),-1)
132 . 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
133 . Q
134 S:XQWRITE XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,LINE)
135 Q
136SUMMARY ;
137 N I,K,N,LINE
138 S I="" F S I=$O(^TMP($J,0,I)) Q:I="" S XQSELUSR=XQSELUSR+1
139 ;
140 I '$$PROD^XUPROD(1) D
141 . F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("?25","*** TEST ACCOUNT DATA ***"))
142 . F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
143 . Q
144 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE("'OR CPRS GUI CHART' DISTRIBUTION ANALYSIS FOR: "))
145 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES," "_$$STATION())
146 F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
147 I XQERR'="" S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQERR),XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
148 I XQCOMMNT'="" S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQCOMMNT),XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
149 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQSELUSR_" USERS WITH ACCESS TO 'OR CPRS GUI CHART'")
150 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,XQTOTUSR_" ACTIVE USERS TOTAL")
151 Q
152SUMMARY1 ;
153 F I=1:1:4 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
154 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,$$SETLINE($E(XQDSH,1,27)," MENU PATH(S) ",$E(XQDSH,1,29)))
155 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES)
156 S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"PATH INSTANCES MENU PATH")
157 F I=1:1:XQPA(0) S K=XQPA(0,I) S LINE=$$SETLINE(I,".","?6",XQPA(0,I,"CNT"),"?18") D
158 . 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))
159 . Q
160 I XQSCD S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"(S) - secondary menu pathway")
161 I XQCOM S XQLINES=$$WRITEOUT(XQOUTPUT,XQLINES,"(C) - COMMON (XUCOMMAND) menu pathway")
162 Q
163 ;
164SEND(MSGTYPE,XMTEXT,XMY) ;
165 N XMSUB,XMDUZ
166 S XMSUB=MSGTYPE_" 'GUI CHART' DATA FOR "_$$STATION()
167 I '$$PROD^XUPROD(1) S XMSUB="** TEST ** "_XMSUB
168 S XMDUZ=0.5
169 D ^XMD
170 Q
171 ;
172NOOPT ;
173 N XMSUB,XMDUZ,XMY,XQMSG,XMTEXT
174 S XQMSG(1)=XQERR
175 S XMSUB="ERROR 'GUI CHART' DATA FOR "_$$STATION()
176 S XMTEXT="XQMSG("
177 M XMY=XQMAIL S:+XQISO>0 XMY(+XQISO)="" S:+XQIRM>0 XMY(+XQIRM)=""
178 S XMDUZ=0.5 D ^XMD
179 G MUS
180 ;
181NOISO ;
182 N XMSUB,XMDUZ,XMY,XQMSG,XQGROUP,XMTEXT
183 S XQMSG(1)="There is no valid entry in file 8989.3 for fields 321.01 OR 321.02"
184 S XQMSG(2)=""
185 S XQMSG(3)="Please correct this since the data is necessary to send a detailed"
186 S XQMSG(4)="report to the local Information Security Officer."
187 S XQMSG(5)=""
188 S XQMSG(6)="Thank you"
189 S XMSUB="ERROR 'GUI CHART' DATA FOR "_$$STATION()
190 S XMTEXT="XQMSG("
191 M XMY=XQMAIL
192 S XQGROUP=$$FIND1^DIC(3.8,"","","PATCHES")
193 I XQGROUP'>0 S XQGROUP=$$FIND1^DIC(3.8,"","","PATCH")
194 I XQGROUP>0 S XQGROUP=$$GET1^DIQ(3.8,XQGROUP_",",.01),XMY("G."_XQGROUP)=""
195 S XMDUZ=0.5 D ^XMD
196 Q
197 ;
198STATION() ;
199 Q $$GET1^DIQ(4.2,(+^XTV(8989.3,1,0))_",",.01)_" ("_$$GET1^DIQ(4.2,(+^XTV(8989.3,1,0))_",",5.5)_")"
200 ;
201MUS ;
202OUT ;
203KILL 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
204 K DIC,I,II,JJ,L,POP,Y
205 K D,DG,D0,D1,D2,DICR,DIW,XMDUN,XMZ,XQCOM,XQTAB,XQWRITE
206 Q
Note: See TracBrowser for help on using the repository browser.