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
