BQIPTPR ;PRXM/HC/BWF-Patient Provider Utilities ; 15 Nov 2005 3:17 PM
;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
;
; This is a utility program containing special function calls
; needed for provider data.
Q
;
PTPROV(DATA,DFN,ALL) ;EP -- BQI PATIENT PROVIDERS
; BQI PATIENT PROVIDERS
; Input
; DFN - Patient IEN
; DATA - Passed by reference
; ALL - 1 if all provider categories are wanted
; Output
; DATA - Set in this routine
;
; Variables
; BDPIEN - Ien from ^BDPRECN
; LCPROV - Last Current Provider
;
N BDPIEN,UID,BQII,X,PROVLST,LCPROV,LCPROVNM,PROVCAT,PROV,BDPINST,BDPCAT
N LSTUP,LSTUPU,BQPRV
NEW LCPRVI
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIPTPR",UID))
K @DATA
S ALL=$G(ALL,0)
;
S BQII=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIPTPR D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
D HDR
;
; Drive through all entries in the BDPRECN global for each patient.
; BDPRECN is part of the DSPM package
;
; Check to see if DSPM is being used. If DSPM is not being used, get roles from
; file/fields listed in the DSPM provider categories.
S BDPINST=$$VERSION^XPDUTL("BDP")
I BDPINST="" D GETPROVS(DFN,.BQII) Q
;
; Loop through DSPM provider categories (if DSPM is in use).
K BQPRV
S BDPCAT=0
F S BDPCAT=$O(^BDPRECN("AA",DFN,BDPCAT)) Q:'BDPCAT D
.S BDPIEN=0
.F S BDPIEN=$O(^BDPRECN("AA",DFN,BDPCAT,BDPIEN)) Q:'BDPIEN D
..S LCPROV=$$GET1^DIQ(90360.1,BDPIEN,.03,"I") ;Last Current Provider
..I LCPROV="" Q
..S LCPROVNM=$$GET1^DIQ(90360.1,BDPIEN,.03,"E")
..S LCPRVI=$$GET1^DIQ(90360.1,BDPIEN,.03,"I")
..S PROVCAT=$$GET1^DIQ(90360.3,BDPCAT,.01,"E") ;Prov Category Name
..S SRCAT=$S(PROVCAT="DESIGNATED PRIMARY PROVIDER":"aDESIGNATED PRIMARY PROVIDER",1:PROVCAT)
..I ALL S BQPRV(BDPCAT)=BDPIEN
..S PROVLST(DFN,SRCAT,LCPROV)=PROVCAT_U_LCPRVI_$C(28)_LCPROVNM_U_U
..D PROVST(SRCAT,LCPROV)
..S LSTUP=$$GET1^DIQ(90360.1,BDPIEN,.05,"I") I LSTUP S LSTUP=$$FMTE^BQIUL1(LSTUP)
..S LSTUPU=$$GET1^DIQ(90360.1,BDPIEN,.04,"E")
..S $P(PROVLST(DFN,SRCAT,LCPROV),U,6,7)=LSTUP_U_LSTUPU
I ALL D
. NEW N,CAT
. S N=0
. F S N=$O(^BDPTCAT(N)) Q:'N I '$D(BQPRV(N)) S CAT=$P(^BDPTCAT(N,0),U,1),PROVLST(DFN,$S(CAT="DESIGNATED PRIMARY PROVIDER":"a"_CAT,1:CAT),"~")=CAT_U_U_U_U_U_U
D LOOP(.BQII)
Q
;
PROVST(SRCAT,LCPROV) ;EP
;Loop through visits, and find the most recent visit that is associated with the current provider.
N LSTVST,FOUND,VSTIEN,VPRVIEN,VSPROV,EXTVST,NXTVST,CLINIC,PROV,STATUS
S LSTVST=0,FOUND=0
F S LSTVST=$O(^AUPNVSIT("AA",DFN,LSTVST)) Q:'LSTVST D Q:FOUND
.S VSTIEN=0
.F S VSTIEN=$O(^AUPNVSIT("AA",DFN,LSTVST,VSTIEN)) Q:VSTIEN=""!(FOUND) D
..I $$GET1^DIQ(9000010,VSTIEN,.11,"I")=1 Q
..S VPRVIEN=0
..F S VPRVIEN=$O(^AUPNVPRV("AD",VSTIEN,VPRVIEN)) Q:'VPRVIEN!(FOUND) D
...S VSPROV=$$GET1^DIQ(9000010.06,VPRVIEN,.01,"I")
...I VSPROV=LCPROV D Q
....S EXTVST=9999999-$P(LSTVST,".")
....S EXTVST=$$FMTE^BQIUL1(EXTVST)
....S $P(PROVLST(DFN,SRCAT,LCPROV),U,3)=$$FMTE^BQIUL1(EXTVST),FOUND=1
....S $P(PROVLST(DFN,SRCAT,LCPROV),U,5)=VSTIEN
;
; Loop through patient appts and find out if prov is primary for appt clinic.
; S NXTVST=DT,FOUND=0
; Start date for appointment search should be 'NOW' to be consistent with PEND^BSDU
S NXTVST=$$NOW^XLFDT,FOUND=0
F S NXTVST=$O(^DPT(DFN,"S",NXTVST)) Q:NXTVST=""!(FOUND) D
.S CLINIC=$$GET1^DIQ(2.98,NXTVST_","_DFN_",",.01,"I")
.S STATUS=$$GET1^DIQ(2.98,NXTVST_","_DFN_",",.02,"I")
.I CLINIC="" Q
.I STATUS="C"!(STATUS="PC") Q
.N TPRI
.S TPRI=0
.F S TPRI=$O(^SC(CLINIC,"PR",TPRI)) Q:'TPRI!(FOUND) D
..I +$G(^SC(CLINIC,"PR",TPRI,0))=LCPROV S $P(PROVLST(DFN,SRCAT,LCPROV),U,4)=$$FMTE^BQIUL1(NXTVST),FOUND=1
Q
;
LOOP(BQII) ;EP
NEW PCAT,LOOP
S PCAT=$O(PROVLST(DFN,"Z"))
I PCAT'="" D
. S LOOP=""
. F S LOOP=$O(PROVLST(DFN,PCAT,LOOP)) Q:LOOP="" D
.. S BQII=BQII+1,@DATA@(BQII)=PROVLST(DFN,PCAT,LOOP)_$C(30)
.. K PROVLST(DFN,PCAT)
S PCAT=""
F S PCAT=$O(PROVLST(DFN,PCAT)) Q:PCAT="" D
. S LOOP=""
. F S LOOP=$O(PROVLST(DFN,PCAT,LOOP)) Q:LOOP="" D
.. S BQII=BQII+1,@DATA@(BQII)=PROVLST(DFN,PCAT,LOOP)_$C(30)
S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
;
GETPROVS(DFN,BQII) ;EP
N DPCP,DPCPI,MHPROV,MHPROVI,SSPROV,SSPROVI,CDPROV,CDPROVI
NEW WHPROV,WHPROVI,TEXT,TIEN
S DPCP=$$GET1^DIQ(9000001,DFN,.14,"E") I DPCP'="" D
. S DPCPI=$$GET1^DIQ(9000001,DFN,.14,"I")
. S TEXT="DESIGNATED PRIMARY PROVIDER",SRCAT="a"_TEXT
. S TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
. S PROVLST(DFN,SRCAT,TIEN)=TEXT_U_DPCPI_$C(28)_DPCP_U_U
. D PROVST(SRCAT,TIEN)
;
S MHPROV=$$GET1^DIQ(9002011.55,DFN,.02,"E") I MHPROV'="" D
. S MHPROVI=$$GET1^DIQ(9002011.55,DFN,.02,"I")
. S TEXT="MENTAL HEALTH",SRCAT=TEXT
. S TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
. S PROVLST(DFN,SRCAT,TIEN)=TEXT_U_MHPROVI_$C(28)_MHPROV_U_U
. D PROVST(SRCAT,TIEN)
;
S SSPROV=$$GET1^DIQ(9002011.55,DFN,.03,"E") I SSPROV'="" D
. S SSPROVI=$$GET1^DIQ(9002011.55,DFN,.03,"I")
. S TEXT="SOCIAL SERVICES",SRCAT=TEXT
. S TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
. S PROVLST(DFN,SSPROVI,TIEN)=TEXT_U_SSPROVI_$C(28)_SSPROV_U_U
. D PROVST(SRCAT,TIEN)
;
S CDPROV=$$GET1^DIQ(9002011.55,DFN,.04,"E") I CDPROV'="" D
. S CDPROVI=$$GET1^DIQ(9002011.55,DFN,.04,"I")
. S TEXT="CHEMICAL DEPENDENCY",SRCAT=TEXT
. S TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
. S PROVLST(DFN,CDPROVI,TIEN)=TEXT_U_CDPROVI_$C(28)_CDPROV_U_U
. D PROVST(SRCAT,TIEN)
;
S WHPROV=$$GET1^DIQ(9002086,DFN,.1,"E") I WHPROV'="" D
. S WHPROVI=$$GET1^DIQ(9002086,DFN,.1,"I")
. S TEXT="WOMENS HEALTH",SRCAT=TEXT
. S TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
. S PROVLST(DFN,SRCAT,TIEN)=TEXT_U_WHPROVI_$C(28)_WHPROV_U_U
. D PROVST(SRCAT,TIEN)
;
D LOOP(.BQII)
Q
;
HDR ;
;S @DATA@(BQII)="T00045BQIPROLE^T00055BQIPROV^D00020BQILVDT^D00020BQINVDT^I00010VIEN"_$C(30)
S @DATA@(BQII)="T00045BQIPROLE^T00055BQIPROV^D00020BQILVDT^D00020BQINVDT^I00010VIEN^D00020BQIUPDT^T00035BQIUPDUS"_$C(30)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(BQII),$D(DATA) S BQII=BQII+1,@DATA@(BQII)=$C(31)
Q
BQIPTPR ;PRXM/HC/BWF-Patient Provider Utilities ; 15 Nov 2005 3:17 PM
+1 ;;2.1;ICARE MANAGEMENT SYSTEM;;Feb 07, 2011
+2 ;
+3 ; This is a utility program containing special function calls
+4 ; needed for provider data.
+5 QUIT
+6 ;
PTPROV(DATA,DFN,ALL) ;EP -- BQI PATIENT PROVIDERS
+1 ; BQI PATIENT PROVIDERS
+2 ; Input
+3 ; DFN - Patient IEN
+4 ; DATA - Passed by reference
+5 ; ALL - 1 if all provider categories are wanted
+6 ; Output
+7 ; DATA - Set in this routine
+8 ;
+9 ; Variables
+10 ; BDPIEN - Ien from ^BDPRECN
+11 ; LCPROV - Last Current Provider
+12 ;
+13 NEW BDPIEN,UID,BQII,X,PROVLST,LCPROV,LCPROVNM,PROVCAT,PROV,BDPINST,BDPCAT
+14 NEW LSTUP,LSTUPU,BQPRV
+15 NEW LCPRVI
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BQIPTPR",UID))
+18 KILL @DATA
+19 SET ALL=$GET(ALL,0)
+20 ;
+21 SET BQII=0
+22 ;
+23 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIPTPR D UNWIND^%ZTER"
+24 ;
+25 DO HDR
+26 ;
+27 ; Drive through all entries in the BDPRECN global for each patient.
+28 ; BDPRECN is part of the DSPM package
+29 ;
+30 ; Check to see if DSPM is being used. If DSPM is not being used, get roles from
+31 ; file/fields listed in the DSPM provider categories.
+32 SET BDPINST=$$VERSION^XPDUTL("BDP")
+33 IF BDPINST=""
DO GETPROVS(DFN,.BQII)
QUIT
+34 ;
+35 ; Loop through DSPM provider categories (if DSPM is in use).
+36 KILL BQPRV
+37 SET BDPCAT=0
+38 FOR
SET BDPCAT=$ORDER(^BDPRECN("AA",DFN,BDPCAT))
IF 'BDPCAT
QUIT
Begin DoDot:1
+39 SET BDPIEN=0
+40 FOR
SET BDPIEN=$ORDER(^BDPRECN("AA",DFN,BDPCAT,BDPIEN))
IF 'BDPIEN
QUIT
Begin DoDot:2
+41 ;Last Current Provider
SET LCPROV=$$GET1^DIQ(90360.1,BDPIEN,.03,"I")
+42 IF LCPROV=""
QUIT
+43 SET LCPROVNM=$$GET1^DIQ(90360.1,BDPIEN,.03,"E")
+44 SET LCPRVI=$$GET1^DIQ(90360.1,BDPIEN,.03,"I")
+45 ;Prov Category Name
SET PROVCAT=$$GET1^DIQ(90360.3,BDPCAT,.01,"E")
+46 SET SRCAT=$SELECT(PROVCAT="DESIGNATED PRIMARY PROVIDER":"aDESIGNATED PRIMARY PROVIDER",1:PROVCAT)
+47 IF ALL
SET BQPRV(BDPCAT)=BDPIEN
+48 SET PROVLST(DFN,SRCAT,LCPROV)=PROVCAT_U_LCPRVI_$CHAR(28)_LCPROVNM_U_U
+49 DO PROVST(SRCAT,LCPROV)
+50 SET LSTUP=$$GET1^DIQ(90360.1,BDPIEN,.05,"I")
IF LSTUP
SET LSTUP=$$FMTE^BQIUL1(LSTUP)
+51 SET LSTUPU=$$GET1^DIQ(90360.1,BDPIEN,.04,"E")
+52 SET $PIECE(PROVLST(DFN,SRCAT,LCPROV),U,6,7)=LSTUP_U_LSTUPU
End DoDot:2
End DoDot:1
+53 IF ALL
Begin DoDot:1
+54 NEW N,CAT
+55 SET N=0
+56 FOR
SET N=$ORDER(^BDPTCAT(N))
IF 'N
QUIT
IF '$DATA(BQPRV(N))
SET CAT=$PIECE(^BDPTCAT(N,0),U,1)
SET PROVLST(DFN,$SELECT(CAT="DESIGNATED PRIMARY PROVIDER":"a"_CAT,1:CAT),"~")=CAT_U_U_U_U_U_U
End DoDot:1
+57 DO LOOP(.BQII)
+58 QUIT
+59 ;
PROVST(SRCAT,LCPROV) ;EP
+1 ;Loop through visits, and find the most recent visit that is associated with the current provider.
+2 NEW LSTVST,FOUND,VSTIEN,VPRVIEN,VSPROV,EXTVST,NXTVST,CLINIC,PROV,STATUS
+3 SET LSTVST=0
SET FOUND=0
+4 FOR
SET LSTVST=$ORDER(^AUPNVSIT("AA",DFN,LSTVST))
IF 'LSTVST
QUIT
Begin DoDot:1
+5 SET VSTIEN=0
+6 FOR
SET VSTIEN=$ORDER(^AUPNVSIT("AA",DFN,LSTVST,VSTIEN))
IF VSTIEN=""!(FOUND)
QUIT
Begin DoDot:2
+7 IF $$GET1^DIQ(9000010,VSTIEN,.11,"I")=1
QUIT
+8 SET VPRVIEN=0
+9 FOR
SET VPRVIEN=$ORDER(^AUPNVPRV("AD",VSTIEN,VPRVIEN))
IF 'VPRVIEN!(FOUND)
QUIT
Begin DoDot:3
+10 SET VSPROV=$$GET1^DIQ(9000010.06,VPRVIEN,.01,"I")
+11 IF VSPROV=LCPROV
Begin DoDot:4
+12 SET EXTVST=9999999-$PIECE(LSTVST,".")
+13 SET EXTVST=$$FMTE^BQIUL1(EXTVST)
+14 SET $PIECE(PROVLST(DFN,SRCAT,LCPROV),U,3)=$$FMTE^BQIUL1(EXTVST)
SET FOUND=1
+15 SET $PIECE(PROVLST(DFN,SRCAT,LCPROV),U,5)=VSTIEN
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
IF FOUND
QUIT
+16 ;
+17 ; Loop through patient appts and find out if prov is primary for appt clinic.
+18 ; S NXTVST=DT,FOUND=0
+19 ; Start date for appointment search should be 'NOW' to be consistent with PEND^BSDU
+20 SET NXTVST=$$NOW^XLFDT
SET FOUND=0
+21 FOR
SET NXTVST=$ORDER(^DPT(DFN,"S",NXTVST))
IF NXTVST=""!(FOUND)
QUIT
Begin DoDot:1
+22 SET CLINIC=$$GET1^DIQ(2.98,NXTVST_","_DFN_",",.01,"I")
+23 SET STATUS=$$GET1^DIQ(2.98,NXTVST_","_DFN_",",.02,"I")
+24 IF CLINIC=""
QUIT
+25 IF STATUS="C"!(STATUS="PC")
QUIT
+26 NEW TPRI
+27 SET TPRI=0
+28 FOR
SET TPRI=$ORDER(^SC(CLINIC,"PR",TPRI))
IF 'TPRI!(FOUND)
QUIT
Begin DoDot:2
+29 IF +$GET(^SC(CLINIC,"PR",TPRI,0))=LCPROV
SET $PIECE(PROVLST(DFN,SRCAT,LCPROV),U,4)=$$FMTE^BQIUL1(NXTVST)
SET FOUND=1
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
LOOP(BQII) ;EP
+1 NEW PCAT,LOOP
+2 SET PCAT=$ORDER(PROVLST(DFN,"Z"))
+3 IF PCAT'=""
Begin DoDot:1
+4 SET LOOP=""
+5 FOR
SET LOOP=$ORDER(PROVLST(DFN,PCAT,LOOP))
IF LOOP=""
QUIT
Begin DoDot:2
+6 SET BQII=BQII+1
SET @DATA@(BQII)=PROVLST(DFN,PCAT,LOOP)_$CHAR(30)
+7 KILL PROVLST(DFN,PCAT)
End DoDot:2
End DoDot:1
+8 SET PCAT=""
+9 FOR
SET PCAT=$ORDER(PROVLST(DFN,PCAT))
IF PCAT=""
QUIT
Begin DoDot:1
+10 SET LOOP=""
+11 FOR
SET LOOP=$ORDER(PROVLST(DFN,PCAT,LOOP))
IF LOOP=""
QUIT
Begin DoDot:2
+12 SET BQII=BQII+1
SET @DATA@(BQII)=PROVLST(DFN,PCAT,LOOP)_$CHAR(30)
End DoDot:2
End DoDot:1
+13 SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+14 QUIT
+15 ;
GETPROVS(DFN,BQII) ;EP
+1 NEW DPCP,DPCPI,MHPROV,MHPROVI,SSPROV,SSPROVI,CDPROV,CDPROVI
+2 NEW WHPROV,WHPROVI,TEXT,TIEN
+3 SET DPCP=$$GET1^DIQ(9000001,DFN,.14,"E")
IF DPCP'=""
Begin DoDot:1
+4 SET DPCPI=$$GET1^DIQ(9000001,DFN,.14,"I")
+5 SET TEXT="DESIGNATED PRIMARY PROVIDER"
SET SRCAT="a"_TEXT
+6 SET TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
+7 SET PROVLST(DFN,SRCAT,TIEN)=TEXT_U_DPCPI_$CHAR(28)_DPCP_U_U
+8 DO PROVST(SRCAT,TIEN)
End DoDot:1
+9 ;
+10 SET MHPROV=$$GET1^DIQ(9002011.55,DFN,.02,"E")
IF MHPROV'=""
Begin DoDot:1
+11 SET MHPROVI=$$GET1^DIQ(9002011.55,DFN,.02,"I")
+12 SET TEXT="MENTAL HEALTH"
SET SRCAT=TEXT
+13 SET TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
+14 SET PROVLST(DFN,SRCAT,TIEN)=TEXT_U_MHPROVI_$CHAR(28)_MHPROV_U_U
+15 DO PROVST(SRCAT,TIEN)
End DoDot:1
+16 ;
+17 SET SSPROV=$$GET1^DIQ(9002011.55,DFN,.03,"E")
IF SSPROV'=""
Begin DoDot:1
+18 SET SSPROVI=$$GET1^DIQ(9002011.55,DFN,.03,"I")
+19 SET TEXT="SOCIAL SERVICES"
SET SRCAT=TEXT
+20 SET TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
+21 SET PROVLST(DFN,SSPROVI,TIEN)=TEXT_U_SSPROVI_$CHAR(28)_SSPROV_U_U
+22 DO PROVST(SRCAT,TIEN)
End DoDot:1
+23 ;
+24 SET CDPROV=$$GET1^DIQ(9002011.55,DFN,.04,"E")
IF CDPROV'=""
Begin DoDot:1
+25 SET CDPROVI=$$GET1^DIQ(9002011.55,DFN,.04,"I")
+26 SET TEXT="CHEMICAL DEPENDENCY"
SET SRCAT=TEXT
+27 SET TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
+28 SET PROVLST(DFN,CDPROVI,TIEN)=TEXT_U_CDPROVI_$CHAR(28)_CDPROV_U_U
+29 DO PROVST(SRCAT,TIEN)
End DoDot:1
+30 ;
+31 SET WHPROV=$$GET1^DIQ(9002086,DFN,.1,"E")
IF WHPROV'=""
Begin DoDot:1
+32 SET WHPROVI=$$GET1^DIQ(9002086,DFN,.1,"I")
+33 SET TEXT="WOMENS HEALTH"
SET SRCAT=TEXT
+34 SET TIEN=$$FIND1^DIC(90360.3,,"X",TEXT)
+35 SET PROVLST(DFN,SRCAT,TIEN)=TEXT_U_WHPROVI_$CHAR(28)_WHPROV_U_U
+36 DO PROVST(SRCAT,TIEN)
End DoDot:1
+37 ;
+38 DO LOOP(.BQII)
+39 QUIT
+40 ;
HDR ;
+1 ;S @DATA@(BQII)="T00045BQIPROLE^T00055BQIPROV^D00020BQILVDT^D00020BQINVDT^I00010VIEN"_$C(30)
+2 SET @DATA@(BQII)="T00045BQIPROLE^T00055BQIPROV^D00020BQILVDT^D00020BQINVDT^I00010VIEN^D00020BQIUPDT^T00035BQIUPDUS"_$CHAR(30)
+3 QUIT
+4 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(BQII)
IF $DATA(DATA)
SET BQII=BQII+1
SET @DATA@(BQII)=$CHAR(31)
+6 QUIT
