- 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
