BGP6UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2010 2:07 PM 19 Feb 2016 11:40 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
;
LABEL(ID,RT,PT,IT,ND) ;EP
I $G(ID)="" Q ""
S IT=$G(IT)
NEW L,X,Y
;GET L LABEL AND THEN PASS BACK AS IS FOR DELIMITED OR ^ PIECED FOR PRINTED
I ND="D" D
.I RT=1 S L=$$VAL^XBDIQ1(90556.02,ID,2501) Q ;NG
.I RT=9 S L=$$VAL^XBDIQ1(90556.02,ID,2601) Q ;DEV
.I RT=7 S L=$$VAL^XBDIQ1(90556.02,ID,2701) Q ;ONM
.I RT=4 D Q
..I IT="D" S L=$$VAL^XBDIQ1(90556.02,ID,2801) Q ;DM
..I IT="C" S L=$$VAL^XBDIQ1(90556.02,ID,2901) Q ;CVD
..I IT="W" S L=$$VAL^XBDIQ1(90556.02,ID,3101) Q ;WH
..I IT="P" S L=$$VAL^XBDIQ1(90556.02,ID,3201) Q ;PQA
..I IT="I" S L=$$VAL^XBDIQ1(90556.02,ID,3301) Q ;IPC
..I IT="A" S L=$$VAL^XBDIQ1(90556.02,ID,3401) Q ;AST
..S L=$$VAL^XBDIQ1(90556.02,ID,2401) Q
.S L=$$VAL^XBDIQ1(90556.02,ID,2401)
;NUMERATOR
I ND="N" D
.I RT=1 S L=$$VAL^XBDIQ1(90556.02,ID,2502) Q ;NG
.I RT=9 S L=$$VAL^XBDIQ1(90556.02,ID,2602) Q ;DEV
.I RT=7 S L=$$VAL^XBDIQ1(90556.02,ID,2702) Q ;ONM
.I RT=4 D Q
..I IT="D" S L=$$VAL^XBDIQ1(90556.02,ID,2802) Q ;DM
..I IT="C" S L=$$VAL^XBDIQ1(90556.02,ID,2902) Q ;CVD
..I IT="W" S L=$$VAL^XBDIQ1(90556.02,ID,3102) Q ;WH
..I IT="P" S L=$$VAL^XBDIQ1(90556.02,ID,3202) Q ;PQA
..I IT="I" S L=$$VAL^XBDIQ1(90556.02,ID,3302) Q ;IPC
..I IT="A" S L=$$VAL^XBDIQ1(90556.02,ID,3402) Q ;AST
..S L=$$VAL^XBDIQ1(90556.02,ID,2402) Q
.S L=$$VAL^XBDIQ1(90556.02,ID,2402)
I $G(L)="" Q $P(^BGPINDMC(ID,0),U,4)_" "_$S(ND="D":"DEN ",1:"NUM ")_" MISSING LABEL"
;
I PT="D" Q L
NEW RL,J
S RL=""
I ND="N",$$VALI^XBDIQ1(90556.02,ID,2307) D Q RL
.S RL=$$VAL^XBDIQ1(90556.02,ID,.15)
.S J=$$VAL^XBDIQ1(90556.02,ID,.16) I J]"" S RL=RL_U_J
.S J=$$VAL^XBDIQ1(90556.02,ID,.19) I J]"" S RL=RL_U_J
K ^UTILITY($J,"W") S X=L,DIWL=0,DIWR=18 D ^DIWP
S X=0 F S X=$O(^UTILITY($J,"W",0,X)) Q:X'=+X S:RL]"" RL=RL_U S RL=RL_^UTILITY($J,"W",0,X,0)
K ^UTILITY($J,"W")
Q RL
LABELE(ID,RT,PT,ND) ;EP
I $G(ID)="" Q ""
NEW L,X,Y
;GET L LABEL AND THEN PASS BACK AS IS FOR DELIMITED OR ^ PIECED FOR PRINTED
I ND="D" D
.S L=$$VAL^XBDIQ1(90557.02,ID,2401)
;NUMERATOR
I ND="N" D
.S L=$$VAL^XBDIQ1(90557.02,ID,2402)
I $G(L)="" Q $P(^BGPELIIM(ID,0),U,4)_" "_$S(ND="D":"DEN ",1:"NUM ")_" MISSING LABEL"
;
I PT="D" Q L
NEW RL
S RL=""
K ^UTILITY($J,"W") S X=L,DIWL=0,DIWR=18 D ^DIWP
S X=0 F S X=$O(^UTILITY($J,"W",0,X)) Q:X'=+X S:RL]"" RL=RL_U S RL=RL_^UTILITY($J,"W",0,X,0)
K ^UTILITY($J,"W")
Q RL
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^BGP6UTL2(BGPDX3,BGPTX5,0)
.S BGPDX4=BGPDX4+1,BGPG(BGPDX4)=$$VD^APCLV($P(^AUPNVPRC(BGPDX1,0),U,3))_"^"_$P($$ICDOP^BGP6UTL2(BGPDX3),U,2)_"^"_$P($$ICDOP^BGP6UTL2(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^BGP6UTL2(BGPDX3,BGPTX5,9)
..S BGPDX4=1_"^"_$P($$ICDDX^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(BGPDX3,BGPTX5,0)
..S BGPDX4=1_"^"_$P($$ICDOP^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(BGPDX3),U,2)_"^"_D_"^"_BGPDX3_"^"_BGPX
.Q
Q BGPDX4
FIRSTCPT(P,T,BDATE,EDATE) ;EP
I '$G(P) Q ""
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
I $G(EDATE)="" S EDATE=DT
NEW BGPT,D,G,C,Y
S BGPT=$O(^ATXAX("B",T,0))
S C=0 F S C=$O(^AUPNVCPT("AA",P,C)) Q:C="" D
.Q:'$$ICD^BGP6UTL2(C,BGPT,1) ;not a code of interest
.S D=9999999 S D=$O(^AUPNVCPT("AA",P,C,D),-1)
.S E=9999999-D
.Q:E>EDATE
.Q:E<BDATE
.S Y=$O(^AUPNVCPT("AA",P,C,D,0))
.S Y(E,Y)=Y
.Q
I '$O(Y(0)) Q ""
S D=$O(Y(0)),C=$O(Y(D,0))
Q D_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,C,.01)
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^BGP6UTL2(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 BGPINDM="E",BGPVALUE]"",BGPAGEB>64 Q 1
I BGPINDM="E",BGPVALUE]"",BGPAGEB<65 Q 0
I BGPVALUE]"" Q 1
Q 0
I12() ;EP
I BGPINDM="D" Q 1
I BGPINDM="D",'BGPD4 Q 0
I BGPINDM="E",(BGPD3+BGPD7) Q 1
I BGPINDM="E",'(BGPD3+BGPD7) Q 0
I BGPACTUP Q 1
Q 0
I13() ;EP
I BGPINDM="D",BGPD2 Q 1
I BGPINDM="D",'BGPD2 Q 0
I BGPINDM="E",(BGPD3+BGPD1) Q 1
I BGPINDM="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 BGPINDM="D",BGPD7,'X Q 1
I BGPINDM="D",BGPD7,X Q 1 ;XXXX CHANGE TO Q 0 AFTER TESTING
I BGPINDM="D",'BGPD7 Q 0
I BGPINDM="C",BGPD8,'X Q 1
I BGPINDM="C",BGPD8,X Q 1 ;XXXX CHANGE TO Q 0
I BGPINDM="C",'BGPD8 Q 0
I BGPINDM="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 BGPINDM="W" Q $S(BGPSEX="F":1,1:0)
Q 1
I25() ;EP
I BGPINDM="D" Q BGPDMD2
I 'BGPD1 Q 0
I BGPINDM="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^BGP6UTL2(BGPDX3,BGPTX5,9) S BGPDX4=1_"^"_$P($$ICDDX^BGP6UTL2(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,RT) ;EP - return ien of CPT entry if patient had this CPT
I '$G(P) Q ""
I '$G(T) Q ""
S RT=$G(RT)
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^BGP6UTL2(I,T,1)
..I RT]"" Q:$P(^AUPNPREF(Y,0),U,7)'=RT
..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^BGP6UTL2(I,T,0)
..S G="1^"_D_"^"_$P(^AUPNPREF(Y,0),U,7)_"^"_$P($$ICDOP^BGP6UTL2(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
BGP6UTL1 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 02 Jul 2010 2:07 PM 19 Feb 2016 11:40 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
+3 ;
LABEL(ID,RT,PT,IT,ND) ;EP
+1 IF $GET(ID)=""
QUIT ""
+2 SET IT=$GET(IT)
+3 NEW L,X,Y
+4 ;GET L LABEL AND THEN PASS BACK AS IS FOR DELIMITED OR ^ PIECED FOR PRINTED
+5 IF ND="D"
Begin DoDot:1
+6 ;NG
IF RT=1
SET L=$$VAL^XBDIQ1(90556.02,ID,2501)
QUIT
+7 ;DEV
IF RT=9
SET L=$$VAL^XBDIQ1(90556.02,ID,2601)
QUIT
+8 ;ONM
IF RT=7
SET L=$$VAL^XBDIQ1(90556.02,ID,2701)
QUIT
+9 IF RT=4
Begin DoDot:2
+10 ;DM
IF IT="D"
SET L=$$VAL^XBDIQ1(90556.02,ID,2801)
QUIT
+11 ;CVD
IF IT="C"
SET L=$$VAL^XBDIQ1(90556.02,ID,2901)
QUIT
+12 ;WH
IF IT="W"
SET L=$$VAL^XBDIQ1(90556.02,ID,3101)
QUIT
+13 ;PQA
IF IT="P"
SET L=$$VAL^XBDIQ1(90556.02,ID,3201)
QUIT
+14 ;IPC
IF IT="I"
SET L=$$VAL^XBDIQ1(90556.02,ID,3301)
QUIT
+15 ;AST
IF IT="A"
SET L=$$VAL^XBDIQ1(90556.02,ID,3401)
QUIT
+16 SET L=$$VAL^XBDIQ1(90556.02,ID,2401)
QUIT
End DoDot:2
QUIT
+17 SET L=$$VAL^XBDIQ1(90556.02,ID,2401)
End DoDot:1
+18 ;NUMERATOR
+19 IF ND="N"
Begin DoDot:1
+20 ;NG
IF RT=1
SET L=$$VAL^XBDIQ1(90556.02,ID,2502)
QUIT
+21 ;DEV
IF RT=9
SET L=$$VAL^XBDIQ1(90556.02,ID,2602)
QUIT
+22 ;ONM
IF RT=7
SET L=$$VAL^XBDIQ1(90556.02,ID,2702)
QUIT
+23 IF RT=4
Begin DoDot:2
+24 ;DM
IF IT="D"
SET L=$$VAL^XBDIQ1(90556.02,ID,2802)
QUIT
+25 ;CVD
IF IT="C"
SET L=$$VAL^XBDIQ1(90556.02,ID,2902)
QUIT
+26 ;WH
IF IT="W"
SET L=$$VAL^XBDIQ1(90556.02,ID,3102)
QUIT
+27 ;PQA
IF IT="P"
SET L=$$VAL^XBDIQ1(90556.02,ID,3202)
QUIT
+28 ;IPC
IF IT="I"
SET L=$$VAL^XBDIQ1(90556.02,ID,3302)
QUIT
+29 ;AST
IF IT="A"
SET L=$$VAL^XBDIQ1(90556.02,ID,3402)
QUIT
+30 SET L=$$VAL^XBDIQ1(90556.02,ID,2402)
QUIT
End DoDot:2
QUIT
+31 SET L=$$VAL^XBDIQ1(90556.02,ID,2402)
End DoDot:1
+32 IF $GET(L)=""
QUIT $PIECE(^BGPINDMC(ID,0),U,4)_" "_$SELECT(ND="D":"DEN ",1:"NUM ")_" MISSING LABEL"
+33 ;
+34 IF PT="D"
QUIT L
+35 NEW RL,J
+36 SET RL=""
+37 IF ND="N"
IF $$VALI^XBDIQ1(90556.02,ID,2307)
Begin DoDot:1
+38 SET RL=$$VAL^XBDIQ1(90556.02,ID,.15)
+39 SET J=$$VAL^XBDIQ1(90556.02,ID,.16)
IF J]""
SET RL=RL_U_J
+40 SET J=$$VAL^XBDIQ1(90556.02,ID,.19)
IF J]""
SET RL=RL_U_J
End DoDot:1
QUIT RL
+41 KILL ^UTILITY($JOB,"W")
SET X=L
SET DIWL=0
SET DIWR=18
DO ^DIWP
+42 SET X=0
FOR
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
IF X'=+X
QUIT
IF RL]""
SET RL=RL_U
SET RL=RL_^UTILITY($JOB,"W",0,X,0)
+43 KILL ^UTILITY($JOB,"W")
+44 QUIT RL
LABELE(ID,RT,PT,ND) ;EP
+1 IF $GET(ID)=""
QUIT ""
+2 NEW L,X,Y
+3 ;GET L LABEL AND THEN PASS BACK AS IS FOR DELIMITED OR ^ PIECED FOR PRINTED
+4 IF ND="D"
Begin DoDot:1
+5 SET L=$$VAL^XBDIQ1(90557.02,ID,2401)
End DoDot:1
+6 ;NUMERATOR
+7 IF ND="N"
Begin DoDot:1
+8 SET L=$$VAL^XBDIQ1(90557.02,ID,2402)
End DoDot:1
+9 IF $GET(L)=""
QUIT $PIECE(^BGPELIIM(ID,0),U,4)_" "_$SELECT(ND="D":"DEN ",1:"NUM ")_" MISSING LABEL"
+10 ;
+11 IF PT="D"
QUIT L
+12 NEW RL
+13 SET RL=""
+14 KILL ^UTILITY($JOB,"W")
SET X=L
SET DIWL=0
SET DIWR=18
DO ^DIWP
+15 SET X=0
FOR
SET X=$ORDER(^UTILITY($JOB,"W",0,X))
IF X'=+X
QUIT
IF RL]""
SET RL=RL_U
SET RL=RL_^UTILITY($JOB,"W",0,X,0)
+16 KILL ^UTILITY($JOB,"W")
+17 QUIT RL
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^BGP6UTL2(BGPDX3,BGPTX5,0)
QUIT
+14 SET BGPDX4=BGPDX4+1
SET BGPG(BGPDX4)=$$VD^APCLV($PIECE(^AUPNVPRC(BGPDX1,0),U,3))_"^"_$PIECE($$ICDOP^BGP6UTL2(BGPDX3),U,2)_"^"_$PIECE($$ICDOP^BGP6UTL2(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^BGP6UTL2(BGPDX3,BGPTX5,9)
QUIT
+17 SET BGPDX4=1_"^"_$PIECE($$ICDDX^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(BGPDX3,BGPTX5,0)
QUIT
+15 SET BGPDX4=1_"^"_$PIECE($$ICDOP^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(BGPDX3),U,2)_"^"_D_"^"_BGPDX3_"^"_BGPX
+19 QUIT
End DoDot:1
+20 QUIT BGPDX4
FIRSTCPT(P,T,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+3 IF $GET(EDATE)=""
SET EDATE=DT
+4 NEW BGPT,D,G,C,Y
+5 SET BGPT=$ORDER(^ATXAX("B",T,0))
+6 SET C=0
FOR
SET C=$ORDER(^AUPNVCPT("AA",P,C))
IF C=""
QUIT
Begin DoDot:1
+7 ;not a code of interest
IF '$$ICD^BGP6UTL2(C,BGPT,1)
QUIT
+8 SET D=9999999
SET D=$ORDER(^AUPNVCPT("AA",P,C,D),-1)
+9 SET E=9999999-D
+10 IF E>EDATE
QUIT
+11 IF E<BDATE
QUIT
+12 SET Y=$ORDER(^AUPNVCPT("AA",P,C,D,0))
+13 SET Y(E,Y)=Y
+14 QUIT
End DoDot:1
+15 IF '$ORDER(Y(0))
QUIT ""
+16 SET D=$ORDER(Y(0))
SET C=$ORDER(Y(D,0))
+17 QUIT D_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,C,.01)
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^BGP6UTL2(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 BGPINDM="E"
IF BGPVALUE]""
IF BGPAGEB>64
QUIT 1
+3 IF BGPINDM="E"
IF BGPVALUE]""
IF BGPAGEB<65
QUIT 0
+4 IF BGPVALUE]""
QUIT 1
+5 QUIT 0
I12() ;EP
+1 IF BGPINDM="D"
QUIT 1
+2 IF BGPINDM="D"
IF 'BGPD4
QUIT 0
+3 IF BGPINDM="E"
IF (BGPD3+BGPD7)
QUIT 1
+4 IF BGPINDM="E"
IF '(BGPD3+BGPD7)
QUIT 0
+5 IF BGPACTUP
QUIT 1
+6 QUIT 0
I13() ;EP
+1 IF BGPINDM="D"
IF BGPD2
QUIT 1
+2 IF BGPINDM="D"
IF 'BGPD2
QUIT 0
+3 IF BGPINDM="E"
IF (BGPD3+BGPD1)
QUIT 1
+4 IF BGPINDM="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 BGPINDM="D"
IF BGPD7
IF 'X
QUIT 1
+5 ;XXXX CHANGE TO Q 0 AFTER TESTING
IF BGPINDM="D"
IF BGPD7
IF X
QUIT 1
+6 IF BGPINDM="D"
IF 'BGPD7
QUIT 0
+7 IF BGPINDM="C"
IF BGPD8
IF 'X
QUIT 1
+8 ;XXXX CHANGE TO Q 0
IF BGPINDM="C"
IF BGPD8
IF X
QUIT 1
+9 IF BGPINDM="C"
IF 'BGPD8
QUIT 0
+10 ;LORI **** CHANGE x:1 TO x:0 AFTER TESTING
IF BGPINDM="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 BGPINDM="W"
QUIT $SELECT(BGPSEX="F":1,1:0)
+3 QUIT 1
I25() ;EP
+1 IF BGPINDM="D"
QUIT BGPDMD2
+2 IF 'BGPD1
QUIT 0
+3 IF BGPINDM="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^BGP6UTL2(BGPDX3,BGPTX5,9)
SET BGPDX4=1_"^"_$PIECE($$ICDDX^BGP6UTL2(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,RT) ;EP - return ien of CPT entry if patient had this CPT
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 SET RT=$GET(RT)
+4 IF $GET(EDATE)=""
QUIT ""
+5 IF $GET(BDATE)=""
SET BDATE=$$FMADD^XLFDT(EDATE,-365)
+6 NEW G,X,Y,Z,I
+7 SET G=""
+8 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,81,I))
IF I=""!($PIECE(G,U))
QUIT
Begin DoDot:1
+9 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
+10 IF '$$ICD^BGP6UTL2(I,T,1)
QUIT
+11 IF RT]""
IF $PIECE(^AUPNPREF(Y,0),U,7)'=RT
QUIT
+12 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)_"^"_$PIECE(^ICPT(I,0),U)
End DoDot:2
+13 QUIT
End DoDot:1
+14 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^BGP6UTL2(I,T,0)
QUIT
+10 SET G="1^"_D_"^"_$PIECE(^AUPNPREF(Y,0),U,7)_"^"_$PIECE($$ICDOP^BGP6UTL2(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
