BGP2UTL1.m

BGP2UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2010 2:07 PM ;

 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 ;

 ;

SETPRC(P,BDATE,EDATE,T,BGPG) ;EP

 K BGPG

 NEW BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5

 ;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=0  ;return value

 F  S BGPDX1=$O(^AUPNVPRC("AC",P,BGPDX1)) Q:BGPDX1=""  D

 .S BGPDX3=$P($G(^AUPNVPRC(BGPDX1,0)),U)

 .Q:BGPDX3=""  ;bad

 .Q:'$$ICD^ATXCHK(BGPDX3,BGPTX5,0)

 .S BGPDX4=BGPDX4+1,BGPG(BGPDX4)=$$VD^APCLV($P(^AUPNVPRC(BGPDX1,0),U,3))_"^"_$P($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_$P($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_BGPDX1_";AUPNVPRC"_"^"_$P(^AUPNVPRC(BGPDX1,0),U,3)

 .Q

 Q

 ;

LASTDX(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 POV

 NEW BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5

 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 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:'$D(^ICD9(BGPDX3))

 ..Q:'$$ICD^ATXCHK(BGPDX3,BGPTX5,9)

 ..S BGPDX4=1_"^"_$P($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2

 ..Q

 .Q

 Q BGPDX4

LASTDXI(P,T,BDATE,EDATE,SC) ;EP

 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(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 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:'$$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

 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)  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

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)_U_$P(^ICPT(C,0),U)_U_$P(^RAMIS(71,I,0),U,1)

 .Q

 Q G

I1() ;EP

 I BGPVALUE="" Q 0

 I BGPINDW="E",BGPVALUE]"",BGPAGEB>64 Q 1

 I BGPINDW="E",BGPVALUE]"",BGPAGEB<65 Q 0

 I BGPVALUE]"" Q 1

 Q 0

I12() ;EP

 I BGPINDW="D" Q 1

 I BGPINDW="D",'BGPD4 Q 0

 I BGPINDW="E",(BGPD3+BGPD7) Q 1

 I BGPINDW="E",'(BGPD3+BGPD7) Q 0

 I BGPACTUP Q 1

 Q 0

I13() ;EP

 I BGPINDW="D",BGPD2 Q 1

 I BGPINDW="D",'BGPD2 Q 0

 I BGPINDW="E",(BGPD3+BGPD1) Q 1

 I BGPINDW="E",'(BGPD3+BGPD1) Q 0

 I (BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7) Q 1

 Q 0

IA() ;EP

 ;TESTING ONLY

 NEW X

 S X=BGPN1

 I BGPINDW="D",BGPD7,'X Q 1

 I BGPINDW="D",BGPD7,X Q 1   ;XXXX CHANGE TO Q 0 AFTER TESTING

 I BGPINDW="D",'BGPD7 Q 0

 I BGPINDW="C",BGPD8,'X Q 1

 I BGPINDW="C",BGPD8,X Q 1  ;XXXX CHANGE TO Q 0

 I BGPINDW="C",'BGPD8 Q 0

 I BGPINDW="S" I (BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8) Q $S(X:1,1:1)  ;LORI **** CHANGE x:1 TO x:0 AFTER TESTING

 Q 0

I17() ;EP

 I 'BGPD1 Q 0

 I BGPINDW="W" Q $S(BGPSEX="F":1,1:0)

 Q 1

I25() ;EP

 I BGPINDW="D" Q BGPDMD2

 I 'BGPD1 Q 0

 I BGPINDW="W" Q $S(BGPSEX="F":1,1:0)

 Q 1

LASTECOD(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 POV

 S (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5,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(P,F,T,B,E) ;EP - refused an item in a taxonomy

 I '$G(P) Q ""

 I '$G(F) Q ""

 I '$G(T) Q ""

 I $G(B)="" Q ""

 I $G(E)="" Q ""

 NEW G,X,Y,%DT,T1 S X=B,%DT="P" D ^%DT S B=Y

 S X=E,%DT="P" D ^%DT S E=Y

 S T1=0,G="" F  S T1=$O(^ATXAX(T,21,"B",T1)) Q:T1=""!(G)  D

 .S (X,G)=0 F  S X=$O(^AUPNPREF("AA",P,F,T1,X)) Q:X'=+X!(G)  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,F,T1,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

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)_"^"_$P(^ICPT(I,0),U)

 .Q

 Q G

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^ATXCHK(I,T,0)

 ..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)_"^"_$P($$ICDOP^ICDCODE(I),U,2)

 .Q

 Q G

