BQIIPOTC ;VNGT/HS/ALA-Outcome Bundle ; 18 Jul 2011 4:00 PM
;;2.4;ICARE MANAGEMENT SYSTEM;**3**;Apr 01, 2015;Build 5
;
EN(BQDATE) ;EP - Outcome Bundle Monthly
NEW BQMON,BQDTE,BEGDT,EDAY,ENDT,PYR,CYR,ID,FAC,DFN,QFL,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)'="" 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)="" 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"
;
; 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
;
K ^XTMP("BQI OUTMON")
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. I $P(^VA(200,PRV,0),U,13)'="" Q
. S DFN=""
. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.. I '$$HRN^BQIUL1(DFN) Q
.. S NA=0,NO=0,YES=0,NDA=0,CNT=3,DEC=0,TOTP=0
.. ;S TOTP=TOTP+1
.. ;F CODE="IPC_DMCTRL","IPC_LDCTRL","IPC_BPCTRL" D
.. F CODE="IPC_DMCTRL","IPC_BPCTRL" D
... S VAL=$$PAT(CRN,DFN,CODE)
... I VAL="{D}" S DEC=1 Q
... I VAL="N/A" S NA=NA+1 Q
... I VAL="NO" S NO=NO+1 Q
... I VAL="YES" S YES=YES+1 Q
... S NDA=NDA+1 Q
.. I DEC Q
.. I NA=CNT Q
.. I NDA=CNT S ^XTMP("BQI OUTMON","PRV",PRV,"NO")=$G(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+1 Q
.. I YES=CNT S ^XTMP("BQI OUTMON","PRV",PRV,"YES")=$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))+1 Q
.. I 'NO S ^XTMP("BQI OUTMON","PRV",PRV,"YES")=$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))+1 Q
.. S ^XTMP("BQI OUTMON","PRV",PRV,"NO")=$G(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+1 Q
;
S CODE="IPC_OUTC"
S FAC=$$HME^BQIGPUTL()
; Set NOs and YESs to get denominator value and store
S PRV="",TDEN=0,TNUM=0
F S PRV=$O(^XTMP("BQI OUTMON","PRV",PRV)) Q:PRV="" D
. S TP=$G(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))
. S PCT=+$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))
. D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
. S TDEN=TDEN+TP,TNUM=TNUM+PCT
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
K ^XTMP("BQI OUTMON")
Q
;
OPAT(CRN,DFN) ;EP - Outcome Bundle by Patient
NEW MSN,CODE,BQDATE
K ^XTMP("BQI OUTCOME",$J)
;F CODE="IPC_DMCTRL","IPC_LDCTRL","IPC_BPCTRL" D
F CODE="IPC_DMCTRL","IPC_BPCTRL" D
. S MSN=$O(^BQI(90508,1,22,CRN,1,"B",CODE,""))
. S BQDATE=""
. ; Find and Store the results of each "sub-bundle"
. S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
. X EXEC
;
S MSN="",NA=0,NO=0,YES=0,NDA=0,CNT=3,DEC=0
F S MSN=$O(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)) Q:MSN="" D
. I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="{D}" S DEC=DEC+1 Q
. I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="N/A" S NA=NA+1 Q
. I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="NO" S NO=NO+1 Q
. I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="YES" S YES=YES+1 Q
. I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="NDA" S NO=NO+1 Q
I DEC Q "{D}"
I NDA Q "NO"
I NA=CNT Q "N/A"
I YES=CNT Q "YES"
I 'NO Q "YES"
Q "NO"
;
DM(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the DM bundle for monthly update
; Input
; CRN - Current IPC IEN
; MSN - Bundle IEN
; CODE - Code name
; BQI(90508,1,22,CRN,1,BNIEN,1
;
NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
S TDEN=0,TNUM=0,CNT=0
D BUN(CRN,MSN,.XX)
;
I $G(DFN)'="" D Q
. S PRV=$P(^AUPNPAT(DFN,0),U,14)
. D DMP(DFN,MSN,PRV) Q
;
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. I $P(^VA(200,PRV,0),U,13)'="" Q
. S DFN=""
. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.. I '$$HRN^BQIUL1(DFN) Q
.. D DMP(DFN,MSN,PRV)
. S TP=$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"NO"))+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"NDA"))+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
. S PCT=+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
. D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
. S TDEN=TDEN+TP,TNUM=TNUM+PCT
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
;
Q
;
DMP(DFN,MSN,BPROV) ;EP
I $$DEC(DFN,MSN,$G(BPROV)) Q
S CD=""
F S CD=$O(XX(CD)) Q:CD="" D
. S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" D NDA(DFN,MSN,BPROV) Q
. I $$PTV(DFN,CD)="N/A" D NA(DFN,MSN,BPROV) Q
. I $$PTV(DFN,CD)="NO" D NO(DFN,MSN,BPROV) Q
. I $$PTV(DFN,CD)="YES" D YES(DFN,MSN,BPROV)
Q
;
LD(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the LDL bundle for monthly update
; Input
; CRN - Current IPC IEN
; MSN - Bundle IEN
; CODE - Code name
; BQI(90508,1,22,CRN,1,BNIEN,1
;
NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
K ^XTMP("BQI OUTCOME",$J,"PRV")
S TDEN=0,TNUM=0,CNT=0
;
I $G(DFN)'="" D Q
. S PRV=$P(^AUPNPAT(DFN,0),U,14)
. D LDP(DFN,MSN,PRV)
;
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. I $P(^VA(200,PRV,0),U,13)'="" Q
. S DFN=""
. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.. I '$$HRN^BQIUL1(DFN) Q
.. D LDP(DFN,MSN,PRV)
. S TP=$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"NO"))+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"NDA"))+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
. S PCT=+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
. D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
. S TDEN=TDEN+TP,TNUM=TNUM+PCT
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
;
Q
;
LDP(DFN,MSN,BPROV) ;EP
I $$DEC(DFN,MSN,$G(BPROV)) Q
I $O(^BQIPAT(DFN,30,0))="" D NDA(DFN,MSN,$G(BPROV)) Q
;
NEW BQIH,BQIYR
S BQIH=$$SPM^BQIGPUTL(),BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
;
I $$PTV(DFN,BQIYR_"_99")="YES" D Q
. D YES(DFN,MSN,$G(BPROV))
I $$PTV(DFN,BQIYR_"_810")="YES"!($$PTV(DFN,BQIYR_"_810")="NO") D Q
. NEW BCODE,IEN,BGPVALUE
. S BCODE=BQIYR_"_810",IEN=$O(^BQIPAT(DFN,30,"B",BCODE,"")) I IEN="" Q
. S BGPVALUE=$P(^BQIPAT(DFN,30,IEN,0),"^",2)
. I $P(BGPVALUE,"|",1)'["CHD" D NA(DFN,MSN,$G(BPROV)) Q
. D YES(DFN,MSN,$G(BPROV)) Q
;
;Check ICD
NEW BQICD
S BQICD=$$DXC()
S RESULT=$$DX^BQIIPDXC("T-12M",DFN,BQCODE)
I RESULT D YES(DFN,MSN,$G(BPROV)) Q
I $$PTV(DFN,BQIYR_"_99")="N/A",$$PTV(DFN,BQIYR_"_810")="N/A" D NA(DFN,MSN,$G(BPROV)) Q
D NO(DFN,MSN,$G(BPROV))
Q
;
DXC() ;EP
I $$VERSION^XPDUTL("AICD")<4.0 S BQCODE="V77.91"
I $$VERSION^XPDUTL("AICD")>3.51 D
. I DT<$$IMP^ICDEXA(30) S BQCODE="V77.91" Q
. S BQCODE="Z13.220"
Q BQCODE
;
BP(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the BP bundle
; Input
; CRN - Current IPC IEN
; MSN - Bundle IEN
; CODE - Code name
; BQI(90508,1,22,CRN,1,BNIEN,1
;
NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
K ^XTMP("BQI OUTCOME",$J,"PRV")
S TDEN=0,TNUM=0,CNT=0
D BUN(CRN,MSN,.XX)
;
I $G(DFN)'="" D Q
. S PRV=$P(^AUPNPAT(DFN,0),U,14)
. D BPP(DFN,MSN,PRV)
;
S PRV=""
F S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV="" D
. I $P(^VA(200,PRV,0),U,13)'="" Q
. S DFN=""
. F S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN="" D
.. I '$$HRN^BQIUL1(DFN) Q
.. D BPP(DFN,MSN,PRV)
. S TP=$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"NO"))+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"NDA"))+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
. S PCT=+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
. D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
. S TDEN=TDEN+TP,TNUM=TNUM+PCT
S FAC=$$HME^BQIGPUTL()
D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
Q
;
BPP(DFN,MSN,BPROV) ;EP
I $$DEC(DFN,MSN,$G(BPROV)) Q
;
NEW BQIH,BQIYR,BQIRES
S BQIH=$$SPM^BQIGPUTL(),BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
;
S TAG=$$ATAG^BQITDUTL(DFN,"Hypertension")
; DM: BP <140/90 = BQIYR_2636
S CD=BQIYR_"_2636",QFL=0 D Q:QFL
. I $$PTV(DFN,CD)="NDA" D NDA(DFN,MSN,BPROV) S QFL=1 Q
. I $$PTV(DFN,CD)="YES" D YES(DFN,MSN,BPROV) S QFL=1 Q
. I $$PTV(DFN,CD)="NO" D NO(DFN,MSN,BPROV) S QFL=1 Q
. ; If it is not applicable, check other BPs
. ;I $$PTV(DFN,CD)="N/A" D Q:QFL
. ; If CRS 15
. I $$VERSION^XPDUTL("BGP")>14.9 D Q
.. S BQIRES=$$PAT^BQIIPCBP(DFN)
.. I BQIRES="YES" D YES(DFN,MSN,$G(BPROV)) S QFL=1 Q
.. I BQIRES="NO" D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
.. I BQIRES="N/A" D NA(DFN,MSN,$G(BPROV)) S QFL=1 Q
.. D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
. D Q:QFL
.. ; CHD: Pre-HTN I BP = BQIYR_909 CHD: Normal BP = BQIYR_908 CHD: Pre-HTN II BP
.. I $$PTV(DFN,BQIYR_"_909")="YES"!($$PTV(DFN,BQIYR_"_908")="YES")!($$PTV(DFN,BQIYR_"_910")="YES") D YES(DFN,MSN,$G(BPROV)) S QFL=1 Q
.. I $$PTV(DFN,BQIYR_"_909")="NO"!($$PTV(DFN,BQIYR_"_908")="NO")!($$PTV(DFN,BQIYR_"_910")="NO") D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
.. I $$PTV(DFN,BQIYR_"_909")="N/A"!($$PTV(DFN,BQIYR_"_908")="N/A")!($$PTV(DFN,BQIYR_"_910")="N/A") D
... ; If tag is no
... I 'TAG,$$PTV(DFN,BQIYR_"_907")="N/A" D NA(DFN,MSN,$G(BPROV)) S QFL=1 Q
... I TAG
... ; 20+: Normal BP = BQIYR_872 20+: Pre-HTN I BP = BQIYR_873 20+: Pre-HTN II BP = BQIYR_874
... I $$PTV(DFN,BQIYR_"_872")="YES"!($$PTV(DFN,BQIYR_"_873")="YES")!($$PTV(DFN,BQIYR_"_874")="YES") D YES(DFN,MSN,$G(BPROV)) S QFL=1 Q
... D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
Q
;
BUN(CRN,MSN,XX) ;EP - Get values for bundle
NEW BN,BCODE
S BN=0
F S BN=$O(^BQI(90508,1,22,CRN,1,MSN,2,BN)) Q:'BN D
. S BCODE=$P(^BQI(90508,1,22,CRN,1,MSN,2,BN,0),U,1),GP=$P(^BQI(90508,1,22,CRN,1,MSN,2,BN,0),U,2)
. I GP="" S XX(BCODE)="" Q
. I GP'="" S XX(GP,BCODE)=""
Q
;
PAT(CRN,DFN,CODE) ;EP - See if patient meets bundle criteria
; Input
; CODE="IPC_DMCTRL" or "IPC_LDCTRL" or "IPC_BPCTRL"
NEW MSN,BQDATE
K ^XTMP("BQI OUTCOME",$J)
S MSN=$O(^BQI(90508,1,22,CRN,1,"B",CODE,""))
S BQDATE=""
; Find and Store the results of each "sub-bundle"
S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
X EXEC
;
I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="{D}" Q "{D}"
I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="N/A" Q "N/A"
I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="NO" Q "NO"
I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="YES" Q "YES"
I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="LDL Result Not Entered" Q "LDL Result Not Entered"
Q "NDA"
;
PROC ;EP - Process data
S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" D NDA(DFN,MSN) Q
S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3)
S DEN=$P(^BQIPAT(DFN,30,IEN,0),U,4)
I NUM="",DEN="" D NA(DFN,MSN) Q
I DEN'="",NUM="" D NO(DFN,MSN) Q
I DEN'="",NUM'="" D YES(DFN,MSN) Q
Q
;
CMPR ;EP - Combo process
NEW CD,TCT,IEN,BQTMP,BCT,DEN,NUM,NA,NO,YES
S CD="",TCT=0 K BQTMP
F S CD=$O(XX(NN,CD)) Q:CD="" D
. S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" D Q
.. S BQTMP("PT",DFN,CD)="NDA",TCT=TCT+1
S BCT=0
F S CD=$O(BQTMP("PT",DFN,CD)) Q:CD="" I BQTMP("PT",DFN,CD)="NDA" S BCT=BCT+1
I $D(BQTMP),BCT=TCT D NDA(DFN,MSN) Q
;
S CD="",TCT=0 K BQTMP
F S CD=$O(XX(NN,CD)) Q:CD="" D
. S IEN=$O(^BQIPAT(DFN,30,"B",CD,""))
. S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3)
. S DEN=$P(^BQIPAT(DFN,30,IEN,0),U,4)
. S TCT=TCT+1
. I DEN="",NUM="" S BQTMP("PT",DFN,CD)="N/A"
. I DEN'="",NUM="" S BQTMP("PT",DFN,CD)="NO"
. I DEN'="",NUM'="" S BQTMP("PT",DFN,CD)="YES"
S NA=0,NO=0,YES=0
F S CD=$O(BQTMP("PT",DFN,CD)) Q:CD="" D
. I BQTMP("PT",DFN,CD)="N/A" S NA=NA+1
. I BQTMP("PT",DFN,CD)="NO" S NO=NO+1
. I BQTMP("PT",DFN,CD)="YES" S YES=YES+1
I NA=TCT D NA(DFN,MSN)
I NA+NO=TCT D NO(DFN,MSN)
I NA+YES=TCT D YES(DFN,MSN)
;
K BQTMP
;
Q
;
PTV(BQDFN,BCODE) ;EP
NEW IEN
I $O(^BQIPAT(BQDFN,30,0))="" Q "NDA"
S IEN=$O(^BQIPAT(BQDFN,30,"B",BCODE,"")) I IEN="" Q "N/A"
S NUM=$P(^BQIPAT(BQDFN,30,IEN,0),U,3)
S DEN=$P(^BQIPAT(BQDFN,30,IEN,0),U,4)
I DEN="",NUM="" Q "N/A"
I DEN'="",NUM="" Q "NO"
I DEN'="",NUM'="" Q "YES"
Q ""
;
YES(DFN,MSN,PROV) ;EP
I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="YES"
I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"YES")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"YES"))+1
Q
;
NO(DFN,MSN,PROV) ;EP
I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="NO"
I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NO")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NO"))+1
Q
;
NA(DFN,MSN,PROV) ;EP
S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="N/A"
I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"N/A")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"N/A"))+1
Q
;
NDA(DFN,MSN,PROV) ;EP
I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="NDA"
I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NDA")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NDA"))+1
Q
;
DEC(DFN,MSN,PROV) ;EP - Deceased check
NEW BQIDOD,FLAG
S BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I"),FLAG=0
I BQIDOD'="" D
. I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="{D}"
. S FLAG=1
. I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"DEC")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"DEC"))+1
Q FLAG
;
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
BQIIPOTC ;VNGT/HS/ALA-Outcome Bundle ; 18 Jul 2011 4:00 PM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;**3**;Apr 01, 2015;Build 5
+2 ;
EN(BQDATE) ;EP - Outcome Bundle Monthly
+1 NEW BQMON,BQDTE,BEGDT,EDAY,ENDT,PYR,CYR,ID,FAC,DFN,QFL,CRST
+2 SET QFL=0
+3 SET CRST=$PIECE($GET(^BQI(90508,1,11)),U,2)
IF CRST=""
SET CRST=1
+4 SET CRST="0"_CRST
+5 ;
+6 IF $GET(BQDATE)'=""
Begin DoDot:1
+7 SET BEGDT=$EXTRACT(BQDATE,1,5)_"01"
SET CYR=$EXTRACT(BQDATE,1,3)
SET BQMON=$EXTRACT(BQDATE,4,5)
+8 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+9 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+10 SET ENDT=$EXTRACT(BQDATE,1,5)_$PIECE(EDAY,U,+BQMON)
End DoDot:1
+11 ;
+12 IF $GET(BQDATE)=""
Begin DoDot:1
+13 IF $EXTRACT(DT,6,7)'=CRST
SET QFL=1
QUIT
+14 SET BQMON=$EXTRACT(DT,4,5)-1
SET CYR=$EXTRACT(DT,1,3)
SET PYR=CYR-1
+15 SET BQDTE=$PIECE($TEXT(BQM+BQMON),";;",2)
+16 IF $LENGTH(BQMON)=1
SET BQMON="0"_BQMON
+17 SET BEGDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_"01"
+18 SET EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+19 SET ENDT=@($PIECE(BQDTE,U,2))_$PIECE(BQDTE,U,1)_$PIECE(EDAY,U,+$PIECE(BQDTE,U,1))
+20 SET BQDATE=$SELECT(BQMON="01":PYR,1:CYR)_BQMON_"00"
End DoDot:1
IF QFL
QUIT
+21 ;
+22 ; Get current IPC
+23 SET CRIPC=$PIECE($GET(^BQI(90508,1,11)),U,1)
+24 SET CRN=$ORDER(^BQI(90508,1,22,"B",CRIPC,""))
IF CRN=""
QUIT
+25 ;
+26 KILL ^XTMP("BQI OUTMON")
+27 SET PRV=""
+28 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+29 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+30 SET DFN=""
+31 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+32 IF '$$HRN^BQIUL1(DFN)
QUIT
+33 SET NA=0
SET NO=0
SET YES=0
SET NDA=0
SET CNT=3
SET DEC=0
SET TOTP=0
+34 ;S TOTP=TOTP+1
+35 ;F CODE="IPC_DMCTRL","IPC_LDCTRL","IPC_BPCTRL" D
+36 FOR CODE="IPC_DMCTRL","IPC_BPCTRL"
Begin DoDot:3
+37 SET VAL=$$PAT(CRN,DFN,CODE)
+38 IF VAL="{D}"
SET DEC=1
QUIT
+39 IF VAL="N/A"
SET NA=NA+1
QUIT
+40 IF VAL="NO"
SET NO=NO+1
QUIT
+41 IF VAL="YES"
SET YES=YES+1
QUIT
+42 SET NDA=NDA+1
QUIT
End DoDot:3
+43 IF DEC
QUIT
+44 IF NA=CNT
QUIT
+45 IF NDA=CNT
SET ^XTMP("BQI OUTMON","PRV",PRV,"NO")=$GET(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+1
QUIT
+46 IF YES=CNT
SET ^XTMP("BQI OUTMON","PRV",PRV,"YES")=$GET(^XTMP("BQI OUTMON","PRV",PRV,"YES"))+1
QUIT
+47 IF 'NO
SET ^XTMP("BQI OUTMON","PRV",PRV,"YES")=$GET(^XTMP("BQI OUTMON","PRV",PRV,"YES"))+1
QUIT
+48 SET ^XTMP("BQI OUTMON","PRV",PRV,"NO")=$GET(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+1
QUIT
End DoDot:2
End DoDot:1
+49 ;
+50 SET CODE="IPC_OUTC"
+51 SET FAC=$$HME^BQIGPUTL()
+52 ; Set NOs and YESs to get denominator value and store
+53 SET PRV=""
SET TDEN=0
SET TNUM=0
+54 FOR
SET PRV=$ORDER(^XTMP("BQI OUTMON","PRV",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+55 SET TP=$GET(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+$GET(^XTMP("BQI OUTMON","PRV",PRV,"YES"))
+56 SET PCT=+$GET(^XTMP("BQI OUTMON","PRV",PRV,"YES"))
+57 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
+58 SET TDEN=TDEN+TP
SET TNUM=TNUM+PCT
End DoDot:1
+59 SET FAC=$$HME^BQIGPUTL()
+60 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+61 KILL ^XTMP("BQI OUTMON")
+62 QUIT
+63 ;
OPAT(CRN,DFN) ;EP - Outcome Bundle by Patient
+1 NEW MSN,CODE,BQDATE
+2 KILL ^XTMP("BQI OUTCOME",$JOB)
+3 ;F CODE="IPC_DMCTRL","IPC_LDCTRL","IPC_BPCTRL" D
+4 FOR CODE="IPC_DMCTRL","IPC_BPCTRL"
Begin DoDot:1
+5 SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,"B",CODE,""))
+6 SET BQDATE=""
+7 ; Find and Store the results of each "sub-bundle"
+8 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+9 XECUTE EXEC
End DoDot:1
+10 ;
+11 SET MSN=""
SET NA=0
SET NO=0
SET YES=0
SET NDA=0
SET CNT=3
SET DEC=0
+12 FOR
SET MSN=$ORDER(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))
IF MSN=""
QUIT
Begin DoDot:1
+13 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="{D}"
SET DEC=DEC+1
QUIT
+14 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="N/A"
SET NA=NA+1
QUIT
+15 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="NO"
SET NO=NO+1
QUIT
+16 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="YES"
SET YES=YES+1
QUIT
+17 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="NDA"
SET NO=NO+1
QUIT
End DoDot:1
+18 IF DEC
QUIT "{D}"
+19 IF NDA
QUIT "NO"
+20 IF NA=CNT
QUIT "N/A"
+21 IF YES=CNT
QUIT "YES"
+22 IF 'NO
QUIT "YES"
+23 QUIT "NO"
+24 ;
DM(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the DM bundle for monthly update
+1 ; Input
+2 ; CRN - Current IPC IEN
+3 ; MSN - Bundle IEN
+4 ; CODE - Code name
+5 ; BQI(90508,1,22,CRN,1,BNIEN,1
+6 ;
+7 NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
+8 SET TDEN=0
SET TNUM=0
SET CNT=0
+9 DO BUN(CRN,MSN,.XX)
+10 ;
+11 IF $GET(DFN)'=""
Begin DoDot:1
+12 SET PRV=$PIECE(^AUPNPAT(DFN,0),U,14)
+13 DO DMP(DFN,MSN,PRV)
QUIT
End DoDot:1
QUIT
+14 ;
+15 SET PRV=""
+16 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+17 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+18 SET DFN=""
+19 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+20 IF '$$HRN^BQIUL1(DFN)
QUIT
+21 DO DMP(DFN,MSN,PRV)
End DoDot:2
+22 SET TP=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"NO"))+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"NDA"))+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"YES"))
+23 SET PCT=+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"YES"))
+24 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
+25 SET TDEN=TDEN+TP
SET TNUM=TNUM+PCT
End DoDot:1
+26 SET FAC=$$HME^BQIGPUTL()
+27 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+28 ;
+29 QUIT
+30 ;
DMP(DFN,MSN,BPROV) ;EP
+1 IF $$DEC(DFN,MSN,$GET(BPROV))
QUIT
+2 SET CD=""
+3 FOR
SET CD=$ORDER(XX(CD))
IF CD=""
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CD,""))
IF IEN=""
DO NDA(DFN,MSN,BPROV)
QUIT
+5 IF $$PTV(DFN,CD)="N/A"
DO NA(DFN,MSN,BPROV)
QUIT
+6 IF $$PTV(DFN,CD)="NO"
DO NO(DFN,MSN,BPROV)
QUIT
+7 IF $$PTV(DFN,CD)="YES"
DO YES(DFN,MSN,BPROV)
End DoDot:1
+8 QUIT
+9 ;
LD(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the LDL bundle for monthly update
+1 ; Input
+2 ; CRN - Current IPC IEN
+3 ; MSN - Bundle IEN
+4 ; CODE - Code name
+5 ; BQI(90508,1,22,CRN,1,BNIEN,1
+6 ;
+7 NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
+8 KILL ^XTMP("BQI OUTCOME",$JOB,"PRV")
+9 SET TDEN=0
SET TNUM=0
SET CNT=0
+10 ;
+11 IF $GET(DFN)'=""
Begin DoDot:1
+12 SET PRV=$PIECE(^AUPNPAT(DFN,0),U,14)
+13 DO LDP(DFN,MSN,PRV)
End DoDot:1
QUIT
+14 ;
+15 SET PRV=""
+16 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+17 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+18 SET DFN=""
+19 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+20 IF '$$HRN^BQIUL1(DFN)
QUIT
+21 DO LDP(DFN,MSN,PRV)
End DoDot:2
+22 SET TP=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"NO"))+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"NDA"))+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"YES"))
+23 SET PCT=+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"YES"))
+24 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
+25 SET TDEN=TDEN+TP
SET TNUM=TNUM+PCT
End DoDot:1
+26 SET FAC=$$HME^BQIGPUTL()
+27 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+28 ;
+29 QUIT
+30 ;
LDP(DFN,MSN,BPROV) ;EP
+1 IF $$DEC(DFN,MSN,$GET(BPROV))
QUIT
+2 IF $ORDER(^BQIPAT(DFN,30,0))=""
DO NDA(DFN,MSN,$GET(BPROV))
QUIT
+3 ;
+4 NEW BQIH,BQIYR
+5 SET BQIH=$$SPM^BQIGPUTL()
SET BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
+6 ;
+7 IF $$PTV(DFN,BQIYR_"_99")="YES"
Begin DoDot:1
+8 DO YES(DFN,MSN,$GET(BPROV))
End DoDot:1
QUIT
+9 IF $$PTV(DFN,BQIYR_"_810")="YES"!($$PTV(DFN,BQIYR_"_810")="NO")
Begin DoDot:1
+10 NEW BCODE,IEN,BGPVALUE
+11 SET BCODE=BQIYR_"_810"
SET IEN=$ORDER(^BQIPAT(DFN,30,"B",BCODE,""))
IF IEN=""
QUIT
+12 SET BGPVALUE=$PIECE(^BQIPAT(DFN,30,IEN,0),"^",2)
+13 IF $PIECE(BGPVALUE,"|",1)'["CHD"
DO NA(DFN,MSN,$GET(BPROV))
QUIT
+14 DO YES(DFN,MSN,$GET(BPROV))
QUIT
End DoDot:1
QUIT
+15 ;
+16 ;Check ICD
+17 NEW BQICD
+18 SET BQICD=$$DXC()
+19 SET RESULT=$$DX^BQIIPDXC("T-12M",DFN,BQCODE)
+20 IF RESULT
DO YES(DFN,MSN,$GET(BPROV))
QUIT
+21 IF $$PTV(DFN,BQIYR_"_99")="N/A"
IF $$PTV(DFN,BQIYR_"_810")="N/A"
DO NA(DFN,MSN,$GET(BPROV))
QUIT
+22 DO NO(DFN,MSN,$GET(BPROV))
+23 QUIT
+24 ;
DXC() ;EP
+1 IF $$VERSION^XPDUTL("AICD")<4.0
SET BQCODE="V77.91"
+2 IF $$VERSION^XPDUTL("AICD")>3.51
Begin DoDot:1
+3 IF DT<$$IMP^ICDEXA(30)
SET BQCODE="V77.91"
QUIT
+4 SET BQCODE="Z13.220"
End DoDot:1
+5 QUIT BQCODE
+6 ;
BP(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the BP bundle
+1 ; Input
+2 ; CRN - Current IPC IEN
+3 ; MSN - Bundle IEN
+4 ; CODE - Code name
+5 ; BQI(90508,1,22,CRN,1,BNIEN,1
+6 ;
+7 NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
+8 KILL ^XTMP("BQI OUTCOME",$JOB,"PRV")
+9 SET TDEN=0
SET TNUM=0
SET CNT=0
+10 DO BUN(CRN,MSN,.XX)
+11 ;
+12 IF $GET(DFN)'=""
Begin DoDot:1
+13 SET PRV=$PIECE(^AUPNPAT(DFN,0),U,14)
+14 DO BPP(DFN,MSN,PRV)
End DoDot:1
QUIT
+15 ;
+16 SET PRV=""
+17 FOR
SET PRV=$ORDER(^AUPNPAT("AK",PRV))
IF PRV=""
QUIT
Begin DoDot:1
+18 IF $PIECE(^VA(200,PRV,0),U,13)'=""
QUIT
+19 SET DFN=""
+20 FOR
SET DFN=$ORDER(^AUPNPAT("AK",PRV,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+21 IF '$$HRN^BQIUL1(DFN)
QUIT
+22 DO BPP(DFN,MSN,PRV)
End DoDot:2
+23 SET TP=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"NO"))+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"NDA"))+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"YES"))
+24 SET PCT=+$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PRV,"YES"))
+25 DO STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
+26 SET TDEN=TDEN+TP
SET TNUM=TNUM+PCT
End DoDot:1
+27 SET FAC=$$HME^BQIGPUTL()
+28 DO STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
+29 QUIT
+30 ;
BPP(DFN,MSN,BPROV) ;EP
+1 IF $$DEC(DFN,MSN,$GET(BPROV))
QUIT
+2 ;
+3 NEW BQIH,BQIYR,BQIRES
+4 SET BQIH=$$SPM^BQIGPUTL()
SET BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
+5 ;
+6 SET TAG=$$ATAG^BQITDUTL(DFN,"Hypertension")
+7 ; DM: BP <140/90 = BQIYR_2636
+8 SET CD=BQIYR_"_2636"
SET QFL=0
Begin DoDot:1
+9 IF $$PTV(DFN,CD)="NDA"
DO NDA(DFN,MSN,BPROV)
SET QFL=1
QUIT
+10 IF $$PTV(DFN,CD)="YES"
DO YES(DFN,MSN,BPROV)
SET QFL=1
QUIT
+11 IF $$PTV(DFN,CD)="NO"
DO NO(DFN,MSN,BPROV)
SET QFL=1
QUIT
+12 ; If it is not applicable, check other BPs
+13 ;I $$PTV(DFN,CD)="N/A" D Q:QFL
+14 ; If CRS 15
+15 IF $$VERSION^XPDUTL("BGP")>14.9
Begin DoDot:2
+16 SET BQIRES=$$PAT^BQIIPCBP(DFN)
+17 IF BQIRES="YES"
DO YES(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+18 IF BQIRES="NO"
DO NO(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+19 IF BQIRES="N/A"
DO NA(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+20 DO NO(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
End DoDot:2
QUIT
+21 Begin DoDot:2
+22 ; CHD: Pre-HTN I BP = BQIYR_909 CHD: Normal BP = BQIYR_908 CHD: Pre-HTN II BP
+23 IF $$PTV(DFN,BQIYR_"_909")="YES"!($$PTV(DFN,BQIYR_"_908")="YES")!($$PTV(DFN,BQIYR_"_910")="YES")
DO YES(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+24 IF $$PTV(DFN,BQIYR_"_909")="NO"!($$PTV(DFN,BQIYR_"_908")="NO")!($$PTV(DFN,BQIYR_"_910")="NO")
DO NO(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+25 IF $$PTV(DFN,BQIYR_"_909")="N/A"!($$PTV(DFN,BQIYR_"_908")="N/A")!($$PTV(DFN,BQIYR_"_910")="N/A")
Begin DoDot:3
+26 ; If tag is no
+27 IF 'TAG
IF $$PTV(DFN,BQIYR_"_907")="N/A"
DO NA(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+28 IF TAG
+29 ; 20+: Normal BP = BQIYR_872 20+: Pre-HTN I BP = BQIYR_873 20+: Pre-HTN II BP = BQIYR_874
+30 IF $$PTV(DFN,BQIYR_"_872")="YES"!($$PTV(DFN,BQIYR_"_873")="YES")!($$PTV(DFN,BQIYR_"_874")="YES")
DO YES(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
+31 DO NO(DFN,MSN,$GET(BPROV))
SET QFL=1
QUIT
End DoDot:3
End DoDot:2
IF QFL
QUIT
End DoDot:1
IF QFL
QUIT
+32 QUIT
+33 ;
BUN(CRN,MSN,XX) ;EP - Get values for bundle
+1 NEW BN,BCODE
+2 SET BN=0
+3 FOR
SET BN=$ORDER(^BQI(90508,1,22,CRN,1,MSN,2,BN))
IF 'BN
QUIT
Begin DoDot:1
+4 SET BCODE=$PIECE(^BQI(90508,1,22,CRN,1,MSN,2,BN,0),U,1)
SET GP=$PIECE(^BQI(90508,1,22,CRN,1,MSN,2,BN,0),U,2)
+5 IF GP=""
SET XX(BCODE)=""
QUIT
+6 IF GP'=""
SET XX(GP,BCODE)=""
End DoDot:1
+7 QUIT
+8 ;
PAT(CRN,DFN,CODE) ;EP - See if patient meets bundle criteria
+1 ; Input
+2 ; CODE="IPC_DMCTRL" or "IPC_LDCTRL" or "IPC_BPCTRL"
+3 NEW MSN,BQDATE
+4 KILL ^XTMP("BQI OUTCOME",$JOB)
+5 SET MSN=$ORDER(^BQI(90508,1,22,CRN,1,"B",CODE,""))
+6 SET BQDATE=""
+7 ; Find and Store the results of each "sub-bundle"
+8 SET EXEC=$GET(^BQI(90508,1,22,CRN,1,MSN,1))
IF EXEC=""
QUIT
+9 XECUTE EXEC
+10 ;
+11 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="{D}"
QUIT "{D}"
+12 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="N/A"
QUIT "N/A"
+13 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="NO"
QUIT "NO"
+14 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="YES"
QUIT "YES"
+15 IF $GET(^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN))="LDL Result Not Entered"
QUIT "LDL Result Not Entered"
+16 QUIT "NDA"
+17 ;
PROC ;EP - Process data
+1 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CD,""))
IF IEN=""
DO NDA(DFN,MSN)
QUIT
+2 SET NUM=$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
+3 SET DEN=$PIECE(^BQIPAT(DFN,30,IEN,0),U,4)
+4 IF NUM=""
IF DEN=""
DO NA(DFN,MSN)
QUIT
+5 IF DEN'=""
IF NUM=""
DO NO(DFN,MSN)
QUIT
+6 IF DEN'=""
IF NUM'=""
DO YES(DFN,MSN)
QUIT
+7 QUIT
+8 ;
CMPR ;EP - Combo process
+1 NEW CD,TCT,IEN,BQTMP,BCT,DEN,NUM,NA,NO,YES
+2 SET CD=""
SET TCT=0
KILL BQTMP
+3 FOR
SET CD=$ORDER(XX(NN,CD))
IF CD=""
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CD,""))
IF IEN=""
Begin DoDot:2
+5 SET BQTMP("PT",DFN,CD)="NDA"
SET TCT=TCT+1
End DoDot:2
QUIT
End DoDot:1
+6 SET BCT=0
+7 FOR
SET CD=$ORDER(BQTMP("PT",DFN,CD))
IF CD=""
QUIT
IF BQTMP("PT",DFN,CD)="NDA"
SET BCT=BCT+1
+8 IF $DATA(BQTMP)
IF BCT=TCT
DO NDA(DFN,MSN)
QUIT
+9 ;
+10 SET CD=""
SET TCT=0
KILL BQTMP
+11 FOR
SET CD=$ORDER(XX(NN,CD))
IF CD=""
QUIT
Begin DoDot:1
+12 SET IEN=$ORDER(^BQIPAT(DFN,30,"B",CD,""))
+13 SET NUM=$PIECE(^BQIPAT(DFN,30,IEN,0),U,3)
+14 SET DEN=$PIECE(^BQIPAT(DFN,30,IEN,0),U,4)
+15 SET TCT=TCT+1
+16 IF DEN=""
IF NUM=""
SET BQTMP("PT",DFN,CD)="N/A"
+17 IF DEN'=""
IF NUM=""
SET BQTMP("PT",DFN,CD)="NO"
+18 IF DEN'=""
IF NUM'=""
SET BQTMP("PT",DFN,CD)="YES"
End DoDot:1
+19 SET NA=0
SET NO=0
SET YES=0
+20 FOR
SET CD=$ORDER(BQTMP("PT",DFN,CD))
IF CD=""
QUIT
Begin DoDot:1
+21 IF BQTMP("PT",DFN,CD)="N/A"
SET NA=NA+1
+22 IF BQTMP("PT",DFN,CD)="NO"
SET NO=NO+1
+23 IF BQTMP("PT",DFN,CD)="YES"
SET YES=YES+1
End DoDot:1
+24 IF NA=TCT
DO NA(DFN,MSN)
+25 IF NA+NO=TCT
DO NO(DFN,MSN)
+26 IF NA+YES=TCT
DO YES(DFN,MSN)
+27 ;
+28 KILL BQTMP
+29 ;
+30 QUIT
+31 ;
PTV(BQDFN,BCODE) ;EP
+1 NEW IEN
+2 IF $ORDER(^BQIPAT(BQDFN,30,0))=""
QUIT "NDA"
+3 SET IEN=$ORDER(^BQIPAT(BQDFN,30,"B",BCODE,""))
IF IEN=""
QUIT "N/A"
+4 SET NUM=$PIECE(^BQIPAT(BQDFN,30,IEN,0),U,3)
+5 SET DEN=$PIECE(^BQIPAT(BQDFN,30,IEN,0),U,4)
+6 IF DEN=""
IF NUM=""
QUIT "N/A"
+7 IF DEN'=""
IF NUM=""
QUIT "NO"
+8 IF DEN'=""
IF NUM'=""
QUIT "YES"
+9 QUIT ""
+10 ;
YES(DFN,MSN,PROV) ;EP
+1 IF $GET(MSN)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN)="YES"
+2 IF $GET(PROV)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"YES")=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"YES"))+1
+3 QUIT
+4 ;
NO(DFN,MSN,PROV) ;EP
+1 IF $GET(MSN)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN)="NO"
+2 IF $GET(PROV)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"NO")=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"NO"))+1
+3 QUIT
+4 ;
NA(DFN,MSN,PROV) ;EP
+1 SET ^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN)="N/A"
+2 IF $GET(PROV)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"N/A")=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"N/A"))+1
+3 QUIT
+4 ;
NDA(DFN,MSN,PROV) ;EP
+1 IF $GET(MSN)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN)="NDA"
+2 IF $GET(PROV)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"NDA")=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"NDA"))+1
+3 QUIT
+4 ;
DEC(DFN,MSN,PROV) ;EP - Deceased check
+1 NEW BQIDOD,FLAG
+2 SET BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
SET FLAG=0
+3 IF BQIDOD'=""
Begin DoDot:1
+4 IF $GET(MSN)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PT",DFN,MSN)="{D}"
+5 SET FLAG=1
+6 IF $GET(PROV)'=""
SET ^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"DEC")=$GET(^XTMP("BQI OUTCOME",$JOB,"PRV",PROV,"DEC"))+1
End DoDot:1
+7 QUIT FLAG
+8 ;
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
