APCHSMU2.m

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