- 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
