- AQAQPR41 ;IHS/ANMC/LJF - OUTPT DX BY PROVIDER; [ 05/27/92 11:16 AM ]
- ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
- ;
- ;>>> initialize variables <<<
- S X="ERR^AQAQPR4",@^%ZOSF("TRAP") X ^%ZOSF("BRK") ;allow break
- K ^UTILITY("AQAQPR4",$J)
- S AQAQDT=AQAQBDT-.0001,AQAQEND=AQAQEDT+.2400
- ;
- ;>>> loop thru visit file by date and screen visit
- LOOP F S AQAQDT=$O(^AUPNVSIT("B",AQAQDT)) Q:AQAQDT="" Q:AQAQDT>AQAQEND D
- .S AQAQVDFN=0
- .F S AQAQVDFN=$O(^AUPNVSIT("B",AQAQDT,AQAQVDFN)) Q:AQAQVDFN="" D
- ..Q:'$D(^AUPNVSIT(AQAQVDFN,0)) S AQAQV=^(0)
- ..Q:$P(AQAQV,U,11)=1 ;deleted visit
- ..Q:$P(AQAQV,U,9)<3 ;must have prov,pov, & proc entries
- ..Q:"AHIS"'[$P(AQAQV,U,7) ;service category
- ..Q:$P(AQAQV,U,6)'=DUZ(2) ;location of encounter
- ..D FINDPROV ;get primary provider
- ..Q:AQAQPRV=0 Q:AQAQPRV="" ;bad visit-no primary provider
- ..I AQAQTYP=1,AQAQSRT'="" Q:+AQAQSRT'=AQAQPRV ;not provider asked for
- ..S AQAQCLS=$P(^DIC(6,AQAQPRV,0),U,4) ;provider class
- ..I AQAQTYP=2 Q:+AQAQSRT'=AQAQCLS ;not class asked for
- ..S AQAQCAT=$P($G(^AQAQC(AQAQPRV,0)),U,2) ;staff category
- ..I AQAQTYP=3 Q:AQAQSRT'=AQAQCAT ;not category asked for
- ..S:AQAQCLS'="" AQAQCLS=$P(^DIC(7,AQAQCLS,0),U) ;class name
- ..S AQAQPRV=$P(^DIC(16,AQAQPRV,0),U)_" ("_AQAQCLS_")"
- ..D FINDDX ;get diagnoses for this visit
- ..Q ;get next visit
- ;
- NEXT ;>>> go to print rtn <<<
- G ^AQAQPR42
- ;
- ;>>> end of main rtn <<<
- ;
- FINDDX ;***> SUBRTN to get diagnoses for visits that passed screens
- S AQAQPDFN=0
- F S AQAQPDFN=$O(^AUPNVPOV("AD",AQAQVDFN,AQAQPDFN)) Q:AQAQPDFN="" D
- .Q:'$D(^AUPNVPOV(AQAQPDFN,0)) S AQAQP=^(0)
- .S AQAQICD=$P(^ICD9($P(AQAQP,U),0),U) ;icd code number
- .D GETGRP ;find dx category for icd code
- .;
- .;**> increment count for diagnostic category
- .S ^UTILITY("AQAQPR4",$J,AQAQPRV,AQAQGRP)=$G(^UTILITY("AQAQPR4",$J,AQAQPRV,AQAQGRP))+1 Q
- Q ;return to main rtn loop
- ;
- ;
- FINDPROV ;***> SUBRTN to find primary provider for ambulatory visits
- S (AQAQRDFN,AQAQPRV)=0
- F S AQAQRDFN=$O(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN)) Q:AQAQRDFN="" D
- .Q:'$D(^AUPNVPRV(AQAQRDFN,0)) S AQAQR=^(0)
- .Q:$P(AQAQR,U,4)'="P" ;find another if not primary provider
- .S AQAQPRV=$P(AQAQR,U) ;get provider pointer
- Q ;return to main rtn loop
- ;
- ;
- GETGRP ;***> SUBRTN to get diagnostic category
- S AQAQG=$O(^AQACGM("B",+$P(AQAQICD,"."),0)) Q:AQAQG=""
- S AQAQGRP=$P($G(^AQACGM(AQAQG,0)),U,2) ;group pointer
- S AQAQGN=$G(^AQACCAT(AQAQGRP,0)),AQAQRNG=$P(AQAQGN,U)
- S AQAQGRP="("_AQAQRNG_") "_$P(AQAQGN,U,2) ;(range)_name
- Q
- AQAQPR41 ;IHS/ANMC/LJF - OUTPT DX BY PROVIDER; [ 05/27/92 11:16 AM ]
- +1 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
- +2 ;
- +3 ;>>> initialize variables <<<
- +4 ;allow break
- SET X="ERR^AQAQPR4"
- SET @^%ZOSF("TRAP")
- XECUTE ^%ZOSF("BRK")
- +5 KILL ^UTILITY("AQAQPR4",$JOB)
- +6 SET AQAQDT=AQAQBDT-.0001
- SET AQAQEND=AQAQEDT+.2400
- +7 ;
- +8 ;>>> loop thru visit file by date and screen visit
- LOOP FOR
- SET AQAQDT=$ORDER(^AUPNVSIT("B",AQAQDT))
- IF AQAQDT=""
- QUIT
- IF AQAQDT>AQAQEND
- QUIT
- Begin DoDot:1
- +1 SET AQAQVDFN=0
- +2 FOR
- SET AQAQVDFN=$ORDER(^AUPNVSIT("B",AQAQDT,AQAQVDFN))
- IF AQAQVDFN=""
- QUIT
- Begin DoDot:2
- +3 IF '$DATA(^AUPNVSIT(AQAQVDFN,0))
- QUIT
- SET AQAQV=^(0)
- +4 ;deleted visit
- IF $PIECE(AQAQV,U,11)=1
- QUIT
- +5 ;must have prov,pov, & proc entries
- IF $PIECE(AQAQV,U,9)<3
- QUIT
- +6 ;service category
- IF "AHIS"'[$PIECE(AQAQV,U,7)
- QUIT
- +7 ;location of encounter
- IF $PIECE(AQAQV,U,6)'=DUZ(2)
- QUIT
- +8 ;get primary provider
- DO FINDPROV
- +9 ;bad visit-no primary provider
- IF AQAQPRV=0
- QUIT
- IF AQAQPRV=""
- QUIT
- +10 ;not provider asked for
- IF AQAQTYP=1
- IF AQAQSRT'=""
- IF +AQAQSRT'=AQAQPRV
- QUIT
- +11 ;provider class
- SET AQAQCLS=$PIECE(^DIC(6,AQAQPRV,0),U,4)
- +12 ;not class asked for
- IF AQAQTYP=2
- IF +AQAQSRT'=AQAQCLS
- QUIT
- +13 ;staff category
- SET AQAQCAT=$PIECE($GET(^AQAQC(AQAQPRV,0)),U,2)
- +14 ;not category asked for
- IF AQAQTYP=3
- IF AQAQSRT'=AQAQCAT
- QUIT
- +15 ;class name
- IF AQAQCLS'=""
- SET AQAQCLS=$PIECE(^DIC(7,AQAQCLS,0),U)
- +16 SET AQAQPRV=$PIECE(^DIC(16,AQAQPRV,0),U)_" ("_AQAQCLS_")"
- +17 ;get diagnoses for this visit
- DO FINDDX
- +18 ;get next visit
- QUIT
- End DoDot:2
- End DoDot:1
- +19 ;
- NEXT ;>>> go to print rtn <<<
- +1 GOTO ^AQAQPR42
- +2 ;
- +3 ;>>> end of main rtn <<<
- +4 ;
- FINDDX ;***> SUBRTN to get diagnoses for visits that passed screens
- +1 SET AQAQPDFN=0
- +2 FOR
- SET AQAQPDFN=$ORDER(^AUPNVPOV("AD",AQAQVDFN,AQAQPDFN))
- IF AQAQPDFN=""
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(^AUPNVPOV(AQAQPDFN,0))
- QUIT
- SET AQAQP=^(0)
- +4 ;icd code number
- SET AQAQICD=$PIECE(^ICD9($PIECE(AQAQP,U),0),U)
- +5 ;find dx category for icd code
- DO GETGRP
- +6 ;
- +7 ;**> increment count for diagnostic category
- +8 SET ^UTILITY("AQAQPR4",$JOB,AQAQPRV,AQAQGRP)=$GET(^UTILITY("AQAQPR4",$JOB,AQAQPRV,AQAQGRP))+1
- QUIT
- End DoDot:1
- +9 ;return to main rtn loop
- QUIT
- +10 ;
- +11 ;
- FINDPROV ;***> SUBRTN to find primary provider for ambulatory visits
- +1 SET (AQAQRDFN,AQAQPRV)=0
- +2 FOR
- SET AQAQRDFN=$ORDER(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN))
- IF AQAQRDFN=""
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(^AUPNVPRV(AQAQRDFN,0))
- QUIT
- SET AQAQR=^(0)
- +4 ;find another if not primary provider
- IF $PIECE(AQAQR,U,4)'="P"
- QUIT
- +5 ;get provider pointer
- SET AQAQPRV=$PIECE(AQAQR,U)
- End DoDot:1
- +6 ;return to main rtn loop
- QUIT
- +7 ;
- +8 ;
- GETGRP ;***> SUBRTN to get diagnostic category
- +1 SET AQAQG=$ORDER(^AQACGM("B",+$PIECE(AQAQICD,"."),0))
- IF AQAQG=""
- QUIT
- +2 ;group pointer
- SET AQAQGRP=$PIECE($GET(^AQACGM(AQAQG,0)),U,2)
- +3 SET AQAQGN=$GET(^AQACCAT(AQAQGRP,0))
- SET AQAQRNG=$PIECE(AQAQGN,U)
- +4 ;(range)_name
- SET AQAQGRP="("_AQAQRNG_") "_$PIECE(AQAQGN,U,2)
- +5 QUIT
