AQAQPR31 ;IHS/ANMC/LJF - DISCHARGES BY PROVIDER & DX; [ 05/27/92 11:21 AM ]
;;2.2;STAFF CREDENTIALS;;01 OCT 1992
;
;>>> initialize variables <<<
S X="ERR^AQAQPR3",@^%ZOSF("TRAP") X ^%ZOSF("BRK") ;allow break
K ^UTILITY("AQAQPR3",$J)
S AQAQDT=AQAQBDT-.0001,AQAQEND=AQAQEDT+.2400
;
;>>> loop thru visit file by date and screen visit
LOOP F S AQAQDT=$O(^AUPNVINP("B",AQAQDT)) Q:AQAQDT="" Q:AQAQDT>AQAQEND D
.S AQAQHDFN=0
.F S AQAQHDFN=$O(^AUPNVINP("B",AQAQDT,AQAQHDFN)) Q:AQAQHDFN="" D
..Q:'$D(^AUPNVINP(AQAQHDFN,0)) S AQAQH=^(0)
..S AQAQVDFN=$P(AQAQH,U,3) Q:AQAQVDFN="" ;visit dfn
..S AQAQV=^AUPNVSIT(AQAQVDFN,0) ;visit node
..Q:$P(AQAQV,U,11)=1 ;deleted visit
..Q:$P(AQAQV,U,9)<3 ;must have prov,pov, & proc entries
..Q:$P(AQAQV,U,7)'="H" ;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 ^AQAQPR32
;
;>>> 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)
.I AQAQCDX=1 Q:$P(AQAQP,U,12)'="P" ;check for primary vs sec
.S AQAQICD=$P(^ICD9($P(AQAQP,U),0),U) ;icd code number
.;
.S AQAQSTR=AQAQPDFN_U_AQAQHDFN ;set string into ^utility
.I AQAQICD'?1"V".E S AQAQICD=+AQAQICD ;to coallate numbers correctly
.S ^UTILITY("AQAQPR3",$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
AQAQPR31 ;IHS/ANMC/LJF - DISCHARGES BY PROVIDER & DX; [ 05/27/92 11:21 AM ]
+1 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
+2 ;
+3 ;>>> initialize variables <<<
+4 ;allow break
SET X="ERR^AQAQPR3"
SET @^%ZOSF("TRAP")
XECUTE ^%ZOSF("BRK")
+5 KILL ^UTILITY("AQAQPR3",$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(^AUPNVINP("B",AQAQDT))
IF AQAQDT=""
QUIT
IF AQAQDT>AQAQEND
QUIT
Begin DoDot:1
+1 SET AQAQHDFN=0
+2 FOR
SET AQAQHDFN=$ORDER(^AUPNVINP("B",AQAQDT,AQAQHDFN))
IF AQAQHDFN=""
QUIT
Begin DoDot:2
+3 IF '$DATA(^AUPNVINP(AQAQHDFN,0))
QUIT
SET AQAQH=^(0)
+4 ;visit dfn
SET AQAQVDFN=$PIECE(AQAQH,U,3)
IF AQAQVDFN=""
QUIT
+5 ;visit node
SET AQAQV=^AUPNVSIT(AQAQVDFN,0)
+6 ;deleted visit
IF $PIECE(AQAQV,U,11)=1
QUIT
+7 ;must have prov,pov, & proc entries
IF $PIECE(AQAQV,U,9)<3
QUIT
+8 ;service category
IF $PIECE(AQAQV,U,7)'="H"
QUIT
+9 ;location of encounter
IF $PIECE(AQAQV,U,6)'=DUZ(2)
QUIT
+10 ;get primary provider
DO FINDPROV
+11 ;bad visit-no primary provider
IF AQAQPRV=0
QUIT
IF AQAQPRV=""
QUIT
+12 ;not provider asked for
IF AQAQTYP=1
IF AQAQSRT'=""
IF +AQAQSRT'=AQAQPRV
QUIT
+13 ;provider class
SET AQAQCLS=$PIECE(^DIC(6,AQAQPRV,0),U,4)
+14 ;not class asked for
IF AQAQTYP=2
IF +AQAQSRT'=AQAQCLS
QUIT
+15 ;staff category
SET AQAQCAT=$PIECE($GET(^AQAQC(AQAQPRV,0)),U,2)
+16 ;not category asked for
IF AQAQTYP=3
IF AQAQSRT'=AQAQCAT
QUIT
+17 ;class name
IF AQAQCLS'=""
SET AQAQCLS=$PIECE(^DIC(7,AQAQCLS,0),U)
+18 SET AQAQPRV=$PIECE(^DIC(16,AQAQPRV,0),U)_" ("_AQAQCLS_")"
+19 ;get diagnoses for this visit
DO FINDDX
+20 ;get next visit
QUIT
End DoDot:2
End DoDot:1
+21 ;
NEXT ;>>> go to print rtn <<<
+1 GOTO ^AQAQPR32
+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 ;check for primary vs sec
IF AQAQCDX=1
IF $PIECE(AQAQP,U,12)'="P"
QUIT
+5 ;icd code number
SET AQAQICD=$PIECE(^ICD9($PIECE(AQAQP,U),0),U)
+6 ;
+7 ;set string into ^utility
SET AQAQSTR=AQAQPDFN_U_AQAQHDFN
+8 ;to coallate numbers correctly
IF AQAQICD'?1"V".E
SET AQAQICD=+AQAQICD
+9 SET ^UTILITY("AQAQPR3",$JOB,AQAQPRV,AQAQICD,AQAQDT,AQAQVDFN)=AQAQSTR
QUIT
End DoDot:1
+10 ;return to main rtn loop
QUIT
+11 ;
+12 ;
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
