AQAOUSA ; IHS/ORDC/LJF - OCCURRENCE ACCESS REPORT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn contains the user interface to print users with access to
;a particular occurrence. The audit report will list who has actually
;accessed the occurrence.
;
OCC ; >> ask user for occ
S AQAOINAC=""
D ASK^AQAOLKP G END:'$D(AQAOIFN),END:$D(DTOUT),OCC:$D(DUOUT)
K AQAOINAC
;
DEV ; >>> get print device
W !! S %ZIS="QP" D ^%ZIS G END:POP
I '$D(IO("Q")) U IO G CALC
K IO("Q") S ZTRTN="CALC^AQAOUSA",ZTDESC="OCCURRENCE ACCESS REPORT"
S ZTSAVE("AQAOIFN")=""
D ^%ZTLOAD K ZTSK D ^%ZISC D HOME^%ZIS D KILL^AQAOUTIL Q
;
;
CALC ; >> find all users with access
K ^TMP("AQAOUSA",$J)
D QISTAFF ;find all qi staff members
D MEMBERS ;find team members associated with indicator
D REFERRAL ;find all users occ was referred to
;
;
PRINT ; >> print user list by category then by name
D ^AQAOUSA1 ;print rtn
;
;
END ; >> eoj
K ^TMP("AQAOUSA",$J)
D ^%ZISC D KILL^AQAOUTIL Q
Q
; >>>>> END OF MAIN ROUTINE <<<<<
;
;
QISTAFF ; >> SUBRTN to find all qi staff members
S AQAOX=0
F S AQAOX=$O(^AQAO(9,"AC",AQAOX)) Q:AQAOX="" D
.S AQAOUSR=0
.F S AQAOUSR=$O(^AQAO(9,"AC",AQAOX,AQAOUSR)) Q:AQAOUSR="" D
..Q:$P(^AQAO(9,AQAOUSR,0),U,4)]"" ;inactive;PATCH 4
..S N=$P(^VA(200,AQAOUSR,0),U) ;user name
..S S=$S(AQAOX="QA":"QAI PKG ADMIN",1:"QI STAFF MEMBER")
..S ^TMP("AQAOUSA",$J,"A",N,AQAOUSR)=S
Q
;
;
MEMBERS ; >> SUBRTN to find team members for ind tied to occ
S AQAOIND=$P(^AQAOC(AQAOIFN,0),U,8) ;indicator
S AQAOSRV=$P(^AQAOC(AQAOIFN,0),U,7) ;service
;
S AQAOT=0 ;find all teams for ind
F S AQAOT=$O(^AQAO(2,AQAOIND,"QTM",AQAOT)) Q:AQAOT'=+AQAOT D
.Q:'$D(^AQAO(2,AQAOIND,"QTM",AQAOT,0)) S AQAOS=^(0)
.S AQAOTN=$P(^AQAO1(1,$P(AQAOS,U),0),U,2) ;team name
.S AQAOTX=$P(AQAOS,U)
.I AQAOSRV]"",+$O(^AQAO1(1,AQAOTX,1,0)) Q:'$D(^AQAO1(1,"AB",AQAOSRV,AQAOTX)) ;team has access by srv; not right srv in this occ
.;
.S AQAOUSR=0 ;find all users on team & their access level
.F S AQAOUSR=$O(^AQAO(9,"AB",AQAOTX,AQAOUSR)) Q:AQAOUSR="" D
..S AQAOX=0
..F S AQAOX=$O(^AQAO(9,"AB",AQAOTX,AQAOUSR,AQAOX)) Q:AQAOX="" D
...Q:$P(^AQAO(9,AQAOUSR,0),U,4)]"" ;inactive;PATCH 4
...S Y=$P($G(^AQAO(9,AQAOUSR,"TM",AQAOX,0)),U,2)
...I Y]"" S C=$P(^DD(9002168.91,.02,0),U,2) D Y^DIQ ;access level
...S N=$P(^VA(200,AQAOUSR,0),U) ;user name
...Q:$D(^TMP("AQAOUSA",$J,"A",N,AQAOUSR)) ;already listed as qi staff
...S ^TMP("AQAOUSA",$J,"M",N,AQAOUSR)=$G(^TMP("AQAOUSA",$J,"M",N,AQAOUSR))_AQAOTN_U_Y_U ;add team & access level
Q
;
;
REFERRAL ; -- SUBRTN to find all users to whom occ was referred;PATCH 4
;PATCH 4: SUBRTN REWRITTEN
NEW X,AQAOX,Y
; -- initial review
S X=$P(^AQAOC(AQAOIFN,1),U,9) Q:X="" S Y=$P(^(1),U,4)
D REFSET(X,Y)
;
; -- addtnl referrals on initial review
S AQAOX=0
F S AQAOX=$O(^AQAOC(AQAOIFN,"IADDRV",AQAOX)) Q:'AQAOX D
. S X=^AQAOC(AQAOIFN,"IADDRV",AQAOX,0) D REFSET(X,Y)
;
; -- referrals from reviews
S AQAOX=0
F S AQAOX=$O(^AQAOC(AQAOIFN,"REV",AQAOX)) Q:'AQAOX D
. S X=$P($G(^AQAOC(AQAOIFN,"REV",AQAOX,0)),U,9) Q:X=""
. S Y=$P($G(^AQAOC(AQAOIFN,"REV",AQAOX,0)),U,2)
. D REFSET(X,Y)
. ; -- addtnl referrals from this review
. S AQAOY=0
. F S AQAOY=$O(^AQAOC(AQAOIFN,"REV",AQAOX,"ADDRV",AQAOY)) Q:'AQAOY D
.. S X=^AQAOC(AQAOIFN,"REV",AQAOX,"ADDRV",AQAOY,0) D REFSET(X,Y)
Q
;
;
REFSET(X,AQAOY) ; -- SUBRTN to set ^tmp for users found;PATCH 4
;PATCH 4: SUBRTN ADDED
; X=referred to, AQAOY=referred by
NEW AQAOUSR,AQAOT,AQAOTN,AQAOX,Y
; -- referred to user by name
I X["AQAO(9" D Q
. S AQAOUSR=$P(X,";"),N=$P(^VA(200,AQAOUSR,0),U)
. Q:$D(^TMP("AQAOUSA",$J,"A",N,AQAOUSR)) ;already on qi staff list
. Q:$D(^TMP("AQAOUSA",$J,"M",N,AQAOUSR)) ;on team listing
. S Y=AQAOY,C=$P(^DD(9002167,.14,0),U,2) D Y^DIQ
. S ^TMP("AQAOUSA",$J,"R",N,AQAOUSR)=$G(^TMP("AQAOUSA",$J,"R",N,AQAOUSR))_Y_U ;Y=referred by
;
; -- else if referred to team
Q:$D(^AQAO(2,AQAOIND,"QTM","B",$P(X,";"))) ;team on ind list
S AQAOT=$P(X,";"),AQAOTN=$P(^AQAO1(1,AQAOT,0),U,2) ;team name
S Y=AQAOY,C=$P(^DD(9002167,.14,0),U,2) D Y^DIQ S AQAOY=Y
;
; -- find all users on team & their access level
S AQAOUSR=0
F S AQAOUSR=$O(^AQAO(9,"AB",AQAOT,AQAOUSR)) Q:AQAOUSR="" D
. S AQAOX=0
. F S AQAOX=$O(^AQAO(9,"AB",AQAOT,AQAOUSR,AQAOX)) Q:AQAOX="" D
.. S Y=$P($G(^AQAO(9,AQAOUSR,"TM",AQAOX,0)),U,2)
.. I Y]"" S C=$P(^DD(9002168.91,.02,0),U,2) D Y^DIQ ;access level
.. S N=$P(^VA(200,AQAOUSR,0),U) ;user name
.. Q:$D(^TMP("AQAOUSA",$J,"A",N,AQAOUSR)) ;already listed as qi staff
.. Q:$D(^TMP("AQAOUSA",$J,"M",N,AQAOUSR)) ;already on team list
.. Q:$D(^TMP("AQAOUSA",$J,"R",N,AQAOUSR)) ;already referred by name
.. S ^TMP("AQAOUSA",$J,"T",N,AQAOUSR)=$G(^TMP("AQAOUSA",$J,"T",N,AQAOUSR))_AQAOY_U_AQAOTN_U_Y_U ;add team & accs lev
Q
AQAOUSA ; IHS/ORDC/LJF - OCCURRENCE ACCESS REPORT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn contains the user interface to print users with access to
+4 ;a particular occurrence. The audit report will list who has actually
+5 ;accessed the occurrence.
+6 ;
OCC ; >> ask user for occ
+1 SET AQAOINAC=""
+2 DO ASK^AQAOLKP
IF '$DATA(AQAOIFN)
GOTO END
IF $DATA(DTOUT)
GOTO END
IF $DATA(DUOUT)
GOTO OCC
+3 KILL AQAOINAC
+4 ;
DEV ; >>> get print device
+1 WRITE !!
SET %ZIS="QP"
DO ^%ZIS
IF POP
GOTO END
+2 IF '$DATA(IO("Q"))
USE IO
GOTO CALC
+3 KILL IO("Q")
SET ZTRTN="CALC^AQAOUSA"
SET ZTDESC="OCCURRENCE ACCESS REPORT"
+4 SET ZTSAVE("AQAOIFN")=""
+5 DO ^%ZTLOAD
KILL ZTSK
DO ^%ZISC
DO HOME^%ZIS
DO KILL^AQAOUTIL
QUIT
+6 ;
+7 ;
CALC ; >> find all users with access
+1 KILL ^TMP("AQAOUSA",$JOB)
+2 ;find all qi staff members
DO QISTAFF
+3 ;find team members associated with indicator
DO MEMBERS
+4 ;find all users occ was referred to
DO REFERRAL
+5 ;
+6 ;
PRINT ; >> print user list by category then by name
+1 ;print rtn
DO ^AQAOUSA1
+2 ;
+3 ;
END ; >> eoj
+1 KILL ^TMP("AQAOUSA",$JOB)
+2 DO ^%ZISC
DO KILL^AQAOUTIL
QUIT
+3 QUIT
+4 ; >>>>> END OF MAIN ROUTINE <<<<<
+5 ;
+6 ;
QISTAFF ; >> SUBRTN to find all qi staff members
+1 SET AQAOX=0
+2 FOR
SET AQAOX=$ORDER(^AQAO(9,"AC",AQAOX))
IF AQAOX=""
QUIT
Begin DoDot:1
+3 SET AQAOUSR=0
+4 FOR
SET AQAOUSR=$ORDER(^AQAO(9,"AC",AQAOX,AQAOUSR))
IF AQAOUSR=""
QUIT
Begin DoDot:2
+5 ;inactive;PATCH 4
IF $PIECE(^AQAO(9,AQAOUSR,0),U,4)]""
QUIT
+6 ;user name
SET N=$PIECE(^VA(200,AQAOUSR,0),U)
+7 SET S=$SELECT(AQAOX="QA":"QAI PKG ADMIN",1:"QI STAFF MEMBER")
+8 SET ^TMP("AQAOUSA",$JOB,"A",N,AQAOUSR)=S
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
+11 ;
MEMBERS ; >> SUBRTN to find team members for ind tied to occ
+1 ;indicator
SET AQAOIND=$PIECE(^AQAOC(AQAOIFN,0),U,8)
+2 ;service
SET AQAOSRV=$PIECE(^AQAOC(AQAOIFN,0),U,7)
+3 ;
+4 ;find all teams for ind
SET AQAOT=0
+5 FOR
SET AQAOT=$ORDER(^AQAO(2,AQAOIND,"QTM",AQAOT))
IF AQAOT'=+AQAOT
QUIT
Begin DoDot:1
+6 IF '$DATA(^AQAO(2,AQAOIND,"QTM",AQAOT,0))
QUIT
SET AQAOS=^(0)
+7 ;team name
SET AQAOTN=$PIECE(^AQAO1(1,$PIECE(AQAOS,U),0),U,2)
+8 SET AQAOTX=$PIECE(AQAOS,U)
+9 ;team has access by srv; not right srv in this occ
IF AQAOSRV]""
IF +$ORDER(^AQAO1(1,AQAOTX,1,0))
IF '$DATA(^AQAO1(1,"AB",AQAOSRV,AQAOTX))
QUIT
+10 ;
+11 ;find all users on team & their access level
SET AQAOUSR=0
+12 FOR
SET AQAOUSR=$ORDER(^AQAO(9,"AB",AQAOTX,AQAOUSR))
IF AQAOUSR=""
QUIT
Begin DoDot:2
+13 SET AQAOX=0
+14 FOR
SET AQAOX=$ORDER(^AQAO(9,"AB",AQAOTX,AQAOUSR,AQAOX))
IF AQAOX=""
QUIT
Begin DoDot:3
+15 ;inactive;PATCH 4
IF $PIECE(^AQAO(9,AQAOUSR,0),U,4)]""
QUIT
+16 SET Y=$PIECE($GET(^AQAO(9,AQAOUSR,"TM",AQAOX,0)),U,2)
+17 ;access level
IF Y]""
SET C=$PIECE(^DD(9002168.91,.02,0),U,2)
DO Y^DIQ
+18 ;user name
SET N=$PIECE(^VA(200,AQAOUSR,0),U)
+19 ;already listed as qi staff
IF $DATA(^TMP("AQAOUSA",$JOB,"A",N,AQAOUSR))
QUIT
+20 ;add team & access level
SET ^TMP("AQAOUSA",$JOB,"M",N,AQAOUSR)=$GET(^TMP("AQAOUSA",$JOB,"M",N,AQAOUSR))_AQAOTN_U_Y_U
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
+23 ;
REFERRAL ; -- SUBRTN to find all users to whom occ was referred;PATCH 4
+1 ;PATCH 4: SUBRTN REWRITTEN
+2 NEW X,AQAOX,Y
+3 ; -- initial review
+4 SET X=$PIECE(^AQAOC(AQAOIFN,1),U,9)
IF X=""
QUIT
SET Y=$PIECE(^(1),U,4)
+5 DO REFSET(X,Y)
+6 ;
+7 ; -- addtnl referrals on initial review
+8 SET AQAOX=0
+9 FOR
SET AQAOX=$ORDER(^AQAOC(AQAOIFN,"IADDRV",AQAOX))
IF 'AQAOX
QUIT
Begin DoDot:1
+10 SET X=^AQAOC(AQAOIFN,"IADDRV",AQAOX,0)
DO REFSET(X,Y)
End DoDot:1
+11 ;
+12 ; -- referrals from reviews
+13 SET AQAOX=0
+14 FOR
SET AQAOX=$ORDER(^AQAOC(AQAOIFN,"REV",AQAOX))
IF 'AQAOX
QUIT
Begin DoDot:1
+15 SET X=$PIECE($GET(^AQAOC(AQAOIFN,"REV",AQAOX,0)),U,9)
IF X=""
QUIT
+16 SET Y=$PIECE($GET(^AQAOC(AQAOIFN,"REV",AQAOX,0)),U,2)
+17 DO REFSET(X,Y)
+18 ; -- addtnl referrals from this review
+19 SET AQAOY=0
+20 FOR
SET AQAOY=$ORDER(^AQAOC(AQAOIFN,"REV",AQAOX,"ADDRV",AQAOY))
IF 'AQAOY
QUIT
Begin DoDot:2
+21 SET X=^AQAOC(AQAOIFN,"REV",AQAOX,"ADDRV",AQAOY,0)
DO REFSET(X,Y)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
+24 ;
REFSET(X,AQAOY) ; -- SUBRTN to set ^tmp for users found;PATCH 4
+1 ;PATCH 4: SUBRTN ADDED
+2 ; X=referred to, AQAOY=referred by
+3 NEW AQAOUSR,AQAOT,AQAOTN,AQAOX,Y
+4 ; -- referred to user by name
+5 IF X["AQAO(9"
Begin DoDot:1
+6 SET AQAOUSR=$PIECE(X,";")
SET N=$PIECE(^VA(200,AQAOUSR,0),U)
+7 ;already on qi staff list
IF $DATA(^TMP("AQAOUSA",$JOB,"A",N,AQAOUSR))
QUIT
+8 ;on team listing
IF $DATA(^TMP("AQAOUSA",$JOB,"M",N,AQAOUSR))
QUIT
+9 SET Y=AQAOY
SET C=$PIECE(^DD(9002167,.14,0),U,2)
DO Y^DIQ
+10 ;Y=referred by
SET ^TMP("AQAOUSA",$JOB,"R",N,AQAOUSR)=$GET(^TMP("AQAOUSA",$JOB,"R",N,AQAOUSR))_Y_U
End DoDot:1
QUIT
+11 ;
+12 ; -- else if referred to team
+13 ;team on ind list
IF $DATA(^AQAO(2,AQAOIND,"QTM","B",$PIECE(X,";")))
QUIT
+14 ;team name
SET AQAOT=$PIECE(X,";")
SET AQAOTN=$PIECE(^AQAO1(1,AQAOT,0),U,2)
+15 SET Y=AQAOY
SET C=$PIECE(^DD(9002167,.14,0),U,2)
DO Y^DIQ
SET AQAOY=Y
+16 ;
+17 ; -- find all users on team & their access level
+18 SET AQAOUSR=0
+19 FOR
SET AQAOUSR=$ORDER(^AQAO(9,"AB",AQAOT,AQAOUSR))
IF AQAOUSR=""
QUIT
Begin DoDot:1
+20 SET AQAOX=0
+21 FOR
SET AQAOX=$ORDER(^AQAO(9,"AB",AQAOT,AQAOUSR,AQAOX))
IF AQAOX=""
QUIT
Begin DoDot:2
+22 SET Y=$PIECE($GET(^AQAO(9,AQAOUSR,"TM",AQAOX,0)),U,2)
+23 ;access level
IF Y]""
SET C=$PIECE(^DD(9002168.91,.02,0),U,2)
DO Y^DIQ
+24 ;user name
SET N=$PIECE(^VA(200,AQAOUSR,0),U)
+25 ;already listed as qi staff
IF $DATA(^TMP("AQAOUSA",$JOB,"A",N,AQAOUSR))
QUIT
+26 ;already on team list
IF $DATA(^TMP("AQAOUSA",$JOB,"M",N,AQAOUSR))
QUIT
+27 ;already referred by name
IF $DATA(^TMP("AQAOUSA",$JOB,"R",N,AQAOUSR))
QUIT
+28 ;add team & accs lev
SET ^TMP("AQAOUSA",$JOB,"T",N,AQAOUSR)=$GET(^TMP("AQAOUSA",$JOB,"T",N,AQAOUSR))_AQAOY_U_AQAOTN_U_Y_U
End DoDot:2
End DoDot:1
+29 QUIT
