- 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 Jan 18, 2025@03:06:02 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