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

AQAOCHK.m

Go to the documentation of this file. 
  1. AQAOCHK ; IHS/ORDC/LJF - CHECK OCC NEEDING REVIEW ;
  1.  ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
  1.  ;
  1.  ;This rtn is main driver for the Introductory Message upom entrance
  1.  ;to main QAI menu.  It is also called from the Tickler Report option.
  1.  ;This rtn finds all occurrences needing some action by the user who
  1.  ;is signed on.  QI staff members see all occurrences pending.
  1.  ;PATCH #4: close to a complete rewrite
  1.  ;
  1.  ; AQAOXYZ="ALL" for QI staff which see all occurrences
  1.  ; AQAOXYZ(1,TEAM IFN)
  1.  ; AQAOXYZ(2,INDICATOR IFN) for entries in AQAOXYZ(1,TEAM IFN)
  1.  ; array for occ counts AQAOXYZ(3,
  1.  ; second subscript: 1=initial review needed
  1.  ;                   2=personal referral
  1.  ;                   3=referral to team
  1.  ;                   4=reviewed, not closed
  1.  ;                   5=pending action plans
  1.  ;
  1. ENTRY ;ENTRY POINT to build array counting occ needing review
  1.  ;called by main menu option AQAOMENU and by AQAOCHK2
  1.  W !!,*7,"Checking for OCCURRENCES & ACTION PLANS you need to review"
  1.  W ". . . . ."
  1.  ;
  1.  S AQAODUZ=DUZ
  1.  K AQAOXYZ K ^TMP("AQAOCHK",$J) ;start clean
  1.  I $P(AQAOUA("USER"),U,6)]"" S AQAOXYZ="ALL" ;qi staff sees all
  1.  ;
  1.  ; -- find indicators user has access to
  1.  ; -- find all teams user has write access to
  1.  S X=0 F  S X=$O(^AQAO(9,AQAODUZ,"TM",X)) Q:'X  D
  1.  . Q:$P(^AQAO(9,AQAODUZ,"TM",X,0),U,2)'=2  ;need write access
  1.  . S Y=$P(^AQAO(9,AQAODUZ,"TM",X,0),U)
  1.  . S AQAOXYZ(1,Y)=""
  1.  . ; -- find all indicators for this team
  1.  . S AQAOIND=0
  1.  . F  S AQAOIND=$O(^AQAO(2,"AC",Y,AQAOIND)) Q:AQAOIND=""  D
  1.  .. S AQAOXYZ(2,AQAOIND)="" ;save list of indicators
  1.  ;
  1.  ;
  1. OCC ;EP; -- loop thru open occurrences then check if on indicator list
  1.  S AQAOIFN=0
  1.  F  S AQAOIFN=$O(^AQAOC("AD",0,AQAOIFN)) Q:AQAOIFN=""  D
  1.  . Q:'$D(^AQAOC(AQAOIFN,0))  Q:$P(^(0),U,9)'=DUZ(2)
  1.  . S AQAOIND=$P(^AQAOC(AQAOIFN,0),U,8),AQAODT=$P(^(0),U,4)
  1.  . S AQAOAC=$P($G(^AQAOC(AQAOIFN,1)),U,6) ;initial review action
  1.  . I AQAOAC="" S X=1 D SET^AQAOCHK0 Q  ;needs initial review
  1.  . D REVIEWS,OPEN
  1.  D ACTION
  1.  ;
  1. NEXT ; -- go to print rtn
  1.  ;if no occ needing review found; quit rtn
  1.  I '$D(AQAOXYZ(3)) W !!,"*** NONE FOUND ***" G END^AQAOCHK2
  1.  G ^AQAOCHK1
  1.  ;
  1.  ;
  1. REVIEWS ; -- SUBRTN to find occ referred to user or team
  1.  K AQAOR1,AQAOR2,AQAOA,AQAOB
  1.  ; -- check for initial referral
  1.  S A=$P(^AQAOC(AQAOIFN,1),U,6) Q:A=""  Q:$P(^AQAO(6,A,0),U,4)'=1
  1.  S AQAOX=$P(^AQAOC(AQAOIFN,1),U,9) Q:AQAOX=""  ;no referral on initial
  1.  S AQAODT=$P(^AQAOC(AQAOIFN,1),U,8),R=$P(^AQAOC(AQAOIFN,1),U,4)
  1.  D REVSET(AQAOX,0,AQAODT,R)
  1.  ;
  1.  ; -- check for addtnl referrals on initial review
  1.  S AQAOA=0
  1.  F  S AQAOA=$O(^AQAOC(AQAOIFN,"IADDRV",AQAOA)) Q:'AQAOA  D
  1.  . S AQAOX=$P(^AQAOC(AQAOIFN,"IADDRV",AQAOA,0),U)
  1.  . D REVSET(AQAOX,0_","_AQAOA,AQAODT,R)
  1.  ;
  1.  ; -- check for other reviews
  1.  S AQAOREV=0
  1.  F  S AQAOREV=$O(^AQAOC(AQAOIFN,"REV",AQAOREV)) Q:AQAOREV'=+AQAOREV  D
  1.  . S X=^AQAOC(AQAOIFN,"REV",AQAOREV,0),AQAOY=$P(X,U,2)
  1.  . S A=$P(X,U,7) Q:A=""
  1.  . S AQAOX=$P(X,U,9),AQAODT=$P(X,U,4)
  1.  . ; -- not referral action but still save reviewed by
  1.  . I (AQAOX="")!($P(^AQAO(6,A,0),U,4)'=1) S AQAOR2(AQAOY)=AQAODT_U_AQAOREV Q
  1.  . D REVSET(AQAOX,AQAOREV,AQAODT,AQAOY) ;chk referred to
  1.  . ;
  1.  . ; -- check addtnl refls on review
  1.  . S AQAOB=0
  1.  . F  S AQAOB=$O(^AQAOC(AQAOIFN,"REV",AQAOREV,"ADDRV",AQAOB)) Q:'AQAOB  D
  1.  .. S AQAOX=$P(^AQAOC(AQAOIFN,"REV",AQAOREV,"ADDRV",AQAOB,0),U)
  1.  .. D REVSET(AQAOX,AQAOREV,AQAODT,AQAOY)
  1.  ;
  1.  ; -- show all referrals not yet reviewed if qi staff
  1.  I $D(AQAOXYZ)#2 D QIREF^AQAOCHK0 Q
  1.  ;
  1.  Q:'$D(AQAOR1)
  1.  D USER
  1.  D TEAM
  1.  Q
  1.  ;
  1.  ;
  1. USER ; -- check if user has referral after last review performed by user
  1.  NEW X,Y,AQAOREF
  1.  S X=AQAODUZ_";AQAO(9," Q:'$D(AQAOR1(X))  ;no referrals for user
  1.  S Y=AQAODUZ_";VA(200,"
  1.  I $P(AQAOR1(X),U)'<+$G(AQAOR2(Y)) D
  1.  . S Y=$P(AQAOR1(X),U,2),(X,AQAOLST)=+Y,Y=$P(Y,",",2)
  1.  . S AQAOREF=$$SETREFRL^AQAOCHK0(X,Y) Q:AQAOREF=""
  1.  . D REFSET^AQAOCHK0
  1.  Q
  1.  ;
  1. TEAM ; -- check if team has referral after last review performed by team
  1.  NEW X,Y,Z,AQAOREF
  1.  S Z=0 F  S Z=$O(AQAOXYZ(1,Z)) Q:'Z  D
  1.  . S (X,Y)=Z_";AQAO1(1," Q:'$D(AQAOR1(X))
  1.  . I $P(AQAOR1(X),U)'<+$G(AQAOR2(Y)) D
  1.  .. S Y=$P(AQAOR1(X),U,2),(X,AQAOLST)=+Y,Y=$P(Y,",",2)
  1.  .. S AQAOREF=$$SETREFRL^AQAOCHK0(X,Y)
  1.  .. D REFSET^AQAOCHK0
  1.  Q
  1.  ;
  1. REVSET(X,Y,D,R) ; -- SUBRTN to set review array
  1.  ; X=referred to, Y=review number, D=review date, R=reviewed by
  1.  S AQAOR1(X)=D_U_Y,AQAOR2(R)=D_U_Y Q
  1.  I $D(AQAOXYZ)#2 S AQAOR1(X)=D_U_Y,AQAOR2(R)=D_U_Y Q
  1.  I X["AQAO(9",+X=AQAODUZ S AQAOR1(X)=D_U_Y
  1.  I X["AQAO1(1",$D(AQAOXYZ(1,+X)) S AQAOR1(X)=D_U_Y
  1.  I R["VA(200",+R=AQAODUZ S AQAOR2(R)=D_U_Y
  1.  I R["AQAO1(1",$D(AQAOXYZ(1,+R)) S AQAOR2(R)=D_U_Y
  1.  Q
  1.  ;
  1. OPEN ; -- SUBRTN to find open cases
  1.  NEW X,Y
  1.  S X=0 F  S X=$O(AQAOR1(X)) Q:'X  D
  1.  . I $P(AQAOR1(X),U)<+$G(AQAOR2(X)) K AQAOR1(X)
  1.  Q:$D(AQAOR1)
  1.  S X=4,AQAOLST=$$LASTREV D SET^AQAOCHK0
  1.  Q
  1.  ;
  1. LASTREV() ; -- SUBRTN to find last review date
  1.  NEW X,D,Y S (X,D,Y)=0
  1.  F  S X=$O(AQAOR2(X)) Q:'X  D
  1.  . I AQAOR2(X)>D S Y=$P(AQAOR2(X),U,2),D=$P(AQAOR2(X),U)
  1.  Q Y
  1.  ;
  1. ACTION ; -- SUBRTN to find any pending action plans user needs to review
  1.  F I=1:1:5 S AQAOPLN=0 D
  1.  .F  S AQAOPLN=$O(^AQAO(5,"AC",I,AQAOPLN)) Q:AQAOPLN=""  D
  1.  ..Q:'$D(^AQAO(5,AQAOPLN,0))  S AQAOSTR=^(0),AQAOIND=$P(AQAOSTR,U,14)
  1.  ..Q:$P(^AQAO(5,AQAOPLN,0),U,12)'=DUZ(2)  ;PATCH 3
  1.  ..I '($D(AQAOXYZ)#2),AQAOIND]"" Q:'$D(AQAOXYZ(2,AQAOIND))  ;not usr ind
  1.  ..I (I=2),($P(AQAOSTR,U,4)]""),($P(AQAOSTR,U,4)<DT) Q  ;future revw dt
  1.  ..Q:$P(AQAOSTR,U,6)]""  ;closed action
  1.  ..S AQAOXYZ(3,5,I)=$G(AQAOXYZ(3,5,I))+1
  1.  ..S ^TMP("AQAOCHK",$J,5,AQAOIND,I,AQAOPLN)=""
  1.  Q