Routine: BQIMUPRS

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

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

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)=""

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

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

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

ERR ;EP - Error trap

 I $ZE["<ZSOAP>" S CONN=0

 D ^%ZTER

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

BQIMUPRS.m