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

AQAOPR71.m

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