- 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
