BQIIPPRG ;VNGT/HS/ALA-RPMS Program ; 13 Sep 2011 5:27 PM
;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
;
;
ERUR(BQDATE) ;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
NEW CLNC,FTOTF,FTOTP
S QFL=0
S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
S CRST="0"_CRST
;
I $G(BQDATE)'="" 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)="" 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"
;
S ID="IPC_ERUR"
S FAC=$$HME^BQIGPUTL()
;
; BQITOTP(primary provider ien,DFN))=# of patients with visits to this provider
S BQITOTV=0,BQITOTR=0
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. S BQITOTP(PRV)=0
. S PIEN="" F S PIEN=$O(^AUPNPAT("AK",PRV,PIEN)) Q:PIEN="" D
.. I '$$HRN^BQIUL1(PIEN) Q
.. S BQITOTP(PRV)=$G(BQITOTP(PRV))+1
;
S BD=BEGDT_".9999"
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
.. S CLN=$P(^AUPNVSIT(VISIT,0),U,8)
.. I CLN="" Q
.. S CLNC=$$PTR^BQIUL2(9000010,.08,CLN,1)
.. I CLNC'=80,CLNC'=30 Q
.. ; 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 BQITOTP(DPCP,DFN)=$G(BQITOTP(DPCP,DFN))+1
;
S DPCP="",FTOTP=0,FTOTF=0
F S DPCP=$O(BQITOTP(DPCP)) Q:DPCP="" D
. S DFN="",TOTP=0
. F S DFN=$O(BQITOTP(DPCP,DFN)) Q:DFN="" S TOTP=TOTP+1
. D STORP^BQIIPUTL(DPCP,ID,BQDATE,BQITOTP(DPCP),TOTP)
. S FTOTP=FTOTP+TOTP
. S FTOTF=FTOTF+BQITOTP(DPCP)
D STORF^BQIIPUTL(FAC,ID,BQDATE,FTOTF,FTOTP)
Q
;
TOT(BQDATE) ;EP - Total patients in microsystem
NEW BQMON,BQDTE,BEGDT,ENDT,EDAY,ID,PROV,BQTOTV,BQTOTP,FAC
NEW FC,TVIS,TPD,CL,QFL,CRST
S QFL=0
S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
S CRST="0"_CRST
;
I $G(BQDATE)'="" 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)="" 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
. I $L(BQMON)=1 S BQMON="0"_BQMON
. S BQDTE=$P($T(BQM+BQMON),";;",2)
. 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"
;
S ID="IPC_TOTP"
S FAC=$$HME^BQIGPUTL()
;
S PROV="",BQTOTP=0
F S PROV=$O(^AUPNPAT("AK",PROV)) Q:PROV="" D
. S BQITOTP(PROV)=0
. S PIEN="" F S PIEN=$O(^AUPNPAT("AK",PROV,PIEN)) Q:PIEN="" D
.. I '$$HRN^BQIUL1(PIEN) Q
.. S BQITOTP(PROV)=$G(BQITOTP(PROV))+1
S DPCP="",FTOTP=0,FTOTF=0
F S DPCP=$O(BQITOTP(DPCP)) Q:DPCP="" D
. D STORP^BQIIPUTL(DPCP,ID,BQDATE,BQITOTP(DPCP),0)
. S FTOTF=FTOTF+BQITOTP(DPCP)
D STORF^BQIIPUTL(FAC,ID,BQDATE,FTOTF,FTOTP)
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
BQIIPPRG ;VNGT/HS/ALA-RPMS Program ; 13 Sep 2011 5:27 PM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;;Apr 18, 2012;Build 59
+2 ;
+3 ;
ERUR(BQDATE) ;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
+3 NEW CLNC,FTOTF,FTOTP
+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 ;
+8 IF $GET(BQDATE)'=""
Begin DoDot:1
+9 SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"
SET CYR=$EXTRACT(BQDATE,1,3)
SET BQMON=$EXTRACT(BQDATE,4,5)
+10 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+11 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+12 SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)
End DoDot:1
+13 ;
+14 IF $GET(BQDATE)=""
Begin DoDot:1
+15 IF $EXTRACT(DT,6,7)'=CRST
SET QFL=1
QUIT
+16 SET BQMON=$EXTRACT(DT,4,5)-1
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+17 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+18 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+19 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+20 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+21 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+22 SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"
End DoDot:1
IF QFL
QUIT
+23 ;
+24 SET ID="IPC_ERUR"
+25 SET FAC=$$HME^BQIGPUTL()
+26 ;
+27 ; BQITOTP(primary provider ien,DFN))=# of patients with visits to this provider
+28 SET BQITOTV=0
SET BQITOTR=0
+29 SET PRV=""
+30 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+31 SET BQITOTP(PRV)=0
+32 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPAT("AK",PRV,PIEN))
IF PIEN=""
QUIT
Begin DoDot:2
+33 IF '$$HRN^BQIUL1(PIEN)
QUIT
+34 SET BQITOTP(PRV)=$GET(BQITOTP(PRV))+1
End DoDot:2
End DoDot:1
+35 ;
+36 SET BD=BEGDT_".9999"
+37 FOR
SET BD=$ORDER(^AUPNVSIT("B",BD))
IF BD=""!(BD\1>ENDT)
QUIT
Begin DoDot:1
+38 SET VISIT=""
+39 FOR
SET VISIT=$ORDER(^AUPNVSIT("B",BD,VISIT))
IF VISIT=""
QUIT
Begin DoDot:2
+40 IF $GET(^AUPNVSIT(VISIT,0))=""
QUIT
+41 IF $PIECE(^AUPNVSIT(VISIT,0),U,11)
QUIT
+42 ; skip E:EVENT (HISTORICAL);D:DAILY HOSP DATA;X:ANCILLARY PACKAGE DAILY visits
+43 IF "EDX"[$PIECE(^AUPNVSIT(VISIT,0),U,7)
QUIT
+44 ; location of visit not facility
+45 SET FC=$PIECE(^AUPNVSIT(VISIT,0),U,6)
IF 'FC
QUIT
+46 IF FC'=FAC
QUIT
+47 SET CLN=$PIECE(^AUPNVSIT(VISIT,0),U,8)
+48 IF CLN=""
QUIT
+49 SET CLNC=$$PTR^BQIUL2(9000010,.08,CLN,1)
+50 IF CLNC'=80
IF CLNC'=30
QUIT
+51 ; if no diagnoses
+52 IF '$DATA(^AUPNVPOV("AD",VISIT))
QUIT
+53 SET DFN=$PIECE(^AUPNVSIT(VISIT,0),U,5)
IF DFN=""
QUIT
+54 IF $GET(^AUPNPAT(DFN,0))=""
QUIT
+55 IF $GET(^DPT(DFN,0))=""
QUIT
+56 ; If no HRN for this facility
+57 IF $GET(^AUPNPAT(DFN,41,FAC,0))=""
QUIT
+58 SET VD=$PIECE(^AUPNVSIT(VISIT,0),U,1)\1
+59 ; HRN is inactive
+60 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)
+61 IF 'X
QUIT
+62 ; patient is deceased
+63 IF $PIECE($GET(^DPT(DFN,.35)),U,1)'=""
QUIT
+64 ; If no DPCP
+65 SET DPCP=$PIECE(^AUPNPAT(DFN,0),U,14)
IF DPCP=""
QUIT
+66 SET BQITOTP(DPCP,DFN)=$GET(BQITOTP(DPCP,DFN))+1
End DoDot:2
End DoDot:1
+67 ;
+68 SET DPCP=""
SET FTOTP=0
SET FTOTF=0
+69 FOR
SET DPCP=$ORDER(BQITOTP(DPCP))
IF DPCP=""
QUIT
Begin DoDot:1
+70 SET DFN=""
SET TOTP=0
+71 FOR
SET DFN=$ORDER(BQITOTP(DPCP,DFN))
IF DFN=""
QUIT
SET TOTP=TOTP+1
+72 DO STORP^BQIIPUTL(DPCP,ID,BQDATE,BQITOTP(DPCP),TOTP)
+73 SET FTOTP=FTOTP+TOTP
+74 SET FTOTF=FTOTF+BQITOTP(DPCP)
End DoDot:1
+75 DO STORF^BQIIPUTL(FAC,ID,BQDATE,FTOTF,FTOTP)
+76 QUIT
+77 ;
TOT(BQDATE) ;EP - Total patients in microsystem
+1 NEW BQMON,BQDTE,BEGDT,ENDT,EDAY,ID,PROV,BQTOTV,BQTOTP,FAC
+2 NEW FC,TVIS,TPD,CL,QFL,CRST
+3 SET QFL=0
+4 SET CRST=$PIECE($GET(^BQI(90508,1,11)),U,2)
IF CRST=""
SET CRST=1
+5 SET CRST="0"_CRST
+6 ;
+7 IF $GET(BQDATE)'=""
Begin DoDot:1
+8 SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"
SET CYR=$EXTRACT(BQDATE,1,3)
SET BQMON=$EXTRACT(BQDATE,4,5)
+9 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+10 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+11 SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)
End DoDot:1
+12 ;
+13 IF $GET(BQDATE)=""
Begin DoDot:1
+14 IF $EXTRACT(DT,6,7)'=CRST
SET QFL=1
QUIT
+15 SET BQMON=$EXTRACT(DT,4,5)-1
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+16 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+17 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+18 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+19 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+20 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+21 SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"
End DoDot:1
IF QFL
QUIT
+22 ;
+23 SET ID="IPC_TOTP"
+24 SET FAC=$$HME^BQIGPUTL()
+25 ;
+26 SET PROV=""
SET BQTOTP=0
+27 FOR
SET PROV=$ORDER(^AUPNPAT("AK",PROV))
IF PROV=""
QUIT
Begin DoDot:1
+28 SET BQITOTP(PROV)=0
+29 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNPAT("AK",PROV,PIEN))
IF PIEN=""
QUIT
Begin DoDot:2
+30 IF '$$HRN^BQIUL1(PIEN)
QUIT
+31 SET BQITOTP(PROV)=$GET(BQITOTP(PROV))+1
End DoDot:2
End DoDot:1
+32 SET DPCP=""
SET FTOTP=0
SET FTOTF=0
+33 FOR
SET DPCP=$ORDER(BQITOTP(DPCP))
IF DPCP=""
QUIT
Begin DoDot:1
+34 DO STORP^BQIIPUTL(DPCP,ID,BQDATE,BQITOTP(DPCP),0)
+35 SET FTOTF=FTOTF+BQITOTP(DPCP)
End DoDot:1
+36 DO STORF^BQIIPUTL(FAC,ID,BQDATE,FTOTF,FTOTP)
+37 QUIT
+38 ;
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
