- 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
