BQIIPCCT ;GDIT/HCSD/ALA-Continuity of Care Team ; 03 Oct 2017 9:37 AM
;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
;
;
EN(BQDATE,BQFROM,BQTHRU) ;EP
NEW BQDTE,BQMON,EDAY,ENDT,CYR,PYR,ID,FAC,BQITOTV,BQITOTR,BD,VISIT
NEW DFN,VD,X,Y,BQA,DPCP,CLN,QFL,BEGDT,BQITOTP,FC,PRV,CRST,CRIPC,CRN
NEW GLOB1,GLOB2,TOTP,TOTV,BQITOTM,GLOB3
;
S QFL=0
S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
S CRST="0"_CRST
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRIPC="IPCMH"
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S GLOB3=$NA(^XTMP("BQITEAM")) K @GLOB3
S @GLOB3@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Team IPC Compilation"
;
I $G(BQDATE)'="",$G(WEEK)="" D
. S BEGDT=$E(BQDATE,1,5)_"01",CYR=$E(BQDATE,1,3),BQMON=$E(BQDATE,4,5)
. I $L(BQMON)=1 S BQMON="0"_BQMON
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S ENDT=$E(BQDATE,1,5)_$P(EDAY,U,+BQMON)
;
I $G(BQDATE)="",$G(WEEK)="" D Q:QFL
. I $E(DT,6,7)'=CRST S QFL=1 Q
. S BQMON=$E(DT,4,5)-1,CYR=$E(DT,1,3),PYR=CYR-1
. S BQDTE=$P($T(BQM+BQMON),";;",2)
. I $L(BQMON)=1 S BQMON="0"_BQMON
. S BEGDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
. S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
. S ENDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))
. S BQDATE=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"
;
I $G(WEEK)="" D
. S GLOB2=$NA(^XTMP("BQICCTM")) K @GLOB2
. S @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Visits"
I $G(WEEK)=1 D
. S BEGDT=BQFROM-.9999,ENDT=BQTHRU,CRIPC="IPCMH",CRN=3
. S GLOB2=$NA(^XTMP("BQICCTW")) K @GLOB2
. S @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Visits"
;
S ID="IPC_CCTM"
;
; check for divisions
I $O(^BQI(90508,1,25,0))'="" D
. S FAC="" F S FAC=$O(^BQI(90508,1,25,"B",FAC)) Q:FAC="" D
.. D VIS K BQITOTM,@GLOB2
.. D STOR
;
I $O(^BQI(90508,1,25,0))="" S FAC=$$HME^BQIGPUTL() D
. D VIS K BQITOTM,@GLOB2
. D STOR
;
S FAC=0,TNUM=0,TDEN=0
F S FAC=$O(@GLOB3@(FAC)) Q:FAC="" D
. S TEAM=""
. F S TEAM=$O(@GLOB3@(FAC,TEAM)) Q:TEAM="" D
.. I $P(@GLOB3@(FAC,TEAM),"^",1)=0,$P(@GLOB3@(FAC,TEAM),"^",2)=0 Q
.. I $G(DEBUG)=1 W !,FAC,"|",TEAM,"|",@GLOB3@(FAC,TEAM)
.. ;S TNUM=TNUM+$P(@GLOB3@(FAC,TEAM),"^",1),TDEN=TDEN+$P(@GLOB3@(FAC,TEAM),"^",2)
.. S TNUM=TNUM+$P(@GLOB3@(FAC,TEAM),"^",1),TDEN=$P(@GLOB3@(FAC,TEAM),"^",2)
.. I $G(WEEK)="" D STORT^BQIIPUTL(TEAM,ID,BQDATE,$P(@GLOB3@(FAC,TEAM),"^",2),$P(@GLOB3@(FAC,TEAM),"^",1))
.. I $G(WEEK)=1 D STORTW^BQIIPUTL(TEAM,ID,BQFROM,BQTHRU,$P(@GLOB3@(FAC,TEAM),"^",2),$P(@GLOB3@(FAC,TEAM),"^",1))
;
S FAC=$$HME^BQIGPUTL(),ID="IPC_CCTM"
I $G(WEEK)="" D STORF^BQIIPUTL(FAC,ID,BQDATE,TDEN,TNUM)
I $G(WEEK)=1 D STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,TDEN,TNUM)
Q
;
STOR ;Store the data
S TMN=0 F S TMN=$O(^BSDPCT(TMN)) Q:'TMN D
. S TEAM=$P(^BSDPCT(TMN,0),"^",1)
. I '$D(@GLOB3@(FAC,TEAM)) S @GLOB3@(FAC,TEAM)="0^0"
Q
;
VIS ; Find visits
S BQITOTV=0,BQITOTR=0
D TMS
;
S BD=BEGDT
F S BD=$O(^AUPNVSIT("B",BD)) Q:BD=""!(BD\1>ENDT) D
. S VISIT=""
. F S VISIT=$O(^AUPNVSIT("B",BD,VISIT)) Q:VISIT="" D
.. I $G(^AUPNVSIT(VISIT,0))="" Q
.. I $P(^AUPNVSIT(VISIT,0),U,11) Q
.. ; skip E:EVENT (HISTORICAL);D:DAILY HOSP DATA;X:ANCILLARY PACKAGE DAILY visits
.. Q:"EDX"[$P(^AUPNVSIT(VISIT,0),U,7)
.. ; location of visit not facility
.. S FC=$P(^AUPNVSIT(VISIT,0),U,6) Q:'FC
.. Q:FC'=FAC
.. ; if no diagnoses
.. Q:'$D(^AUPNVPOV("AD",VISIT))
.. S DFN=$P(^AUPNVSIT(VISIT,0),U,5) I DFN="" Q
.. I $G(^AUPNPAT(DFN,0))="" Q
.. I $G(^DPT(DFN,0))="" Q
.. ; If no HRN for this facility
.. I $G(^AUPNPAT(DFN,41,FAC,0))="" Q
.. S VD=$P(^AUPNVSIT(VISIT,0),U,1)\1
.. ; HRN is inactive
.. S X=$S($P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)="":1,$P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)>VD:1,1:0)
.. I 'X Q
.. ; patient is deceased
.. I $P($G(^DPT(DFN,.35)),U,1)'="" Q
.. ; If no DPCP
.. S DPCP=$P(^AUPNPAT(DFN,0),U,14) I DPCP="" Q
.. S CLN=$P(^AUPNVSIT(VISIT,0),U,8) I CLN="" Q
.. ; check against primary care clinic list
.. I '$D(^BQI(90508,1,23,"B",CLN)) Q
.. ; No primary provider
.. S BQA=$$PRIMPROV^APCLV(VISIT,"I") I BQA="" Q
.. S BQITOTV=BQITOTV+1 ; Denominator
.. ; primary provider of visit
.. S @GLOB2@(DFN,BQA)=""
;
D TMB
S TEAM=""
F S TEAM=$O(BQITOTM(FAC,TEAM)) Q:TEAM="" D
. I $P(BQITOTM(FAC,TEAM),"^",1)'=0 S $P(BQITOTM(FAC,TEAM),"^",2)=BQITOTV,@GLOB3@(FAC,TEAM)=BQITOTM(FAC,TEAM)
Q
;
TMS ;EP - Team setup
I $G(WEEK)="" D
. K ^XTMP("BQITEAMM")
. S ^XTMP("BQITEAMM",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Compile"
. S GLOB1=$NA(^XTMP("BQITEAMM"))
I $G(WEEK)=1 D
. K ^XTMP("BQITEAMW")
. S ^XTMP("BQITEAMW",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Compile"
. S GLOB1=$NA(^XTMP("BQITEAMW"))
;
S TMN=0 F S TMN=$O(^BSDPCT(TMN)) Q:'TMN D
. S TEAM=$P(^BSDPCT(TMN,0),"^",1)
. S BQITOTM(FAC,TEAM)="0^0"
. S TMM="" F S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM="" D
.. S DFN="" F S DFN=$O(^AUPNPAT("AK",TMM,DFN)) Q:DFN="" S @GLOB1@(FAC,TEAM,DFN)=""
Q
;
TMB ;EP - Is provider member of a team?
S DFN=0,TOTP=0,TOTV=0
F S DFN=$O(@GLOB2@(DFN)) Q:DFN="" D
. S PRV=""
. F S PRV=$O(@GLOB2@(DFN,PRV)) Q:PRV="" D
.. S TOTP=$G(TOTP)+1
.. S TMN=$O(^BSDPCT("AB",PRV,"")) I TMN="" Q
.. S TEAM=$P(^BSDPCT(TMN,0),"^",1)
.. I $D(@GLOB1@(FAC,TEAM,DFN)) S $P(BQITOTM(FAC,TEAM),"^",1)=$P($G(BQITOTM(FAC,TEAM)),"^",1)+1
.. S TOTV=TOTV+1
Q
;
BQM ;
;;12^PYR
;;01^CYR
;;02^CYR
;;03^CYR
;;04^CYR
;;05^CYR
;;06^CYR
;;07^CYR
;;08^CYR
;;09^CYR
;;10^CYR
;;11^CYR
BQIIPCCT ;GDIT/HCSD/ALA-Continuity of Care Team ; 03 Oct 2017 9:37 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
+2 ;
+3 ;
EN(BQDATE,BQFROM,BQTHRU) ;EP
+1 NEW BQDTE,BQMON,EDAY,ENDT,CYR,PYR,ID,FAC,BQITOTV,BQITOTR,BD,VISIT
+2 NEW DFN,VD,X,Y,BQA,DPCP,CLN,QFL,BEGDT,BQITOTP,FC,PRV,CRST,CRIPC,CRN
+3 NEW GLOB1,GLOB2,TOTP,TOTV,BQITOTM,GLOB3
+4 ;
+5 SET QFL=0
+6 SET CRST=$PIECE($GET(^BQI(90508,1,11)),U,2)
IF CRST=""
SET CRST=1
+7 SET CRST="0"_CRST
+8 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+9 SET CRIPC="IPCMH"
+10 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+11 SET GLOB3=$NAME(^XTMP("BQITEAM"))
KILL @GLOB3
+12 SET @GLOB3@(0)=$$FMADD^XLFDT(DT,7)_U_DT_U_"Team IPC Compilation"
+13 ;
+14 IF $GET(BQDATE)'=""
IF $GET(WEEK)=""
Begin DoDot:1
+15 SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"
SET CYR=$EXTRACT(BQDATE,1,3)
SET BQMON=$EXTRACT(BQDATE,4,5)
+16 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+17 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+18 SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)
End DoDot:1
+19 ;
+20 IF $GET(BQDATE)=""
IF $GET(WEEK)=""
Begin DoDot:1
+21 IF $EXTRACT(DT,6,7)'=CRST
SET QFL=1
QUIT
+22 SET BQMON=$EXTRACT(DT,4,5)-1
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+23 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+24 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+25 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+26 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+27 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+28 SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"
End DoDot:1
IF QFL
QUIT
+29 ;
+30 IF $GET(WEEK)=""
Begin DoDot:1
+31 SET GLOB2=$NAME(^XTMP("BQICCTM"))
KILL @GLOB2
+32 SET @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Visits"
End DoDot:1
+33 IF $GET(WEEK)=1
Begin DoDot:1
+34 SET BEGDT=BQFROM-.9999
SET ENDT=BQTHRU
SET CRIPC="IPCMH"
SET CRN=3
+35 SET GLOB2=$NAME(^XTMP("BQICCTW"))
KILL @GLOB2
+36 SET @GLOB2@(0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Visits"
End DoDot:1
+37 ;
+38 SET ID="IPC_CCTM"
+39 ;
+40 ; check for divisions
+41 IF $ORDER(^BQI(90508,1,25,0))'=""
Begin DoDot:1
+42 SET FAC=""
FOR
SET FAC=$ORDER(^BQI(90508,1,25,"B",FAC))
IF FAC=""
QUIT
Begin DoDot:2
+43 DO VIS
KILL BQITOTM,@GLOB2
+44 DO STOR
End DoDot:2
End DoDot:1
+45 ;
+46 IF $ORDER(^BQI(90508,1,25,0))=""
SET FAC=$$HME^BQIGPUTL()
Begin DoDot:1
+47 DO VIS
KILL BQITOTM,@GLOB2
+48 DO STOR
End DoDot:1
+49 ;
+50 SET FAC=0
SET TNUM=0
SET TDEN=0
+51 FOR
SET FAC=$ORDER(@GLOB3@(FAC))
IF FAC=""
QUIT
Begin DoDot:1
+52 SET TEAM=""
+53 FOR
SET TEAM=$ORDER(@GLOB3@(FAC,TEAM))
IF TEAM=""
QUIT
Begin DoDot:2
+54 IF $PIECE(@GLOB3@(FAC,TEAM),"^",1)=0
IF $PIECE(@GLOB3@(FAC,TEAM),"^",2)=0
QUIT
+55 IF $GET(DEBUG)=1
WRITE !,FAC,"|",TEAM,"|",@GLOB3@(FAC,TEAM)
+56 ;S TNUM=TNUM+$P(@GLOB3@(FAC,TEAM),"^",1),TDEN=TDEN+$P(@GLOB3@(FAC,TEAM),"^",2)
+57 SET TNUM=TNUM+$PIECE(@GLOB3@(FAC,TEAM),"^",1)
SET TDEN=$PIECE(@GLOB3@(FAC,TEAM),"^",2)
+58 IF $GET(WEEK)=""
DO STORT^BQIIPUTL(TEAM,ID,BQDATE,$PIECE(@GLOB3@(FAC,TEAM),"^",2),$PIECE(@GLOB3@(FAC,TEAM),"^",1))
+59 IF $GET(WEEK)=1
DO STORTW^BQIIPUTL(TEAM,ID,BQFROM,BQTHRU,$PIECE(@GLOB3@(FAC,TEAM),"^",2),$PIECE(@GLOB3@(FAC,TEAM),"^",1))
End DoDot:2
End DoDot:1
+60 ;
+61 SET FAC=$$HME^BQIGPUTL()
SET ID="IPC_CCTM"
+62 IF $GET(WEEK)=""
DO STORF^BQIIPUTL(FAC,ID,BQDATE,TDEN,TNUM)
+63 IF $GET(WEEK)=1
DO STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,TDEN,TNUM)
+64 QUIT
+65 ;
STOR ;Store the data
+1 SET TMN=0
FOR
SET TMN=$ORDER(^BSDPCT(TMN))
IF 'TMN
QUIT
Begin DoDot:1
+2 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+3 IF '$DATA(@GLOB3@(FAC,TEAM))
SET @GLOB3@(FAC,TEAM)="0^0"
End DoDot:1
+4 QUIT
+5 ;
VIS ; Find visits
+1 SET BQITOTV=0
SET BQITOTR=0
+2 DO TMS
+3 ;
+4 SET BD=BEGDT
+5 FOR
SET BD=$ORDER(^AUPNVSIT("B",BD))
IF BD=""!(BD\1>ENDT)
QUIT
Begin DoDot:1
+6 SET VISIT=""
+7 FOR
SET VISIT=$ORDER(^AUPNVSIT("B",BD,VISIT))
IF VISIT=""
QUIT
Begin DoDot:2
+8 IF $GET(^AUPNVSIT(VISIT,0))=""
QUIT
+9 IF $PIECE(^AUPNVSIT(VISIT,0),U,11)
QUIT
+10 ; skip E:EVENT (HISTORICAL);D:DAILY HOSP DATA;X:ANCILLARY PACKAGE DAILY visits
+11 IF "EDX"[$PIECE(^AUPNVSIT(VISIT,0),U,7)
QUIT
+12 ; location of visit not facility
+13 SET FC=$PIECE(^AUPNVSIT(VISIT,0),U,6)
IF 'FC
QUIT
+14 IF FC'=FAC
QUIT
+15 ; if no diagnoses
+16 IF '$DATA(^AUPNVPOV("AD",VISIT))
QUIT
+17 SET DFN=$PIECE(^AUPNVSIT(VISIT,0),U,5)
IF DFN=""
QUIT
+18 IF $GET(^AUPNPAT(DFN,0))=""
QUIT
+19 IF $GET(^DPT(DFN,0))=""
QUIT
+20 ; If no HRN for this facility
+21 IF $GET(^AUPNPAT(DFN,41,FAC,0))=""
QUIT
+22 SET VD=$PIECE(^AUPNVSIT(VISIT,0),U,1)\1
+23 ; HRN is inactive
+24 SET X=$SELECT($PIECE($GET(^AUPNPAT(DFN,41,FAC,0)),U,3)="":1,$PIECE($GET(^AUPNPAT(DFN,41,FAC,0)),U,3)>VD:1,1:0)
+25 IF 'X
QUIT
+26 ; patient is deceased
+27 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+28 ; If no DPCP
+29 SET DPCP=$PIECE(^AUPNPAT(DFN,0),U,14)
IF DPCP=""
QUIT
+30 SET CLN=$PIECE(^AUPNVSIT(VISIT,0),U,8)
IF CLN=""
QUIT
+31 ; check against primary care clinic list
+32 IF '$DATA(^BQI(90508,1,23,"B",CLN))
QUIT
+33 ; No primary provider
+34 SET BQA=$$PRIMPROV^APCLV(VISIT,"I")
IF BQA=""
QUIT
+35 ; Denominator
SET BQITOTV=BQITOTV+1
+36 ; primary provider of visit
+37 SET @GLOB2@(DFN,BQA)=""
End DoDot:2
End DoDot:1
+38 ;
+39 DO TMB
+40 SET TEAM=""
+41 FOR
SET TEAM=$ORDER(BQITOTM(FAC,TEAM))
IF TEAM=""
QUIT
Begin DoDot:1
+42 IF $PIECE(BQITOTM(FAC,TEAM),"^",1)'=0
SET $PIECE(BQITOTM(FAC,TEAM),"^",2)=BQITOTV
SET @GLOB3@(FAC,TEAM)=BQITOTM(FAC,TEAM)
End DoDot:1
+43 QUIT
+44 ;
TMS ;EP - Team setup
+1 IF $GET(WEEK)=""
Begin DoDot:1
+2 KILL ^XTMP("BQITEAMM")
+3 SET ^XTMP("BQITEAMM",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Monthly Compile"
+4 SET GLOB1=$NAME(^XTMP("BQITEAMM"))
End DoDot:1
+5 IF $GET(WEEK)=1
Begin DoDot:1
+6 KILL ^XTMP("BQITEAMW")
+7 SET ^XTMP("BQITEAMW",0)=$$FMADD^XLFDT(DT,14)_U_DT_U_"IPC Weekly Compile"
+8 SET GLOB1=$NAME(^XTMP("BQITEAMW"))
End DoDot:1
+9 ;
+10 SET TMN=0
FOR
SET TMN=$ORDER(^BSDPCT(TMN))
IF 'TMN
QUIT
Begin DoDot:1
+11 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+12 SET BQITOTM(FAC,TEAM)="0^0"
+13 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
Begin DoDot:2
+14 SET DFN=""
FOR
SET DFN=$ORDER(^AUPNPAT("AK",TMM,DFN))
IF DFN=""
QUIT
SET @GLOB1@(FAC,TEAM,DFN)=""
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
TMB ;EP - Is provider member of a team?
+1 SET DFN=0
SET TOTP=0
SET TOTV=0
+2 FOR
SET DFN=$ORDER(@GLOB2@(DFN))
IF DFN=""
QUIT
Begin DoDot:1
+3 SET PRV=""
+4 FOR
SET PRV=$ORDER(@GLOB2@(DFN,PRV))
IF PRV=""
QUIT
Begin DoDot:2
+5 SET TOTP=$GET(TOTP)+1
+6 SET TMN=$ORDER(^BSDPCT("AB",PRV,""))
IF TMN=""
QUIT
+7 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+8 IF $DATA(@GLOB1@(FAC,TEAM,DFN))
SET $PIECE(BQITOTM(FAC,TEAM),"^",1)=$PIECE($GET(BQITOTM(FAC,TEAM)),"^",1)+1
+9 SET TOTV=TOTV+1
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
BQM ;
+1 ;;12^PYR
+2 ;;01^CYR
+3 ;;02^CYR
+4 ;;03^CYR
+5 ;;04^CYR
+6 ;;05^CYR
+7 ;;06^CYR
+8 ;;07^CYR
+9 ;;08^CYR
+10 ;;09^CYR
+11 ;;10^CYR
+12 ;;11^CYR
