Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BQIIPOTC

BQIIPOTC.m

Go to the documentation of this file. 
  1. BQIIPOTC ;VNGT/HS/ALA-Outcome Bundle ; 18 Jul 2011  4:00 PM
  1.  ;;2.4;ICARE MANAGEMENT SYSTEM;**3**;Apr 01, 2015;Build 5
  1.  ;
  1. EN(BQDATE) ;EP - Outcome Bundle Monthly
  1.  NEW BQMON,BQDTE,BEGDT,EDAY,ENDT,PYR,CYR,ID,FAC,DFN,QFL,CRST
  1.  S QFL=0
  1.  S CRST=$P($G(^BQI(90508,1,11)),U,2) S:CRST="" CRST=1
  1.  S CRST="0"_CRST
  1.  ;
  1.  I $G(BQDATE)'="" D
  1.  . S BEGDT=$E(BQDATE,1,5)_"01",CYR=$E(BQDATE,1,3),BQMON=$E(BQDATE,4,5)
  1.  . I $L(BQMON)=1 S BQMON="0"_BQMON
  1.  . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S ENDT=$E(BQDATE,1,5)_$P(EDAY,U,+BQMON)
  1.  ;
  1.  I $G(BQDATE)="" D  Q:QFL
  1.  . I $E(DT,6,7)'=CRST S QFL=1 Q
  1.  . S BQMON=$E(DT,4,5)-1,CYR=$E(DT,1,3),PYR=CYR-1
  1.  . S BQDTE=$P($T(BQM+BQMON),";;",2)
  1.  . I $L(BQMON)=1 S BQMON="0"_BQMON
  1.  . S BEGDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_"01"
  1.  . S EDAY="31^"_($$LEAP^XLFDT2(CYR)+28)_"^31^30^31^30^31^31^30^31^30^31"
  1.  . S ENDT=@($P(BQDTE,U,2))_$P(BQDTE,U,1)_$P(EDAY,U,+$P(BQDTE,U,1))
  1.  . S BQDATE=$S(BQMON="01":PYR,1:CYR)_BQMON_"00"
  1.  ;
  1.  ; Get current IPC
  1.  S CRIPC=$P($G(^BQI(90508,1,11)),U,1)
  1.  S CRN=$O(^BQI(90508,1,22,"B",CRIPC,"")) I CRN="" Q
  1.  ;
  1.  K ^XTMP("BQI OUTMON")
  1.  S PRV=""
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  1.  . S DFN=""
  1.  . F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  .. I '$$HRN^BQIUL1(DFN) Q
  1.  .. S NA=0,NO=0,YES=0,NDA=0,CNT=3,DEC=0,TOTP=0
  1.  .. ;S TOTP=TOTP+1
  1.  .. ;F CODE="IPC_DMCTRL","IPC_LDCTRL","IPC_BPCTRL" D
  1.  .. F CODE="IPC_DMCTRL","IPC_BPCTRL" D
  1.  ... S VAL=$$PAT(CRN,DFN,CODE)
  1.  ... I VAL="{D}" S DEC=1 Q
  1.  ... I VAL="N/A" S NA=NA+1 Q
  1.  ... I VAL="NO" S NO=NO+1 Q
  1.  ... I VAL="YES" S YES=YES+1 Q
  1.  ... S NDA=NDA+1 Q
  1.  .. I DEC Q
  1.  .. I NA=CNT Q
  1.  .. I NDA=CNT S ^XTMP("BQI OUTMON","PRV",PRV,"NO")=$G(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+1 Q
  1.  .. I YES=CNT S ^XTMP("BQI OUTMON","PRV",PRV,"YES")=$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))+1 Q
  1.  .. I 'NO S ^XTMP("BQI OUTMON","PRV",PRV,"YES")=$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))+1 Q
  1.  .. S ^XTMP("BQI OUTMON","PRV",PRV,"NO")=$G(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+1 Q
  1.  ;
  1.  S CODE="IPC_OUTC"
  1.  S FAC=$$HME^BQIGPUTL()
  1.  ; Set NOs and YESs to get denominator value and store
  1.  S PRV="",TDEN=0,TNUM=0
  1.  F  S PRV=$O(^XTMP("BQI OUTMON","PRV",PRV)) Q:PRV=""  D
  1.  . S TP=$G(^XTMP("BQI OUTMON","PRV",PRV,"NO"))+$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))
  1.  . S PCT=+$G(^XTMP("BQI OUTMON","PRV",PRV,"YES"))
  1.  . D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
  1.  . S TDEN=TDEN+TP,TNUM=TNUM+PCT
  1.  S FAC=$$HME^BQIGPUTL()
  1.  D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  K ^XTMP("BQI OUTMON")
  1.  Q
  1.  ;
  1. OPAT(CRN,DFN) ;EP - Outcome Bundle by Patient
  1.  NEW MSN,CODE,BQDATE
  1.  K ^XTMP("BQI OUTCOME",$J)
  1.  ;F CODE="IPC_DMCTRL","IPC_LDCTRL","IPC_BPCTRL" D
  1.  F CODE="IPC_DMCTRL","IPC_BPCTRL" D
  1.  . S MSN=$O(^BQI(90508,1,22,CRN,1,"B",CODE,""))
  1.  . S BQDATE=""
  1.  . ; Find and Store the results of each "sub-bundle"
  1.  . S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
  1.  . X EXEC
  1.  ;
  1.  S MSN="",NA=0,NO=0,YES=0,NDA=0,CNT=3,DEC=0
  1.  F  S MSN=$O(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)) Q:MSN=""  D
  1.  . I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="{D}" S DEC=DEC+1 Q
  1.  . I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="N/A" S NA=NA+1 Q
  1.  . I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="NO" S NO=NO+1 Q
  1.  . I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="YES" S YES=YES+1 Q
  1.  . I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="NDA" S NO=NO+1 Q
  1.  I DEC Q "{D}"
  1.  I NDA Q "NO"
  1.  I NA=CNT Q "N/A"
  1.  I YES=CNT Q "YES"
  1.  I 'NO Q "YES"
  1.  Q "NO"
  1.  ;
  1. DM(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the DM bundle for monthly update
  1.  ; Input
  1.  ;   CRN  - Current IPC IEN
  1.  ;   MSN - Bundle IEN
  1.  ;   CODE  - Code name
  1.  ;   BQI(90508,1,22,CRN,1,BNIEN,1
  1.  ;
  1.  NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
  1.  S TDEN=0,TNUM=0,CNT=0
  1.  D BUN(CRN,MSN,.XX)
  1.  ;
  1.  I $G(DFN)'="" D  Q
  1.  . S PRV=$P(^AUPNPAT(DFN,0),U,14)
  1.  . D DMP(DFN,MSN,PRV) Q
  1.  ;
  1.  S PRV=""
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  1.  . S DFN=""
  1.  . F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  .. I '$$HRN^BQIUL1(DFN) Q
  1.  .. D DMP(DFN,MSN,PRV)
  1.  . 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"))
  1.  . S PCT=+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
  1.  . D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
  1.  . S TDEN=TDEN+TP,TNUM=TNUM+PCT
  1.  S FAC=$$HME^BQIGPUTL()
  1.  D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  ;
  1.  Q
  1.  ;
  1. DMP(DFN,MSN,BPROV) ;EP
  1.  I $$DEC(DFN,MSN,$G(BPROV)) Q
  1.  S CD=""
  1.  F  S CD=$O(XX(CD)) Q:CD=""  D
  1.  . S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" D NDA(DFN,MSN,BPROV) Q
  1.  . I $$PTV(DFN,CD)="N/A" D NA(DFN,MSN,BPROV) Q
  1.  . I $$PTV(DFN,CD)="NO" D NO(DFN,MSN,BPROV) Q
  1.  . I $$PTV(DFN,CD)="YES" D YES(DFN,MSN,BPROV)
  1.  Q
  1.  ;
  1. LD(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the LDL bundle for monthly update
  1.  ; Input
  1.  ;   CRN  - Current IPC IEN
  1.  ;   MSN - Bundle IEN
  1.  ;   CODE  - Code name
  1.  ;   BQI(90508,1,22,CRN,1,BNIEN,1
  1.  ;
  1.  NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
  1.  K ^XTMP("BQI OUTCOME",$J,"PRV")
  1.  S TDEN=0,TNUM=0,CNT=0
  1.  ;
  1.  I $G(DFN)'="" D  Q
  1.  . S PRV=$P(^AUPNPAT(DFN,0),U,14)
  1.  . D LDP(DFN,MSN,PRV)
  1.  ;
  1.  S PRV=""
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  1.  . S DFN=""
  1.  . F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  .. I '$$HRN^BQIUL1(DFN) Q
  1.  .. D LDP(DFN,MSN,PRV)
  1.  . 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"))
  1.  . S PCT=+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
  1.  . D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
  1.  . S TDEN=TDEN+TP,TNUM=TNUM+PCT
  1.  S FAC=$$HME^BQIGPUTL()
  1.  D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  ;
  1.  Q
  1.  ;
  1. LDP(DFN,MSN,BPROV) ;EP
  1.  I $$DEC(DFN,MSN,$G(BPROV)) Q
  1.  I $O(^BQIPAT(DFN,30,0))="" D NDA(DFN,MSN,$G(BPROV)) Q
  1.  ;
  1.  NEW BQIH,BQIYR
  1.  S BQIH=$$SPM^BQIGPUTL(),BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
  1.  ;
  1.  I $$PTV(DFN,BQIYR_"_99")="YES" D  Q
  1.  . D YES(DFN,MSN,$G(BPROV))
  1.  I $$PTV(DFN,BQIYR_"_810")="YES"!($$PTV(DFN,BQIYR_"_810")="NO") D  Q
  1.  . NEW BCODE,IEN,BGPVALUE
  1.  . S BCODE=BQIYR_"_810",IEN=$O(^BQIPAT(DFN,30,"B",BCODE,"")) I IEN="" Q
  1.  . S BGPVALUE=$P(^BQIPAT(DFN,30,IEN,0),"^",2)
  1.  . I $P(BGPVALUE,"|",1)'["CHD" D NA(DFN,MSN,$G(BPROV)) Q
  1.  . D YES(DFN,MSN,$G(BPROV)) Q
  1.  ;
  1.  ;Check ICD
  1.  NEW BQICD
  1.  S BQICD=$$DXC()
  1.  S RESULT=$$DX^BQIIPDXC("T-12M",DFN,BQCODE)
  1.  I RESULT D YES(DFN,MSN,$G(BPROV)) Q
  1.  I $$PTV(DFN,BQIYR_"_99")="N/A",$$PTV(DFN,BQIYR_"_810")="N/A" D NA(DFN,MSN,$G(BPROV)) Q
  1.  D NO(DFN,MSN,$G(BPROV))
  1.  Q
  1.  ;
  1. DXC() ;EP
  1.  I $$VERSION^XPDUTL("AICD")<4.0 S BQCODE="V77.91"
  1.  I $$VERSION^XPDUTL("AICD")>3.51 D
  1.  . I DT<$$IMP^ICDEXA(30) S BQCODE="V77.91" Q
  1.  . S BQCODE="Z13.220"
  1.  Q BQCODE
  1.  ;
  1. BP(CRN,MSN,BQDATE,CODE,DFN) ;EP - do the BP bundle
  1.  ; Input
  1.  ;   CRN  - Current IPC IEN
  1.  ;   MSN - Bundle IEN
  1.  ;   CODE  - Code name
  1.  ;   BQI(90508,1,22,CRN,1,BNIEN,1
  1.  ;
  1.  NEW TDEN,TNUM,CNT,XX,PRV,BQIDOD,CD,IEN,NUM,DEN,PCT,TP,FAC
  1.  K ^XTMP("BQI OUTCOME",$J,"PRV")
  1.  S TDEN=0,TNUM=0,CNT=0
  1.  D BUN(CRN,MSN,.XX)
  1.  ;
  1.  I $G(DFN)'="" D  Q
  1.  . S PRV=$P(^AUPNPAT(DFN,0),U,14)
  1.  . D BPP(DFN,MSN,PRV)
  1.  ;
  1.  S PRV=""
  1.  F  S PRV=$O(^AUPNPAT("AK",PRV)) Q:PRV=""  D
  1.  . I $P(^VA(200,PRV,0),U,13)'="" Q
  1.  . S DFN=""
  1.  . F  S DFN=$O(^AUPNPAT("AK",PRV,DFN)) Q:DFN=""  D
  1.  .. I '$$HRN^BQIUL1(DFN) Q
  1.  .. D BPP(DFN,MSN,PRV)
  1.  . 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"))
  1.  . S PCT=+$G(^XTMP("BQI OUTCOME",$J,"PRV",PRV,"YES"))
  1.  . D STORP^BQIIPUTL(PRV,CODE,BQDATE,TP,PCT)
  1.  . S TDEN=TDEN+TP,TNUM=TNUM+PCT
  1.  S FAC=$$HME^BQIGPUTL()
  1.  D STORF^BQIIPUTL(FAC,CODE,BQDATE,TDEN,TNUM)
  1.  Q
  1.  ;
  1. BPP(DFN,MSN,BPROV) ;EP
  1.  I $$DEC(DFN,MSN,$G(BPROV)) Q
  1.  ;
  1.  NEW BQIH,BQIYR,BQIRES
  1.  S BQIH=$$SPM^BQIGPUTL(),BQIYR=$$GET1^DIQ(90508,BQIH_",",2,"E")
  1.  ;
  1.  S TAG=$$ATAG^BQITDUTL(DFN,"Hypertension")
  1.  ; DM: BP <140/90 = BQIYR_2636
  1.  S CD=BQIYR_"_2636",QFL=0 D  Q:QFL
  1.  . I $$PTV(DFN,CD)="NDA" D NDA(DFN,MSN,BPROV) S QFL=1 Q
  1.  . I $$PTV(DFN,CD)="YES" D YES(DFN,MSN,BPROV) S QFL=1 Q
  1.  . I $$PTV(DFN,CD)="NO" D NO(DFN,MSN,BPROV) S QFL=1 Q
  1.  . ; If it is not applicable, check other BPs
  1.  . ;I $$PTV(DFN,CD)="N/A" D  Q:QFL
  1.  . ; If CRS 15
  1.  . I $$VERSION^XPDUTL("BGP")>14.9 D  Q
  1.  .. S BQIRES=$$PAT^BQIIPCBP(DFN)
  1.  .. I BQIRES="YES" D YES(DFN,MSN,$G(BPROV)) S QFL=1 Q
  1.  .. I BQIRES="NO" D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
  1.  .. I BQIRES="N/A" D NA(DFN,MSN,$G(BPROV)) S QFL=1 Q
  1.  .. D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
  1.  . D  Q:QFL
  1.  .. ; CHD: Pre-HTN I BP = BQIYR_909   CHD: Normal BP = BQIYR_908    CHD: Pre-HTN II BP
  1.  .. 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
  1.  .. 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
  1.  .. I $$PTV(DFN,BQIYR_"_909")="N/A"!($$PTV(DFN,BQIYR_"_908")="N/A")!($$PTV(DFN,BQIYR_"_910")="N/A") D
  1.  ... ; If tag is no
  1.  ... I 'TAG,$$PTV(DFN,BQIYR_"_907")="N/A" D NA(DFN,MSN,$G(BPROV)) S QFL=1 Q
  1.  ... I TAG
  1.  ... ; 20+: Normal BP = BQIYR_872 20+: Pre-HTN I BP = BQIYR_873  20+: Pre-HTN II BP = BQIYR_874
  1.  ... 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
  1.  ... D NO(DFN,MSN,$G(BPROV)) S QFL=1 Q
  1.  Q
  1.  ;
  1. BUN(CRN,MSN,XX) ;EP - Get values for bundle
  1.  NEW BN,BCODE
  1.  S BN=0
  1.  F  S BN=$O(^BQI(90508,1,22,CRN,1,MSN,2,BN)) Q:'BN  D
  1.  . 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)
  1.  . I GP="" S XX(BCODE)="" Q
  1.  . I GP'="" S XX(GP,BCODE)=""
  1.  Q
  1.  ;
  1. PAT(CRN,DFN,CODE) ;EP - See if patient meets bundle criteria
  1.  ; Input
  1.  ;  CODE="IPC_DMCTRL" or "IPC_LDCTRL" or "IPC_BPCTRL"
  1.  NEW MSN,BQDATE
  1.  K ^XTMP("BQI OUTCOME",$J)
  1.  S MSN=$O(^BQI(90508,1,22,CRN,1,"B",CODE,""))
  1.  S BQDATE=""
  1.  ; Find and Store the results of each "sub-bundle"
  1.  S EXEC=$G(^BQI(90508,1,22,CRN,1,MSN,1)) I EXEC="" Q
  1.  X EXEC
  1.  ;
  1.  I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="{D}" Q "{D}"
  1.  I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="N/A" Q "N/A"
  1.  I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="NO" Q "NO"
  1.  I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="YES" Q "YES"
  1.  I $G(^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN))="LDL Result Not Entered" Q "LDL Result Not Entered"
  1.  Q "NDA"
  1.  ;
  1. PROC ;EP - Process data
  1.  S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" D NDA(DFN,MSN) Q
  1.  S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3)
  1.  S DEN=$P(^BQIPAT(DFN,30,IEN,0),U,4)
  1.  I NUM="",DEN="" D NA(DFN,MSN) Q
  1.  I DEN'="",NUM="" D NO(DFN,MSN) Q
  1.  I DEN'="",NUM'="" D YES(DFN,MSN) Q
  1.  Q
  1.  ;
  1. CMPR ;EP - Combo process
  1.  NEW CD,TCT,IEN,BQTMP,BCT,DEN,NUM,NA,NO,YES
  1.  S CD="",TCT=0 K BQTMP
  1.  F  S CD=$O(XX(NN,CD)) Q:CD=""  D
  1.  . S IEN=$O(^BQIPAT(DFN,30,"B",CD,"")) I IEN="" D  Q
  1.  .. S BQTMP("PT",DFN,CD)="NDA",TCT=TCT+1
  1.  S BCT=0
  1.  F  S CD=$O(BQTMP("PT",DFN,CD)) Q:CD=""  I BQTMP("PT",DFN,CD)="NDA" S BCT=BCT+1
  1.  I $D(BQTMP),BCT=TCT D NDA(DFN,MSN) Q
  1.  ;
  1.  S CD="",TCT=0 K BQTMP
  1.  F  S CD=$O(XX(NN,CD)) Q:CD=""  D
  1.  . S IEN=$O(^BQIPAT(DFN,30,"B",CD,""))
  1.  . S NUM=$P(^BQIPAT(DFN,30,IEN,0),U,3)
  1.  . S DEN=$P(^BQIPAT(DFN,30,IEN,0),U,4)
  1.  . S TCT=TCT+1
  1.  . I DEN="",NUM="" S BQTMP("PT",DFN,CD)="N/A"
  1.  . I DEN'="",NUM="" S BQTMP("PT",DFN,CD)="NO"
  1.  . I DEN'="",NUM'="" S BQTMP("PT",DFN,CD)="YES"
  1.  S NA=0,NO=0,YES=0
  1.  F  S CD=$O(BQTMP("PT",DFN,CD)) Q:CD=""  D
  1.  . I BQTMP("PT",DFN,CD)="N/A" S NA=NA+1
  1.  . I BQTMP("PT",DFN,CD)="NO" S NO=NO+1
  1.  . I BQTMP("PT",DFN,CD)="YES" S YES=YES+1
  1.  I NA=TCT D NA(DFN,MSN)
  1.  I NA+NO=TCT D NO(DFN,MSN)
  1.  I NA+YES=TCT D YES(DFN,MSN)
  1.  ;
  1.  K BQTMP
  1.  ;
  1.  Q
  1.  ;
  1. PTV(BQDFN,BCODE) ;EP
  1.  NEW IEN
  1.  I $O(^BQIPAT(BQDFN,30,0))="" Q "NDA"
  1.  S IEN=$O(^BQIPAT(BQDFN,30,"B",BCODE,"")) I IEN="" Q "N/A"
  1.  S NUM=$P(^BQIPAT(BQDFN,30,IEN,0),U,3)
  1.  S DEN=$P(^BQIPAT(BQDFN,30,IEN,0),U,4)
  1.  I DEN="",NUM="" Q "N/A"
  1.  I DEN'="",NUM="" Q "NO"
  1.  I DEN'="",NUM'="" Q "YES"
  1.  Q ""
  1.  ;
  1. YES(DFN,MSN,PROV) ;EP
  1.  I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="YES"
  1.  I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"YES")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"YES"))+1
  1.  Q
  1.  ;
  1. NO(DFN,MSN,PROV) ;EP
  1.  I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="NO"
  1.  I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NO")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NO"))+1
  1.  Q
  1.  ;
  1. NA(DFN,MSN,PROV) ;EP
  1.  S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="N/A"
  1.  I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"N/A")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"N/A"))+1
  1.  Q
  1.  ;
  1. NDA(DFN,MSN,PROV) ;EP
  1.  I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="NDA"
  1.  I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NDA")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"NDA"))+1
  1.  Q
  1.  ;
  1. DEC(DFN,MSN,PROV) ;EP - Deceased check
  1.  NEW BQIDOD,FLAG
  1.  S BQIDOD=$$GET1^DIQ(2,DFN_",",.351,"I"),FLAG=0
  1.  I BQIDOD'="" D
  1.  . I $G(MSN)'="" S ^XTMP("BQI OUTCOME",$J,"PT",DFN,MSN)="{D}"
  1.  . S FLAG=1
  1.  . I $G(PROV)'="" S ^XTMP("BQI OUTCOME",$J,"PRV",PROV,"DEC")=$G(^XTMP("BQI OUTCOME",$J,"PRV",PROV,"DEC"))+1
  1.  Q FLAG
  1.  ;
  1. BQM ;
  1.  ;;12^PYR
  1.  ;;01^CYR
  1.  ;;02^CYR
  1.  ;;03^CYR
  1.  ;;04^CYR
  1.  ;;05^CYR
  1.  ;;06^CYR
  1.  ;;07^CYR
  1.  ;;08^CYR
  1.  ;;09^CYR
  1.  ;;10^CYR
  1.  ;;11^CYR