BQIIPMNU ;GDIT/HS/ALA-Update Monthly ; 24 Jun 2013 8:43 AM
;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
;
EN ;EP - IPC calculations
;
NEW BQMON,CYR,PYR,YR,TMFRAME,CRIPC,CRN,MSN,IDATA,CODE,TYP,BARDUZ2
NEW BCODE,BCT,BEGDT,BN,BQDTE,CD,CNT,DEN,DFN,EDAY,ENDT,EXEC,FAC,IEN
NEW NUM,PCT,PDEN,PNUM,PRV,QFL,TDEN,TNUM,TP,XX,Y,CRST,BQDA,PROW
S QFL=0
S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
S CRST="0"_CRST
;
; If passing a date in
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)
;
; If no date, then if not the designated day of the month, quit
I $G(BQDATE)="" D Q:QFL
. I $E(DT,6,7)'=CRST D CHK Q:QFL
. S BQMON=$E(DT,4,5),CYR=$E(DT,1,3),PYR=CYR-1
. S BQDTE=$P($T(BQM+BQMON),";;",2)
. S BQMON=$P(BQDTE,U,1)
. I $L(BQMON)=1 S BQMON="0"_BQMON
. S BEGDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
. S EDAY="31^"_($$LEAP^XLFDT2($P(BQDTE,U,2))+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=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"00"
;
S BQIUPD(90508,"1,",11.05)=BQDATE
D FILE^DIE("","BQIUPD","ERROR")
;
; Set the DATE/TIME FLAG STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",8.1)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.12)=1
S BQIUPD(90508,DA_",",24.08)=$G(ZTSK)
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
; Get current IPC
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
;
D PROC
;
I CRIPC="IPC4/IPC5" D
. S CRIPC="IPCMH",CRN=3 D PROC
;
; Send the files to the Data Warehouse
; Provider List
D PROV^BQIIPCMF
; Measure List
D MEAS^BQIIPCMF
; Data
D RET^BQIIPCME(.DATA,BQDATE,"")
;
; Set the DATE/TIME FLAG ENDED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",8.11)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.12)="@"
S BQIUPD(90508,DA_",",24.08)="@"
S BQIUPD(90508,"1,",11.04)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
PROC ;EP - Process the data
I $G(DEBUG)=1 W !,CRIPC
; Set the date
NEW DA,DIC,X,PRDTE,PRN,ROW,FROW,QFL,RMON,RYEAR,RROW
I $G(^BQI(90508,1,22,CRN,3,0))="" S ^BQI(90508,1,22,CRN,3,0)="^90508.223D^^"
S DA(2)=1,DA(1)=CRN,DIC(0)="LMNZ",DLAYGO=90508.223,X=$S($L(BQDATE)=5:BQDATE_"00",1:BQDATE)
S DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",3,"
D ^DIC
I Y=-1 K DO,DD D FILE^DICN
S BQDA=+Y
S PRDTE=$O(^BQI(90508,1,22,CRN,3,"B",X),-1)
;
I CRIPC'="IPCMH" D
. S QFL=0 F BI=1:1:16 S FROW=$P($T(ROW+BI),";;",2) D Q:QFL
.. S RMON=$P(FROW,U,1),RYEAR=$P(FROW,U,2),RROW=$P(FROW,U,3)
.. I $E(BQDATE,1,3)=RYEAR,$E(BQDATE,4,5)=RMON D Q
... S ROW=RROW,QFL=1
... S $P(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
. ;
. I 'QFL D
.. S PRN=$O(^BQI(90508,1,22,CRN,3,"B",PRDTE,""))
.. S PROW=$P(^BQI(90508,1,22,CRN,3,PRN,0),U,2)
.. S ROW=PROW+1
.. S $P(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
;
S MSN=0
F S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN D
. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
. S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2) I $G(DEBUG)=1 W !,IDATA
. ; If inactive, quit
. I $P(IDATA,U,7)=1 Q
. ; If type is RPMS
. I TYP="R" D Q
.. S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
.. X EXEC
. ;
. S BQIPROV=$P($G(^BQI(90508,1,11)),U,3)
. S TDEN=0,TNUM=0
. F S BQIPROV=$O(^AUPNPAT("AK",BQIPROV)) Q:BQIPROV="" D
.. I $P(^VA(200,BQIPROV,0),U,13)'="" Q
.. S MSNN=MSN
.. D EN^BQIIPSNG(BQIPROV,BQDATE,CRIPC)
.. S $P(^BQI(90508,1,11),U,3)=BQIPROV,MSN=MSNN
;
S $P(^BQI(90508,1,11),U,3)=""
;
S MSN=0
F S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN D
. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
. S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
. ; If inactive, quit
. I $P(IDATA,U,7)=1 Q
. ; If type is CRS, update the facility
. ;I TYP'="G" Q
. S PRV="",TDEN=0,TNUM=0
. F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
.. I $P(^VA(200,PRV,0),U,13)'="" Q
.. S IPRN=$O(^BQIPROV(PRV,30,"B",CODE,"")) I IPRN="" Q
.. S IPRD=$O(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
.. S DEN=$P(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
.. S TNUM=TNUM+NUM,TDEN=TDEN+DEN
. S FAC=$$HME^BQIGPUTL()
. I $G(DEBUG)=1 W !,FAC,"|",CODE,"|",BQDATE,"|",TDEN,"|",TNUM
. D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
;
S MSN=0
F S MSN=$O(^BQI(90508,1,22,CRN,1,MSN)) Q:'MSN D
. S IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
. S CODE=$P(IDATA,U,1),TYP=$P(IDATA,U,2)
. ; If inactive, quit
. I $P(IDATA,U,7)=1 Q
. I CODE="IPC_CCPR"!(CODE="IPC_PEMP") Q
. NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
. S TMN=0
. F S TMN=$O(^BSDPCT(TMN)) Q:'TMN D
.. ; Check inactivation date
.. I $P(^BSDPCT(TMN,0),"^",3)'="" Q
.. S TEAM=$P(^BSDPCT(TMN,0),"^",1)
.. ; Check if the team members has at least one member with patients assigned to them
.. S OK=0
.. S TMM="" F S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM="" I $O(^AUPNPAT("AK",TMM,""))'="" S OK=1
.. I 'OK Q
.. I CODE="IPC_CCTM" D Q
... S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
... X EXEC
.. S TDEN=0,TNUM=0
.. S TMM="" F S TMM=$O(^BSDPCT(TMN,1,"B",TMM)) Q:TMM="" I $O(^AUPNPAT("AK",TMM,""))'="" D
... I $P(^VA(200,TMM,0),U,13)'="" Q
... S IPRN=$O(^BQIPROV(TMM,30,"B",CODE,"")) I IPRN="" Q
... S IPRD=$O(^BQIPROV(TMM,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
... S DEN=$P(^BQIPROV(TMM,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
... S TNUM=TNUM+NUM,TDEN=TDEN+DEN
.. I $G(DEBUG)=1 W !,TEAM,"|",CODE,"|",TDEN,"|",TNUM
.. D STORT^BQIIPUTL(TEAM,CODE,BQDATE,TDEN,TNUM)
;
TOT ;EP total up values for MU
I CRIPC'="IPCMH" D
. NEW MCOD
. F MCOD="MU_2","MU_6","MU_7","MU_3","MU_5","MU_8","MU_55","MU_56","MU_57" D
.. NEW PRV,TDEN,TNUM,IPRN,IPRD,DEN,NUM
.. S PRV="",TDEN=0,TNUM=0
.. F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
... I $P(^VA(200,PRV,0),U,13)'="" Q
... S IPRN=$O(^BQIPROV(PRV,30,"B",MCOD,"")) I IPRN="" Q
... S IPRD=$O(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,"")) I IPRD="" Q
... S DEN=$P(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2),NUM=$P(^(0),U,3)
... S TDEN=TDEN+DEN,TNUM=TNUM+NUM
.. S FAC=$$HME^BQIGPUTL()
.. D STORF^BQIIPUTL(FAC,MCOD,BQDATE,TDEN,TNUM)
. ;
. S YEAR=$$GET1^DIQ(90508,1_",",2,"E")
. S FAC=$$HME^BQIGPUTL()
. S TPRN=$O(^BQIFAC(FAC,30,"B","IPC_TOTP",""))
. I TPRN'="" S TPRD=$O(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,""))
. S GPRN=$O(^BQIFAC(FAC,30,"B",YEAR_"_2452","")),GPRD=""
. I GPRN'="" S GPRD=$O(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,""))
. I TPRN'="",TPRD'="" D
.. S DEN=$P(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
.. I GPRN=""!(GPRD="") Q
.. S $P(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
;
Q
;
CHK ; EP - Check whether the IPC data ran or not
NEW LPRV,PRDTE
S QFL=1
I $E(DT,6,7)<CRST Q
S BQMON=$E(DT,4,5),CYR=$E(DT,1,3),PYR=CYR-1
S BQDTE=$P($T(BQM+BQMON),";;",2)
S BQMON=$P(BQDTE,U,1)
I $L(BQMON)=1 S BQMON="0"_BQMON
S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
S BQDATE=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"00"
S PRDTE=$O(^BQI(90508,1,22,CRN,3,"B",BQDATE),-1)
; if date has already been set and last provider done
S LPRV=$O(^AUPNPAT("AK",""),-1)
I $D(^BQIPROV(LPRV,30,"AB",BQDATE)),$D(^BQI(90508,1,22,CRN,3,"B",BQDATE)) Q
; If date not set up
I '$D(BQI(90508,1,22,CRN,3,"B",BQDATE)) D
. ; If a provider is still in the queue and the date is the previous date
. I $P(^BQI(90508,1,11),U,3)="",$P(^BQI(90508,1,11),U,5)=PRDTE S QFL=0 Q
Q
;
ROW ;
;;06^314^71
;;07^314^72
;;08^314^73
;;09^314^74
;;10^314^75
;;11^314^76
;;12^314^77
;;01^315^78
;;02^315^79
;;03^315^80
;;04^315^81
;;05^315^82
;;06^315^83
;;07^315^84
;;08^315^85
;;09^315^86
;;10^315^87
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
BQIIPMNU ;GDIT/HS/ALA-Update Monthly ; 24 Jun 2013 8:43 AM
+1 ;;2.7;ICARE MANAGEMENT SYSTEM;**1**;Dec 19, 2017;Build 12
+2 ;
EN ;EP - IPC calculations
+1 ;
+2 NEW BQMON,CYR,PYR,YR,TMFRAME,CRIPC,CRN,MSN,IDATA,CODE,TYP,BARDUZ2
+3 NEW BCODE,BCT,BEGDT,BN,BQDTE,CD,CNT,DEN,DFN,EDAY,ENDT,EXEC,FAC,IEN
+4 NEW NUM,PCT,PDEN,PNUM,PRV,QFL,TDEN,TNUM,TP,XX,Y,CRST,BQDA,PROW
+5 SET QFL=0
+6 SET CRST=$PIECE($GET(^BQI(90508,1,11)),U,2)
IF CRST=""
SET CRST=1
+7 SET CRST="0"_CRST
+8 ;
+9 ; If passing a date in
+10 IF $GET(BQDATE)'=""
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 no date, then if not the designated day of the month, quit
+17 IF $GET(BQDATE)=""
Begin DoDot:1
+18 IF $EXTRACT(DT,6,7)'=CRST
DO CHK
IF QFL
QUIT
+19 SET BQMON=$EXTRACT(DT,4,5)
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+20 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+21 SET BQMON=$PIECE(BQDTE,U,1)
+22 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+23 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+24 SET EDAY="31^"_($$LEAP^XLFDT2($PIECE(BQDTE,U,2))+28)_"^31^30^31^30^31^31^30^31^30^31"
+25 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+26 SET BQDATE=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"00"
End DoDot:1
IF QFL
QUIT
+27 ;
+28 SET BQIUPD(90508,"1,",11.05)=BQDATE
+29 DO FILE^DIE("","BQIUPD","ERROR")
+30 ;
+31 ; Set the DATE/TIME FLAG STARTED field
+32 NEW DA
+33 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+34 SET BQIUPD(90508,DA_",",8.1)=$$NOW^XLFDT()
+35 SET BQIUPD(90508,DA_",",8.12)=1
+36 SET BQIUPD(90508,DA_",",24.08)=$GET(ZTSK)
+37 DO FILE^DIE("","BQIUPD","ERROR")
+38 KILL BQIUPD
+39 ; Get current IPC
+40 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+41 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+42 ;
+43 DO PROC
+44 ;
+45 IF CRIPC="IPC4/IPC5"
Begin DoDot:1
+46 SET CRIPC="IPCMH"
SET CRN=3
DO PROC
End DoDot:1
+47 ;
+48 ; Send the files to the Data Warehouse
+49 ; Provider List
+50 DO PROV^BQIIPCMF
+51 ; Measure List
+52 DO MEAS^BQIIPCMF
+53 ; Data
+54 DO RET^BQIIPCME(.DATA,BQDATE,"")
+55 ;
+56 ; Set the DATE/TIME FLAG ENDED field
+57 NEW DA
+58 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+59 SET BQIUPD(90508,DA_",",8.11)=$$NOW^XLFDT()
+60 SET BQIUPD(90508,DA_",",8.12)="@"
+61 SET BQIUPD(90508,DA_",",24.08)="@"
+62 SET BQIUPD(90508,"1,",11.04)="@"
+63 DO FILE^DIE("","BQIUPD","ERROR")
+64 KILL BQIUPD
+65 QUIT
+66 ;
PROC ;EP - Process the data
+1 IF $GET(DEBUG)=1
WRITE !,CRIPC
+2 ; Set the date
+3 NEW DA,DIC,X,PRDTE,PRN,ROW,FROW,QFL,RMON,RYEAR,RROW
+4 IF $GET(^BQI(90508,1,22,CRN,3,0))=""
SET ^BQI(90508,1,22,CRN,3,0)="^90508.223D^^"
+5 SET DA(2)=1
SET DA(1)=CRN
SET DIC(0)="LMNZ"
SET DLAYGO=90508.223
SET X=$SELECT($LENGTH(BQDATE)=5:BQDATE_"00",1:BQDATE)
+6 SET DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",3,"
+7 DO ^DIC
+8 IF Y=-1
KILL DO,DD
DO FILE^DICN
+9 SET BQDA=+Y
+10 SET PRDTE=$ORDER(^BQI(90508,1,22,CRN,3,"B",X),-1)
+11 ;
+12 IF CRIPC'="IPCMH"
Begin DoDot:1
+13 SET QFL=0
FOR BI=1:1:16
SET FROW=$PIECE($TEXT(ROW+BI),";;",2)
Begin DoDot:2
+14 SET RMON=$PIECE(FROW,U,1)
SET RYEAR=$PIECE(FROW,U,2)
SET RROW=$PIECE(FROW,U,3)
+15 IF $EXTRACT(BQDATE,1,3)=RYEAR
IF $EXTRACT(BQDATE,4,5)=RMON
Begin DoDot:3
+16 SET ROW=RROW
SET QFL=1
+17 SET $PIECE(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
End DoDot:3
QUIT
End DoDot:2
IF QFL
QUIT
+18 ;
+19 IF 'QFL
Begin DoDot:2
+20 SET PRN=$ORDER(^BQI(90508,1,22,CRN,3,"B",PRDTE,""))
+21 SET PROW=$PIECE(^BQI(90508,1,22,CRN,3,PRN,0),U,2)
+22 SET ROW=PROW+1
+23 SET $PIECE(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
End DoDot:2
End DoDot:1
+24 ;
+25 SET MSN=0
+26 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+27 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+28 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
IF $GET(DEBUG)=1
WRITE !,IDATA
+29 ; If inactive, quit
+30 IF $PIECE(IDATA,U,7)=1
QUIT
+31 ; If type is RPMS
+32 IF TYP="R"
Begin DoDot:2
+33 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+34 XECUTE EXEC
End DoDot:2
QUIT
+35 ;
+36 SET BQIPROV=$PIECE($GET(^BQI(90508,1,11)),U,3)
+37 SET TDEN=0
SET TNUM=0
+38 FOR
SET BQIPROV=$ORDER(^AUPNPAT("AK",BQIPROV))
IF BQIPROV=""
QUIT
Begin DoDot:2
+39 IF $PIECE(^VA(200,BQIPROV,0),U,13)'=""
QUIT
+40 SET MSNN=MSN
+41 DO EN^BQIIPSNG(BQIPROV,BQDATE,CRIPC)
+42 SET $PIECE(^BQI(90508,1,11),U,3)=BQIPROV
SET MSN=MSNN
End DoDot:2
End DoDot:1
+43 ;
+44 SET $PIECE(^BQI(90508,1,11),U,3)=""
+45 ;
+46 SET MSN=0
+47 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+48 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+49 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+50 ; If inactive, quit
+51 IF $PIECE(IDATA,U,7)=1
QUIT
+52 ; If type is CRS, update the facility
+53 ;I TYP'="G" Q
+54 SET PRV=""
SET TDEN=0
SET TNUM=0
+55 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:2
+56 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+57 SET IPRN=$ORDER(^BQIPROV(PRV,30,"B",CODE,""))
IF IPRN=""
QUIT
+58 SET IPRD=$ORDER(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+59 SET DEN=$PIECE(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+60 SET TNUM=TNUM+NUM
SET TDEN=TDEN+DEN
End DoDot:2
+61 SET FAC=$$HME^BQIGPUTL()
+62 IF $GET(DEBUG)=1
WRITE !,FAC,"|",CODE,"|",BQDATE,"|",TDEN,"|",TNUM
+63 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
End DoDot:1
+64 ;
+65 SET MSN=0
+66 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+67 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+68 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+69 ; If inactive, quit
+70 IF $PIECE(IDATA,U,7)=1
QUIT
+71 IF CODE="IPC_CCPR"!(CODE="IPC_PEMP")
QUIT
+72 NEW TMN,TEAM,TMM,OK,TDEN,TNUM,IPRN,IPRD,DEN,NUM
+73 SET TMN=0
+74 FOR
SET TMN=$ORDER(^BSDPCT(TMN))
IF 'TMN
QUIT
Begin DoDot:2
+75 ; Check inactivation date
+76 IF $PIECE(^BSDPCT(TMN,0),"^",3)'=""
QUIT
+77 SET TEAM=$PIECE(^BSDPCT(TMN,0),"^",1)
+78 ; Check if the team members has at least one member with patients assigned to them
+79 SET OK=0
+80 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
IF $ORDER(^AUPNPAT("AK",TMM,""))'=""
SET OK=1
+81 IF 'OK
QUIT
+82 IF CODE="IPC_CCTM"
Begin DoDot:3
+83 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+84 XECUTE EXEC
End DoDot:3
QUIT
+85 SET TDEN=0
SET TNUM=0
+86 SET TMM=""
FOR
SET TMM=$ORDER(^BSDPCT(TMN,1,"B",TMM))
IF TMM=""
QUIT
IF $ORDER(^AUPNPAT("AK",TMM,""))'=""
Begin DoDot:3
+87 IF $PIECE(^VA(200,TMM,0),U,13)'=""
QUIT
+88 SET IPRN=$ORDER(^BQIPROV(TMM,30,"B",CODE,""))
IF IPRN=""
QUIT
+89 SET IPRD=$ORDER(^BQIPROV(TMM,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+90 SET DEN=$PIECE(^BQIPROV(TMM,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+91 SET TNUM=TNUM+NUM
SET TDEN=TDEN+DEN
End DoDot:3
+92 IF $GET(DEBUG)=1
WRITE !,TEAM,"|",CODE,"|",TDEN,"|",TNUM
+93 DO STORT^BQIIPUTL(TEAM,CODE,BQDATE,TDEN,TNUM)
End DoDot:2
End DoDot:1
+94 ;
TOT ;EP total up values for MU
+1 IF CRIPC'="IPCMH"
Begin DoDot:1
+2 NEW MCOD
+3 FOR MCOD="MU_2","MU_6","MU_7","MU_3","MU_5","MU_8","MU_55","MU_56","MU_57"
Begin DoDot:2
+4 NEW PRV,TDEN,TNUM,IPRN,IPRD,DEN,NUM
+5 SET PRV=""
SET TDEN=0
SET TNUM=0
+6 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:3
+7 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+8 SET IPRN=$ORDER(^BQIPROV(PRV,30,"B",MCOD,""))
IF IPRN=""
QUIT
+9 SET IPRD=$ORDER(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+10 SET DEN=$PIECE(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+11 SET TDEN=TDEN+DEN
SET TNUM=TNUM+NUM
End DoDot:3
+12 SET FAC=$$HME^BQIGPUTL()
+13 DO STORF^BQIIPUTL(FAC,MCOD,BQDATE,TDEN,TNUM)
End DoDot:2
+14 ;
+15 SET YEAR=$$GET1^DIQ(90508,1_",",2,"E")
+16 SET FAC=$$HME^BQIGPUTL()
+17 SET TPRN=$ORDER(^BQIFAC(FAC,30,"B","IPC_TOTP",""))
+18 IF TPRN'=""
SET TPRD=$ORDER(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,""))
+19 SET GPRN=$ORDER(^BQIFAC(FAC,30,"B",YEAR_"_2452",""))
SET GPRD=""
+20 IF GPRN'=""
SET GPRD=$ORDER(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,""))
+21 IF TPRN'=""
IF TPRD'=""
Begin DoDot:2
+22 SET DEN=$PIECE(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
+23 IF GPRN=""!(GPRD="")
QUIT
+24 SET $PIECE(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
CHK ; EP - Check whether the IPC data ran or not
+1 NEW LPRV,PRDTE
+2 SET QFL=1
+3 IF $EXTRACT(DT,6,7)<CRST
QUIT
+4 SET BQMON=$EXTRACT(DT,4,5)
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+5 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+6 SET BQMON=$PIECE(BQDTE,U,1)
+7 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+8 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+9 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+10 SET BQDATE=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"00"
+11 SET PRDTE=$ORDER(^BQI(90508,1,22,CRN,3,"B",BQDATE),-1)
+12 ; if date has already been set and last provider done
+13 SET LPRV=$ORDER(^AUPNPAT("AK",""),-1)
+14 IF $DATA(^BQIPROV(LPRV,30,"AB",BQDATE))
IF $DATA(^BQI(90508,1,22,CRN,3,"B",BQDATE))
QUIT
+15 ; If date not set up
+16 IF '$DATA(BQI(90508,1,22,CRN,3,"B",BQDATE))
Begin DoDot:1
+17 ; If a provider is still in the queue and the date is the previous date
+18 IF $PIECE(^BQI(90508,1,11),U,3)=""
IF $PIECE(^BQI(90508,1,11),U,5)=PRDTE
SET QFL=0
QUIT
End DoDot:1
+19 QUIT
+20 ;
ROW ;
+1 ;;06^314^71
+2 ;;07^314^72
+3 ;;08^314^73
+4 ;;09^314^74
+5 ;;10^314^75
+6 ;;11^314^76
+7 ;;12^314^77
+8 ;;01^315^78
+9 ;;02^315^79
+10 ;;03^315^80
+11 ;;04^315^81
+12 ;;05^315^82
+13 ;;06^315^83
+14 ;;07^315^84
+15 ;;08^315^85
+16 ;;09^315^86
+17 ;;10^315^87
+18 QUIT
+19 ;
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
