AQAOPC21 ; IHS/ORDC/LJF - CALCULATE OCC BY ICD CODES ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn contains the code to find the occurrences for the selected
;indicator & date range screened by the diagnoses & procedures the
;user selected.
;
K ^TMP("AQAOPC2",$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)
...I $D(AQAOXSN) Q:$$CHK^AQAOPCX(AQAOXSN)=0 ;spec rev type searches
...; ;AQAOARS array returned
...S AQAOFLG=0 D ICDCHK ;check if occ has icd code in range
...Q:AQAOFLG=0 ;no icd code in ranges
...S AQAOCNT=AQAOCNT+1 ;increment total cases
...;
...S AQAOSUB=0
...I '$D(AQAOXSN) S ^TMP("AQAOPC2",$J,AQAOSUB,AQAODT,AQAOIFN)="" Q
...F S AQAOSUB=$O(AQAOARS(AQAOSUB)) Q:AQAOSUB="" D
....S ^TMP("AQAOPC2",$J,AQAOSUB,AQAODT,AQAOIFN)=""
;
NEXT ; >>> go to print rtn
G ^AQAOPC22
;
;
ICDCHK ; >> SUBRTN to check occ for icd codes in range
I $D(AQAOARR("ALL")),$D(AQAOARR1("ALL")) S AQAOFLG=1 Q ;all codes
F I=8,9 D
.I I=8,$D(AQAOARR("ALL")) S AQAOFLG(I)=1 Q ;bypass dx chk if all dx
.I I=9,$D(AQAOARR1("ALL")) S AQAOFLG(I)=1 Q ;bypass chk if all proc
.S AQAOFLG(I)=0 ;init flag for type of code
.S X=0 F S X=$O(^AQAOCC(I,"AB",AQAOIFN,X)) Q:X'=+X Q:AQAOFLG(I)=1 D
..Q:'$D(^AQAOCC(I,X,0)) S Y=+^(0) ;set pointer to icd file
..S AQAOY=$S(I=8:$P(^ICD9(Y,0),U),1:$P(^ICD0(Y,0),U)) ;icd code #
..S AQAOX=$S(I=8:"AQAOARR(",1:"AQAOARR1(") D RANGE ;is code in range
..S AQAOFLG(I)=AQAOFLG,AQAOFLG=0
I AQAOFLG(8)=1,AQAOFLG(9)=1 S AQAOFLG=1
Q
;
;
RANGE ; >> SUBRTN to check occ code against range selected
S Y=AQAOY-1,AQAOFLG=0
; ;case1:past AQAOY
F S Y=$O(@(AQAOX_""""_Y_""")")) Q:Y="" Q:AQAOY<+Y Q:AQAOFLG=1 D
.S Z=AQAOX_""""_Y_""")",Z=@Z I AQAOY>+Z Q ;case2:continu loop-too low
.S AQAOFLG=1 Q
Q
AQAOPC21 ; IHS/ORDC/LJF - CALCULATE OCC BY ICD CODES ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn contains the code to find the occurrences for the selected
+4 ;indicator & date range screened by the diagnoses & procedures the
+5 ;user selected.
+6 ;
+7 KILL ^TMP("AQAOPC2",$JOB)
+8 ;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 IF $$EXCEP^AQAOLKP(AQAOIFN)
QUIT
+10 ;spec rev type searches
IF $DATA(AQAOXSN)
IF $$CHK^AQAOPCX(AQAOXSN)=0
QUIT
+11 ; ;AQAOARS array returned
+12 ;check if occ has icd code in range
SET AQAOFLG=0
DO ICDCHK
+13 ;no icd code in ranges
IF AQAOFLG=0
QUIT
+14 ;increment total cases
SET AQAOCNT=AQAOCNT+1
+15 ;
+16 SET AQAOSUB=0
+17 IF '$DATA(AQAOXSN)
SET ^TMP("AQAOPC2",$JOB,AQAOSUB,AQAODT,AQAOIFN)=""
QUIT
+18 FOR
SET AQAOSUB=$ORDER(AQAOARS(AQAOSUB))
IF AQAOSUB=""
QUIT
Begin DoDot:4
+19 SET ^TMP("AQAOPC2",$JOB,AQAOSUB,AQAODT,AQAOIFN)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;
NEXT ; >>> go to print rtn
+1 GOTO ^AQAOPC22
+2 ;
+3 ;
ICDCHK ; >> SUBRTN to check occ for icd codes in range
+1 ;all codes
IF $DATA(AQAOARR("ALL"))
IF $DATA(AQAOARR1("ALL"))
SET AQAOFLG=1
QUIT
+2 FOR I=8,9
Begin DoDot:1
+3 ;bypass dx chk if all dx
IF I=8
IF $DATA(AQAOARR("ALL"))
SET AQAOFLG(I)=1
QUIT
+4 ;bypass chk if all proc
IF I=9
IF $DATA(AQAOARR1("ALL"))
SET AQAOFLG(I)=1
QUIT
+5 ;init flag for type of code
SET AQAOFLG(I)=0
+6 SET X=0
FOR
SET X=$ORDER(^AQAOCC(I,"AB",AQAOIFN,X))
IF X'=+X
QUIT
IF AQAOFLG(I)=1
QUIT
Begin DoDot:2
+7 ;set pointer to icd file
IF '$DATA(^AQAOCC(I,X,0))
QUIT
SET Y=+^(0)
+8 ;icd code #
SET AQAOY=$SELECT(I=8:$PIECE(^ICD9(Y,0),U),1:$PIECE(^ICD0(Y,0),U))
+9 ;is code in range
SET AQAOX=$SELECT(I=8:"AQAOARR(",1:"AQAOARR1(")
DO RANGE
+10 SET AQAOFLG(I)=AQAOFLG
SET AQAOFLG=0
End DoDot:2
End DoDot:1
+11 IF AQAOFLG(8)=1
IF AQAOFLG(9)=1
SET AQAOFLG=1
+12 QUIT
+13 ;
+14 ;
RANGE ; >> SUBRTN to check occ code against range selected
+1 SET Y=AQAOY-1
SET AQAOFLG=0
+2 ; ;case1:past AQAOY
+3 FOR
SET Y=$ORDER(@(AQAOX_""""_Y_""")"))
IF Y=""
QUIT
IF AQAOY<+Y
QUIT
IF AQAOFLG=1
QUIT
Begin DoDot:1
+4 ;case2:continu loop-too low
SET Z=AQAOX_""""_Y_""")"
SET Z=@Z
IF AQAOY>+Z
QUIT
+5 SET AQAOFLG=1
QUIT
End DoDot:1
+6 QUIT
