BQIMUPRS ;VNGT/HS/ALA-Update a single provider ; 27 Apr 2011 8:28 AM
;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
;
MON(BGPPROV) ;EP - Monthly CQM Process
NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM
; Current
S BGPBEN=3
S BGPRTYPE=4,BGP0RPTH="A",BGPMUT="P",BGPMUYF=90595.11
S (BGPBD,BGPED,BGPTP,BGPINDT)=""
S BGPBD=$P(^BQI(90508,1,12),U,8),BGPED=$P(^BQI(90508,1,12),U,9)
S BQTDT=$E(BGPBD,1,5)_"00"
S BQTMN=$O(^BQIPROV(BGPPROV,50,"B",BQTDT,""))
I BQTMN="" D UPD(50)
S BGPPBD="",BGPPED=""
; Baseline
S BGPBBD=BGPPBD,BGPBED=BGPPED
S BQIGREF=$NA(^TMP("BQICQM",$J)) K @BQIGREF
D IND("E")
I $G(DUZ(2))="" D
. D DZ^BQITASK1 M DUZ=^XTMP("BQIRMDR","DUZ")
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(I)=$G(CDEN(I))+$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(I)=$G(CNUM(I))+NUM
.. S CEXC(I)=$G(CEXC(I))+$P($G(@BQIGREF@(BGPPROV,DFN,"C",I)),U,3)
.. ;S ^XTMP("BQIMCQMPT",DFN,BGPPROV,BQTDT,I)=$G(@BQIGREF@(BGPPROV,DFN,"C",I))
D STORP(50)
K @BQIGREF
Q
;
STORP(NODE) ;EP - Store data
I '$D(@BQIGREF) Q
;
S BQTMN=$O(^BQIPROV(BGPPROV,NODE,"B",BQTDT,""))
I BQTMN="" D UPD(NODE)
S FAC=$$HME^BQIGPUTL()
;
I NODE=50 D Q
. S $P(^BQIPROV(BGPPROV,2),U,1)=$$NOW^XLFDT()
. S CT=0
. S I=0 F S I=$O(^BGPMUIND(90596.11,I)) Q:'I D
.. S MSN=$P(^BGPMUIND(90596.11,I,0),U,1)
.. I $G(^BGPMUIND(90595.11,MSN,0))="" Q
.. I $P(^BGPMUIND(90595.11,MSN,0),U,4)="H" Q
.. S ID=$P(^BGPMUIND(90596.11,I,0),"^",4)
.. S CT=CT+1,^BQIPROV(BGPPROV,NODE,BQTMN,1,CT,0)=ID_U_$G(CDEN(I))_U_$G(CNUM(I))_U_$G(CEXC(I))
.. S ^BQIPROV(BGPPROV,NODE,BQTMN,1,"B",ID,CT)=""
.. S ^BQIPROV(BGPPROV,NODE,BQTMN,1,0)="^90505.451^"_CT_"^"_CT
.. ;
.. ; Set up by providers divisions
.. NEW NODE,BQTMN
.. S DV=0,NODE=80
.. F S DV=$O(^VA(200,BGPPROV,2,DV)) Q:'DV D
... I $G(^BQIFAC(DV,0))="" S ^BQIFAC(DV,0)=DV,^BQIFAC("B",DV,DV)=""
... S FAC=DV D UPD(80)
... S DN=$O(^BQIFAC(DV,NODE,BQTMN,1,"B",ID,"")) I DN="" S DN=CT
... I $G(^BQIFAC(DV,NODE,BQTMN,1,DN,0))="" S ^BQIFAC(DV,NODE,BQTMN,1,DN,0)=ID,^BQIFAC(DV,NODE,BQTMN,1,"B",ID,DN)=""
... S $P(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,2)=$P($G(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,2)+$G(CDEN(I))
... S $P(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,3)=$P($G(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,3)+$G(CNUM(I))
... S $P(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,4)=$P($G(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,4)+$G(CEXC(I))
;
I NODE=40 D Q
. NEW PGLOB
. S PGLOB=$$CURPGL^BQIMUTAB()
. S ID="",CT=0
. F S ID=$O(@GLOBAL@(BGPPROV,ID)) Q:ID="" D
.. S IIEN=$O(@PGLOB@("B",ID,"")) I IIEN="" Q
.. I $P(@PGLOB@(IIEN,0),"^",6)'="R" Q
.. S CDEN=$P($G(@GLOBAL@(BGPPROV,ID,"CURR")),"^",1),CNUM=$P($G(@GLOBAL@(BGPPROV,ID,"CURR")),"^",2)
.. S CEXC=$P($G(@GLOBAL@(BGPPROV,ID,"CURR")),"^",3)
.. S CT=CT+1,^BQIPROV(BGPPROV,NODE,BQTMN,1,CT,0)=ID_U_CDEN_U_CNUM_U_$$CURREP^BQIMUTAB()
.. I CEXC'="" S ^BQIPROV(BGPPROV,NODE,BQTMN,1,CT,1)=CEXC
.. S ^BQIPROV(BGPPROV,NODE,BQTMN,1,"B",ID,CT)=""
.. S ^BQIPROV(BGPPROV,NODE,BQTMN,1,0)="^90505.441^"_CT_"^"_CT
.. ;
.. ; set up by providers divisions
.. NEW DV,DN,NODE,BQTMN
.. S DV=0,NODE=70
.. F S DV=$O(^VA(200,BGPPROV,2,DV)) Q:'DV D
... I $G(^BQIFAC(DV,0))="" S ^BQIFAC(DV,0)=DV,^BQIFAC("B",DV,DV)=""
... S FAC=DV D UPD(70)
... S DN=$O(^BQIFAC(DV,NODE,BQTMN,1,"B",ID,"")) I DN="" S DN=CT
... I $G(^BQIFAC(DV,NODE,BQTMN,1,DN,0))="" S ^BQIFAC(DV,NODE,BQTMN,1,DN,0)=ID,^BQIFAC(DV,NODE,BQTMN,1,"B",ID,DN)=""
... S $P(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,2)=$P($G(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,2)+CDEN
... S $P(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,3)=$P($G(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,3)+CNUM
... S $P(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,4)=$$CURREP^BQIMUTAB()
... I CEXC'="" S ^BQIFAC(DV,NODE,BQTMN,1,DN,1)=CEXC
. NEW DIK,DA
. S DIK="^BQIPROV(",DA=BGPPROV D IX^DIK
Q
;
IND(TY) ; EP - Set indicators
; Input
; TY = Type (H=Hospital)
K BGPIND
I TY'="H" D
. S X=0 F S X=$O(^BGPMUIND(90595.11,X)) Q:'X I $P(^BGPMUIND(90595.11,X,0),U,4)'="H" S BGPIND(X)=""
I TY="H" D
. S X=0 F S X=$O(^BGPMUIND(90595.11,X)) Q:'X I $P(^BGPMUIND(90595.11,X,0),U,4)="H" S BGPIND(X)=""
Q
;
UPD(NODE) ;EP
NEW BEGDT,ENDT,TMFRAME,XX,V,I,ERROR,BQIUPD,BQDATE
;
I NODE=50 D
. S BEGDT=$P($G(^BQI(90508,1,12)),U,8),ENDT=$P($G(^BQI(90508,1,12)),U,9)
. S BQDATE=$E(BEGDT,1,5)_"00"
. I $G(^BQIPROV(BGPPROV,50,0))="" S ^BQIPROV(BGPPROV,50,0)="^90505.45D^^"
I NODE=40 D
. S BEGDT=$P($G(^BQI(90508,1,9)),U,1),ENDT=$P($G(^BQI(90508,1,9)),U,2)
. S BQDATE=$E(BEGDT,1,5)_"00"
. I $G(^BQIPROV(BGPPROV,40,0))="" S ^BQIPROV(BGPPROV,40,0)="^90505.44D^^"
I NODE=70 D
. S BEGDT=$P($G(^BQI(90508,1,9)),U,1),ENDT=$P($G(^BQI(90508,1,9)),U,2)
. S BQDATE=$E(BEGDT,1,5)_"00"
. I $G(^BQIFAC(FAC,70,0))="" S ^BQIFAC(FAC,70,0)="^90505.67D^^"
I NODE=80 D
. S BEGDT=$P($G(^BQI(90508,1,12)),U,8),ENDT=$P($G(^BQI(90508,1,12)),U,9)
. S BQDATE=$E(BEGDT,1,5)_"00"
. I $G(^BQIFAC(FAC,80,0))="" S ^BQIFAC(FAC,80,0)="^90505.68D^^"
;
NEW DA,X,IENS,Y,DIC,DLAYGO
I NODE=50 S DA(1)=BGPPROV,DIC="^BQIPROV("_DA(1)_",50,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.45,DIC("P")=DLAYGO
I NODE=40 S DA(1)=BGPPROV,DIC="^BQIPROV("_DA(1)_",40,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.44,DIC("P")=DLAYGO
I NODE=70 S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",70,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.67,DIC("P")=DLAYGO
I NODE=80 S DA(1)=FAC,DIC="^BQIFAC("_DA(1)_",80,",X=BQDATE,DIC(0)="LNZ",DLAYGO=90505.68,DIC("P")=DLAYGO
D ^DIC
S DA=+Y I DA=-1 Q
S BQTMN=DA
Q
;
PMON(BGPPROV) ;EP - Monthly Performance Process
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
;
; Set the DATE/TIME MU STARTED field
NEW DA
S DA=$O(^BQI(90508,0)) I 'DA Q
S BQIUPD(90508,DA_",",8.04)=$$NOW^XLFDT()
S BQIUPD(90508,DA_",",8.06)=1
S BQIUPD(90508,DA_",",24.1)=$G(ZTSK)
D FILE^DIE("","BQIUPD","ERROR")
K BQIUPD
;
; one month period
NEW APCMED,APCMBD,APCMRPT,APCMPBD,APCMPED,APCMTIME,APCMRPTT,BQIPROV,APCMATTE,APCMIND
NEW APCM100R,APCM13ON,APCM2ON,APCMECHI,APCMIMME,APCMN565,APCMOFFV,APCMRCIS,APCMTRAE
NEW APCM4D,APCMAGEB,APCMAGEE,APCMBDAT,APCMBT,APCMEDAT,APCMEP,APCMET,APCMFILN,APCMGBL
NEW APCMH,APCMHV,APCMIC,APCMJ,APCMP,APCMSEX,APCMVALU,APCMWPP,APCMX,BEGDT,BQIGREF,BQTDT
NEW BQTMN,CDEN,CEXC,CNUM,CT,DFN,ENDT,F,FAC,GLOBAL,ID,IIEN,LABSNO,SD,PGLOB,PROU
;
S PGLOB=$$CURPGL^BQIMUTAB()
S PROU=$$CURPRT^BQIMUTAB()
S BEGDT=$P($G(^BQI(90508,1,9)),U,1),ENDT=$P($G(^BQI(90508,1,9)),U,2)
S BQTDT=$E(BEGDT,1,5)_"00"
S APCMED=ENDT,APCMBD=BEGDT,APCMRPT=1,APCMDEMO="E"
S APCMPED=$$FMADD^XLFDT(APCMED,-30),APCMPBD=$$FMADD^XLFDT(APCMBD,-60)
S APCMTIME=1,APCMRPTT=1
S GLOBAL=$NA(^TMP("BQIMUP1",$J))
;F X="S1.010.EP","S1.013.EP","S1.014.EP","S1.015.EP","S1.018.EP","S1.020.EP","S1.024.EP","S1.025.EP" D
;. S BQIPROV(BGPPROV)=""
;. S APCMATTE(X,BGPPROV)=""
;gather up measures for this report
S X=0 F S X=$O(@PGLOB@(X)) Q:X'=+X I $P(@PGLOB@(X,0),U,2)="E" D
. S ID=$P(@PGLOB@(X,0),U,1)
. I $P(@PGLOB@(X,0),U,6)'="R" Q
. S @GLOBAL@(BGPPROV,ID,"CURR")="",@GLOBAL@(BGPPROV,ID,"PREV")="",APCMATTE(ID,BGPPROV)=""
. S BQIPROV(BGPPROV)="",APCMIND(X)=""
;
; Check if connection to server is working
S CONN=1
I PGLOB="^APCM24OB" D PHRC I 'CONN D
. NEW MN
. S MN=$O(@PGLOB@("B","S2.026.EP",""))
. I MN'="" K APCMIND(MN)
;
I $G(DUZ(2))="" D
. D DZ^BQITASK1 M DUZ=^XTMP("BQIRMDR","DUZ")
;
S APCMWPP=1
;I $T(BQI^APCM11E1)'="" D BQI^APCM11E1(.GLOBAL,.BQIPROV)
D @("BQI^"_PROU_"(.GLOBAL,.BQIPROV)")
;
S BQIGREF=GLOBAL
D STORP(40)
K @GLOBAL
Q
;
PHRC ;EP - Check if PHR is installed, if performance report is 2014
I $T(PHR^BPHRMUPM)="" Q
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIMUPRS D UNWIND^%ZTER"
;
NEW BPHRP,EXEC,RESULT,BPHRR,BDT,EDT
S BDT=DT,EDT=DT
K BPARRAY
D GETS^DIQ(90670.2,"1,","**","E","BPARRAY")
S BPHRP("URLROOT")=$G(BPARRAY(90670.2,"1,",.02,"E"))
S BPHRP("SERVICEPATH")=$G(BPARRAY(90670.2,"1,",.11,"E"))
S BPHRP("PORT")=$G(BPARRAY(90670.2,"1,",.03,"E"))
S BPHRP("TIMEOUT")=$G(BPARRAY(90670.2,"1,",.05,"E"))
S BPHRP("USER")=$G(BPARRAY(90670.2,"1,",.07,"E"))
S BPHRP("PASS")=$G(BPARRAY(90670.2,"1,",.08,"E"))
; Pass Patient ICN and BDT and EDT to web service call
S BPHRP("EUID")=$G(BPHREUID)
; Change BDT and EDT to appropriate dates from FileMan date
S BPHRP("FROM")=$$DATE^BPHRMUPM(BDT)_"T00:00:00"_$$TMZ^BPHRMUPM()
S BPHRP("TO")=$$DATE^BPHRMUPM(EDT)_"T23:59:59"_$$TMZ^BPHRMUPM()
;
; Returns data
S EXEC="S STS=##class(BPHR.WebServiceCalls).PMQueryRequest(.BPHRP,.BPHRR)" X EXEC
I $P($G(STS),U,1)=0,$P(STS,U,2)["ERROR" S CONN=0
Q
;
ERR ;EP - Error trap
I $ZE["<ZSOAP>" S CONN=0
D ^%ZTER
Q
BQIMUPRS ;VNGT/HS/ALA-Update a single provider ; 27 Apr 2011 8:28 AM
+1 ;;2.3;ICARE MANAGEMENT SYSTEM;**3,4**;Apr 18, 2012;Build 66
+2 ;
MON(BGPPROV) ;EP - Monthly CQM Process
+1 NEW BGPBEN,BGPRTYPE,BGP0RPTH,BGPMUT,BGPMUYF,BGPBD,BGPED,BGPTP,BGPINDT
+2 NEW BQTDT,BQTMN,BQIGREF,DFN,CDEN,CNUM,CEXC,NUM
+3 ; Current
+4 SET BGPBEN=3
+5 SET BGPRTYPE=4
SET BGP0RPTH="A"
SET BGPMUT="P"
SET BGPMUYF=90595.11
+6 SET (BGPBD,BGPED,BGPTP,BGPINDT)=""
+7 SET BGPBD=$PIECE(^BQI(90508,1,12),U,8)
SET BGPED=$PIECE(^BQI(90508,1,12),U,9)
+8 SET BQTDT=$EXTRACT(BGPBD,1,5)_"00"
+9 SET BQTMN=$ORDER(^BQIPROV(BGPPROV,50,"B",BQTDT,""))
+10 IF BQTMN=""
DO UPD(50)
+11 SET BGPPBD=""
SET BGPPED=""
+12 ; Baseline
+13 SET BGPBBD=BGPPBD
SET BGPBED=BGPPED
+14 SET BQIGREF=$NAME(^TMP("BQICQM",$JOB))
KILL @BQIGREF
+15 DO IND("E")
+16 IF $GET(DUZ(2))=""
Begin DoDot:1
+17 DO DZ^BQITASK1
MERGE DUZ=^XTMP("BQIRMDR","DUZ")
End DoDot:1
+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:1
+22 SET I=""
+23 FOR
SET I=$ORDER(@BQIGREF@(BGPPROV,DFN,"C",I))
IF I=""
QUIT
Begin DoDot:2
+24 SET CDEN(I)=$GET(CDEN(I))+$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(I)=$GET(CNUM(I))+NUM
+28 SET CEXC(I)=$GET(CEXC(I))+$PIECE($GET(@BQIGREF@(BGPPROV,DFN,"C",I)),U,3)
+29 ;S ^XTMP("BQIMCQMPT",DFN,BGPPROV,BQTDT,I)=$G(@BQIGREF@(BGPPROV,DFN,"C",I))
End DoDot:2
End DoDot:1
+30 DO STORP(50)
+31 KILL @BQIGREF
+32 QUIT
+33 ;
STORP(NODE) ;EP - Store data
+1 IF '$DATA(@BQIGREF)
QUIT
+2 ;
+3 SET BQTMN=$ORDER(^BQIPROV(BGPPROV,NODE,"B",BQTDT,""))
+4 IF BQTMN=""
DO UPD(NODE)
+5 SET FAC=$$HME^BQIGPUTL()
+6 ;
+7 IF NODE=50
Begin DoDot:1
+8 SET $PIECE(^BQIPROV(BGPPROV,2),U,1)=$$NOW^XLFDT()
+9 SET CT=0
+10 SET I=0
FOR
SET I=$ORDER(^BGPMUIND(90596.11,I))
IF 'I
QUIT
Begin DoDot:2
+11 SET MSN=$PIECE(^BGPMUIND(90596.11,I,0),U,1)
+12 IF $GET(^BGPMUIND(90595.11,MSN,0))=""
QUIT
+13 IF $PIECE(^BGPMUIND(90595.11,MSN,0),U,4)="H"
QUIT
+14 SET ID=$PIECE(^BGPMUIND(90596.11,I,0),"^",4)
+15 SET CT=CT+1
SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,CT,0)=ID_U_$GET(CDEN(I))_U_$GET(CNUM(I))_U_$GET(CEXC(I))
+16 SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,"B",ID,CT)=""
+17 SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,0)="^90505.451^"_CT_"^"_CT
+18 ;
+19 ; Set up by providers divisions
+20 NEW NODE,BQTMN
+21 SET DV=0
SET NODE=80
+22 FOR
SET DV=$ORDER(^VA(200,BGPPROV,2,DV))
IF 'DV
QUIT
Begin DoDot:3
+23 IF $GET(^BQIFAC(DV,0))=""
SET ^BQIFAC(DV,0)=DV
SET ^BQIFAC("B",DV,DV)=""
+24 SET FAC=DV
DO UPD(80)
+25 SET DN=$ORDER(^BQIFAC(DV,NODE,BQTMN,1,"B",ID,""))
IF DN=""
SET DN=CT
+26 IF $GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0))=""
SET ^BQIFAC(DV,NODE,BQTMN,1,DN,0)=ID
SET ^BQIFAC(DV,NODE,BQTMN,1,"B",ID,DN)=""
+27 SET $PIECE(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,2)=$PIECE($GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,2)+$GET(CDEN(I))
+28 SET $PIECE(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,3)=$PIECE($GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,3)+$GET(CNUM(I))
+29 SET $PIECE(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,4)=$PIECE($GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,4)+$GET(CEXC(I))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+30 ;
+31 IF NODE=40
Begin DoDot:1
+32 NEW PGLOB
+33 SET PGLOB=$$CURPGL^BQIMUTAB()
+34 SET ID=""
SET CT=0
+35 FOR
SET ID=$ORDER(@GLOBAL@(BGPPROV,ID))
IF ID=""
QUIT
Begin DoDot:2
+36 SET IIEN=$ORDER(@PGLOB@("B",ID,""))
IF IIEN=""
QUIT
+37 IF $PIECE(@PGLOB@(IIEN,0),"^",6)'="R"
QUIT
+38 SET CDEN=$PIECE($GET(@GLOBAL@(BGPPROV,ID,"CURR")),"^",1)
SET CNUM=$PIECE($GET(@GLOBAL@(BGPPROV,ID,"CURR")),"^",2)
+39 SET CEXC=$PIECE($GET(@GLOBAL@(BGPPROV,ID,"CURR")),"^",3)
+40 SET CT=CT+1
SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,CT,0)=ID_U_CDEN_U_CNUM_U_$$CURREP^BQIMUTAB()
+41 IF CEXC'=""
SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,CT,1)=CEXC
+42 SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,"B",ID,CT)=""
+43 SET ^BQIPROV(BGPPROV,NODE,BQTMN,1,0)="^90505.441^"_CT_"^"_CT
+44 ;
+45 ; set up by providers divisions
+46 NEW DV,DN,NODE,BQTMN
+47 SET DV=0
SET NODE=70
+48 FOR
SET DV=$ORDER(^VA(200,BGPPROV,2,DV))
IF 'DV
QUIT
Begin DoDot:3
+49 IF $GET(^BQIFAC(DV,0))=""
SET ^BQIFAC(DV,0)=DV
SET ^BQIFAC("B",DV,DV)=""
+50 SET FAC=DV
DO UPD(70)
+51 SET DN=$ORDER(^BQIFAC(DV,NODE,BQTMN,1,"B",ID,""))
IF DN=""
SET DN=CT
+52 IF $GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0))=""
SET ^BQIFAC(DV,NODE,BQTMN,1,DN,0)=ID
SET ^BQIFAC(DV,NODE,BQTMN,1,"B",ID,DN)=""
+53 SET $PIECE(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,2)=$PIECE($GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,2)+CDEN
+54 SET $PIECE(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,3)=$PIECE($GET(^BQIFAC(DV,NODE,BQTMN,1,DN,0)),U,3)+CNUM
+55 SET $PIECE(^BQIFAC(DV,NODE,BQTMN,1,DN,0),U,4)=$$CURREP^BQIMUTAB()
+56 IF CEXC'=""
SET ^BQIFAC(DV,NODE,BQTMN,1,DN,1)=CEXC
End DoDot:3
End DoDot:2
+57 NEW DIK,DA
+58 SET DIK="^BQIPROV("
SET DA=BGPPROV
DO IX^DIK
End DoDot:1
QUIT
+59 QUIT
+60 ;
IND(TY) ; EP - Set indicators
+1 ; Input
+2 ; TY = Type (H=Hospital)
+3 KILL BGPIND
+4 IF TY'="H"
Begin DoDot:1
+5 SET X=0
FOR
SET X=$ORDER(^BGPMUIND(90595.11,X))
IF 'X
QUIT
IF $PIECE(^BGPMUIND(90595.11,X,0),U,4)'="H"
SET BGPIND(X)=""
End DoDot:1
+6 IF TY="H"
Begin DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^BGPMUIND(90595.11,X))
IF 'X
QUIT
IF $PIECE(^BGPMUIND(90595.11,X,0),U,4)="H"
SET BGPIND(X)=""
End DoDot:1
+8 QUIT
+9 ;
UPD(NODE) ;EP
+1 NEW BEGDT,ENDT,TMFRAME,XX,V,I,ERROR,BQIUPD,BQDATE
+2 ;
+3 IF NODE=50
Begin DoDot:1
+4 SET BEGDT=$PIECE($GET(^BQI(90508,1,12)),U,8)
SET ENDT=$PIECE($GET(^BQI(90508,1,12)),U,9)
+5 SET BQDATE=$EXTRACT(BEGDT,1,5)_"00"
+6 IF $GET(^BQIPROV(BGPPROV,50,0))=""
SET ^BQIPROV(BGPPROV,50,0)="^90505.45D^^"
End DoDot:1
+7 IF NODE=40
Begin DoDot:1
+8 SET BEGDT=$PIECE($GET(^BQI(90508,1,9)),U,1)
SET ENDT=$PIECE($GET(^BQI(90508,1,9)),U,2)
+9 SET BQDATE=$EXTRACT(BEGDT,1,5)_"00"
+10 IF $GET(^BQIPROV(BGPPROV,40,0))=""
SET ^BQIPROV(BGPPROV,40,0)="^90505.44D^^"
End DoDot:1
+11 IF NODE=70
Begin DoDot:1
+12 SET BEGDT=$PIECE($GET(^BQI(90508,1,9)),U,1)
SET ENDT=$PIECE($GET(^BQI(90508,1,9)),U,2)
+13 SET BQDATE=$EXTRACT(BEGDT,1,5)_"00"
+14 IF $GET(^BQIFAC(FAC,70,0))=""
SET ^BQIFAC(FAC,70,0)="^90505.67D^^"
End DoDot:1
+15 IF NODE=80
Begin DoDot:1
+16 SET BEGDT=$PIECE($GET(^BQI(90508,1,12)),U,8)
SET ENDT=$PIECE($GET(^BQI(90508,1,12)),U,9)
+17 SET BQDATE=$EXTRACT(BEGDT,1,5)_"00"
+18 IF $GET(^BQIFAC(FAC,80,0))=""
SET ^BQIFAC(FAC,80,0)="^90505.68D^^"
End DoDot:1
+19 ;
+20 NEW DA,X,IENS,Y,DIC,DLAYGO
+21 IF NODE=50
SET DA(1)=BGPPROV
SET DIC="^BQIPROV("_DA(1)_",50,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.45
SET DIC("P")=DLAYGO
+22 IF NODE=40
SET DA(1)=BGPPROV
SET DIC="^BQIPROV("_DA(1)_",40,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.44
SET DIC("P")=DLAYGO
+23 IF NODE=70
SET DA(1)=FAC
SET DIC="^BQIFAC("_DA(1)_",70,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.67
SET DIC("P")=DLAYGO
+24 IF NODE=80
SET DA(1)=FAC
SET DIC="^BQIFAC("_DA(1)_",80,"
SET X=BQDATE
SET DIC(0)="LNZ"
SET DLAYGO=90505.68
SET DIC("P")=DLAYGO
+25 DO ^DIC
+26 SET DA=+Y
IF DA=-1
QUIT
+27 SET BQTMN=DA
+28 QUIT
+29 ;
PMON(BGPPROV) ;EP - Monthly Performance Process
+1 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQI1POJB D UNWIND^%ZTER"
+2 ;
+3 ; Set the DATE/TIME MU STARTED field
+4 NEW DA
+5 SET DA=$ORDER(^BQI(90508,0))
IF 'DA
QUIT
+6 SET BQIUPD(90508,DA_",",8.04)=$$NOW^XLFDT()
+7 SET BQIUPD(90508,DA_",",8.06)=1
+8 SET BQIUPD(90508,DA_",",24.1)=$GET(ZTSK)
+9 DO FILE^DIE("","BQIUPD","ERROR")
+10 KILL BQIUPD
+11 ;
+12 ; one month period
+13 NEW APCMED,APCMBD,APCMRPT,APCMPBD,APCMPED,APCMTIME,APCMRPTT,BQIPROV,APCMATTE,APCMIND
+14 NEW APCM100R,APCM13ON,APCM2ON,APCMECHI,APCMIMME,APCMN565,APCMOFFV,APCMRCIS,APCMTRAE
+15 NEW APCM4D,APCMAGEB,APCMAGEE,APCMBDAT,APCMBT,APCMEDAT,APCMEP,APCMET,APCMFILN,APCMGBL
+16 NEW APCMH,APCMHV,APCMIC,APCMJ,APCMP,APCMSEX,APCMVALU,APCMWPP,APCMX,BEGDT,BQIGREF,BQTDT
+17 NEW BQTMN,CDEN,CEXC,CNUM,CT,DFN,ENDT,F,FAC,GLOBAL,ID,IIEN,LABSNO,SD,PGLOB,PROU
+18 ;
+19 SET PGLOB=$$CURPGL^BQIMUTAB()
+20 SET PROU=$$CURPRT^BQIMUTAB()
+21 SET BEGDT=$PIECE($GET(^BQI(90508,1,9)),U,1)
SET ENDT=$PIECE($GET(^BQI(90508,1,9)),U,2)
+22 SET BQTDT=$EXTRACT(BEGDT,1,5)_"00"
+23 SET APCMED=ENDT
SET APCMBD=BEGDT
SET APCMRPT=1
SET APCMDEMO="E"
+24 SET APCMPED=$$FMADD^XLFDT(APCMED,-30)
SET APCMPBD=$$FMADD^XLFDT(APCMBD,-60)
+25 SET APCMTIME=1
SET APCMRPTT=1
+26 SET GLOBAL=$NAME(^TMP("BQIMUP1",$JOB))
+27 ;F X="S1.010.EP","S1.013.EP","S1.014.EP","S1.015.EP","S1.018.EP","S1.020.EP","S1.024.EP","S1.025.EP" D
+28 ;. S BQIPROV(BGPPROV)=""
+29 ;. S APCMATTE(X,BGPPROV)=""
+30 ;gather up measures for this report
+31 SET X=0
FOR
SET X=$ORDER(@PGLOB@(X))
IF X'=+X
QUIT
IF $PIECE(@PGLOB@(X,0),U,2)="E"
Begin DoDot:1
+32 SET ID=$PIECE(@PGLOB@(X,0),U,1)
+33 IF $PIECE(@PGLOB@(X,0),U,6)'="R"
QUIT
+34 SET @GLOBAL@(BGPPROV,ID,"CURR")=""
SET @GLOBAL@(BGPPROV,ID,"PREV")=""
SET APCMATTE(ID,BGPPROV)=""
+35 SET BQIPROV(BGPPROV)=""
SET APCMIND(X)=""
End DoDot:1
+36 ;
+37 ; Check if connection to server is working
+38 SET CONN=1
+39 IF PGLOB="^APCM24OB"
DO PHRC
IF 'CONN
Begin DoDot:1
+40 NEW MN
+41 SET MN=$ORDER(@PGLOB@("B","S2.026.EP",""))
+42 IF MN'=""
KILL APCMIND(MN)
End DoDot:1
+43 ;
+44 IF $GET(DUZ(2))=""
Begin DoDot:1
+45 DO DZ^BQITASK1
MERGE DUZ=^XTMP("BQIRMDR","DUZ")
End DoDot:1
+46 ;
+47 SET APCMWPP=1
+48 ;I $T(BQI^APCM11E1)'="" D BQI^APCM11E1(.GLOBAL,.BQIPROV)
+49 DO @("BQI^"_PROU_"(.GLOBAL,.BQIPROV)")
+50 ;
+51 SET BQIGREF=GLOBAL
+52 DO STORP(40)
+53 KILL @GLOBAL
+54 QUIT
+55 ;
PHRC ;EP - Check if PHR is installed, if performance report is 2014
+1 IF $TEXT(PHR^BPHRMUPM)=""
QUIT
+2 NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIMUPRS D UNWIND^%ZTER"
+3 ;
+4 NEW BPHRP,EXEC,RESULT,BPHRR,BDT,EDT
+5 SET BDT=DT
SET EDT=DT
+6 KILL BPARRAY
+7 DO GETS^DIQ(90670.2,"1,","**","E","BPARRAY")
+8 SET BPHRP("URLROOT")=$GET(BPARRAY(90670.2,"1,",.02,"E"))
+9 SET BPHRP("SERVICEPATH")=$GET(BPARRAY(90670.2,"1,",.11,"E"))
+10 SET BPHRP("PORT")=$GET(BPARRAY(90670.2,"1,",.03,"E"))
+11 SET BPHRP("TIMEOUT")=$GET(BPARRAY(90670.2,"1,",.05,"E"))
+12 SET BPHRP("USER")=$GET(BPARRAY(90670.2,"1,",.07,"E"))
+13 SET BPHRP("PASS")=$GET(BPARRAY(90670.2,"1,",.08,"E"))
+14 ; Pass Patient ICN and BDT and EDT to web service call
+15 SET BPHRP("EUID")=$GET(BPHREUID)
+16 ; Change BDT and EDT to appropriate dates from FileMan date
+17 SET BPHRP("FROM")=$$DATE^BPHRMUPM(BDT)_"T00:00:00"_$$TMZ^BPHRMUPM()
+18 SET BPHRP("TO")=$$DATE^BPHRMUPM(EDT)_"T23:59:59"_$$TMZ^BPHRMUPM()
+19 ;
+20 ; Returns data
+21 SET EXEC="S STS=##class(BPHR.WebServiceCalls).PMQueryRequest(.BPHRP,.BPHRR)"
XECUTE EXEC
+22 IF $PIECE($GET(STS),U,1)=0
IF $PIECE(STS,U,2)["ERROR"
SET CONN=0
+23 QUIT
+24 ;
ERR ;EP - Error trap
+1 IF $ZE["<ZSOAP>"
SET CONN=0
+2 DO ^%ZTER
+3 QUIT
