AQAOPC51 ; IHS/ORDC/LJF - CALC FOR QTR PROGRESS RPT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn counts occ finding/action pairs by month for indicator(s)
;selected by user. It also finds action plans tied to the indicators.
;
K ^TMP("AQAOPC5A",$J),^TMP("AQAOPC5B",$J) ;start with clean globals
;
TMP ; >>> loop thru ^TMP to find indicators
F AQAOI="SINGLE","MED STAFF F","FACILITY WIDE","KEY FUNCTION","OTHER","DIMENSION" D
.S AQAOF=AQAOI
.F S AQAOF=$O(^TMP("AQAOPC5",$J,1,AQAOF)) Q:AQAOF'[AQAOI D
..S AQAOIND=0
..F S AQAOIND=$O(^TMP("AQAOPC5",$J,1,AQAOF,AQAOIND)) Q:AQAOIND="" D
...;
...; >>for this indicator, find occ for date range
...S AQAODT=AQAOBD-.001
...F S AQAODT=$O(^AQAOC("AA",AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAODT>(AQAOED_".24") 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
......D CHECK ;check occ for validity
......Q:'$D(AQAOK) ;occ not valid for this report
......D COUNT ;increment counts
...;
...; >>for this indicator, find any action plans linked to it for dates
...D ACTION ;check if action plan linked for date range
;
PRINT ; >>> go to print rtn
I $D(AQAODLM) G ^AQAOPC53 ; ASCIIformat
G ^AQAOPC52
;
;
;
CHECK ; >> SUBRTN to check out occurrence
K AQAOK ;occ okay flag
I '$D(^AQAOC(AQAOIFN,0)) Q ;bad xref
Q:'$D(^AQAOC(AQAOIFN,1)) Q:$P(^(1),U)'=1 ;not closed
Q:$$EXCEP^AQAOLKP(AQAOIFN) ;exception to criteria
Q:'$D(^AQAOC(AQAOIFN,"FINAL")) S AQAOS=^("FINAL")
;Q:$P(AQAOS,U,4)="" Q:$P(AQAOS,U,6)="" ;need final finding & action
S AQAOK="" Q
;
;
COUNT ; >> SUBRTN to increment counts of findings, actions by indicator
;
S X=$P(AQAOS,U,4),AQAOFA=$S(X="":"??",1:$P(^AQAO(8,X,0),U,2)) ;findng
S X=$P(AQAOS,U,6),AQAOAA=$S(X="":"??",1:$P(^AQAO(6,X,0),U,2)) ;action
S AQAOMON=$E(AQAODT,1,5) ;month of occ
;
;increment total count for indicator
S ^TMP("AQAOPC5A",$J,AQAOF,AQAOIND)=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND))+1
;increment count for ind for find&action
S ^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA)=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA))+1
;increment for find&act&month
S ^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA,AQAOMON)=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA,AQAOMON))+1
Q
;
;
ACTION ; >> SUBRTN to find any action plans tied to ind for date range
S AQAOAC=0
F S AQAOAC=$O(^AQAO(5,"C",AQAOIND,AQAOAC)) Q:AQAOAC="" D
.Q:'$D(^AQAO(5,AQAOAC,0)) S AQAOS=^(0)
.Q:$P(AQAOS,U,5)=9 ;deleted action plan
.Q:$P(AQAOS,U,3)<AQAOBD ;implemented before those occurrences
.S ^TMP("AQAOPC5B",$J,AQAOIND,AQAOAC)=""
Q
AQAOPC51 ; IHS/ORDC/LJF - CALC FOR QTR PROGRESS RPT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn counts occ finding/action pairs by month for indicator(s)
+4 ;selected by user. It also finds action plans tied to the indicators.
+5 ;
+6 ;start with clean globals
KILL ^TMP("AQAOPC5A",$JOB),^TMP("AQAOPC5B",$JOB)
+7 ;
TMP ; >>> loop thru ^TMP to find indicators
+1 FOR AQAOI="SINGLE","MED STAFF F","FACILITY WIDE","KEY FUNCTION","OTHER","DIMENSION"
Begin DoDot:1
+2 SET AQAOF=AQAOI
+3 FOR
SET AQAOF=$ORDER(^TMP("AQAOPC5",$JOB,1,AQAOF))
IF AQAOF'[AQAOI
QUIT
Begin DoDot:2
+4 SET AQAOIND=0
+5 FOR
SET AQAOIND=$ORDER(^TMP("AQAOPC5",$JOB,1,AQAOF,AQAOIND))
IF AQAOIND=""
QUIT
Begin DoDot:3
+6 ;
+7 ; >>for this indicator, find occ for date range
+8 SET AQAODT=AQAOBD-.001
+9 FOR
SET AQAODT=$ORDER(^AQAOC("AA",AQAOIND,AQAODT))
IF AQAODT=""
QUIT
IF AQAODT>(AQAOED_".24")
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 ;check occ for validity
DO CHECK
+15 ;occ not valid for this report
IF '$DATA(AQAOK)
QUIT
+16 ;increment counts
DO COUNT
End DoDot:6
End DoDot:5
End DoDot:4
+17 ;
+18 ; >>for this indicator, find any action plans linked to it for dates
+19 ;check if action plan linked for date range
DO ACTION
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;
PRINT ; >>> go to print rtn
+1 ; ASCIIformat
IF $DATA(AQAODLM)
GOTO ^AQAOPC53
+2 GOTO ^AQAOPC52
+3 ;
+4 ;
+5 ;
CHECK ; >> SUBRTN to check out occurrence
+1 ;occ okay flag
KILL AQAOK
+2 ;bad xref
IF '$DATA(^AQAOC(AQAOIFN,0))
QUIT
+3 ;not closed
IF '$DATA(^AQAOC(AQAOIFN,1))
QUIT
IF $PIECE(^(1),U)'=1
QUIT
+4 ;exception to criteria
IF $$EXCEP^AQAOLKP(AQAOIFN)
QUIT
+5 IF '$DATA(^AQAOC(AQAOIFN,"FINAL"))
QUIT
SET AQAOS=^("FINAL")
+6 ;Q:$P(AQAOS,U,4)="" Q:$P(AQAOS,U,6)="" ;need final finding & action
+7 SET AQAOK=""
QUIT
+8 ;
+9 ;
COUNT ; >> SUBRTN to increment counts of findings, actions by indicator
+1 ;
+2 ;findng
SET X=$PIECE(AQAOS,U,4)
SET AQAOFA=$SELECT(X="":"??",1:$PIECE(^AQAO(8,X,0),U,2))
+3 ;action
SET X=$PIECE(AQAOS,U,6)
SET AQAOAA=$SELECT(X="":"??",1:$PIECE(^AQAO(6,X,0),U,2))
+4 ;month of occ
SET AQAOMON=$EXTRACT(AQAODT,1,5)
+5 ;
+6 ;increment total count for indicator
+7 SET ^TMP("AQAOPC5A",$JOB,AQAOF,AQAOIND)=$GET(^TMP("AQAOPC5A",$JOB,AQAOF,AQAOIND))+1
+8 ;increment count for ind for find&action
+9 SET ^TMP("AQAOPC5A",$JOB,AQAOF,AQAOIND,AQAOFA,AQAOAA)=$GET(^TMP("AQAOPC5A",$JOB,AQAOF,AQAOIND,AQAOFA,AQAOAA))+1
+10 ;increment for find&act&month
+11 SET ^TMP("AQAOPC5A",$JOB,AQAOF,AQAOIND,AQAOFA,AQAOAA,AQAOMON)=$GET(^TMP("AQAOPC5A",$JOB,AQAOF,AQAOIND,AQAOFA,AQAOAA,AQAOMON))+1
+12 QUIT
+13 ;
+14 ;
ACTION ; >> SUBRTN to find any action plans tied to ind for date range
+1 SET AQAOAC=0
+2 FOR
SET AQAOAC=$ORDER(^AQAO(5,"C",AQAOIND,AQAOAC))
IF AQAOAC=""
QUIT
Begin DoDot:1
+3 IF '$DATA(^AQAO(5,AQAOAC,0))
QUIT
SET AQAOS=^(0)
+4 ;deleted action plan
IF $PIECE(AQAOS,U,5)=9
QUIT
+5 ;implemented before those occurrences
IF $PIECE(AQAOS,U,3)<AQAOBD
QUIT
+6 SET ^TMP("AQAOPC5B",$JOB,AQAOIND,AQAOAC)=""
End DoDot:1
+7 QUIT
