BQIIPCCP ;VNGT/HS/ALA-Continuity of Care Provider ; 05 May 2011 12:06 PM
;;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
;
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 CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
;
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)=1 D
. S BEGDT=BQFROM-.9999,ENDT=BQTHRU,CRIPC="IPCMH",CRN=3
;
S ID="IPC_CCPR"
S FAC=$$HME^BQIGPUTL()
;
; BQITOTP(primary provider ien,clinic or "UNKNOWN"))=# of visits^# of visits to this provider
S BQITOTV=0,BQITOTR=0
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" S BQITOTP(PRV)="0^0"
;
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
.. ; No primary provider
.. S BQA=$$PRIMPROV^APCLV(VISIT,"I") I BQA="" 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
.. S $P(BQITOTP(DPCP),U,1)=$P($G(BQITOTP(DPCP)),U,1)+1
.. S $P(BQITOTP(DPCP,CLN),U,1)=$P($G(BQITOTP(DPCP,CLN)),U,1)+1
.. S BQITOTV=BQITOTV+1 ; Denominator
.. I BQA,BQA=DPCP D
... S $P(BQITOTP(DPCP,CLN),U,2)=$P($G(BQITOTP(DPCP,CLN)),U,2)+1
... S $P(BQITOTP(DPCP),U,2)=$P($G(BQITOTP(DPCP)),U,2)+1
... S BQITOTR=BQITOTR+1 ; Numerator
;
S DPCP=""
F S DPCP=$O(BQITOTP(DPCP)) Q:DPCP="" D
. I $G(WEEK)="" D STORP^BQIIPUTL(DPCP,ID,BQDATE,$P(BQITOTP(DPCP),U,1),$P(BQITOTP(DPCP),U,2))
. I $G(WEEK)=1 D STORPW^BQIIPUTL(DPCP,ID,BQFROM,BQTHRU,$P(BQITOTP(DPCP),U,1),$P(BQITOTP(DPCP),U,2))
I $G(WEEK)="" D STORF^BQIIPUTL(FAC,ID,BQDATE,BQITOTV,BQITOTR)
I $G(WEEK)=1 D STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,BQITOTV,BQITOTR)
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
BQIIPCCP ;VNGT/HS/ALA-Continuity of Care Provider ; 05 May 2011 12:06 PM
+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 ;
+4 SET QFL=0
+5 SET CRST=$PIECE($GET(^BQI(90508,1,11)),U,2)
IF CRST=""
SET CRST=1
+6 SET CRST="0"_CRST
+7 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+8 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+9 ;
+10 IF $GET(BQDATE)'=""
IF $GET(WEEK)=""
Begin DoDot:1
+11 SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"
SET CYR=$EXTRACT(BQDATE,1,3)
SET BQMON=$EXTRACT(BQDATE,4,5)
+12 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+13 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+14 SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)
End DoDot:1
+15 ;
+16 IF $GET(BQDATE)=""
IF $GET(WEEK)=""
Begin DoDot:1
+17 IF $EXTRACT(DT,6,7)'=CRST
SET QFL=1
QUIT
+18 SET BQMON=$EXTRACT(DT,4,5)-1
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+19 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+20 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+21 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+22 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+23 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+24 SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"
End DoDot:1
IF QFL
QUIT
+25 ;
+26 IF $GET(WEEK)=1
Begin DoDot:1
+27 SET BEGDT=BQFROM-.9999
SET ENDT=BQTHRU
SET CRIPC="IPCMH"
SET CRN=3
End DoDot:1
+28 ;
+29 SET ID="IPC_CCPR"
+30 SET FAC=$$HME^BQIGPUTL()
+31 ;
+32 ; BQITOTP(primary provider ien,clinic or "UNKNOWN"))=# of visits^# of visits to this provider
+33 SET BQITOTV=0
SET BQITOTR=0
+34 SET PRV=""
+35 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
SET BQITOTP(PRV)="0^0"
+36 ;
+37 SET BD=BEGDT
+38 FOR
SET BD=$ORDER(^AUPNVSIT("B",BD))
IF BD=""!(BD\1>ENDT)
QUIT
Begin DoDot:1
+39 SET VISIT=""
+40 FOR
SET VISIT=$ORDER(^AUPNVSIT("B",BD,VISIT))
IF VISIT=""
QUIT
Begin DoDot:2
+41 IF $GET(^AUPNVSIT(VISIT,0))=""
QUIT
+42 IF $PIECE(^AUPNVSIT(VISIT,0),U,11)
QUIT
+43 ; skip E:EVENT (HISTORICAL);D:DAILY HOSP DATA;X:ANCILLARY PACKAGE DAILY visits
+44 IF "EDX"[$PIECE(^AUPNVSIT(VISIT,0),U,7)
QUIT
+45 ; location of visit not facility
+46 SET FC=$PIECE(^AUPNVSIT(VISIT,0),U,6)
IF 'FC
QUIT
+47 IF FC'=FAC
QUIT
+48 ; if no diagnoses
+49 IF '$DATA(^AUPNVPOV("AD",VISIT))
QUIT
+50 SET DFN=$PIECE(^AUPNVSIT(VISIT,0),U,5)
IF DFN=""
QUIT
+51 IF $GET(^AUPNPAT(DFN,0))=""
QUIT
+52 IF $GET(^DPT(DFN,0))=""
QUIT
+53 ; If no HRN for this facility
+54 IF $GET(^AUPNPAT(DFN,41,FAC,0))=""
QUIT
+55 SET VD=$PIECE(^AUPNVSIT(VISIT,0),U,1)\1
+56 ; HRN is inactive
+57 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)
+58 IF 'X
QUIT
+59 ; patient is deceased
+60 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+61 ; No primary provider
+62 SET BQA=$$PRIMPROV^APCLV(VISIT,"I")
IF BQA=""
QUIT
+63 ; If no DPCP
+64 SET DPCP=$PIECE(^AUPNPAT(DFN,0),U,14)
IF DPCP=""
QUIT
+65 SET CLN=$PIECE(^AUPNVSIT(VISIT,0),U,8)
IF CLN=""
QUIT
+66 ; check against primary care clinic list
+67 IF '$DATA(^BQI(90508,1,23,"B",CLN))
QUIT
+68 SET $PIECE(BQITOTP(DPCP),U,1)=$PIECE($GET(BQITOTP(DPCP)),U,1)+1
+69 SET $PIECE(BQITOTP(DPCP,CLN),U,1)=$PIECE($GET(BQITOTP(DPCP,CLN)),U,1)+1
+70 ; Denominator
SET BQITOTV=BQITOTV+1
+71 IF BQA
IF BQA=DPCP
Begin DoDot:3
+72 SET $PIECE(BQITOTP(DPCP,CLN),U,2)=$PIECE($GET(BQITOTP(DPCP,CLN)),U,2)+1
+73 SET $PIECE(BQITOTP(DPCP),U,2)=$PIECE($GET(BQITOTP(DPCP)),U,2)+1
+74 ; Numerator
SET BQITOTR=BQITOTR+1
End DoDot:3
End DoDot:2
End DoDot:1
+75 ;
+76 SET DPCP=""
+77 FOR
SET DPCP=$ORDER(BQITOTP(DPCP))
IF DPCP=""
QUIT
Begin DoDot:1
+78 IF $GET(WEEK)=""
DO STORP^BQIIPUTL(DPCP,ID,BQDATE,$PIECE(BQITOTP(DPCP),U,1),$PIECE(BQITOTP(DPCP),U,2))
+79 IF $GET(WEEK)=1
DO STORPW^BQIIPUTL(DPCP,ID,BQFROM,BQTHRU,$PIECE(BQITOTP(DPCP),U,1),$PIECE(BQITOTP(DPCP),U,2))
End DoDot:1
+80 IF $GET(WEEK)=""
DO STORF^BQIIPUTL(FAC,ID,BQDATE,BQITOTV,BQITOTR)
+81 IF $GET(WEEK)=1
DO STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,BQITOTV,BQITOTR)
+82 QUIT
+83 ;
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
