BQIIPMON ;VNGT/HS/ALA-IPC Monthly Calculation ; 26 May 2011 8:11 AM
;;2.3;ICARE MANAGEMENT SYSTEM;**1,3,4**;Apr 18, 2012;Build 66
;
;
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=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"
. S BQDATE=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"00"
;
S BQIUPD(90508,"1,",11.05)=BQDATE
D FILE^DIE("","BQIUPD","ERROR")
;
; 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
;
; 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)
;
S QFL=0 F BI=1:1:13 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
;
; 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
;
; Calculate the IPC measures
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 non calculable
. I TYP="N" D NCLC 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
. ; If type is CRS
. I TYP="G" D CRS Q
. I TYP="M" D MU
;
; Update the Goal Set
NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
S PRV="",YEAR=$$GET1^DIQ(90508,1_",",2,"E")
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. I $P(^VA(200,PRV,0),U,13)'="" Q
. S TPRN=$O(^BQIPROV(PRV,30,"B","IPC_TOTP","")) I TPRN="" Q
. S TPRD=$O(^BQIPROV(PRV,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
. S GPRN=$O(^BQIPROV(PRV,30,"B",YEAR_"_2452","")) I GPRN="" Q
. S GPRD=$O(^BQIPROV(PRV,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
. S DEN=$P(^BQIPROV(PRV,30,TPRN,1,TPRD,0),U,2)
. S $P(^BQIPROV(PRV,30,GPRN,1,GPRD,0),U,2)=DEN
. S $P(^BQIPROV(PRV,2),U,3)=$$NOW^XLFDT()
. ; Update the MU bundles
. NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
. S MPRN=$O(^BQIPROV(PRV,30,"B","IPC_WGT","")) I MPRN="" Q
. S MPRD=$O(^BQIPROV(PRV,30,MPRN,1,"B",BQDATE,"")) I MPRD="" Q
. K MBUN
. F MCOD="MU_6","MU_6","MU_7" D
.. 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 MBUN(+DEN)=+NUM
. S DEN=$O(MBUN("")),NUM=MBUN(DEN)
. S $P(^BQIPROV(PRV,30,MPRN,1,MPRD,0),U,2)=DEN,$P(^BQIPROV(PRV,30,MPRN,1,MPRD,0),U,3)=NUM
;
S FAC=$$HME^BQIGPUTL()
S TPRN=$O(^BQIFAC(FAC,30,"B","IPC_TOTP","")) I TPRN="" Q
S TPRD=$O(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,"")) I TPRD="" Q
S GPRN=$O(^BQIFAC(FAC,30,"B",YEAR_"_2452","")) I GPRN="" Q
S GPRD=$O(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,"")) I GPRD="" Q
S DEN=$P(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
S $P(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
;
; 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)="@"
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
Q
;
NCLC ; No calculation possible
Q
;
CRS ; Get values from BQIPAT
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 DFN="",PDEN=0,PNUM=0
. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.. I '$$HRN^BQIUL1(DFN) Q
.. S IEN=$O(^BQIPAT(DFN,30,"B",CODE,"")) I IEN="" Q
.. S PNUM=PNUM+$P(^BQIPAT(DFN,30,IEN,0),U,3)
.. S PDEN=PDEN+$P(^BQIPAT(DFN,30,IEN,0),U,4)
. D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
. S TNUM=TNUM+PNUM,TDEN=TDEN+PDEN
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
Q
;
MU ; Get values for MU measures
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
. NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
. NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM,BQTN,MUIND
. S PDEN=0,PNUM=0
. ; Current
. S BGPBEN=3
. S BGPRTYPE=4,BGP0RPTH="A",BGPMUT="P",BGPMUYF=90595.11
. S (BGPBD,BGPED,BGPTP,BGPINDT)=""
. S BGPBD=BEGDT,BGPED=ENDT
. S BGPPBD="",BGPPED=""
. ; Baseline
. S BGPBBD=BGPPBD,BGPBED=BGPPED
. S BQIGREF=$NA(^TMP("BQICQM",$J)) K @BQIGREF
. S MUIND=$P($G(^BGPMUIND(90596.11,$P(CODE,"_",2),0)),U,1) I MUIND="" Q
. S BGPIND(MUIND)="",BGPPROV=PRV
. D BQI^BGPMUEPD(.BQIGREF,BGPPROV)
. K CDEN,CNUM,CEXC,NUM
. S DFN=""
. F S DFN=$O(@BQIGREF@(BGPPROV,DFN)) Q:DFN="" D
.. S I=""
.. F S I=$O(@BQIGREF@(BGPPROV,DFN,"C",I)) Q:I="" D
... S CDEN=$G(CDEN)+$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,1)
... S NUM=$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,2)
... I NUM>1,$$FMTE^BQIUL1(NUM)'?.N S NUM=1
... S CNUM=$G(CNUM)+NUM
... S CEXC=$G(CEXC)+$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,3)
. S PDEN=PDEN+$G(CDEN),PNUM=PNUM+$G(CNUM),TDEN=TDEN+PDEN,TNUM=TNUM+PNUM
. D STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
K BQIND
Q
;
CHK ; EP - Check whether the IPC data ran or not
NEW LPRV
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"
I $D(^BQI(90508,1,22,CRN,3,"B",BQDATE)) Q
S LPRV=$O(^AUPNPAT("AK",""),-1)
I $D(^BQIPROV(LPRV,30,"AB",BQDATE)) Q
S QFL=0
Q
;
NMS(CDE) ; New measure
Q
;
NTM(PROV) ; New timeframe
Q
;
ROW ;
;;08^312^49
;;09^312^50
;;10^312^51
;;11^312^52
;;12^312^53
;;01^313^54
;;02^313^55
;;03^313^56
;;04^313^57
;;05^313^58
;;06^313^59
;;07^313^60
;;08^313^61
;;09^313^62
;;10^313^63
;;11^313^64
;;12^313^65
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
BQIIPMON ;VNGT/HS/ALA-IPC Monthly Calculation ; 26 May 2011 8:11 AM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**1,3,4**;Apr 18, 2012;Build 66
+2 ;
+3 ;
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 ;S BQDATE=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"
+27 SET BQDATE=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"00"
End DoDot:1
IF QFL
QUIT
+28 ;
+29 SET BQIUPD(90508,"1,",11.05)=BQDATE
+30 DO FILE^DIE("","BQIUPD","ERROR")
+31 ;
+32 ; Get current IPC
+33 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+34 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+35 ;
+36 ; Set the date
+37 NEW DA,DIC,X,PRDTE,PRN,ROW,FROW,QFL,RMON,RYEAR,RROW
+38 IF $GET(^BQI(90508,1,22,CRN,3,0))=""
SET ^BQI(90508,1,22,CRN,3,0)="^90508.223D^^"
+39 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)
+40 SET DIC="^BQI(90508,"_DA(2)_",22,"_DA(1)_",3,"
+41 DO ^DIC
+42 IF Y=-1
KILL DO,DD
DO FILE^DICN
+43 SET BQDA=+Y
+44 SET PRDTE=$ORDER(^BQI(90508,1,22,CRN,3,"B",X),-1)
+45 ;
+46 SET QFL=0
FOR BI=1:1:13
SET FROW=$PIECE($TEXT(ROW+BI),";;",2)
Begin DoDot:1
+47 SET RMON=$PIECE(FROW,U,1)
SET RYEAR=$PIECE(FROW,U,2)
SET RROW=$PIECE(FROW,U,3)
+48 IF $EXTRACT(BQDATE,1,3)=RYEAR
IF $EXTRACT(BQDATE,4,5)=RMON
Begin DoDot:2
+49 SET ROW=RROW
SET QFL=1
+50 SET $PIECE(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
End DoDot:2
QUIT
End DoDot:1
IF QFL
QUIT
+51 IF 'QFL
Begin DoDot:1
+52 SET PRN=$ORDER(^BQI(90508,1,22,CRN,3,"B",PRDTE,""))
+53 SET PROW=$PIECE(^BQI(90508,1,22,CRN,3,PRN,0),U,2)
+54 SET ROW=PROW+1
+55 SET $PIECE(^BQI(90508,1,22,CRN,3,BQDA,0),U,2)=ROW
End DoDot:1
+56 ;
+57 ; Set the DATE/TIME FLAG STARTED field
+58 NEW DA
+59 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+60 SET BQIUPD(90508,DA_",",8.1)=$$NOW^XLFDT()
+61 SET BQIUPD(90508,DA_",",8.12)=1
+62 SET BQIUPD(90508,DA_",",24.08)=$GET(ZTSK)
+63 DO FILE^DIE("","BQIUPD","ERROR")
+64 KILL BQIUPD
+65 ;
+66 ; Calculate the IPC measures
+67 SET MSN=0
+68 FOR
SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,MSN))
IF 'MSN
QUIT
Begin DoDot:1
+69 SET IDATA=^BQI(90508,1,22,CRN,1,MSN,0)
+70 SET CODE=$PIECE(IDATA,U,1)
SET TYP=$PIECE(IDATA,U,2)
+71 ; If inactive, quit
+72 IF $PIECE(IDATA,U,7)=1
QUIT
+73 ; If type is non calculable
+74 IF TYP="N"
DO NCLC
QUIT
+75 ; If type is RPMS
+76 IF TYP="R"
Begin DoDot:2
+77 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+78 XECUTE EXEC
End DoDot:2
QUIT
+79 ; If type is CRS
+80 IF TYP="G"
DO CRS
QUIT
+81 IF TYP="M"
DO MU
End DoDot:1
+82 ;
+83 ; Update the Goal Set
+84 NEW TPRN,PRV,TPRD,GPRN,GPRD,DEN,FAC,YEAR
+85 SET PRV=""
SET YEAR=$$GET1^DIQ(90508,1_",",2,"E")
+86 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+87 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+88 SET TPRN=$ORDER(^BQIPROV(PRV,30,"B","IPC_TOTP",""))
IF TPRN=""
QUIT
+89 SET TPRD=$ORDER(^BQIPROV(PRV,30,TPRN,1,"B",BQDATE,""))
IF TPRD=""
QUIT
+90 SET GPRN=$ORDER(^BQIPROV(PRV,30,"B",YEAR_"_2452",""))
IF GPRN=""
QUIT
+91 SET GPRD=$ORDER(^BQIPROV(PRV,30,GPRN,1,"B",BQDATE,""))
IF GPRD=""
QUIT
+92 SET DEN=$PIECE(^BQIPROV(PRV,30,TPRN,1,TPRD,0),U,2)
+93 SET $PIECE(^BQIPROV(PRV,30,GPRN,1,GPRD,0),U,2)=DEN
+94 SET $PIECE(^BQIPROV(PRV,2),U,3)=$$NOW^XLFDT()
+95 ; Update the MU bundles
+96 NEW MPRN,IPRN,IPRD,DEN,NUM,MCOD,MPRD,MBUN
+97 SET MPRN=$ORDER(^BQIPROV(PRV,30,"B","IPC_WGT",""))
IF MPRN=""
QUIT
+98 SET MPRD=$ORDER(^BQIPROV(PRV,30,MPRN,1,"B",BQDATE,""))
IF MPRD=""
QUIT
+99 KILL MBUN
+100 FOR MCOD="MU_6","MU_6","MU_7"
Begin DoDot:2
+101 SET IPRN=$ORDER(^BQIPROV(PRV,30,"B",MCOD,""))
IF IPRN=""
QUIT
+102 SET IPRD=$ORDER(^BQIPROV(PRV,30,IPRN,1,"B",BQDATE,""))
IF IPRD=""
QUIT
+103 SET DEN=$PIECE(^BQIPROV(PRV,30,IPRN,1,IPRD,0),U,2)
SET NUM=$PIECE(^(0),U,3)
+104 SET MBUN(+DEN)=+NUM
End DoDot:2
+105 SET DEN=$ORDER(MBUN(""))
SET NUM=MBUN(DEN)
+106 SET $PIECE(^BQIPROV(PRV,30,MPRN,1,MPRD,0),U,2)=DEN
SET $PIECE(^BQIPROV(PRV,30,MPRN,1,MPRD,0),U,3)=NUM
End DoDot:1
+107 ;
+108 SET FAC=$$HME^BQIGPUTL()
+109 SET TPRN=$ORDER(^BQIFAC(FAC,30,"B","IPC_TOTP",""))
IF TPRN=""
QUIT
+110 SET TPRD=$ORDER(^BQIFAC(FAC,30,TPRN,1,"B",BQDATE,""))
IF TPRD=""
QUIT
+111 SET GPRN=$ORDER(^BQIFAC(FAC,30,"B",YEAR_"_2452",""))
IF GPRN=""
QUIT
+112 SET GPRD=$ORDER(^BQIFAC(FAC,30,GPRN,1,"B",BQDATE,""))
IF GPRD=""
QUIT
+113 SET DEN=$PIECE(^BQIFAC(FAC,30,TPRN,1,TPRD,0),U,2)
+114 SET $PIECE(^BQIFAC(FAC,30,GPRN,1,GPRD,0),U,2)=DEN
+115 ;
+116 ; Set the DATE/TIME FLAG ENDED field
+117 NEW DA
+118 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+119 SET BQIUPD(90508,DA_",",8.11)=$$NOW^XLFDT()
+120 SET BQIUPD(90508,DA_",",8.12)="@"
+121 SET BQIUPD(90508,DA_",",24.08)="@"
+122 DO FILE^DIE("","BQIUPD","ERROR")
+123 KILL BQIUPD
+124 QUIT
+125 ;
NCLC ; No calculation possible
+1 QUIT
+2 ;
CRS ; Get values from BQIPAT
+1 SET PRV=""
SET TDEN=0
SET TNUM=0
+2 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+3 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+4 SET DFN=""
SET PDEN=0
SET PNUM=0
+5 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+6 IF '$$HRN^BQIUL1(DFN)
QUIT
+7 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CODE,""))
IF IEN=""
QUIT
+8 SET PNUM=PNUM+$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
+9 SET PDEN=PDEN+$PIECE(^BQIPAT(DFN,30,IEN,0),U,4)
End DoDot:2
+10 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
+11 SET TNUM=TNUM+PNUM
SET TDEN=TDEN+PDEN
End DoDot:1
+12 SET FAC=$$HME^BQIGPUTL()
+13 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+14 QUIT
+15 ;
MU ; Get values for MU measures
+1 SET PRV=""
SET TDEN=0
SET TNUM=0
+2 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+3 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+4 NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
+5 NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM,BQTN,MUIND
+6 SET PDEN=0
SET PNUM=0
+7 ; Current
+8 SET BGPBEN=3
+9 SET BGPRTYPE=4
SET BGP0RPTH="A"
SET BGPMUT="P"
SET BGPMUYF=90595.11
+10 SET (BGPBD,BGPED,BGPTP,BGPINDT)=""
+11 SET BGPBD=BEGDT
SET BGPED=ENDT
+12 SET BGPPBD=""
SET BGPPED=""
+13 ; Baseline
+14 SET BGPBBD=BGPPBD
SET BGPBED=BGPPED
+15 SET BQIGREF=$NAME(^TMP("BQICQM",$JOB))
KILL @BQIGREF
+16 SET MUIND=$PIECE($GET(^BGPMUIND(90596.11,$PIECE(CODE,"_",2),0)),U,1)
IF MUIND=""
QUIT
+17 SET BGPIND(MUIND)=""
SET BGPPROV=PRV
+18 DO BQI^BGPMUEPD(.BQIGREF,BGPPROV)
+19 KILL CDEN,CNUM,CEXC,NUM
+20 SET DFN=""
+21 FOR
SET DFN=$ORDER(@BQIGREF@(BGPPROV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+22 SET I=""
+23 FOR
SET I=$ORDER(@BQIGREF@(BGPPROV,DFN,"C",I))
IF I=""
QUIT
Begin DoDot:3
+24 SET CDEN=$GET(CDEN)+$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",I)),U,1)
+25 SET NUM=$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",I)),U,2)
+26 IF NUM>1
IF $$FMTE^BQIUL1(NUM)'?.N
SET NUM=1
+27 SET CNUM=$GET(CNUM)+NUM
+28 SET CEXC=$GET(CEXC)+$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",I)),U,3)
End DoDot:3
End DoDot:2
+29 SET PDEN=PDEN+$GET(CDEN)
SET PNUM=PNUM+$GET(CNUM)
SET TDEN=TDEN+PDEN
SET TNUM=TNUM+PNUM
+30 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,PDEN,PNUM)
End DoDot:1
+31 SET FAC=$$HME^BQIGPUTL()
+32 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+33 KILL BQIND
+34 QUIT
+35 ;
CHK ; EP - Check whether the IPC data ran or not
+1 NEW LPRV
+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 IF $DATA(^BQI(90508,1,22,CRN,3,"B",BQDATE))
QUIT
+12 SET LPRV=$ORDER(^AUPNPAT("AK",""),-1)
+13 IF $DATA(^BQIPROV(LPRV,30,"AB",BQDATE))
QUIT
+14 SET QFL=0
+15 QUIT
+16 ;
NMS(CDE) ; New measure
+1 QUIT
+2 ;
NTM(PROV) ; New timeframe
+1 QUIT
+2 ;
ROW ;
+1 ;;08^312^49
+2 ;;09^312^50
+3 ;;10^312^51
+4 ;;11^312^52
+5 ;;12^312^53
+6 ;;01^313^54
+7 ;;02^313^55
+8 ;;03^313^56
+9 ;;04^313^57
+10 ;;05^313^58
+11 ;;06^313^59
+12 ;;07^313^60
+13 ;;08^313^61
+14 ;;09^313^62
+15 ;;10^313^63
+16 ;;11^313^64
+17 ;;12^313^65
+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
