AQAOPC71 ; IHS/ORDC/LJF - CALC FOR SINGLE CRIT RPT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This routine contains the code for calculating the totals for each
;possible value of a review criterion by occurrence date grouped
;by month.
;
;start with clean globals
K ^TMP("AQAOPC7",$J),^TMP("AQAOPC7A",$J),^TMP("AQAOPC7B",$J)
;
LOOP ; >>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
...Q:'$D(^AQAOC(AQAOIFN,0)) S AQAOSTR=^(0) Q:$P(^(1),U)=2 ;deleted
...Q:$P(^AQAOC(AQAOIFN,0),U,9)'=DUZ(2) ;PATCH 3
...Q:$$EXCEP^AQAOLKP(AQAOIFN)
...I $D(AQAOXSN) Q:$$CHK^AQAOPCX(AQAOXSN)=0 ;flag for special searches
...; ;also returns AQAOARS arry
...;
...; >> loop thru criteria values for occurrence
...S AQAOCRT=0
...F S AQAOCRT=$O(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT)) Q:AQAOCRT="" D
....Q:'$D(AQAOCR(AQAOCRT)) ;criteria not chosen for report
....S AQAOT=$P($G(^AQAO1(6,AQAOCRT,0)),U,2) ;set crit type
....S AQAOC=0
....F S AQAOC=$O(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT,AQAOC)) Q:AQAOC="" D
.....D SET ;set ^tmp and increment totals
;
;
;
PRINT ; >>> go to print rtn
I $D(AQAODLM) G ^AQAOPC73 ; ASCIIformat
G ^AQAOPC72
;
;
;
SET ; >> SUBRTN to set ^tmp & increment totals
S AQAOMON=$E(AQAODT,1,5) ;month of occ
I AQAOT="" Q ;no value
S AQAOVAL=$P(^AQAOCC(5,AQAOC,0),U,AQAOT+4) ;crit value
I AQAOVAL="" Q ;no value set, skip counts
;I AQAOT=2 S AQAOVAL=$P(^AQAO1(4,AQAOVAL,0),U,2) G SET1
S X=$S(AQAOT=1:.05,AQAOT=2:.06,AQAOT=3:.07,1:.08),Y=AQAOVAL
I X=.08 S AQAOVAL=$E(Y,4,5)_" "_$E(Y,6,7)_" "_$E(Y,2,3)
E S C=$P(^DD(9002166.5,X,0),U,2) D Y^DIQ S AQAOVAL=Y ;printable form
COMMAS I AQAOVAL["," S AQAOVAL=$P(AQAOVAL,",")_" "_$P(AQAOVAL,",",2,99) G COMMAS
;
SET1 S AQAOSUB=0 I '$D(AQAOXSN) D SET2 Q
F S AQAOSUB=$O(AQAOARS(AQAOSUB)) Q:AQAOSUB="" D SET2
Q
;
;
SET2 ; >> SUBRTN to increment counts
Q:AQAOVAL="N/A"
S AQAOCNT(AQAOSUB)=$G(AQAOCNT(AQAOSUB))+1 ;increment occ total
S ^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL)=$G(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL))+1
S ^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON)=$G(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON))+1
S ^TMP("AQAOPC7B",$J,AQAOSUB,AQAOMON)=$G(^TMP("AQAOPC7B",$J,AQAOSUB,AQAOMON))+1
I AQAOTYPE="L" D
.S AQAOID=$P(^AQAOC(AQAOIFN,0),U)
.K ^UTILITY("DIQ1",$J) S DIC="^AQAOC(",DA=AQAOIFN,DR=".025" D EN^DIQ1
.S X=^UTILITY("DIQ1",$J,9002167,AQAOIFN,.025) ;age at time of occ
.S DFN=$P(^AQAOC(AQAOIFN,0),U,2) Q:DFN=""
.S X=X_U_$P(^DPT(DFN,0),U,2)_U_AQAOVAL
.S ^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT,AQAOID)=X
Q
AQAOPC71 ; IHS/ORDC/LJF - CALC FOR SINGLE CRIT RPT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This routine contains the code for calculating the totals for each
+4 ;possible value of a review criterion by occurrence date grouped
+5 ;by month.
+6 ;
+7 ;start with clean globals
+8 KILL ^TMP("AQAOPC7",$JOB),^TMP("AQAOPC7A",$JOB),^TMP("AQAOPC7B",$JOB)
+9 ;
LOOP ; >>for this indicator, find occ for date range
+1 SET AQAODT=AQAOBD-.001
+2 FOR
SET AQAODT=$ORDER(^AQAOC("AA",AQAOIND,AQAODT))
IF AQAODT=""
QUIT
IF AQAODT>(AQAOED_".24")
QUIT
Begin DoDot:1
+3 SET DFN=0
+4 FOR
SET DFN=$ORDER(^AQAOC("AA",AQAOIND,AQAODT,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+5 SET AQAOIFN=0
+6 FOR
SET AQAOIFN=$ORDER(^AQAOC("AA",AQAOIND,AQAODT,DFN,AQAOIFN))
IF AQAOIFN=""
QUIT
Begin DoDot:3
+7 ;deleted
IF '$DATA(^AQAOC(AQAOIFN,0))
QUIT
SET AQAOSTR=^(0)
IF $PIECE(^(1),U)=2
QUIT
+8 ;PATCH 3
IF $PIECE(^AQAOC(AQAOIFN,0),U,9)'=DUZ(2)
QUIT
+9 IF $$EXCEP^AQAOLKP(AQAOIFN)
QUIT
+10 ;flag for special searches
IF $DATA(AQAOXSN)
IF $$CHK^AQAOPCX(AQAOXSN)=0
QUIT
+11 ; ;also returns AQAOARS arry
+12 ;
+13 ; >> loop thru criteria values for occurrence
+14 SET AQAOCRT=0
+15 FOR
SET AQAOCRT=$ORDER(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT))
IF AQAOCRT=""
QUIT
Begin DoDot:4
+16 ;criteria not chosen for report
IF '$DATA(AQAOCR(AQAOCRT))
QUIT
+17 ;set crit type
SET AQAOT=$PIECE($GET(^AQAO1(6,AQAOCRT,0)),U,2)
+18 SET AQAOC=0
+19 FOR
SET AQAOC=$ORDER(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT,AQAOC))
IF AQAOC=""
QUIT
Begin DoDot:5
+20 ;set ^tmp and increment totals
DO SET
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 ;
+23 ;
PRINT ; >>> go to print rtn
+1 ; ASCIIformat
IF $DATA(AQAODLM)
GOTO ^AQAOPC73
+2 GOTO ^AQAOPC72
+3 ;
+4 ;
+5 ;
SET ; >> SUBRTN to set ^tmp & increment totals
+1 ;month of occ
SET AQAOMON=$EXTRACT(AQAODT,1,5)
+2 ;no value
IF AQAOT=""
QUIT
+3 ;crit value
SET AQAOVAL=$PIECE(^AQAOCC(5,AQAOC,0),U,AQAOT+4)
+4 ;no value set, skip counts
IF AQAOVAL=""
QUIT
+5 ;I AQAOT=2 S AQAOVAL=$P(^AQAO1(4,AQAOVAL,0),U,2) G SET1
+6 SET X=$SELECT(AQAOT=1:.05,AQAOT=2:.06,AQAOT=3:.07,1:.08)
SET Y=AQAOVAL
+7 IF X=.08
SET AQAOVAL=$EXTRACT(Y,4,5)_" "_$EXTRACT(Y,6,7)_" "_$EXTRACT(Y,2,3)
+8 ;printable form
IF '$TEST
SET C=$PIECE(^DD(9002166.5,X,0),U,2)
DO Y^DIQ
SET AQAOVAL=Y
COMMAS IF AQAOVAL[","
SET AQAOVAL=$PIECE(AQAOVAL,",")_" "_$PIECE(AQAOVAL,",",2,99)
GOTO COMMAS
+1 ;
SET1 SET AQAOSUB=0
IF '$DATA(AQAOXSN)
DO SET2
QUIT
+1 FOR
SET AQAOSUB=$ORDER(AQAOARS(AQAOSUB))
IF AQAOSUB=""
QUIT
DO SET2
+2 QUIT
+3 ;
+4 ;
SET2 ; >> SUBRTN to increment counts
+1 IF AQAOVAL="N/A"
QUIT
+2 ;increment occ total
SET AQAOCNT(AQAOSUB)=$GET(AQAOCNT(AQAOSUB))+1
+3 SET ^TMP("AQAOPC7",$JOB,AQAOSUB,AQAOVAL)=$GET(^TMP("AQAOPC7",$JOB,AQAOSUB,AQAOVAL))+1
+4 SET ^TMP("AQAOPC7",$JOB,AQAOSUB,AQAOVAL,AQAOMON)=$GET(^TMP("AQAOPC7",$JOB,AQAOSUB,AQAOVAL,AQAOMON))+1
+5 SET ^TMP("AQAOPC7B",$JOB,AQAOSUB,AQAOMON)=$GET(^TMP("AQAOPC7B",$JOB,AQAOSUB,AQAOMON))+1
+6 IF AQAOTYPE="L"
Begin DoDot:1
+7 SET AQAOID=$PIECE(^AQAOC(AQAOIFN,0),U)
+8 KILL ^UTILITY("DIQ1",$JOB)
SET DIC="^AQAOC("
SET DA=AQAOIFN
SET DR=".025"
DO EN^DIQ1
+9 ;age at time of occ
SET X=^UTILITY("DIQ1",$JOB,9002167,AQAOIFN,.025)
+10 SET DFN=$PIECE(^AQAOC(AQAOIFN,0),U,2)
IF DFN=""
QUIT
+11 SET X=X_U_$PIECE(^DPT(DFN,0),U,2)_U_AQAOVAL
+12 SET ^TMP("AQAOPC7A",$JOB,AQAOSUB,AQAODT,AQAOID)=X
End DoDot:1
+13 QUIT
