- BQIIPEMP ;VNGT/HS/ALA-Empanelled Patients ; 06 May 2011 1:38 PM
- ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
- ;
- ;
- EN(BQDATE,BQFROM,BQTHRU) ;EP
- NEW BQMON,BQDTE,BEGDT,EDAY,ENDT,PYR,CYR,ID,FAC,BQITOTP,BQITOTR,DFN,BD,ED
- NEW BQGOTA,F,QFL,X,Y,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)'="",$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 BGDT=BQFROM-.9999,ENDT=BQTHRU
- ;
- S ID="IPC_PEMP"
- S FAC=$$HME^BQIGPUTL()
- ;
- I $G(WEEK)="" S BGDT=$$FMADD^XLFDT(ENDT,1),BGDT=($E(BGDT,1,3)-3)_$E(BGDT,4,7)
- ; BQITOTP = Total active patients ; BQITOTR = Total active patients empanelled
- S BQITOTP=0,BQITOTR=0
- ;
- S DFN=0
- F S DFN=$O(^AUPNPAT(DFN)) Q:'DFN D
- . I $G(^AUPNPAT(DFN,0))="" Q
- . I $G(^DPT(DFN,0))="" Q
- . ; If patient merged to a different IEN
- . I $P(^DPT(DFN,0),U,19)'="" Q
- . ; if a demo patient
- . I $$DEMO^APCLUTL(DFN,"E") Q
- . ; if deceased
- . I $D(^DPT(DFN,.35)),$P(^(.35),U)]"",$P(^(.35),U)'>ENDT Q
- . ; if no HRN for this facility
- . I $G(^AUPNPAT(DFN,41,FAC,0))="" Q
- . ; if HRN marked inactive
- . ;I $P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)'="",$P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)'>ENDT Q
- . ;
- . S BD=(9999999-ENDT)-.0001,ED=9999999-BGDT,BQGOTA=0
- . F S BD=$O(^AUPNVSIT("AA",DFN,BD)) Q:BD=""!(BD\1>ED) D
- .. S VISIT=""
- .. F S VISIT=$O(^AUPNVSIT("AA",DFN,BD,VISIT)) Q:VISIT="" D
- ... I $G(^AUPNVSIT(VISIT,0))="" Q
- ... I $P(^AUPNVSIT(VISIT,0),U,11) Q
- ... I BQGOTA=1 Q
- ... Q:'$P(^AUPNVSIT(VISIT,0),U,9)
- ... Q:"DXECTI"[$P(^AUPNVSIT(VISIT,0),U,7)
- ... S CL=$$CLINIC^APCLV(VISIT,"C") I CL=11!(CL=68)!(CL=51)!(CL=52) Q
- ... Q:'$D(^AUPNVPOV("AD",VISIT))
- ... Q:$$PRIMPROV^APCLV(VISIT,"I")=""
- ... S F=$P(^AUPNVSIT(VISIT,0),U,6) I F="" Q
- ... I F'=FAC Q
- ... S BQGOTA=1
- ... S BQITOTP=BQITOTP+1 ; Denominator
- ... I $P(^AUPNPAT(DFN,0),U,14) S BQITOTR=BQITOTR+1 ; Numerator
- ;
- I $G(WEEK)="" D STORF^BQIIPUTL(FAC,ID,BQDATE,BQITOTP,BQITOTR)
- I $G(WEEK)=1 D STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,BQITOTP,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
- BQIIPEMP ;VNGT/HS/ALA-Empanelled Patients ; 06 May 2011 1:38 PM
- +1 ;;2.7;ICARE MANAGEMENT SYSTEM;;Dec 19, 2017;Build 23
- +2 ;
- +3 ;
- EN(BQDATE,BQFROM,BQTHRU) ;EP
- +1 NEW BQMON,BQDTE,BEGDT,EDAY,ENDT,PYR,CYR,ID,FAC,BQITOTP,BQITOTR,DFN,BD,ED
- +2 NEW BQGOTA,F,QFL,X,Y,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)'=""
- IF $GET(WEEK)=""
- 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)=""
- IF $GET(WEEK)=""
- 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 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
- +17 IF $LENGTH(BQMON)=1
- SET BQMON="0"_BQMON
- +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 IF $GET(WEEK)=1
- Begin DoDot:1
- +24 SET BGDT=BQFROM-.9999
- SET ENDT=BQTHRU
- End DoDot:1
- +25 ;
- +26 SET ID="IPC_PEMP"
- +27 SET FAC=$$HME^BQIGPUTL()
- +28 ;
- +29 IF $GET(WEEK)=""
- SET BGDT=$$FMADD^XLFDT(ENDT,1)
- SET BGDT=($EXTRACT(BGDT,1,3)-3)_$EXTRACT(BGDT,4,7)
- +30 ; BQITOTP = Total active patients ; BQITOTR = Total active patients empanelled
- +31 SET BQITOTP=0
- SET BQITOTR=0
- +32 ;
- +33 SET DFN=0
- +34 FOR
- SET DFN=$ORDER(^AUPNPAT(DFN))
- IF 'DFN
- QUIT
- Begin DoDot:1
- +35 IF $GET(^AUPNPAT(DFN,0))=""
- QUIT
- +36 IF $GET(^DPT(DFN,0))=""
- QUIT
- +37 ; If patient merged to a different IEN
- +38 IF $PIECE(^DPT(DFN,0),U,19)'=""
- QUIT
- +39 ; if a demo patient
- +40 IF $$DEMO^APCLUTL(DFN,"E")
- QUIT
- +41 ; if deceased
- +42 IF $DATA(^DPT(DFN,.35))
- IF $PIECE(^(.35),U)]""
- IF $PIECE(^(.35),U)'>ENDT
- QUIT
- +43 ; if no HRN for this facility
- +44 IF $GET(^AUPNPAT(DFN,41,FAC,0))=""
- QUIT
- +45 ; if HRN marked inactive
- +46 ;I $P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)'="",$P($G(^AUPNPAT(DFN,41,FAC,0)),U,3)'>ENDT Q
- +47 ;
- +48 SET BD=(9999999-ENDT)-.0001
- SET ED=9999999-BGDT
- SET BQGOTA=0
- +49 FOR
- SET BD=$ORDER(^AUPNVSIT("AA",DFN,BD))
- IF BD=""!(BD\1>ED)
- QUIT
- Begin DoDot:2
- +50 SET VISIT=""
- +51 FOR
- SET VISIT=$ORDER(^AUPNVSIT("AA",DFN,BD,VISIT))
- IF VISIT=""
- QUIT
- Begin DoDot:3
- +52 IF $GET(^AUPNVSIT(VISIT,0))=""
- QUIT
- +53 IF $PIECE(^AUPNVSIT(VISIT,0),U,11)
- QUIT
- +54 IF BQGOTA=1
- QUIT
- +55 IF '$PIECE(^AUPNVSIT(VISIT,0),U,9)
- QUIT
- +56 IF "DXECTI"[$PIECE(^AUPNVSIT(VISIT,0),U,7)
- QUIT
- +57 SET CL=$$CLINIC^APCLV(VISIT,"C")
- IF CL=11!(CL=68)!(CL=51)!(CL=52)
- QUIT
- +58 IF '$DATA(^AUPNVPOV("AD",VISIT))
- QUIT
- +59 IF $$PRIMPROV^APCLV(VISIT,"I")=""
- QUIT
- +60 SET F=$PIECE(^AUPNVSIT(VISIT,0),U,6)
- IF F=""
- QUIT
- +61 IF F'=FAC
- QUIT
- +62 SET BQGOTA=1
- +63 ; Denominator
- SET BQITOTP=BQITOTP+1
- +64 ; Numerator
- IF $PIECE(^AUPNPAT(DFN,0),U,14)
- SET BQITOTR=BQITOTR+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +65 ;
- +66 IF $GET(WEEK)=""
- DO STORF^BQIIPUTL(FAC,ID,BQDATE,BQITOTP,BQITOTR)
- +67 IF $GET(WEEK)=1
- DO STORFW^BQIIPUTL(FAC,ID,BQFROM,BQTHRU,BQITOTP,BQITOTR)
- +68 QUIT
- +69 ;
- 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
