APCHSMU2 ; IHS/CMI/LAB - utilities for hmr ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;
;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^ATXAPI($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 APCHSVDT
;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 APCHSVDT=$P(+V,".") Q $P($P($G(^AUPNVSIT(V,0)),U),".")_"^"_$P($$CPT^ICPTCOD($P(^AUPNVCPT(G,0),U),APCHSVDT),U,2)
;cmi/anch/maw 8/28/2007 end of mods
Q ""
LASTDX(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
S (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
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 APCHTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I APCHTX5="" Q "" ;not a valid taxonomy
S APCHDX4="" ;return value
S APCHDXBD=9999999-BDATE,APCHDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S APCHDX1=APCHDXED-1 F S APCHDX1=$O(^AUPNVPOV("AA",P,APCHDX1)) Q:APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"") D
.S APCHDX2=0 F S APCHDX2=$O(^AUPNVPOV("AA",P,APCHDX1,APCHDX2)) Q:APCHDX2'=+APCHDX2!(APCHDX4]"") D
..S APCHDX3=$P($G(^AUPNVPOV(APCHDX2,0)),U)
..Q:APCHDX3="" ;bad xref
..Q:'$D(^ICD9(APCHDX3))
..Q:'$$ICD^ATXAPI(APCHDX3,APCHTX5,9)
..S APCHDX4=1_"^"_$P($$ICDDX^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
..Q
.Q
Q APCHDX4
LASTDXI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
NEW APCHDX1,APCHDX2,APCHDX3,APCHDX5,APCHTX5,APCHDXBD,APCHDXED
S (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
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 APCHTX5=+$$CODEABA^ICDEX(T,80)
I APCHTX5=""!(APCHTX5=-1) Q "" ;not a CODE
S APCHDX4="" ;return value
S APCHDXBD=9999999-BDATE,APCHDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S APCHDX1=APCHDXED-1 F S APCHDX1=$O(^AUPNVPOV("AA",P,APCHDX1)) Q:APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"") D
.S APCHDX2=0 F S APCHDX2=$O(^AUPNVPOV("AA",P,APCHDX1,APCHDX2)) Q:APCHDX2'=+APCHDX2!(APCHDX4]"") D
..S APCHDX3=$P($G(^AUPNVPOV(APCHDX2,0)),U)
..Q:APCHDX3="" ;bad xref
..Q:APCHDX3'=APCHTX5
..S APCHDX4=1_"^"_$P($$ICDDX^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
..Q
.Q
Q APCHDX4
LASTPRC(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
S (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
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 APCHTX5=$O(^ATXAX("B",T,0)) ;get taxonomy ien
I APCHTX5="" Q "" ;not a valid taxonomy
S APCHDX4="" ;return value
S APCHDXBD=9999999-BDATE,APCHDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S APCHDX1=APCHDXED-1 F S APCHDX1=$O(^AUPNVPRC("AA",P,APCHDX1)) Q:APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"") D
.S APCHDX2=0 F S APCHDX2=$O(^AUPNVPRC("AA",P,APCHDX1,APCHDX2)) Q:APCHDX2'=+APCHDX2!(APCHDX4]"") D
..S APCHDX3=$P($G(^AUPNVPRC(APCHDX2,0)),U)
..Q:APCHDX3="" ;bad xref
..Q:'$$ICD^ATXAPI(APCHDX3,APCHTX5,0)
..S APCHDX4=1_"^"_$P($$ICDOP^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
..Q
.Q
Q APCHDX4
;
LASTPRCI(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
S (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
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 APCHTX5=+$$CODEABA^ICDEX(T,80.1)
I APCHTX5=""!(APCHTX5=-1) Q "" ;not a valid PROC
S APCHDX4="" ;return value
S APCHDXBD=9999999-BDATE,APCHDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S APCHDX1=APCHDXED-1 F S APCHDX1=$O(^AUPNVPRC("AA",P,APCHDX1)) Q:APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"") D
.S APCHDX2=0 F S APCHDX2=$O(^AUPNVPRC("AA",P,APCHDX1,APCHDX2)) Q:APCHDX2'=+APCHDX2!(APCHDX4]"") D
..S APCHDX3=$P($G(^AUPNVPRC(APCHDX2,0)),U)
..Q:APCHDX3="" ;bad xref
..Q:APCHTX5'=APCHDX3
..S APCHDX4=1_"^"_$P($$ICDOP^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
..Q
.Q
Q APCHDX4
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 APCHDX4=1 or 0^CPT code^date found^IEN OF CPT CODE^IEN OF V CPT
NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
S (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
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 APCHTX5=+$$CODEN^ICPTCOD(T)
I APCHTX5="" Q "" ;not a valid CPT
S APCHDX4="" ;return value
S APCHDXBD=9999999-BDATE,APCHDXED=9999999-EDATE ;get inverse date and begin at edate-1 and end when greater than begin date
S APCHDX1=APCHDXED-1 F S APCHDX1=$O(^AUPNVCPT("AA",P,APCHTX5,APCHDX1)) Q:APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"") D
.S APCHDX2=0 F S APCHDX2=$O(^AUPNVCPT("AA",P,APCHTX5,APCHDX1,APCHDX2)) Q:APCHDX2'=+APCHDX2!(APCHDX4]"") D
..S APCHDX3=$P($G(^AUPNVCPT(APCHDX2,0)),U)
..Q:APCHDX3="" ;bad xref
..Q:APCHTX5'=APCHDX3
..S APCHDX4=1_"^"_$P($$CPT^ICPTCOD(APCHDX3),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
..Q
.Q
Q APCHDX4
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^ATXAPI(I,T,1)
..S G=$$TYPEREF^APCHSMU(Y)_$E($$VAL^XBDIQ1(81,I,$$FFD^APCHSMU(81)),1,(44-$L($$TYPEREF^APCHSMU(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^ATXAPI(C,T,1)
..S N=$P(^AUPNPREF(Y,0),U,7)
..S G=$$TYPEREF^APCHSMU(Y)_$E($$VAL^XBDIQ1(81,C,$$FFD^APCHSMU(81)),1,(44-$L($$TYPEREF^APCHSMU(Y))))_"^on "_$$FMTE^XLFDT(D)_"^"_D
.Q
Q G
;
LASTTD(P) ;EP
I '$G(P) Q ""
Q $$LASTTD^APCLAPI4(P)
PRCREFT(P,BDATE,EDATE,T) ;EP - return ien of proc
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^ATXAPI(I,T,0)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)_"^"_$P($$ICDOP^ICDEX(I,"","","I"),U,2)
.Q
Q G
MAMREF ;EP
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",76092,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",76090,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",76091,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",77055,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",77056,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",77057,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",77058,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D",77059,0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D","G0202",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D","G0204",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
S V=$$REF^APCHSMU(APCHSPAT,71,$O(^RAMIS(71,"D","G0206",0)),APCHLAST) I V]"" S X=$P(V,U) D S(X) S X=$P(V,U,2) I X]"" D S(X)
Q
S(X) ;
NEW %,C S (C,%)=0 F S %=$O(APCHSTEX(%)) Q:%'=+% S C=C+1
S APCHSTEX(C+1)=X
Q
APCHSMU2 ; IHS/CMI/LAB - utilities for hmr ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+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^ATXAPI($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 APCHSVDT
+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 APCHSVDT=$PIECE(+V,".")
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")_"^"_$PIECE($$CPT^ICPTCOD($PIECE(^AUPNVCPT(G,0),U),APCHSVDT),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 APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
+4 SET (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
+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 APCHTX5=$ORDER(^ATXAX("B",T,0))
+8 ;not a valid taxonomy
IF APCHTX5=""
QUIT ""
+9 ;return value
SET APCHDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET APCHDXBD=9999999-BDATE
SET APCHDXED=9999999-EDATE
+11 SET APCHDX1=APCHDXED-1
FOR
SET APCHDX1=$ORDER(^AUPNVPOV("AA",P,APCHDX1))
IF APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"")
QUIT
Begin DoDot:1
+12 SET APCHDX2=0
FOR
SET APCHDX2=$ORDER(^AUPNVPOV("AA",P,APCHDX1,APCHDX2))
IF APCHDX2'=+APCHDX2!(APCHDX4]"")
QUIT
Begin DoDot:2
+13 SET APCHDX3=$PIECE($GET(^AUPNVPOV(APCHDX2,0)),U)
+14 ;bad xref
IF APCHDX3=""
QUIT
+15 IF '$DATA(^ICD9(APCHDX3))
QUIT
+16 IF '$$ICD^ATXAPI(APCHDX3,APCHTX5,9)
QUIT
+17 SET APCHDX4=1_"^"_$PIECE($$ICDDX^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT APCHDX4
LASTDXI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV
+3 NEW APCHDX1,APCHDX2,APCHDX3,APCHDX5,APCHTX5,APCHDXBD,APCHDXED
+4 SET (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
+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 APCHTX5=+$$CODEABA^ICDEX(T,80)
+8 ;not a CODE
IF APCHTX5=""!(APCHTX5=-1)
QUIT ""
+9 ;return value
SET APCHDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET APCHDXBD=9999999-BDATE
SET APCHDXED=9999999-EDATE
+11 SET APCHDX1=APCHDXED-1
FOR
SET APCHDX1=$ORDER(^AUPNVPOV("AA",P,APCHDX1))
IF APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"")
QUIT
Begin DoDot:1
+12 SET APCHDX2=0
FOR
SET APCHDX2=$ORDER(^AUPNVPOV("AA",P,APCHDX1,APCHDX2))
IF APCHDX2'=+APCHDX2!(APCHDX4]"")
QUIT
Begin DoDot:2
+13 SET APCHDX3=$PIECE($GET(^AUPNVPOV(APCHDX2,0)),U)
+14 ;bad xref
IF APCHDX3=""
QUIT
+15 IF APCHDX3'=APCHTX5
QUIT
+16 SET APCHDX4=1_"^"_$PIECE($$ICDDX^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT APCHDX4
LASTPRC(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
+4 SET (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
+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 APCHTX5=$ORDER(^ATXAX("B",T,0))
+8 ;not a valid taxonomy
IF APCHTX5=""
QUIT ""
+9 ;return value
SET APCHDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET APCHDXBD=9999999-BDATE
SET APCHDXED=9999999-EDATE
+11 SET APCHDX1=APCHDXED-1
FOR
SET APCHDX1=$ORDER(^AUPNVPRC("AA",P,APCHDX1))
IF APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"")
QUIT
Begin DoDot:1
+12 SET APCHDX2=0
FOR
SET APCHDX2=$ORDER(^AUPNVPRC("AA",P,APCHDX1,APCHDX2))
IF APCHDX2'=+APCHDX2!(APCHDX4]"")
QUIT
Begin DoDot:2
+13 SET APCHDX3=$PIECE($GET(^AUPNVPRC(APCHDX2,0)),U)
+14 ;bad xref
IF APCHDX3=""
QUIT
+15 IF '$$ICD^ATXAPI(APCHDX3,APCHTX5,0)
QUIT
+16 SET APCHDX4=1_"^"_$PIECE($$ICDOP^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT APCHDX4
+20 ;
LASTPRCI(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;RETURN APCHDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC
+3 NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
+4 SET (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
+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 APCHTX5=+$$CODEABA^ICDEX(T,80.1)
+8 ;not a valid PROC
IF APCHTX5=""!(APCHTX5=-1)
QUIT ""
+9 ;return value
SET APCHDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET APCHDXBD=9999999-BDATE
SET APCHDXED=9999999-EDATE
+11 SET APCHDX1=APCHDXED-1
FOR
SET APCHDX1=$ORDER(^AUPNVPRC("AA",P,APCHDX1))
IF APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"")
QUIT
Begin DoDot:1
+12 SET APCHDX2=0
FOR
SET APCHDX2=$ORDER(^AUPNVPRC("AA",P,APCHDX1,APCHDX2))
IF APCHDX2'=+APCHDX2!(APCHDX4]"")
QUIT
Begin DoDot:2
+13 SET APCHDX3=$PIECE($GET(^AUPNVPRC(APCHDX2,0)),U)
+14 ;bad xref
IF APCHDX3=""
QUIT
+15 IF APCHTX5'=APCHDX3
QUIT
+16 SET APCHDX4=1_"^"_$PIECE($$ICDOP^ICDEX(APCHDX3,,,"I"),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT APCHDX4
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 APCHDX4=1 or 0^CPT code^date found^IEN OF CPT CODE^IEN OF V CPT
+3 NEW APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5,APCHDXBD,APCHDXED
+4 SET (APCHDX1,APCHDX2,APCHDX3,APCHDX4,APCHTX5)=""
+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 APCHTX5=+$$CODEN^ICPTCOD(T)
+8 ;not a valid CPT
IF APCHTX5=""
QUIT ""
+9 ;return value
SET APCHDX4=""
+10 ;get inverse date and begin at edate-1 and end when greater than begin date
SET APCHDXBD=9999999-BDATE
SET APCHDXED=9999999-EDATE
+11 SET APCHDX1=APCHDXED-1
FOR
SET APCHDX1=$ORDER(^AUPNVCPT("AA",P,APCHTX5,APCHDX1))
IF APCHDX1=""!(APCHDX1>APCHDXBD)!(APCHDX4]"")
QUIT
Begin DoDot:1
+12 SET APCHDX2=0
FOR
SET APCHDX2=$ORDER(^AUPNVCPT("AA",P,APCHTX5,APCHDX1,APCHDX2))
IF APCHDX2'=+APCHDX2!(APCHDX4]"")
QUIT
Begin DoDot:2
+13 SET APCHDX3=$PIECE($GET(^AUPNVCPT(APCHDX2,0)),U)
+14 ;bad xref
IF APCHDX3=""
QUIT
+15 IF APCHTX5'=APCHDX3
QUIT
+16 SET APCHDX4=1_"^"_$PIECE($$CPT^ICPTCOD(APCHDX3),U,2)_"^"_(9999999-APCHDX1)_"^"_APCHDX3_"^"_APCHDX2
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT APCHDX4
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^ATXAPI(I,T,1)
QUIT
+10 SET G=$$TYPEREF^APCHSMU(Y)_$EXTRACT($$VAL^XBDIQ1(81,I,$$FFD^APCHSMU(81)),1,(44-$LENGTH($$TYPEREF^APCHSMU(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^ATXAPI(C,T,1)
QUIT
+11 SET N=$PIECE(^AUPNPREF(Y,0),U,7)
+12 SET G=$$TYPEREF^APCHSMU(Y)_$EXTRACT($$VAL^XBDIQ1(81,C,$$FFD^APCHSMU(81)),1,(44-$LENGTH($$TYPEREF^APCHSMU(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)
PRCREFT(P,BDATE,EDATE,T) ;EP - return ien of proc
+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^ATXAPI(I,T,0)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)_"^"_$PIECE($$ICDOP^ICDEX(I,"","","I"),U,2)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
MAMREF ;EP
+1 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",76092,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+2 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",76090,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+3 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",76091,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+4 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",77055,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+5 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",77056,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+6 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",77057,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+7 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",77058,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+8 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D",77059,0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+9 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D","G0202",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+10 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D","G0204",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+11 SET V=$$REF^APCHSMU(APCHSPAT,71,$ORDER(^RAMIS(71,"D","G0206",0)),APCHLAST)
IF V]""
SET X=$PIECE(V,U)
DO S(X)
SET X=$PIECE(V,U,2)
IF X]""
DO S(X)
+12 QUIT
S(X) ;
+1 NEW %,C
SET (C,%)=0
FOR
SET %=$ORDER(APCHSTEX(%))
IF %'=+%
QUIT
SET C=C+1
+2 SET APCHSTEX(C+1)=X
+3 QUIT
