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