BGP3UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2010 2:07 PM ; 19 Feb 2013 11:40 AM
;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
;
;
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 BGPINDH="E",BGPVALUE]"",BGPAGEB>64 Q 1
I BGPINDH="E",BGPVALUE]"",BGPAGEB<65 Q 0
I BGPVALUE]"" Q 1
Q 0
I12() ;EP
I BGPINDH="D" Q 1
I BGPINDH="D",'BGPD4 Q 0
I BGPINDH="E",(BGPD3+BGPD7) Q 1
I BGPINDH="E",'(BGPD3+BGPD7) Q 0
I BGPACTUP Q 1
Q 0
I13() ;EP
I BGPINDH="D",BGPD2 Q 1
I BGPINDH="D",'BGPD2 Q 0
I BGPINDH="E",(BGPD3+BGPD1) Q 1
I BGPINDH="E",'(BGPD3+BGPD1) Q 0
I (BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9) Q 1
Q 0
IA() ;EP
;TESTING ONLY
NEW X
S X=BGPN1
I BGPINDH="D",BGPD7,'X Q 1
I BGPINDH="D",BGPD7,X Q 1 ;XXXX CHANGE TO Q 0 AFTER TESTING
I BGPINDH="D",'BGPD7 Q 0
I BGPINDH="C",BGPD8,'X Q 1
I BGPINDH="C",BGPD8,X Q 1 ;XXXX CHANGE TO Q 0
I BGPINDH="C",'BGPD8 Q 0
I BGPINDH="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 BGPINDH="W" Q $S(BGPSEX="F":1,1:0)
Q 1
I25() ;EP
I BGPINDH="D" Q BGPDMD2
I 'BGPD1 Q 0
I BGPINDH="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
BGP3UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2010 2:07 PM ; 19 Feb 2013 11:40 AM
+1 ;;13.0;IHS CLINICAL REPORTING;**1**;NOV 20, 2012;Build 7
+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
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
+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
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)
+9 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)_U_$PIECE(^ICPT(C,0),U)_U_$PIECE(^RAMIS(71,I,0),U,1)
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT G
I1() ;EP
+1 IF BGPVALUE=""
QUIT 0
+2 IF BGPINDH="E"
IF BGPVALUE]""
IF BGPAGEB>64
QUIT 1
+3 IF BGPINDH="E"
IF BGPVALUE]""
IF BGPAGEB<65
QUIT 0
+4 IF BGPVALUE]""
QUIT 1
+5 QUIT 0
I12() ;EP
+1 IF BGPINDH="D"
QUIT 1
+2 IF BGPINDH="D"
IF 'BGPD4
QUIT 0
+3 IF BGPINDH="E"
IF (BGPD3+BGPD7)
QUIT 1
+4 IF BGPINDH="E"
IF '(BGPD3+BGPD7)
QUIT 0
+5 IF BGPACTUP
QUIT 1
+6 QUIT 0
I13() ;EP
+1 IF BGPINDH="D"
IF BGPD2
QUIT 1
+2 IF BGPINDH="D"
IF 'BGPD2
QUIT 0
+3 IF BGPINDH="E"
IF (BGPD3+BGPD1)
QUIT 1
+4 IF BGPINDH="E"
IF '(BGPD3+BGPD1)
QUIT 0
+5 IF (BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9)
QUIT 1
+6 QUIT 0
IA() ;EP
+1 ;TESTING ONLY
+2 NEW X
+3 SET X=BGPN1
+4 IF BGPINDH="D"
IF BGPD7
IF 'X
QUIT 1
+5 ;XXXX CHANGE TO Q 0 AFTER TESTING
IF BGPINDH="D"
IF BGPD7
IF X
QUIT 1
+6 IF BGPINDH="D"
IF 'BGPD7
QUIT 0
+7 IF BGPINDH="C"
IF BGPD8
IF 'X
QUIT 1
+8 ;XXXX CHANGE TO Q 0
IF BGPINDH="C"
IF BGPD8
IF X
QUIT 1
+9 IF BGPINDH="C"
IF 'BGPD8
QUIT 0
+10 ;LORI **** CHANGE x:1 TO x:0 AFTER TESTING
IF BGPINDH="S"
IF (BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8)
QUIT $SELECT(X:1,1:1)
+11 QUIT 0
I17() ;EP
+1 IF 'BGPD1
QUIT 0
+2 IF BGPINDH="W"
QUIT $SELECT(BGPSEX="F":1,1:0)
+3 QUIT 1
I25() ;EP
+1 IF BGPINDH="D"
QUIT BGPDMD2
+2 IF 'BGPD1
QUIT 0
+3 IF BGPINDH="W"
QUIT $SELECT(BGPSEX="F":1,1:0)
+4 QUIT 1
LASTECOD(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 SET (BGPDX1,BGPDX2,BGPDX3,BGPDX4,BGPTX5,BGPDX6,BGPDX7)=""
+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(^AUPNVPOV("AA",P,BGPDX1))
IF BGPDX1=""!(BGPDX1>BGPDXBD)!(BGPDX4]"")
QUIT
Begin DoDot:1
+11 SET BGPDX2=0
FOR
SET BGPDX2=$ORDER(^AUPNVPOV("AA",P,BGPDX1,BGPDX2))
IF BGPDX2'=+BGPDX2!(BGPDX4]"")
QUIT
Begin DoDot:2
+12 FOR BGPDX6=9,18,19
SET BGPDX3=$PIECE($GET(^AUPNVPOV(BGPDX2,0)),U,BGPDX6)
Begin DoDot:3
+13 ;no ecode
IF BGPDX3=""
QUIT
+14 IF $$ICD^ATXCHK(BGPDX3,BGPTX5,9)
SET BGPDX4=1_"^"_$PIECE($$ICDDX^ICDCODE(BGPDX3),U,2)_"^"_(9999999-BGPDX1)_"^"_BGPDX3_"^"_BGPDX2
End DoDot:3
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT BGPDX4
REFTAX(P,F,T,B,E) ;EP - refused an item in a taxonomy
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(T)
QUIT ""
+4 IF $GET(B)=""
QUIT ""
+5 IF $GET(E)=""
QUIT ""
+6 NEW G,X,Y,%DT,T1
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 T1=0
SET G=""
FOR
SET T1=$ORDER(^ATXAX(T,21,"B",T1))
IF T1=""!(G)
QUIT
Begin DoDot:1
+9 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,T1,X))
IF X'=+X!(G)
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,F,T1,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)
End DoDot:1
+10 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)_"^"_$PIECE(^ICPT(I,0),U)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
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^ATXCHK(I,T,0)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)_"^"_$PIECE($$ICDOP^ICDCODE(I),U,2)
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT G
STI16A() ;EP
+1 IF 'BGPACTCL
QUIT 0
+2 IF BGPD4
IF (BGPD4'=BGPN9)
QUIT 1
+3 IF BGPN18
QUIT 1
+4 QUIT 0
STI16B() ;EP
+1 IF 'BGPACTUP
QUIT 0
+2 IF BGPD4
IF (BGPD4'=BGPN9)
QUIT 1
+3 IF BGPN18
QUIT 1
+4 QUIT 0