STI16A() ;EP

 I 'BGPACTCL Q 0

 I BGPD4,(BGPD4'=BGPN9) Q 1

 I BGPN18 Q 1

 Q 0

STI16B() ;EP

 I 'BGPACTUP Q 0

 I BGPD4,(BGPD4'=BGPN9) Q 1

 I BGPN18 Q 1

 Q 0

BGP2UTL1  ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2010 2:07 PM ;

 +1       ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66

 +2       ;

 +3       ;

SETPRC(P,BDATE,EDATE,T,BGPG) ;EP

 +1        KILL BGPG

 +2        NEW BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5

 +3       ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V PROC

 +4        SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""

 +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=0

 +10       FOR 

               SET BGPDX1=$ORDER(^AUPNVPRC("AC",P,BGPDX1))

               IF BGPDX1=""

                   QUIT 

               Begin DoDot:1

 +11               SET BGPDX3=$PIECE($GET(^AUPNVPRC(BGPDX1,0)),U)

 +12      ;bad

                   IF BGPDX3=""

                       QUIT 

 +13               IF '$$ICD^ATXCHK(BGPDX3,BGPTX5,0)

                       QUIT 

 +14               SET BGPDX4=BGPDX4+1

                   SET BGPG(BGPDX4)=$$VD^APCLV($PIECE(^AUPNVPRC(BGPDX1,0),U,3))_"^"_$PIECE($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_$PIECE($$ICDOP^ICDCODE(BGPDX3),U,2)_"^"_BGPDX1_";AUPNVPRC"_"^"_$PIECE(^AUPNVPRC(BGPDX1,0),U,3)

 +15               QUIT 

               End DoDot:1

 +16       QUIT 

 +17      ;

LASTDX(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 POV

 +3        NEW BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5

 +4        SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""

 +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                       SET BGPDX3=$PIECE($GET(^AUPNVPOV(BGPDX2,0)),U)

 +14      ;bad xref

                           IF BGPDX3=""

                               QUIT 

 +15                       IF '$DATA(^ICD9(BGPDX3))

                               QUIT 

 +16                       IF '$$ICD^ATXCHK(BGPDX3,BGPTX5,9)

                               QUIT 

 +17                       SET BGPDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2

 +18                       QUIT 

                       End DoDot:2

 +19               QUIT 

               End DoDot:1

 +20       QUIT BGPDX4

LASTDXI(P,T,BDATE,EDATE,SC) ;EP

 +1        IF '$GET(P)

               QUIT ""

 +2        SET SC=$GET(SC)

 +3       ;RETURN BGPDX4=1 or 0^dx code^date found^IEN OF ICD CODE^IEN OF V POV

 +4        NEW BGPDX1,BGPDX2,BGPDX3,BGPDX5,BGPTX5,BGPDX4,BGPDXV

 +5        SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5)=""

 +6       ;if no date then set to DOB

           IF $GET(BDATE)=""

               SET BDATE=$PIECE(^DPT(P,0),U,3)

 +7       ;if no end date then set to today

           IF $GET(EDATE)=""

               SET EDATE=DT

 +8       ;S BGPTX5=$O(^ICD9("AB",T,0))  ;get taxonomy ien

 +9        SET BGPTX5=+$$CODEN^ICDCODE(T,80)

 +10      ;not a valid code

           IF BGPTX5'>0

               QUIT ""

 +11      ;return value

           SET BGPDX4=""

 +12      ;get inverse date and begin at edate-1 and end when greater than begin date

           SET BGPDXBD=9999999-BDATE

           SET BGPDXED=9999999-EDATE

 +13       SET BGPDX1=BGPDXED-1

           FOR 

               SET BGPDX1=$ORDER(^AUPNVPOV("AA",P,BGPDX1))

               IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"")

                   QUIT 

               Begin DoDot:1

 +14               SET BGPDX2=0

                   FOR 

                       SET BGPDX2=$ORDER(^AUPNVPOV("AA",P,BGPDX1,BGPDX2))

                       IF BGPDX2'=+BGPDX2!(BGPDX4]"")

                           QUIT 

                       Begin DoDot:2

 +15                       SET BGPDX3=$PIECE($GET(^AUPNVPOV(BGPDX2,0)),U)

 +16      ;bad xref

                           IF BGPDX3=""

                               QUIT 

 +17                       IF BGPDX3'=BGPTX5

                               QUIT 

 +18                       SET BGPDXV=$PIECE(^AUPNVPOV(BGPDX2,0),U,3)

 +19      ;no visit entry

                           IF '$DATA(^AUPNVSIT(BGPDXV,0))

                               QUIT 

 +20                       IF SC]""

                               IF SC'[$PIECE(^AUPNVSIT(BGPDXV,0),U,7)

 +21                       SET BGPDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2

 +22                       QUIT 

                       End DoDot:2

 +23               QUIT 

               End DoDot:1

 +24       QUIT BGPDX4

LASTPRC(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       ;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",P,BGPDX1))

               IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"")

                   QUIT 

               Begin DoDot:1

 +11               SET BGPDX2=0

                   FOR 

                       SET BGPDX2=$ORDER(^AUPNVPRC("AA",P,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