BDMSMU2 ; IHS/CMI/LAB - utilities for hmr ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,8,9**;JUN 14, 2007;Build 78
;
;
;cmi/anch/maw 8/28/2007 code set versioning in CPT
;
WH(P,BDATE,EDATE,T,F) ;EP
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through procedures in a date range for this patient, check proc type
NEW D,X,Y,G,V
S (G,V)=0 F S V=$O(^BWPCD("C",P,V)) Q:V=""!(G) D
.Q:'$D(^BWPCD(V,0))
.I $P(^BWPCD(V,0),U,4)'=T Q
.S D=$P(^BWPCD(V,0),U,12)
.Q:D<BDATE
.Q:D>EDATE
.S G=V
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S D=$P(^BWPCD(G,0),U,12) Q D
I F=4 S D=$P(^BWPCD(G,0),U,12) Q $$FMTE^XLFDT(D)
Q ""
;
CPT(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" Q ""
I $G(BDATE)="" S BDATE=$$FMADD^XLFDT(EDATE,-365)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^BDMUTL($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
;cmi/anch/maw 8/28/2007 mods for code set versioning
N BDMSVDT
;I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^ICPT($P(^AUPNVCPT(G,0),U),0),U)
I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V S BDMSVDT=$P(+V,".") Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U),BDMSVDT),U,2)
;cmi/anch/maw 8/28/2007 end of mods
Q ""
LASTDX(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
S (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
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 BDMTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BDMTX5="" Q "" ;not a valid taxonomy
S BDMDX4="" ;return value
S BDMDXBD=9999999-BDATE,BDMDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BDMDX1=BDMDXED-1 F S BDMDX1=$O(^AUPNVPOV("AA",P,BDMDX1)) Q:BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"") D
.S BDMDX2=0 F S BDMDX2=$O(^AUPNVPOV("AA",P,BDMDX1,BDMDX2)) Q:BDMDX2'=+BDMDX2!(BDMDX4]"") D
..S BDMDX3=$P($G(^AUPNVPOV(BDMDX2,0)),U)
..Q:BDMDX3="" ;bad xref
..Q:'$D(^ICD9(BDMDX3))
..Q:'$$ICD^BDMUTL(BDMDX3,BDMTX5,9)
..S BDMDX4=1_"^"_$P($$ICDDX^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
..Q
.Q
Q BDMDX4
LASTDXI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
NEW BDMDX1,BDMDX2,BDMDX3,BDMDX5,BDMTX5,BDMDXBD,BDMDXED
S (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
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 BDMTX5=+$$CODEN^BDMUTL(T,80) ;cmi/maw 5/13/2014 patch 8 ICD-10
;S BDMTX5=+$$CODEN^ICDCODE(T,80)
I BDMTX5=""!(BDMTX5=-1) Q "" ;not a CODE
S BDMDX4="" ;return value
S BDMDXBD=9999999-BDATE,BDMDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BDMDX1=BDMDXED-1 F S BDMDX1=$O(^AUPNVPOV("AA",P,BDMDX1)) Q:BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"") D
.S BDMDX2=0 F S BDMDX2=$O(^AUPNVPOV("AA",P,BDMDX1,BDMDX2)) Q:BDMDX2'=+BDMDX2!(BDMDX4]"") D
..S BDMDX3=$P($G(^AUPNVPOV(BDMDX2,0)),U)
..Q:BDMDX3="" ;bad xref
..Q:BDMDX3'=BDMTX5
..S BDMDX4=1_"^"_$P($$ICDDX^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
..Q
.Q
Q BDMDX4
LASTPRC(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
S (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
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 BDMTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I BDMTX5="" Q "" ;not a valid taxonomy
S BDMDX4="" ;return value
S BDMDXBD=9999999-BDATE,BDMDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BDMDX1=BDMDXED-1 F S BDMDX1=$O(^AUPNVPRC("AA",P,BDMDX1)) Q:BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"") D
.S BDMDX2=0 F S BDMDX2=$O(^AUPNVPRC("AA",P,BDMDX1,BDMDX2)) Q:BDMDX2'=+BDMDX2!(BDMDX4]"") D
..S BDMDX3=$P($G(^AUPNVPRC(BDMDX2,0)),U)
..Q:BDMDX3="" ;bad xref
..Q:'$$ICD^BDMUTL(BDMDX3,BDMTX5,0)
..S BDMDX4=1_"^"_$P($$ICDOP^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
..Q
.Q
Q BDMDX4
;
LASTPRCI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
S (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
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 BDMTX5=+$$CODEN^BDMUTL(T,80.1) ;cmi/maw 5/13/2014 patch 8 ICD-10
;S BDMTX5=+$$CODEN^ICDCODE(T,80.1)
I BDMTX5=""!(BDMTX5=-1) Q "" ;not a valid PROC
S BDMDX4="" ;return value
S BDMDXBD=9999999-BDATE,BDMDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BDMDX1=BDMDXED-1 F S BDMDX1=$O(^AUPNVPRC("AA",P,BDMDX1)) Q:BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"") D
.S BDMDX2=0 F S BDMDX2=$O(^AUPNVPRC("AA",P,BDMDX1,BDMDX2)) Q:BDMDX2'=+BDMDX2!(BDMDX4]"") D
..S BDMDX3=$P($G(^AUPNVPRC(BDMDX2,0)),U)
..Q:BDMDX3="" ;bad xref
..Q:BDMTX5'=BDMDX3
..S BDMDX4=1_"^"_$P($$ICDOP^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
..Q
.Q
Q BDMDX4
CPTI(P,BDATE,EDATE,CPTI) ;EP - did patient have this cpt (ien) in date range
I '$G(P) Q ""
I $G(CPTI)="" Q ""
I $G(BDATE)="" Q ""
I $G(EDATE)="" Q ""
I '$D(^ICPT(CPTI)) Q "" ;not a valid cpt ien
I '$D(^AUPNVCPT("AA",P)) Q "" ;no cpts for this patient
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE-1,BD=9999999-BDATE,G=""
F S ED=$O(^AUPNVCPT("AA",P,CPTI,ED)) Q:ED=""!($P(ED,".")>BD)!(G) S G="1"_"^"_(9999999-ED)
Q G
;
LASTCPTI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN BDMDX4=1 or 0^CPT code^date found^IEN OF CPT CODE^IEN OF V CPT
NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
S (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
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 BDMTX5=+$$CODEN^ICPTCOD(T)
I BDMTX5="" Q "" ;not a valid CPT
S BDMDX4="" ;return value
S BDMDXBD=9999999-BDATE,BDMDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S BDMDX1=BDMDXED-1 F S BDMDX1=$O(^AUPNVCPT("AA",P,BDMTX5,BDMDX1)) Q:BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"") D
.S BDMDX2=0 F S BDMDX2=$O(^AUPNVCPT("AA",P,BDMTX5,BDMDX1,BDMDX2)) Q:BDMDX2'=+BDMDX2!(BDMDX4]"") D
..S BDMDX3=$P($G(^AUPNVCPT(BDMDX2,0)),U)
..Q:BDMDX3="" ;bad xref
..Q:BDMTX5'=BDMDX3
..S BDMDX4=1_"^"_$P($$CPT^ICPTCOD(BDMDX3),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
..Q
.Q
Q BDMDX4
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=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^BDMUTL(I,T,1)
..S G=$$TYPEREF^BDMSMU(Y)_$E($$VAL^XBDIQ1(81,I,$$FFD^BDMSMU(81)),1,(44-$L($$TYPEREF^BDMSMU(Y))))_"^on "_$$FMTE^XLFDT(D)_"^"_D
.Q
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,C
S G=""
S I=0 F S I=$O(^AUPNPREF("AA",P,71,I)) Q:I=""!($P(G,U)]"") D
.S X=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^BDMUTL(C,T,1)
..S N=$P(^AUPNPREF(Y,0),U,7)
..S G=$$TYPEREF^BDMSMU(Y)_$E($$VAL^XBDIQ1(81,C,$$FFD^BDMSMU(81)),1,(44-$L($$TYPEREF^BDMSMU(Y))))_"^on "_$$FMTE^XLFDT(D)_"^"_D
.Q
Q G
;
LASTTD(P) ;EP
I '$G(P) Q ""
Q $$LASTTD^APCLAPI4(P)
BDMSMU2 ; IHS/CMI/LAB - utilities for hmr ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,8,9**;JUN 14, 2007;Build 78
+2 ;
+3 ;
+4 ;cmi/anch/maw 8/28/2007 code set versioning in CPT
+5 ;
WH(P,BDATE,EDATE,T,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through procedures in a date range for this patient, check proc type
+7 NEW D,X,Y,G,V
+8 SET (G,V)=0
FOR
SET V=$ORDER(^BWPCD("C",P,V))
IF V=""!(G)
QUIT
Begin DoDot:1
+9 IF '$DATA(^BWPCD(V,0))
QUIT
+10 IF $PIECE(^BWPCD(V,0),U,4)'=T
QUIT
+11 SET D=$PIECE(^BWPCD(V,0),U,12)
+12 IF D<BDATE
QUIT
+13 IF D>EDATE
QUIT
+14 SET G=V
+15 QUIT
End DoDot:1
+16 IF 'G
QUIT ""
+17 IF F=1
QUIT $SELECT(G:1,1:"")
+18 IF F=2
QUIT G
+19 IF F=3
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT D
+20 IF F=4
SET D=$PIECE(^BWPCD(G,0),U,12)
QUIT $$FMTE^XLFDT(D)
+21 QUIT ""
+22 ;
CPT(P,BDATE,EDATE,T,F) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF $$ICD^BDMUTL($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 ;cmi/anch/maw 8/28/2007 mods for code set versioning
+24 NEW BDMSVDT
+25 ;I F=5 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P(^ICPT($P(^AUPNVCPT(G,0),U),0),U)
+26 IF F=5
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
SET BDMSVDT=$PIECE(+V,".")
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U),BDMSVDT),U,2)
+27 ;cmi/anch/maw 8/28/2007 end of mods
+28 QUIT ""
LASTDX(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
+4 SET (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
+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 BDMTX5=$ORDER(^ATXAX("B",T,0))
+8 ;not a valid taxonomy
IF BDMTX5=""
QUIT ""
+9 ;return value
SET BDMDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BDMDXBD=9999999-BDATE
SET BDMDXED=9999999-EDATE
+11 SET BDMDX1=BDMDXED-1
FOR
SET BDMDX1=$ORDER(^AUPNVPOV("AA",P,BDMDX1))
IF BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"")
QUIT
Begin DoDot:1
+12 SET BDMDX2=0
FOR
SET BDMDX2=$ORDER(^AUPNVPOV("AA",P,BDMDX1,BDMDX2))
IF BDMDX2'=+BDMDX2!(BDMDX4]"")
QUIT
Begin DoDot:2
+13 SET BDMDX3=$PIECE($GET(^AUPNVPOV(BDMDX2,0)),U)
+14 ;bad xref
IF BDMDX3=""
QUIT
+15 IF '$DATA(^ICD9(BDMDX3))
QUIT
+16 IF '$$ICD^BDMUTL(BDMDX3,BDMTX5,9)
QUIT
+17 SET BDMDX4=1_"^"_$PIECE($$ICDDX^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT BDMDX4
LASTDXI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 NEW BDMDX1,BDMDX2,BDMDX3,BDMDX5,BDMTX5,BDMDXBD,BDMDXED
+4 SET (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
+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 ;cmi/maw 5/13/2014 patch 8 ICD-10
SET BDMTX5=+$$CODEN^BDMUTL(T,80)
+8 ;S BDMTX5=+$$CODEN^ICDCODE(T,80)
+9 ;not a CODE
IF BDMTX5=""!(BDMTX5=-1)
QUIT ""
+10 ;return value
SET BDMDX4=""
+11 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BDMDXBD=9999999-BDATE
SET BDMDXED=9999999-EDATE
+12 SET BDMDX1=BDMDXED-1
FOR
SET BDMDX1=$ORDER(^AUPNVPOV("AA",P,BDMDX1))
IF BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"")
QUIT
Begin DoDot:1
+13 SET BDMDX2=0
FOR
SET BDMDX2=$ORDER(^AUPNVPOV("AA",P,BDMDX1,BDMDX2))
IF BDMDX2'=+BDMDX2!(BDMDX4]"")
QUIT
Begin DoDot:2
+14 SET BDMDX3=$PIECE($GET(^AUPNVPOV(BDMDX2,0)),U)
+15 ;bad xref
IF BDMDX3=""
QUIT
+16 IF BDMDX3'=BDMTX5
QUIT
+17 SET BDMDX4=1_"^"_$PIECE($$ICDDX^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT BDMDX4
LASTPRC(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
+4 SET (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
+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 BDMTX5=$ORDER(^ATXAX("B",T,0))
+8 ;not a valid taxonomy
IF BDMTX5=""
QUIT ""
+9 ;return value
SET BDMDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BDMDXBD=9999999-BDATE
SET BDMDXED=9999999-EDATE
+11 SET BDMDX1=BDMDXED-1
FOR
SET BDMDX1=$ORDER(^AUPNVPRC("AA",P,BDMDX1))
IF BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"")
QUIT
Begin DoDot:1
+12 SET BDMDX2=0
FOR
SET BDMDX2=$ORDER(^AUPNVPRC("AA",P,BDMDX1,BDMDX2))
IF BDMDX2'=+BDMDX2!(BDMDX4]"")
QUIT
Begin DoDot:2
+13 SET BDMDX3=$PIECE($GET(^AUPNVPRC(BDMDX2,0)),U)
+14 ;bad xref
IF BDMDX3=""
QUIT
+15 IF '$$ICD^BDMUTL(BDMDX3,BDMTX5,0)
QUIT
+16 SET BDMDX4=1_"^"_$PIECE($$ICDOP^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT BDMDX4
+20 ;
LASTPRCI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BDMDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
+4 SET (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
+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 ;cmi/maw 5/13/2014 patch 8 ICD-10
SET BDMTX5=+$$CODEN^BDMUTL(T,80.1)
+8 ;S BDMTX5=+$$CODEN^ICDCODE(T,80.1)
+9 ;not a valid PROC
IF BDMTX5=""!(BDMTX5=-1)
QUIT ""
+10 ;return value
SET BDMDX4=""
+11 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BDMDXBD=9999999-BDATE
SET BDMDXED=9999999-EDATE
+12 SET BDMDX1=BDMDXED-1
FOR
SET BDMDX1=$ORDER(^AUPNVPRC("AA",P,BDMDX1))
IF BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"")
QUIT
Begin DoDot:1
+13 SET BDMDX2=0
FOR
SET BDMDX2=$ORDER(^AUPNVPRC("AA",P,BDMDX1,BDMDX2))
IF BDMDX2'=+BDMDX2!(BDMDX4]"")
QUIT
Begin DoDot:2
+14 SET BDMDX3=$PIECE($GET(^AUPNVPRC(BDMDX2,0)),U)
+15 ;bad xref
IF BDMDX3=""
QUIT
+16 IF BDMTX5'=BDMDX3
QUIT
+17 SET BDMDX4=1_"^"_$PIECE($$ICDOP^BDMUTL(BDMDX3,,,"I"),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT BDMDX4
CPTI(P,BDATE,EDATE,CPTI) ;EP - did patient have this cpt (ien) in date range
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(CPTI)=""
QUIT ""
+3 IF $GET(BDATE)=""
QUIT ""
+4 IF $GET(EDATE)=""
QUIT ""
+5 ;not a valid cpt ien
IF '$DATA(^ICPT(CPTI))
QUIT ""
+6 ;no cpts for this patient
IF '$DATA(^AUPNVCPT("AA",P))
QUIT ""
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE-1
SET BD=9999999-BDATE
SET G=""
+9 FOR
SET ED=$ORDER(^AUPNVCPT("AA",P,CPTI,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
SET G="1"_"^"_(9999999-ED)
+10 QUIT G
+11 ;
LASTCPTI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN BDMDX4=1 or 0^CPT code^date found^IEN OF CPT CODE^IEN OF V CPT
+3 NEW BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5,BDMDXBD,BDMDXED
+4 SET (BDMDX1,BDMDX2,BDMDX3,BDMDX4,BDMTX5)=""
+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 SET BDMTX5=+$$CODEN^ICPTCOD(T)
+8 ;not a valid CPT
IF BDMTX5=""
QUIT ""
+9 ;return value
SET BDMDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET BDMDXBD=9999999-BDATE
SET BDMDXED=9999999-EDATE
+11 SET BDMDX1=BDMDXED-1
FOR
SET BDMDX1=$ORDER(^AUPNVCPT("AA",P,BDMTX5,BDMDX1))
IF BDMDX1=""!(BDMDX1>BDMDXBD)!(BDMDX4]"")
QUIT
Begin DoDot:1
+12 SET BDMDX2=0
FOR
SET BDMDX2=$ORDER(^AUPNVCPT("AA",P,BDMTX5,BDMDX1,BDMDX2))
IF BDMDX2'=+BDMDX2!(BDMDX4]"")
QUIT
Begin DoDot:2
+13 SET BDMDX3=$PIECE($GET(^AUPNVCPT(BDMDX2,0)),U)
+14 ;bad xref
IF BDMDX3=""
QUIT
+15 IF BDMTX5'=BDMDX3
QUIT
+16 SET BDMDX4=1_"^"_$PIECE($$CPT^ICPTCOD(BDMDX3),U,2)_"^"_(9999999-BDMDX1)_"^"_BDMDX3_"^"_BDMDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT BDMDX4
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=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^BDMUTL(I,T,1)
QUIT
+10 SET G=$$TYPEREF^BDMSMU(Y)_$EXTRACT($$VAL^XBDIQ1(81,I,$$FFD^BDMSMU(81)),1,(44-$LENGTH($$TYPEREF^BDMSMU(Y))))_"^on "_$$FMTE^XLFDT(D)_"^"_D
End DoDot:2
+11 QUIT
End DoDot:1
+12 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,C
+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=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^BDMUTL(C,T,1)
QUIT
+11 SET N=$PIECE(^AUPNPREF(Y,0),U,7)
+12 SET G=$$TYPEREF^BDMSMU(Y)_$EXTRACT($$VAL^XBDIQ1(81,C,$$FFD^BDMSMU(81)),1,(44-$LENGTH($$TYPEREF^BDMSMU(Y))))_"^on "_$$FMTE^XLFDT(D)_"^"_D
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT G
+15 ;
LASTTD(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 QUIT $$LASTTD^APCLAPI4(P)
