Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AQAOUSA

AQAOUSA.m

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