AQAQPR21 ;IHS/ANMC/LJF - PROCEDURES BY PROVIDER; [ 05/27/92 11:28 AM ]
;;2.2;STAFF CREDENTIALS;;01 OCT 1992
;
;>>> initialize variables <<<
S X="ERR^AQAQPR2",@^%ZOSF("TRAP") X ^%ZOSF("BRK") ;allow break
K ^UTILITY("AQAQPR2",$J)
S AQAQDT=AQAQBDT-.0001,AQAQEND=AQAQEDT+.2400
;
;>>> loop thru visit file by date and screen visit
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 FINDPROC ;get procedures for this visit
..Q ;get next visit
;
NEXT ;>>> go to print rtn <<<
G ^AQAQPR22
;
;>>> end of main rtn <<<
;
FINDPROC ;***> SUBRTN to get procedures for visits that passed screens
S (AQAQPDFN,AQAQPRV)=0
F S AQAQPDFN=$O(^AUPNVPRC("AD",AQAQVDFN,AQAQPDFN)) Q:AQAQPDFN="" D
.Q:'$D(^AUPNVPRC(AQAQPDFN,0)) S AQAQP=^(0)
.S AQAQICD=$P(^ICD0($P(AQAQP,U),0),U) ;icd code number
.S AQAQICDN=$P(^ICD0($P(AQAQP,U),0),U,4) ;icd narrative
.I $P(AQAQV,U,7)="H" S AQAQPRV=$P(AQAQP,U,11) ;oper prov for hosp
.E D FINDPROV ;get primary provider for visit
.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 prov 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 AQAQX=$P(^DIC(6,AQAQPRV,0),U,4)
.S:AQAQX'="" AQAQX=$P(^DIC(7,AQAQX,0),U)
.S AQAQPRV=$P(^DIC(16,AQAQPRV,0),U)_" ("_AQAQX_")"
.;
.S AQAQSTR=AQAQPDFN_U_AQAQICDN ;set data in ^utility
.S ^UTILITY("AQAQPR2",$J,AQAQPRV,+AQAQICD,AQAQDT,AQAQVDFN)=AQAQSTR Q
Q ;return to main rtn loop
;
;
FINDPROV ;***> SUBRTN to find primary provider for ambulatory visits
S AQAQRDFN=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 procedure subrtn
;
;
HOSPERR ;***> SUBRTN to find all prov for inpt proc without oper provider
S AQAQRDFN=0
F S AQAQRDFN=$O(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN)) Q:AQAQRDFN="" D
.Q:'$D(^AUPNVPRV(AQAQRDFN,0)) S AQAQR=^(0)
.S AQAQSTR=AQAQVDFN_U_AQAQICDN_U_AQAQPDFN_U_AQAQDT
.S ^UTILITY("AQAQPR2",$J,"zz",AQAQICD,AQAQVDFN,AQAQRDFN)=AQAQSTR Q
Q ;return to procedure subrtn
AQAQPR21 ;IHS/ANMC/LJF - PROCEDURES BY PROVIDER; [ 05/27/92 11:28 AM ]
+1 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
+2 ;
+3 ;>>> initialize variables <<<
+4 ;allow break
SET X="ERR^AQAQPR2"
SET @^%ZOSF("TRAP")
XECUTE ^%ZOSF("BRK")
+5 KILL ^UTILITY("AQAQPR2",$JOB)
+6 SET AQAQDT=AQAQBDT-.0001
SET AQAQEND=AQAQEDT+.2400
+7 ;
+8 ;>>> loop thru visit file by date and screen visit
+9 FOR
SET AQAQDT=$ORDER(^AUPNVSIT("B",AQAQDT))
IF AQAQDT=""
QUIT
IF AQAQDT>AQAQEND
QUIT
Begin DoDot:1
+10 SET AQAQVDFN=0
+11 FOR
SET AQAQVDFN=$ORDER(^AUPNVSIT("B",AQAQDT,AQAQVDFN))
IF AQAQVDFN=""
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVSIT(AQAQVDFN,0))
QUIT
SET AQAQV=^(0)
+13 ;deleted visit
IF $PIECE(AQAQV,U,11)=1
QUIT
+14 ;must have prov,pov, & proc entries
IF $PIECE(AQAQV,U,9)<3
QUIT
+15 ;service category
IF "AHIS"'[$PIECE(AQAQV,U,7)
QUIT
+16 ;location of encounter
IF $PIECE(AQAQV,U,6)'=DUZ(2)
QUIT
+17 ;get procedures for this visit
DO FINDPROC
+18 ;get next visit
QUIT
End DoDot:2
End DoDot:1
+19 ;
NEXT ;>>> go to print rtn <<<
+1 GOTO ^AQAQPR22
+2 ;
+3 ;>>> end of main rtn <<<
+4 ;
FINDPROC ;***> SUBRTN to get procedures for visits that passed screens
+1 SET (AQAQPDFN,AQAQPRV)=0
+2 FOR
SET AQAQPDFN=$ORDER(^AUPNVPRC("AD",AQAQVDFN,AQAQPDFN))
IF AQAQPDFN=""
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVPRC(AQAQPDFN,0))
QUIT
SET AQAQP=^(0)
+4 ;icd code number
SET AQAQICD=$PIECE(^ICD0($PIECE(AQAQP,U),0),U)
+5 ;icd narrative
SET AQAQICDN=$PIECE(^ICD0($PIECE(AQAQP,U),0),U,4)
+6 ;oper prov for hosp
IF $PIECE(AQAQV,U,7)="H"
SET AQAQPRV=$PIECE(AQAQP,U,11)
+7 ;get primary provider for visit
IF '$TEST
DO FINDPROV
+8 ;bad visit-no primary provider
IF AQAQPRV=0
QUIT
IF AQAQPRV=""
QUIT
+9 ;not provider asked for
IF AQAQTYP=1
IF AQAQSRT'=""
IF +AQAQSRT'=AQAQPRV
QUIT
+10 ;provider class
SET AQAQCLS=$PIECE(^DIC(6,AQAQPRV,0),U,4)
+11 ;not prov class asked for
IF AQAQTYP=2
IF +AQAQSRT'=AQAQCLS
QUIT
+12 ;staff category
SET AQAQCAT=$PIECE($GET(^AQAQC(AQAQPRV,0)),U,2)
+13 ;not category asked for
IF AQAQTYP=3
IF AQAQSRT'=AQAQCAT
QUIT
+14 SET AQAQX=$PIECE(^DIC(6,AQAQPRV,0),U,4)
+15 IF AQAQX'=""
SET AQAQX=$PIECE(^DIC(7,AQAQX,0),U)
+16 SET AQAQPRV=$PIECE(^DIC(16,AQAQPRV,0),U)_" ("_AQAQX_")"
+17 ;
+18 ;set data in ^utility
SET AQAQSTR=AQAQPDFN_U_AQAQICDN
+19 SET ^UTILITY("AQAQPR2",$JOB,AQAQPRV,+AQAQICD,AQAQDT,AQAQVDFN)=AQAQSTR
QUIT
End DoDot:1
+20 ;return to main rtn loop
QUIT
+21 ;
+22 ;
FINDPROV ;***> SUBRTN to find primary provider for ambulatory visits
+1 SET AQAQRDFN=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 procedure subrtn
QUIT
+7 ;
+8 ;
HOSPERR ;***> SUBRTN to find all prov for inpt proc without oper provider
+1 SET AQAQRDFN=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 SET AQAQSTR=AQAQVDFN_U_AQAQICDN_U_AQAQPDFN_U_AQAQDT
+5 SET ^UTILITY("AQAQPR2",$JOB,"zz",AQAQICD,AQAQVDFN,AQAQRDFN)=AQAQSTR
QUIT
End DoDot:1
+6 ;return to procedure subrtn
QUIT
