BGPMUUT2 ; IHS/MSC/MGH - MEANINGFUL USE UTILITIES 02 Jul 2008 2:07 PM ;01-Mar-2011 15:32;DU
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
;
NPI(USR) ;EP - Return the NPI for the selected Provider
Q $S($D(^VA(200,USR,"NPI")):$P(^VA(200,USR,"NPI"),U),1:"UNKNOWN")
TIN(USR) ;EP - Return the Tax ID number for selected Provider
Q $S($D(^VA(200,USR,"TPB")):$P(^VA(200,USR,"TPB"),U,2),1:"UNKNOWN")
INITIALS(USR) ;Return the initials for selected Provider
Q $S($D(^VA(200,USR,0)):$P(^VA(200,USR,0),U,2),1:"UNKNOWN")
LASTDX(DFN,BDATE,EDATE,TAX) ;EP
I '$G(DFN) Q 0
;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(DFN,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BGPTX5=$O(^ATXAX("B",TAX,0)) ;get taxonomy ien
I BGPTX5="" Q 0 ;not a valid taxonomy
S BGPDX4=0 ;return value
S BGPDXBD=9999999-BDATE,BGPDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BGPDX1=BGPDXED-1 F S BGPDX1=$O(^AUPNVPOV("AA",DFN,BGPDX1)) Q:BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4'=0) D
.S BGPDX2=0 F S BGPDX2=$O(^AUPNVPOV("AA",DFN,BGPDX1,BGPDX2)) Q:BGPDX2'=+BGPDX2!(BGPDX4'=0) D
..S BGPDX3=$P($G(^AUPNVPOV(BGPDX2,0)),U)
..Q:BGPDX3="" ;bad xref
..Q:'$D(^ICD9(BGPDX3))
..Q:'$$ICD^ATXCHK(BGPDX3,BGPTX5,9)
..S BGPDX4=1_"^"_$P($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
Q BGPDX4
LASTDXI(P,T,BDATE,EDATE,SC) ;EP
; P = DFN
; T = Diagnosis Code
; SC = Cause of DX (see field 07 of V POV file)
I '$G(P) Q ""
S SC=$G(SC)
;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
NEW BGPDX1,BGPDX2,BGPDX3,BGPDX5,BGPTX5,BGPDX4,BGPDXV
S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
;S BGPTX5=$O(^ICD9("AB",T,0)) ;get taxonomy ien
S BGPTX5=+$$CODEN^ICDCODE(T,80)
I BGPTX5'>0 Q "" ;not a valid code
S BGPDX4="" ;return value
S BGPDXBD=9999999-BDATE,BGPDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BGPDX1=BGPDXED-1 F S BGPDX1=$O(^AUPNVPOV("AA",P,BGPDX1)) Q:BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"") D
.S BGPDX2=0 F S BGPDX2=$O(^AUPNVPOV("AA",P,BGPDX1,BGPDX2)) Q:BGPDX2'=+BGPDX2!(BGPDX4]"") D
..S BGPDX3=$P($G(^AUPNVPOV(BGPDX2,0)),U)
..Q:BGPDX3="" ;bad xref
..Q:BGPDX3'=BGPTX5
..S BGPDXV=$P(^AUPNVPOV(BGPDX2,0),U,3)
..I '$D(^AUPNVSIT(BGPDXV,0)) Q ;no visit entry
..I SC]"",SC'[$P(^AUPNVSIT(BGPDXV,0),U,7)
..S BGPDX4=1_"^"_$P($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
..Q
.Q
Q BGPDX4
LASTPRC(DFN,BDATE,EDATE,TAX) ;EP
I '$G(DFN) Q 0
;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(DFN,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BGPTX5=$O(^ATXAX("B",TAX,0)) ;get taxonomy ien
I BGPTX5="" Q "" ;not a valid taxonomy
S BGPDX4=0 ;return value
S BGPDXBD=9999999-BDATE,BGPDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BGPDX1=BGPDXED-1 F S BGPDX1=$O(^AUPNVPRC("AA",DFN,BGPDX1)) Q:BGPDX1=""!(BGPDX1>BGPDXBD)!(+BGPDX4) D
.S BGPDX2=0 F S BGPDX2=$O(^AUPNVPRC("AA",DFN,BGPDX1,BGPDX2)) Q:BGPDX2'=+BGPDX2!(+BGPDX4) D
..S BGPDX3=$P($G(^AUPNVPRC(BGPDX2,0)),U)
..Q:BGPDX3="" ;bad xref
..Q:'$$ICD^ATXCHK(BGPDX3,BGPTX5,0)
..S BGPDX4=1_"^"_$P($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
..Q
.Q
Q BGPDX4
;
LASTPRCI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
;S BGPTX5=$O(^ICD0("AB",T,0)) ;get ICD PROC ien
S BGPTX5=+$$CODEN^ICDCODE(T,80.1)
I BGPTX5'>0 Q "" ;not a valid PROC
S BGPDX4="" ;return value
S BGPDXBD=9999999-BDATE,BGPDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BGPDX1=BGPDXED-1 F S BGPDX1=$O(^AUPNVPRC("AA",P,BGPDX1)) Q:BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"") D
.S BGPDX2=0 F S BGPDX2=$O(^AUPNVPRC("AA",P,BGPDX1,BGPDX2)) Q:BGPDX2'=+BGPDX2!(BGPDX4]"") D
..S BGPDX3=$P($G(^AUPNVPRC(BGPDX2,0)),U)
..Q:BGPDX3="" ;bad xref
..Q:BGPTX5'=BGPDX3
..S BGPDX4=1_"^"_$P($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
..Q
.Q
Q BGPDX4
FIRSTPRC(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BGPTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BGPTX5="" Q "" ;not a valid taxonomy
S BGPDX4="" ;return value
S BGPX=0 F S BGPX=$O(^AUPNVPRC("AC",P,BGPX)) Q:BGPX'=+BGPX!(BGPDX4]"") D
.S BGPDX3=$P($G(^AUPNVPRC(BGPX,0)),U)
.Q:BGPDX3="" ;BAD XREF
.Q:'$$ICD^ATXCHK(BGPDX3,BGPTX5,0)
.S D=$P(^AUPNVPRC(BGPX,0),U,3)
.Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPDX4=1_"^"_$P($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_D_"^"_BGPDX3_"^"_BGPX
.Q
Q BGPDX4
NMIREF(P,F,I,B,E) ;EP
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) D
.S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
REFUSAL(P,F,I,B,E) ;EP (PAT,FILE,ITEM,BDT,EDT)
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(B)="" Q ""
I $G(E)="" Q ""
;backup the begin date by 1 day to accomodate the > check below
S B=$$FMADD^XLFDT(B,-1)
NEW G,X,Y,%DT S X=B,%DT="P" D ^%DT S B=Y
S X=E,%DT="P" D ^%DT S E=Y
S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,F,I,X)) Q:X'=+X!(G) S Y=0 F S Y=$O(^AUPNPREF("AA",P,F,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
MEDREF(PAT,BDT,EDT,TAX) ;EP
NEW G,X,Y,%DT,NDC,NDCCODE,REASON,NDCF
;S X=BDT,%DT="P" D ^%DT S BDT=Y
;S X=EDT,%DT="P" D ^%DT S EDT=Y
S (ITEM,G)=0 F S ITEM=$O(^AUPNPREF("AA",PAT,50,ITEM)) Q:'+ITEM!(G) D
.;See if this item is in the taxonomy
.S NDC=$P($G(^PSDRUG(ITEM,2)),U,4)
.Q:'NDC
.;Setup the NDC code for a proper lookup in the taxonomy
.S NDCCODE=$$RJ^XLFSTR($P(NDC,"-"),5,0)_$$RJ^XLFSTR($P(NDC,"-",2),4,0)_$$RJ^XLFSTR($P(NDC,"-",3),2,0)
.;call the taxonomy lookup
.S NDCF=$$MEDTAX^BGPMUUT3(DFN,NDCCODE,TAX)
.I +NDCF D
..;Now check dates and reason
..S X=0 F S X=$O(^AUPNPREF("AA",PAT,50,ITEM,X)) Q:X'=+X!(G) D
...S Y=0 F S Y=$O(^AUPNPREF("AA",PAT,50,ITEM,X,Y)) Q:Y'=+Y D
....S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDT&(D'>EDT) D
.....S REASON=$P(^AUPNPREF(Y,0),U,7)
.....I REASON="R"!(REASON="N") S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
RADREF(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,71,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,71,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,71,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..S C=$P($G(^RAMIS(71,I,0)),U,9) Q:C=""
..Q:'$$ICD^ATXCHK(C,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
LABREF(P,BDATE,EDATE,LT,CT) ;EP - return date and reason for refusal of LAB (LOINC)
; P = Patient IEN
; BDATE = begin date to search
; EDATE = end date to search
; LT = Taxonomy name for LOINC check
; CT = Taxonomy name for CPT check
I '$G(P) Q ""
I $G(LT)="" Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S C=""
S G=0
S I=0 F S I=$O(^AUPNPREF("AA",P,60,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,60,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,60,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..S BGPH=0 F S BGPH=$O(^LAB(60,I,1,BGPH)) Q:BGPH'>0 D
...S L=$P($G(^LAB(60,I,1,BGPH,95.3)),U,1)
...I L'="" I $$LOINCREF(L,LT) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
...Q:+G
...S C=$P($G(^LAB(60,I,1,BGPH,3)),U,1)
...I L'="" I $$ICD^ATXCHK(C,CT,1) S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
Q G
LOINCREF(C,T) ;check taxonomy T for LOINC code; passed in LOINC code might not have the check digit
N TIEN
S TIEN="" S TIEN=$O(^ATXAX("B",T,TIEN)) Q:'TIEN 0
Q +$O(^ATXAX(TIEN,21,"B",$P(C,"-",1)_"-"))
;
LASTECOD(P,T,BDATE,EDATE) ;EP
N BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPDX5,BGPDX6,BGPDX7,BGPDXBD,BGPDXED
I '$G(P) Q ""
;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPDX5,BGPDX6,BGPDX7)=""
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3) ;if no date then set to DOB
I $G(EDATE)="" S EDATE=DT ;if no end date then set to today
S BGPTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BGPTX5="" Q "" ;not a valid taxonomy
S BGPDX4="" ;return value
S BGPDXBD=9999999-BDATE,BGPDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BGPDX1=BGPDXED-1 F S BGPDX1=$O(^AUPNVPOV("AA",P,BGPDX1)) Q:BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"") D
.S BGPDX2=0 F S BGPDX2=$O(^AUPNVPOV("AA",P,BGPDX1,BGPDX2)) Q:BGPDX2'=+BGPDX2!(BGPDX4]"") D
..F BGPDX6=9,18,19 S BGPDX3=$P($G(^AUPNVPOV(BGPDX2,0)),U,BGPDX6) D
...Q:BGPDX3="" ;no ecode
...I $$ICD^ATXCHK(BGPDX3,BGPTX5,9) S BGPDX4=1_"^"_$P($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
..Q
.Q
Q BGPDX4
REFTAX(PAT,FILE,TAX,BEG,END) ;EP - refused an item in a taxonomy
I '$G(PAT) Q 0
I '$G(FILE) Q 0
I $G(TAX)="" Q 0
I $G(BEG)="" Q 0
I $G(END)="" Q 0
NEW G,X,Y,%DT,T1,TIEN,T1PTR
S X=BEG,%DT="P" D ^%DT S BEG=Y
;S X=END,%DT="P" D ^%DT S E=Y
S TIEN=$O(^ATXAX("B",TAX,0)) ;get taxonomy ien
S T1=0,G="" F S T1=$O(^ATXAX(TIEN,21,"B",T1)) Q:T1=""!(G) D
.S T1PTR=$S(FILE=80:$P($$ICDDX^ICDCODE(T1),U),FILE=80.1:$P($$ICDOP^ICDCODE(T1),U),FILE=81:$P($$CPT^ICPTCOD(T1),U),1:X)
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",PAT,FILE,T1PTR,X)) Q:X'=+X!(G) D
..S Y=0 F S Y=$O(^AUPNPREF("AA",PAT,FILE,T1PTR,X,Y)) Q:Y'=+Y D
...S D=$P(^AUPNPREF(Y,0),U,3) I D'<BEG&(D'>END) D
....I $P(^AUPNPREF(Y,0),U,7)="R"!($P(^AUPNPREF(Y,0),U,7)="N") S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)_"^"_T1
Q G
CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,81,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..Q:'$$ICD^ATXCHK(I,T,1)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
PRCREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
NEW G,X,Y,Z,I
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,80.1,I)) Q:I=""!($P(G,U)) D
.S (X,G)=0 F S X=$O(^AUPNPREF("AA",P,80.1,I,X)) Q:X'=+X!($P(G,U)) S Y=0 F S Y=$O(^AUPNPREF("AA",P,80.1,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<BDATE&(D'>EDATE) D
..Q:'$$ICD^ATXCHK(I,T,0)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)
.Q
Q G
LOINC(DFN,BDATE,EDATE,TAX) ;Retuns IEN of Lab test if pt has this LOINC code
N IEN,CODE,B,E,D,L,G,X,J
S (CODE,B,E,D,L,G,X,J)=""
S IEN=$O(^ATXAX("B",TAX,0))
Q:'IEN
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",DFN,D)) Q:D'=+D!(D>B)!(G]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",DFN,D,L)) Q:L'=+L!(G]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",DFN,D,L,X)) Q:X'=+X!(G]"") D
...Q:'$D(^AUPNVLAB(X,0))
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I $$LOINC2(J,IEN) D
....S G=(9999999-D)_U_X Q
Q G
;
LOINC2(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) S CODE=% Q 1
Q ""
;
COLD(DFN,BDATE,EDATE,TAX) ;Retuns IEN of Lab test if pt has this LOINC code
N IEN,CODE,COLDTE,B,E,D,L,G,X,J
S (CODE,B,E,D,L,G,X,J)=""
S IEN=$O(^ATXAX("B",TAX,0))
Q:'IEN
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",DFN,D)) Q:D'=+D!(D>B)!(G]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",DFN,D,L)) Q:L'=+L!(G]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",DFN,D,L,X)) Q:X'=+X!(G]"") D
...Q:'$D(^AUPNVLAB(X,0))
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...S COLDTE=$P($G(^AUPNVLAB(X,12)),U,1)
...Q:COLDTE<BDATE!(COLDTE>EDATE)
...I $$LOINC2(J,IEN) D
....S G=(9999999-D)_U_X_U_$P($G(^AUPNVLAB(X,12)),U,1) Q
Q G
;
GETIMMS(P,EDATE,C,BGPX,CPTLST) ;EP
K BGPX
NEW X,Y,I,Z,V
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.F Z=1:1:$L(C,U) I I=$P(C,U,Z) S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".") I D]"",D'>EDATE S BGPX(D)=Y_U_V
.Q
I $D(CPTLST) D GIMMCPT(P,EDATE,CPTLST,.BGPX)
Q
GIMMCPT(P,EDATE,CPTLST,BGPX) ;
N V,G,X,Y,Z
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U) S Y=$P($$CPT^ICPTCOD(Y),U,2) I $$CPTCHK(CPTLST,Y) S BGPX(9999999-$P(ED,"."))=Y_U_V_U_1
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Y=$P($$CPT^ICPTCOD(Y),U,2) I $$CPTCHK(CPTLST,Y) S BGPX(9999999-$P(ED,"."))=Y_U_V_U_1
Q
CPTCHK(CPTLST,Y) ;Check if variable Y is in CPTLST
N I,FF
S FF=0
F I=1:1:$L(CPTLST,U) I $P(CPTLST,U,I)=Y S FF=1 Q
Q FF
IMMREF(P,IMM,BD,ED) ;EP
NEW X,Y,G,D,R
I 'IMM Q ""
S (X,G)=0,Y=$O(^AUTTIMM("C",IMM,0))
I 'Y Q ""
F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=G+1
Q G
BGPMUUT2 ; IHS/MSC/MGH - MEANINGFUL USE UTILITIES 02 Jul 2008 2:07 PM ;01-Mar-2011 15:32;DU
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
+3 ;
NPI(USR) ;EP - Return the NPI for the selected Provider
+1 QUIT $SELECT($DATA(^VA(200,USR,"NPI")):$PIECE(^VA(200,USR,"NPI"),U),1:"UNKNOWN")
TIN(USR) ;EP - Return the Tax ID number for selected Provider
+1 QUIT $SELECT($DATA(^VA(200,USR,"TPB")):$PIECE(^VA(200,USR,"TPB"),U,2),1:"UNKNOWN")
INITIALS(USR) ;Return the initials for selected Provider
+1 QUIT $SELECT($DATA(^VA(200,USR,0)):$PIECE(^VA(200,USR,0),U,2),1:"UNKNOWN")
LASTDX(DFN,BDATE,EDATE,TAX) ;EP
+1 IF '$GET(DFN)
QUIT 0
+2 ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(DFN,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BGPTX5=$ORDER(^ATXAX("B",TAX,0))
+7 ;not a valid taxonomy
IF BGPTX5=""
QUIT 0
+8 ;return value
SET BGPDX4=0
+9 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BGPDXBD=9999999-BDATE
SET BGPDXED=9999999-EDATE
+10 SET BGPDX1=BGPDXED-1
FOR
SET BGPDX1=$ORDER(^AUPNVPOV("AA",DFN,BGPDX1))
IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4'=0)
QUIT
Begin DoDot:1
+11 SET BGPDX2=0
FOR
SET BGPDX2=$ORDER(^AUPNVPOV("AA",DFN,BGPDX1,BGPDX2))
IF BGPDX2'=+BGPDX2!(BGPDX4'=0)
QUIT
Begin DoDot:2
+12 SET BGPDX3=$PIECE($GET(^AUPNVPOV(BGPDX2,0)),U)
+13 ;bad xref
IF BGPDX3=""
QUIT
+14 IF '$DATA(^ICD9(BGPDX3))
QUIT
+15 IF '$$ICD^ATXCHK(BGPDX3,BGPTX5,9)
QUIT
+16 SET BGPDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
End DoDot:2
End DoDot:1
+17 QUIT BGPDX4
LASTDXI(P,T,BDATE,EDATE,SC) ;EP
+1 ; P = DFN
+2 ; T = Diagnosis Code
+3 ; SC = Cause of DX (see field 07 of V POV file)
+4 IF '$GET(P)
QUIT ""
+5 SET SC=$GET(SC)
+6 ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+7 NEW BGPDX1,BGPDX2,BGPDX3,BGPDX5,BGPTX5,BGPDX4,BGPDXV
+8 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
+9 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+10 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+11 ;S BGPTX5=$O(^ICD9("AB",T,0)) ;get taxonomy ien
+12 SET BGPTX5=+$$CODEN^ICDCODE(T,80)
+13 ;not a valid code
IF BGPTX5'>0
QUIT ""
+14 ;return value
SET BGPDX4=""
+15 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BGPDXBD=9999999-BDATE
SET BGPDXED=9999999-EDATE
+16 SET BGPDX1=BGPDXED-1
FOR
SET BGPDX1=$ORDER(^AUPNVPOV("AA",P,BGPDX1))
IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"")
QUIT
Begin DoDot:1
+17 SET BGPDX2=0
FOR
SET BGPDX2=$ORDER(^AUPNVPOV("AA",P,BGPDX1,BGPDX2))
IF BGPDX2'=+BGPDX2!(BGPDX4]"")
QUIT
Begin DoDot:2
+18 SET BGPDX3=$PIECE($GET(^AUPNVPOV(BGPDX2,0)),U)
+19 ;bad xref
IF BGPDX3=""
QUIT
+20 IF BGPDX3'=BGPTX5
QUIT
+21 SET BGPDXV=$PIECE(^AUPNVPOV(BGPDX2,0),U,3)
+22 ;no visit entry
IF '$DATA(^AUPNVSIT(BGPDXV,0))
QUIT
+23 IF SC]""
IF SC'[$PIECE(^AUPNVSIT(BGPDXV,0),U,7)
+24 SET BGPDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
+27 QUIT BGPDX4
LASTPRC(DFN,BDATE,EDATE,TAX) ;EP
+1 IF '$GET(DFN)
QUIT 0
+2 ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(DFN,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BGPTX5=$ORDER(^ATXAX("B",TAX,0))
+7 ;not a valid taxonomy
IF BGPTX5=""
QUIT ""
+8 ;return value
SET BGPDX4=0
+9 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BGPDXBD=9999999-BDATE
SET BGPDXED=9999999-EDATE
+10 SET BGPDX1=BGPDXED-1
FOR
SET BGPDX1=$ORDER(^AUPNVPRC("AA",DFN,BGPDX1))
IF BGPDX1=""!(BGPDX1>BGPDXBD)!(+BGPDX4)
QUIT
Begin DoDot:1
+11 SET BGPDX2=0
FOR
SET BGPDX2=$ORDER(^AUPNVPRC("AA",DFN,BGPDX1,BGPDX2))
IF BGPDX2'=+BGPDX2!(+BGPDX4)
QUIT
Begin DoDot:2
+12 SET BGPDX3=$PIECE($GET(^AUPNVPRC(BGPDX2,0)),U)
+13 ;bad xref
IF BGPDX3=""
QUIT
+14 IF '$$ICD^ATXCHK(BGPDX3,BGPTX5,0)
QUIT
+15 SET BGPDX4=1_"^"_$PIECE($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT BGPDX4
+19 ;
LASTPRCI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;S BGPTX5=$O(^ICD0("AB",T,0)) ;get ICD PROC ien
+7 SET BGPTX5=+$$CODEN^ICDCODE(T,80.1)
+8 ;not a valid PROC
IF BGPTX5'>0
QUIT ""
+9 ;return value
SET BGPDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BGPDXBD=9999999-BDATE
SET BGPDXED=9999999-EDATE
+11 SET BGPDX1=BGPDXED-1
FOR
SET BGPDX1=$ORDER(^AUPNVPRC("AA",P,BGPDX1))
IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"")
QUIT
Begin DoDot:1
+12 SET BGPDX2=0
FOR
SET BGPDX2=$ORDER(^AUPNVPRC("AA",P,BGPDX1,BGPDX2))
IF BGPDX2'=+BGPDX2!(BGPDX4]"")
QUIT
Begin DoDot:2
+13 SET BGPDX3=$PIECE($GET(^AUPNVPRC(BGPDX2,0)),U)
+14 ;bad xref
IF BGPDX3=""
QUIT
+15 IF BGPTX5'=BGPDX3
QUIT
+16 SET BGPDX4=1_"^"_$PIECE($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT BGPDX4
FIRSTPRC(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""
+4 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+5 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+6 ;get taxonomy ien
SET BGPTX5=$ORDER(^ATXAX("B",T,0))
+7 ;not a valid taxonomy
IF BGPTX5=""
QUIT ""
+8 ;return value
SET BGPDX4=""
+9 SET BGPX=0
FOR
SET BGPX=$ORDER(^AUPNVPRC("AC",P,BGPX))
IF BGPX'=+BGPX!(BGPDX4]"")
QUIT
Begin DoDot:1
+10 SET BGPDX3=$PIECE($GET(^AUPNVPRC(BGPX,0)),U)
+11 ;BAD XREF
IF BGPDX3=""
QUIT
+12 IF '$$ICD^ATXCHK(BGPDX3,BGPTX5,0)
QUIT
+13 SET D=$PIECE(^AUPNVPRC(BGPX,0),U,3)
+14 IF 'D
QUIT
+15 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+16 IF D<BDATE
QUIT
+17 IF D>EDATE
QUIT
+18 SET BGPDX4=1_"^"_$PIECE($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_D_"^"_BGPDX3_"^"_BGPX
+19 QUIT
End DoDot:1
+20 QUIT BGPDX4
NMIREF(P,F,I,B,E) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+7 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+11 SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
End DoDot:1
+12 QUIT G
REFUSAL(P,F,I,B,E) ;EP (PAT,FILE,ITEM,BDT,EDT)
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 ;backup the begin date by 1 day to accomodate the > check below
+7 SET B=$$FMADD^XLFDT(B,-1)
+8 NEW G,X,Y,%DT
SET X=B
SET %DT="P"
DO ^%DT
SET B=Y
+9 SET X=E
SET %DT="P"
DO ^%DT
SET E=Y
+10 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,X))
IF X'=+X!(G)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
+11 QUIT G
MEDREF(PAT,BDT,EDT,TAX) ;EP
+1 NEW G,X,Y,%DT,NDC,NDCCODE,REASON,NDCF
+2 ;S X=BDT,%DT="P" D ^%DT S BDT=Y
+3 ;S X=EDT,%DT="P" D ^%DT S EDT=Y
+4 SET (ITEM,G)=0
FOR
SET ITEM=$ORDER(^AUPNPREF("AA",PAT,50,ITEM))
IF '+ITEM!(G)
QUIT
Begin DoDot:1
+5 ;See if this item is in the taxonomy
+6 SET NDC=$PIECE($GET(^PSDRUG(ITEM,2)),U,4)
+7 IF 'NDC
QUIT
+8 ;Setup the NDC code for a proper lookup in the taxonomy
+9 SET NDCCODE=$$RJ^XLFSTR($PIECE(NDC,"-"),5,0)_$$RJ^XLFSTR($PIECE(NDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(NDC,"-",3),2,0)
+10 ;call the taxonomy lookup
+11 SET NDCF=$$MEDTAX^BGPMUUT3(DFN,NDCCODE,TAX)
+12 IF +NDCF
Begin DoDot:2
+13 ;Now check dates and reason
+14 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",PAT,50,ITEM,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+15 SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",PAT,50,ITEM,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:4
+16 SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDT&(D'>EDT)
Begin DoDot:5
+17 SET REASON=$PIECE(^AUPNPREF(Y,0),U,7)
+18 IF REASON="R"!(REASON="N")
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT G
RADREF(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,71,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,71,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,71,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 SET C=$PIECE($GET(^RAMIS(71,I,0)),U,9)
IF C=""
QUIT
+10 IF '$$ICD^ATXCHK(C,T,1)
QUIT
+11 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT G
LABREF(P,BDATE,EDATE,LT,CT) ;EP - return date and reason for refusal of LAB (LOINC)
+1 ; P = Patient IEN
+2 ; BDATE = begin date to search
+3 ; EDATE = end date to search
+4 ; LT = Taxonomy name for LOINC check
+5 ; CT = Taxonomy name for CPT check
+6 IF '$GET(P)
QUIT ""
+7 IF $GET(LT)=""
QUIT ""
+8 IF $GET(EDATE)=""
QUIT ""
+9 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+10 NEW G,X,Y,Z,I
+11 SET C=""
+12 SET G=0
+13 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,60,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+14 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,60,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,60,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+15 SET BGPH=0
FOR
SET BGPH=$ORDER(^LAB(60,I,1,BGPH))
IF BGPH'>0
QUIT
Begin DoDot:3
+16 SET L=$PIECE($GET(^LAB(60,I,1,BGPH,95.3)),U,1)
+17 IF L'=""
IF $$LOINCREF(L,LT)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
+18 IF +G
QUIT
+19 SET C=$PIECE($GET(^LAB(60,I,1,BGPH,3)),U,1)
+20 IF L'=""
IF $$ICD^ATXCHK(C,CT,1)
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT G
LOINCREF(C,T) ;check taxonomy T for LOINC code; passed in LOINC code might not have the check digit
+1 NEW TIEN
+2 SET TIEN=""
SET TIEN=$ORDER(^ATXAX("B",T,TIEN))
IF 'TIEN
QUIT 0
+3 QUIT +$ORDER(^ATXAX(TIEN,21,"B",$PIECE(C,"-",1)_"-"))
+4 ;
LASTECOD(P,T,BDATE,EDATE) ;EP
+1 NEW BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPDX5,BGPDX6,BGPDX7,BGPDXBD,BGPDXED
+2 IF '$GET(P)
QUIT ""
+3 ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+4 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPDX5,BGPDX6,BGPDX7)=""
+5 ;if no date then set to DOB
IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 ;if no end date then set to today
IF $GET(EDATE)=""
SET EDATE=DT
+7 ;get taxonomy ien
SET BGPTX5=$ORDER(^ATXAX("B",T,0))
+8 ;not a valid taxonomy
IF BGPTX5=""
QUIT ""
+9 ;return value
SET BGPDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BGPDXBD=9999999-BDATE
SET BGPDXED=9999999-EDATE
+11 SET BGPDX1=BGPDXED-1
FOR
SET BGPDX1=$ORDER(^AUPNVPOV("AA",P,BGPDX1))
IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"")
QUIT
Begin DoDot:1
+12 SET BGPDX2=0
FOR
SET BGPDX2=$ORDER(^AUPNVPOV("AA",P,BGPDX1,BGPDX2))
IF BGPDX2'=+BGPDX2!(BGPDX4]"")
QUIT
Begin DoDot:2
+13 FOR BGPDX6=9,18,19
SET BGPDX3=$PIECE($GET(^AUPNVPOV(BGPDX2,0)),U,BGPDX6)
Begin DoDot:3
+14 ;no ecode
IF BGPDX3=""
QUIT
+15 IF $$ICD^ATXCHK(BGPDX3,BGPTX5,9)
SET BGPDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT BGPDX4
REFTAX(PAT,FILE,TAX,BEG,END) ;EP - refused an item in a taxonomy
+1 IF '$GET(PAT)
QUIT 0
+2 IF '$GET(FILE)
QUIT 0
+3 IF $GET(TAX)=""
QUIT 0
+4 IF $GET(BEG)=""
QUIT 0
+5 IF $GET(END)=""
QUIT 0
+6 NEW G,X,Y,%DT,T1,TIEN,T1PTR
+7 SET X=BEG
SET %DT="P"
DO ^%DT
SET BEG=Y
+8 ;S X=END,%DT="P" D ^%DT S E=Y
+9 ;get taxonomy ien
SET TIEN=$ORDER(^ATXAX("B",TAX,0))
+10 SET T1=0
SET G=""
FOR
SET T1=$ORDER(^ATXAX(TIEN,21,"B",T1))
IF T1=""!(G)
QUIT
Begin DoDot:1
+11 SET T1PTR=$SELECT(FILE=80:$PIECE($$ICDDX^ICDCODE(T1),U),FILE=80.1:$PIECE($$ICDOP^ICDCODE(T1),U),FILE=81:$PIECE($$CPT^ICPTCOD(T1),U),1:X)
+12 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",PAT,FILE,T1PTR,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+13 SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",PAT,FILE,T1PTR,X,Y))
IF Y'=+Y
QUIT
Begin DoDot:3
+14 SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BEG&(D'>END)
Begin DoDot:4
+15 IF $PIECE(^AUPNPREF(Y,0),U,7)="R"!($PIECE(^AUPNPREF(Y,0),U,7)="N")
SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)_"^"_T1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT G
CPTREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,81,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 IF '$$ICD^ATXCHK(I,T,1)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
PRCREFT(P,BDATE,EDATE,T) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF $GET(EDATE)=""
QUIT ""
+4 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+5 NEW G,X,Y,Z,I
+6 SET G=""
+7 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,80.1,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+8 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,80.1,I,X))
IF X'=+X!($PIECE(G,U))
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,80.1,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<BDATE&(D'>EDATE)
Begin DoDot:2
+9 IF '$$ICD^ATXCHK(I,T,0)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
LOINC(DFN,BDATE,EDATE,TAX) ;Retuns IEN of Lab test if pt has this LOINC code
+1 NEW IEN,CODE,B,E,D,L,G,X,J
+2 SET (CODE,B,E,D,L,G,X,J)=""
+3 SET IEN=$ORDER(^ATXAX("B",TAX,0))
+4 IF 'IEN
QUIT
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",DFN,D))
IF D'=+D!(D>B)!(G]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",DFN,D,L))
IF L'=+L!(G]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",DFN,D,L,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+10 IF $$LOINC2(J,IEN)
Begin DoDot:4
+11 SET G=(9999999-D)_U_X
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT G
+13 ;
LOINC2(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
SET CODE=%
QUIT 1
+6 QUIT ""
+7 ;
COLD(DFN,BDATE,EDATE,TAX) ;Retuns IEN of Lab test if pt has this LOINC code
+1 NEW IEN,CODE,COLDTE,B,E,D,L,G,X,J
+2 SET (CODE,B,E,D,L,G,X,J)=""
+3 SET IEN=$ORDER(^ATXAX("B",TAX,0))
+4 IF 'IEN
QUIT
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",DFN,D))
IF D'=+D!(D>B)!(G]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",DFN,D,L))
IF L'=+L!(G]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",DFN,D,L,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+10 SET COLDTE=$PIECE($GET(^AUPNVLAB(X,12)),U,1)
+11 IF COLDTE<BDATE!(COLDTE>EDATE)
QUIT
+12 IF $$LOINC2(J,IEN)
Begin DoDot:4
+13 SET G=(9999999-D)_U_X_U_$PIECE($GET(^AUPNVLAB(X,12)),U,1)
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT G
+15 ;
GETIMMS(P,EDATE,C,BGPX,CPTLST) ;EP
+1 KILL BGPX
+2 NEW X,Y,I,Z,V
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+5 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+6 ;happens too
IF 'Y
QUIT
+7 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+8 FOR Z=1:1:$LENGTH(C,U)
IF I=$PIECE(C,U,Z)
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
IF D]""
IF D'>EDATE
SET BGPX(D)=Y_U_V
+9 QUIT
End DoDot:1
+10 IF $DATA(CPTLST)
DO GIMMCPT(P,EDATE,CPTLST,.BGPX)
+11 QUIT
GIMMCPT(P,EDATE,CPTLST,BGPX) ;
+1 NEW V,G,X,Y,Z
+2 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+3 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+4 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+5 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+7 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF $$CPTCHK(CPTLST,Y)
SET BGPX(9999999-$PIECE(ED,"."))=Y_U_V_U_1
End DoDot:3
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+9 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF $$CPTCHK(CPTLST,Y)
SET BGPX(9999999-$PIECE(ED,"."))=Y_U_V_U_1
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
CPTCHK(CPTLST,Y) ;Check if variable Y is in CPTLST
+1 NEW I,FF
+2 SET FF=0
+3 FOR I=1:1:$LENGTH(CPTLST,U)
IF $PIECE(CPTLST,U,I)=Y
SET FF=1
QUIT
+4 QUIT FF
IMMREF(P,IMM,BD,ED) ;EP
+1 NEW X,Y,G,D,R
+2 IF 'IMM
QUIT ""
+3 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",IMM,0))
+4 IF 'Y
QUIT ""
+5 FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET R=$PIECE(^BIPC(X,0),U,3)
+7 IF R=""
QUIT
+8 IF '$DATA(^BICONT(R,0))
QUIT
+9 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+10 SET D=$PIECE(^BIPC(X,0),U,4)
+11 IF D=""
QUIT
+12 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+13 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+14 SET G=G+1
End DoDot:1
+15 QUIT G
