- 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
