AQAOPR71 ; IHS/ORDC/LJF - CALCULATE REVIEWED OCC RPRT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn finds all appropriate occurrences based on indicators
;selected and date range.
;
K ^TMP("AQAOPR7A",$J)
S AQAOCNT=0 ;initialize total count
TMP ; >>> loop thru ^TMP to find indicators
F AQAOI="SINGLE","MED STAFF F","FACILITY WIDE","KEY FUNCTION","DIMENSION","OTHER" D
.S AQAOF=AQAOI
.F S AQAOF=$O(^TMP("AQAOPR7",$J,1,AQAOF)) Q:AQAOF'[AQAOI D
..S AQAOIND=0
..F S AQAOIND=$O(^TMP("AQAOPR7",$J,1,AQAOF,AQAOIND)) Q:AQAOIND="" D
...;
...; >>for this indicator, find occ for date range
...S AQAODT=AQAOBD-.0001,AQAOEDT=AQAOED_.2400
...F S AQAODT=$O(^AQAOC("AA",AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAODT>AQAOEDT D
....S DFN=0
....F S DFN=$O(^AQAOC("AA",AQAOIND,AQAODT,DFN)) Q:DFN="" D
.....S AQAOIFN=0
.....F S AQAOIFN=$O(^AQAOC("AA",AQAOIND,AQAODT,DFN,AQAOIFN)) Q:AQAOIFN="" D
......Q:'$$STATUS ;wrong case status
......Q:'$$USERTEAM ;at least one rev/ref has one of selected user/team
......S AQAOCNT=AQAOCNT+1 ;increment total cases
......S X=$P(^AQAO(2,AQAOIND,0),U)_" "_$P(^(0),U,2) ;ind # & name
......S ^TMP("AQAOPR7A",$J,X,AQAODT,AQAOIFN)=""
;
NEXT ; >>> go to print rtn
G ^AQAOPR72
;
;
STATUS() ;EXTR VAR to check case status against user's choice
N X,Y S X=1,Y=$P(^AQAOC(AQAOIFN,1),U) ;status (open,closed,deleted)
I (AQAOSTAT'[1),(Y=0) S X=0 ;open not included in user's choice
I (AQAOSTAT'[2),(Y=1) S X=0 ;closed not included in user's choice
I (AQAOSTAT'[3),(Y=2) S X=0 ;deleted not included in user's choice
Q X
;
;
USERTEAM() ;EXTR VAR to check selected user/teams against occ review
N W,X,Y,Z
S Z=$P($G(^AQAOC(AQAOIFN,1)),U,4) I Z="" Q 0 ;initial reviewer
I ('$O(AQAOO("USR",0))),('$O(AQAOO("TEAM",0))) Q 1 ;no restrictions
I $$OK Q 1
S Z=$P($G(^AQAOC(AQAOIFN,1)),U,9) I Z="" Q 0 ;initial referral
I $$OK Q 1
S (Y,X)=0 F S X=$O(^AQAOC(AQAOIFN,"IADDRV",X)) Q:'X Q:Y=1 D
.S Z=$P($G(^AQAOC(AQAOIFN,"IADDRV",X,0)),U) I Z="" Q
.I $$OK S Y=1 Q
I Y=1 Q 1 ;at least one add referrals
S (Y,X)=0 F S X=$O(^AQAOC(AQAOIFN,"REV",X)) Q:'X Q:Y=1 D
.S Z=$P($G(^AQAOC(AQAOIFN,"REV",X,0)),U,2) I Z="" Q
.I $$OK S Y=1 Q
.S W=0 F S W=$O(^AQAOC(AQAOIFN,"REV",X,"ADDRV",W)) Q:'W Q:Y=1 D
..S Z=$P($G(^AQAOC(AQAOIFN,"REV",X,"ADDRV",W,0)),U) I Z="" Q
..I $$OK S Y=1 Q
Q Y
;
;
OK() ;EXTR VAR to test entry against selection arrays
Q ($D(AQAOO("USR",Z)))!($D(AQAOO("TEAM",Z)))
AQAOPR71 ; IHS/ORDC/LJF - CALCULATE REVIEWED OCC RPRT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn finds all appropriate occurrences based on indicators
+4 ;selected and date range.
+5 ;
+6 KILL ^TMP("AQAOPR7A",$JOB)
+7 ;initialize total count
SET AQAOCNT=0
TMP ; >>> loop thru ^TMP to find indicators
+1 FOR AQAOI="SINGLE","MED STAFF F","FACILITY WIDE","KEY FUNCTION","DIMENSION","OTHER"
Begin DoDot:1
+2 SET AQAOF=AQAOI
+3 FOR
SET AQAOF=$ORDER(^TMP("AQAOPR7",$JOB,1,AQAOF))
IF AQAOF'[AQAOI
QUIT
Begin DoDot:2
+4 SET AQAOIND=0
+5 FOR
SET AQAOIND=$ORDER(^TMP("AQAOPR7",$JOB,1,AQAOF,AQAOIND))
IF AQAOIND=""
QUIT
Begin DoDot:3
+6 ;
+7 ; >>for this indicator, find occ for date range
+8 SET AQAODT=AQAOBD-.0001
SET AQAOEDT=AQAOED_.2400
+9 FOR
SET AQAODT=$ORDER(^AQAOC("AA",AQAOIND,AQAODT))
IF AQAODT=""
QUIT
IF AQAODT>AQAOEDT
QUIT
Begin DoDot:4
+10 SET DFN=0
+11 FOR
SET DFN=$ORDER(^AQAOC("AA",AQAOIND,AQAODT,DFN))
IF DFN=""
QUIT
Begin DoDot:5
+12 SET AQAOIFN=0
+13 FOR
SET AQAOIFN=$ORDER(^AQAOC("AA",AQAOIND,AQAODT,DFN,AQAOIFN))
IF AQAOIFN=""
QUIT
Begin DoDot:6
+14 ;wrong case status
IF '$$STATUS
QUIT
+15 ;at least one rev/ref has one of selected user/team
IF '$$USERTEAM
QUIT
+16 ;increment total cases
SET AQAOCNT=AQAOCNT+1
+17 ;ind # & name
SET X=$PIECE(^AQAO(2,AQAOIND,0),U)_" "_$PIECE(^(0),U,2)
+18 SET ^TMP("AQAOPR7A",$JOB,X,AQAODT,AQAOIFN)=""
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
NEXT ; >>> go to print rtn
+1 GOTO ^AQAOPR72
+2 ;
+3 ;
STATUS() ;EXTR VAR to check case status against user's choice
+1 ;status (open,closed,deleted)
NEW X,Y
SET X=1
SET Y=$PIECE(^AQAOC(AQAOIFN,1),U)
+2 ;open not included in user's choice
IF (AQAOSTAT'[1)
IF (Y=0)
SET X=0
+3 ;closed not included in user's choice
IF (AQAOSTAT'[2)
IF (Y=1)
SET X=0
+4 ;deleted not included in user's choice
IF (AQAOSTAT'[3)
IF (Y=2)
SET X=0
+5 QUIT X
+6 ;
+7 ;
USERTEAM() ;EXTR VAR to check selected user/teams against occ review
+1 NEW W,X,Y,Z
+2 ;initial reviewer
SET Z=$PIECE($GET(^AQAOC(AQAOIFN,1)),U,4)
IF Z=""
QUIT 0
+3 ;no restrictions
IF ('$ORDER(AQAOO("USR",0)))
IF ('$ORDER(AQAOO("TEAM",0)))
QUIT 1
+4 IF $$OK
QUIT 1
+5 ;initial referral
SET Z=$PIECE($GET(^AQAOC(AQAOIFN,1)),U,9)
IF Z=""
QUIT 0
+6 IF $$OK
QUIT 1
+7 SET (Y,X)=0
FOR
SET X=$ORDER(^AQAOC(AQAOIFN,"IADDRV",X))
IF 'X
QUIT
IF Y=1
QUIT
Begin DoDot:1
+8 SET Z=$PIECE($GET(^AQAOC(AQAOIFN,"IADDRV",X,0)),U)
IF Z=""
QUIT
+9 IF $$OK
SET Y=1
QUIT
End DoDot:1
+10 ;at least one add referrals
IF Y=1
QUIT 1
+11 SET (Y,X)=0
FOR
SET X=$ORDER(^AQAOC(AQAOIFN,"REV",X))
IF 'X
QUIT
IF Y=1
QUIT
Begin DoDot:1
+12 SET Z=$PIECE($GET(^AQAOC(AQAOIFN,"REV",X,0)),U,2)
IF Z=""
QUIT
+13 IF $$OK
SET Y=1
QUIT
+14 SET W=0
FOR
SET W=$ORDER(^AQAOC(AQAOIFN,"REV",X,"ADDRV",W))
IF 'W
QUIT
IF Y=1
QUIT
Begin DoDot:2
+15 SET Z=$PIECE($GET(^AQAOC(AQAOIFN,"REV",X,"ADDRV",W,0)),U)
IF Z=""
QUIT
+16 IF $$OK
SET Y=1
QUIT
End DoDot:2
End DoDot:1
+17 QUIT Y
+18 ;
+19 ;
OK() ;EXTR VAR to test entry against selection arrays
+1 QUIT ($DATA(AQAOO("USR",Z)))!($DATA(AQAOO("TEAM",Z)))
