AQAOPC11 ; IHS/ORDC/LJF - CALCULATE OCC BY IND ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn contains the code to find the occ by indicator & date range
;and find criteria values.
;
K ^TMP("AQAOPC1",$J) K ^TMP("AQAOPC11",$J)
S AQAOCNT=0 ;initialize total count
DTLOOP ; >>> loop thru occ file by date for indicator
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:'$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) ;exception to criteria?
...I $D(AQAOXSN) Q:$$CHK^AQAOPCX(AQAOXSN)=0 ;flag for special searches
...; ;also returns AQAOARS arry
...S AQAOCNT=AQAOCNT+1 ;increment occ total
...;
...; >> 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
;
NEXT ; >>> go to print rtn
G ^AQAOPC12
;
;
SET ; >> SUBRTN to set ^tmp & increment totals
I AQAOT="" S AQAOVAL="" G SET1 ;no value
S AQAOVAL=$P(^AQAOCC(5,AQAOC,0),U,AQAOT+4) ;crit value
S AQAOVALP="" I AQAOVAL="" G SET1 ;no value set, skip counts
I AQAOT=2 S AQAOVALP=$P($G(^AQAO1(4,AQAOVAL,0)),U,2)
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
I (AQAOT'=2),(AQAOVAL]"") D ;increment value cnt
.S ^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVAL)=$G(^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVAL))+1
I (AQAOT=2),(AQAOVALP]"") D ;increment value counts for set of codes
.S ^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVALP)=$G(^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVALP))+1
I '$D(^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAOIFN)) D
.S ^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAOIFN)=$P(AQAOSTR,U)_U_AQAOCRT_U_AQAOVAL
E S ^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAOIFN)=^(AQAOIFN)_U_AQAOCRT_U_AQAOVAL
Q
AQAOPC11 ; IHS/ORDC/LJF - CALCULATE OCC BY IND ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn contains the code to find the occ by indicator & date range
+4 ;and find criteria values.
+5 ;
+6 KILL ^TMP("AQAOPC1",$JOB)
KILL ^TMP("AQAOPC11",$JOB)
+7 ;initialize total count
SET AQAOCNT=0
DTLOOP ; >>> loop thru occ file by date for indicator
+1 SET AQAODT=AQAOBD-.0001
SET AQAOEDT=AQAOED_.2400
+2 FOR
SET AQAODT=$ORDER(^AQAOC("AA",AQAOIND,AQAODT))
IF AQAODT=""
QUIT
IF AQAODT>AQAOEDT
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 ;exception to criteria?
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 ;increment occ total
SET AQAOCNT=AQAOCNT+1
+13 ;
+14 ; >> loop thru criteria values for occurrence
+15 SET AQAOCRT=0
+16 FOR
SET AQAOCRT=$ORDER(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT))
IF AQAOCRT=""
QUIT
Begin DoDot:4
+17 ;criteria not chosen for report
IF '$DATA(AQAOCR(AQAOCRT))
QUIT
+18 ;set crit type
SET AQAOT=$PIECE($GET(^AQAO1(6,AQAOCRT,0)),U,2)
+19 SET AQAOC=0
+20 FOR
SET AQAOC=$ORDER(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT,AQAOC))
IF AQAOC=""
QUIT
Begin DoDot:5
+21 ;set ^tmp and increment totals
DO SET
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
NEXT ; >>> go to print rtn
+1 GOTO ^AQAOPC12
+2 ;
+3 ;
SET ; >> SUBRTN to set ^tmp & increment totals
+1 ;no value
IF AQAOT=""
SET AQAOVAL=""
GOTO SET1
+2 ;crit value
SET AQAOVAL=$PIECE(^AQAOCC(5,AQAOC,0),U,AQAOT+4)
+3 ;no value set, skip counts
SET AQAOVALP=""
IF AQAOVAL=""
GOTO SET1
+4 IF AQAOT=2
SET AQAOVALP=$PIECE($GET(^AQAO1(4,AQAOVAL,0)),U,2)
+5 SET X=$SELECT(AQAOT=1:.05,AQAOT=2:.06,AQAOT=3:.07,1:.08)
SET Y=AQAOVAL
+6 IF X=.08
SET AQAOVAL=$EXTRACT(Y,4,5)_" "_$EXTRACT(Y,6,7)_" "_$EXTRACT(Y,2,3)
+7 ;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 ;increment value cnt
IF (AQAOT'=2)
IF (AQAOVAL]"")
Begin DoDot:1
+2 SET ^TMP("AQAOPC11",$JOB,AQAOSUB,AQAOCRT,AQAOVAL)=$GET(^TMP("AQAOPC11",$JOB,AQAOSUB,AQAOCRT,AQAOVAL))+1
End DoDot:1
+3 ;increment value counts for set of codes
IF (AQAOT=2)
IF (AQAOVALP]"")
Begin DoDot:1
+4 SET ^TMP("AQAOPC11",$JOB,AQAOSUB,AQAOCRT,AQAOVALP)=$GET(^TMP("AQAOPC11",$JOB,AQAOSUB,AQAOCRT,AQAOVALP))+1
End DoDot:1
+5 IF '$DATA(^TMP("AQAOPC1",$JOB,AQAOSUB,AQAODT,AQAOIFN))
Begin DoDot:1
+6 SET ^TMP("AQAOPC1",$JOB,AQAOSUB,AQAODT,AQAOIFN)=$PIECE(AQAOSTR,U)_U_AQAOCRT_U_AQAOVAL
End DoDot:1
+7 IF '$TEST
SET ^TMP("AQAOPC1",$JOB,AQAOSUB,AQAODT,AQAOIFN)=^(AQAOIFN)_U_AQAOCRT_U_AQAOVAL
+8 QUIT
