BGP6UTL1.m

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