BGPMUUT5 ;IHS/MSC/MGH - Find lab results for date range ;16-Dec-11 13:21;MMT
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
Q
LAB(DATA,DFN,TAX,BDATE,EDATE,FLG) ; EP
;This function is designed to see if the patient has any labs
;in the given taxonomy in the date range
;
N LRDFN,MAX,IDT,BGP1,BGP2,CNT,IEN
S FLG=$G(FLG)
S IEN=$O(^ATXAX("B",TAX,0))
Q:IEN=""
S MAX=9999
S BGP2=9999999-$P(BDATE,"."),BGP1=9999999-$P(EDATE,".")-.24
Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR")
S IDT=BGP1,CNT=0 F S IDT=$O(^LR(LRDFN,"CH",IDT)) Q:IDT=""!(IDT>BGP2) D:CNT'>MAX CHSET
Q
CHSET ;Finds and evaluates chemistry tests
N CDT,SITE,SPEC,PTR
S CDT=+^LR(LRDFN,"CH",IDT,0),SITE=$P(^(0),U,5)
Q:SITE=""
S SPEC=$P($G(^LAB(61,SITE,0)),U,1),CNT=CNT+1
S PTR=1 F S PTR=$O(^LR(LRDFN,"CH",IDT,PTR)) Q:PTR<1 D
.I FLG="" D NXTST
.I FLG=1 D NXTCPT
Q
NXTST ;Visit next node in
N RESULT,FLAG,TEST,TNM,DESCR,%,THER,UNIT,HI,LO,CIS,LOINC
S RESULT=$P(^LR(LRDFN,"CH",IDT,PTR),U),FLAG=$P(^(PTR),U,2),CIS=""
I FLAG["*" S FLAG=$S(FLAG="L*":"LL",FLAG="H*":"HH",1:FLAG)
S TEST=$O(^LAB(60,"C","CH;"_PTR_";1",0)) Q:TEST'>0
S TNM=$P(^LAB(60,TEST,0),U,1)
S LOINC=$P($G(^LAB(60,TEST,1,SITE,95.3)),U,1)
I LOINC="" S LOINC=$P($G(^LAB(60,TEST,9999999)),U,2)
Q:LOINC=""
S %=$P($G(^LAB(95.3,LOINC,0)),U)_"-"_$P($G(^LAB(95.3,LOINC,0)),U,15)
I $D(^ATXAX(IEN,21,"B",%)) D
.S DATA(IDT)=RESULT
Q
NXTCPT ;Get data
N RESULT,FLAG,TEST,TNM,DESCR,%,THER,UNIT,HI,LO,CIS,CPT
S RESULT=$P(^LR(LRDFN,"CH",IDT,PTR),U),FLAG=$P(^(PTR),U,2),CIS=""
I FLAG["*" S FLAG=$S(FLAG="L*":"LL",FLAG="H*":"HH",1:FLAG)
S TEST=$O(^LAB(60,"C","CH;"_PTR_";1",0)) Q:TEST'>0
S TNM=$P(^LAB(60,TEST,0),U,1)
S CPT=$P($G(^LAB(60,TEST,1,SITE,3)),U,1)
I CPT="" S CPT=$P($G(^LAB(60,TEST,9999999)),U,1)
Q:CPT=""
I $D(^ATXAX(IEN,21,"B",CPT)) D
.S DATA(IDT)=RESULT
Q
LABCPT(DATA,DFN,TAX,BDATE,EDATE) ; EP
N FLG
S FLG=1
D LAB(.DATA,DFN,TAX,BDATE,EDATE,FLG)
Q
RHTYPE(DFN) ; EP
;This function is designed to see if the patient has RH in blood bank
;
N LRDFN,IDT,RESULT
S RESULT=0
Q:'$D(^DPT(DFN,"LR")) 0
S LRDFN=+^DPT(DFN,"LR")
S IDT=0 F S IDT=$O(^LR(LRDFN,"BB",IDT)) Q:IDT=""!+RESULT D
.S RESULT=$P($G(^LR(LRDFN,"BB",IDT,11)),U,1)
.I RESULT'="" S RESULT=1_U_RESULT
I RESULT="" S RESULT=0
Q RESULT
ANTI(DFN) ;EP
;Check blood bank for direct coombs
N LRDFN,IDT,RESULT
S RESULT=0
Q:'$D(^DPT(DFN,"LR")) 0
S LRDFN=+^DPT(DFN,"LR")
S IDT=0 F S IDT=$O(^LR(LRDFN,"BB",IDT)) Q:IDT=""!+RESULT D
.S RESULT=$P($G(^LR(LRDFN,"BB",IDT,6)),U,1)
.I RESULT'="" S RESULT=1_U_RESULT
I RESULT="" S RESULT=0
Q RESULT
;
FTAX(BGPVAL) ;find a taxonomy in BGPMU for the given value
S ATX="BGPMU" F S ATX=$O(^ATXAX("B",ATX)) Q:ATX="" Q:$E(ATX,1,5)'="BGPMU" D
.S ATXIEN=$O(^ATXAX("B",ATX,0))
.I $D(^ATXAX(ATXIEN,21,"B",BGPVAL)) W !,ATX
Q
MICRO(DFN,BDATE,EDATE,TAX) ;Retuns IEN of Lab test if pt has this LOINC code
N IEN,CODE,B,E,D,L,G,X,J,START,END,TEST
S (CODE,B,E,D,L,G,X,J)=""
S IEN=$O(^ATXAX("B",TAX,0))
Q:'IEN
S START=BDATE-1,END=EDATE+1
S B=9999999-START,E=9999999-END S D=E-1 F S D=$O(^AUPNVMIC("AE",DFN,D)) Q:D'=+D!(D>B)!(G]"") D
.S L=0 F S L=$O(^AUPNVMIC("AE",DFN,D,L)) Q:L'=+L!(G]"") D
..S X=0 F S X=$O(^AUPNVMIC("AE",DFN,D,L,X)) Q:X'=+X!(G]"") D
...Q:'$D(^AUPNVMIC(X,0))
...S COMPLETE=$P($P($G(^AUPNVMIC(X,0)),U,9),".")
...;done in the correct time frame
...I (COMPLETE>BDATE!(COMPLETE=BDATE))&((COMPLETE<EDATE)!(COMPLETE=EDATE)) D
....S TEST=$P($G(^AUPNVMIC(X,0)),U,1)
....S J=$P($G(^LAB(60,TEST,9999999)),U,2) Q:J=""
....I $$LOINC2^BGPMUUT2(J,IEN) D
.....S G=(9999999-D)_U_X Q
Q G
BGPMUUT5 ;IHS/MSC/MGH - Find lab results for date range ;16-Dec-11 13:21;MMT
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 QUIT
LAB(DATA,DFN,TAX,BDATE,EDATE,FLG) ; EP
+1 ;This function is designed to see if the patient has any labs
+2 ;in the given taxonomy in the date range
+3 ;
+4 NEW LRDFN,MAX,IDT,BGP1,BGP2,CNT,IEN
+5 SET FLG=$GET(FLG)
+6 SET IEN=$ORDER(^ATXAX("B",TAX,0))
+7 IF IEN=""
QUIT
+8 SET MAX=9999
+9 SET BGP2=9999999-$PIECE(BDATE,".")
SET BGP1=9999999-$PIECE(EDATE,".")-.24
+10 IF '$DATA(^DPT(DFN,"LR"))
QUIT
SET LRDFN=+^DPT(DFN,"LR")
+11 SET IDT=BGP1
SET CNT=0
FOR
SET IDT=$ORDER(^LR(LRDFN,"CH",IDT))
IF IDT=""!(IDT>BGP2)
QUIT
IF CNT'>MAX
DO CHSET
+12 QUIT
CHSET ;Finds and evaluates chemistry tests
+1 NEW CDT,SITE,SPEC,PTR
+2 SET CDT=+^LR(LRDFN,"CH",IDT,0)
SET SITE=$PIECE(^(0),U,5)
+3 IF SITE=""
QUIT
+4 SET SPEC=$PIECE($GET(^LAB(61,SITE,0)),U,1)
SET CNT=CNT+1
+5 SET PTR=1
FOR
SET PTR=$ORDER(^LR(LRDFN,"CH",IDT,PTR))
IF PTR<1
QUIT
Begin DoDot:1
+6 IF FLG=""
DO NXTST
+7 IF FLG=1
DO NXTCPT
End DoDot:1
+8 QUIT
NXTST ;Visit next node in
+1 NEW RESULT,FLAG,TEST,TNM,DESCR,%,THER,UNIT,HI,LO,CIS,LOINC
+2 SET RESULT=$PIECE(^LR(LRDFN,"CH",IDT,PTR),U)
SET FLAG=$PIECE(^(PTR),U,2)
SET CIS=""
+3 IF FLAG["*"
SET FLAG=$SELECT(FLAG="L*":"LL",FLAG="H*":"HH",1:FLAG)
+4 SET TEST=$ORDER(^LAB(60,"C","CH;"_PTR_";1",0))
IF TEST'>0
QUIT
+5 SET TNM=$PIECE(^LAB(60,TEST,0),U,1)
+6 SET LOINC=$PIECE($GET(^LAB(60,TEST,1,SITE,95.3)),U,1)
+7 IF LOINC=""
SET LOINC=$PIECE($GET(^LAB(60,TEST,9999999)),U,2)
+8 IF LOINC=""
QUIT
+9 SET %=$PIECE($GET(^LAB(95.3,LOINC,0)),U)_"-"_$PIECE($GET(^LAB(95.3,LOINC,0)),U,15)
+10 IF $DATA(^ATXAX(IEN,21,"B",%))
Begin DoDot:1
+11 SET DATA(IDT)=RESULT
End DoDot:1
+12 QUIT
NXTCPT ;Get data
+1 NEW RESULT,FLAG,TEST,TNM,DESCR,%,THER,UNIT,HI,LO,CIS,CPT
+2 SET RESULT=$PIECE(^LR(LRDFN,"CH",IDT,PTR),U)
SET FLAG=$PIECE(^(PTR),U,2)
SET CIS=""
+3 IF FLAG["*"
SET FLAG=$SELECT(FLAG="L*":"LL",FLAG="H*":"HH",1:FLAG)
+4 SET TEST=$ORDER(^LAB(60,"C","CH;"_PTR_";1",0))
IF TEST'>0
QUIT
+5 SET TNM=$PIECE(^LAB(60,TEST,0),U,1)
+6 SET CPT=$PIECE($GET(^LAB(60,TEST,1,SITE,3)),U,1)
+7 IF CPT=""
SET CPT=$PIECE($GET(^LAB(60,TEST,9999999)),U,1)
+8 IF CPT=""
QUIT
+9 IF $DATA(^ATXAX(IEN,21,"B",CPT))
Begin DoDot:1
+10 SET DATA(IDT)=RESULT
End DoDot:1
+11 QUIT
LABCPT(DATA,DFN,TAX,BDATE,EDATE) ; EP
+1 NEW FLG
+2 SET FLG=1
+3 DO LAB(.DATA,DFN,TAX,BDATE,EDATE,FLG)
+4 QUIT
RHTYPE(DFN) ; EP
+1 ;This function is designed to see if the patient has RH in blood bank
+2 ;
+3 NEW LRDFN,IDT,RESULT
+4 SET RESULT=0
+5 IF '$DATA(^DPT(DFN,"LR"))
QUIT 0
+6 SET LRDFN=+^DPT(DFN,"LR")
+7 SET IDT=0
FOR
SET IDT=$ORDER(^LR(LRDFN,"BB",IDT))
IF IDT=""!+RESULT
QUIT
Begin DoDot:1
+8 SET RESULT=$PIECE($GET(^LR(LRDFN,"BB",IDT,11)),U,1)
+9 IF RESULT'=""
SET RESULT=1_U_RESULT
End DoDot:1
+10 IF RESULT=""
SET RESULT=0
+11 QUIT RESULT
ANTI(DFN) ;EP
+1 ;Check blood bank for direct coombs
+2 NEW LRDFN,IDT,RESULT
+3 SET RESULT=0
+4 IF '$DATA(^DPT(DFN,"LR"))
QUIT 0
+5 SET LRDFN=+^DPT(DFN,"LR")
+6 SET IDT=0
FOR
SET IDT=$ORDER(^LR(LRDFN,"BB",IDT))
IF IDT=""!+RESULT
QUIT
Begin DoDot:1
+7 SET RESULT=$PIECE($GET(^LR(LRDFN,"BB",IDT,6)),U,1)
+8 IF RESULT'=""
SET RESULT=1_U_RESULT
End DoDot:1
+9 IF RESULT=""
SET RESULT=0
+10 QUIT RESULT
+11 ;
FTAX(BGPVAL) ;find a taxonomy in BGPMU for the given value
+1 SET ATX="BGPMU"
FOR
SET ATX=$ORDER(^ATXAX("B",ATX))
IF ATX=""
QUIT
IF $EXTRACT(ATX,1,5)'="BGPMU"
QUIT
Begin DoDot:1
+2 SET ATXIEN=$ORDER(^ATXAX("B",ATX,0))
+3 IF $DATA(^ATXAX(ATXIEN,21,"B",BGPVAL))
WRITE !,ATX
End DoDot:1
+4 QUIT
MICRO(DFN,BDATE,EDATE,TAX) ;Retuns IEN of Lab test if pt has this LOINC code
+1 NEW IEN,CODE,B,E,D,L,G,X,J,START,END,TEST
+2 SET (CODE,B,E,D,L,G,X,J)=""
+3 SET IEN=$ORDER(^ATXAX("B",TAX,0))
+4 IF 'IEN
QUIT
+5 SET START=BDATE-1
SET END=EDATE+1
+6 SET B=9999999-START
SET E=9999999-END
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",DFN,D))
IF D'=+D!(D>B)!(G]"")
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",DFN,D,L))
IF L'=+L!(G]"")
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVMIC("AE",DFN,D,L,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVMIC(X,0))
QUIT
+10 SET COMPLETE=$PIECE($PIECE($GET(^AUPNVMIC(X,0)),U,9),".")
+11 ;done in the correct time frame
+12 IF (COMPLETE>BDATE!(COMPLETE=BDATE))&((COMPLETE<EDATE)!(COMPLETE=EDATE))
Begin DoDot:4
+13 SET TEST=$PIECE($GET(^AUPNVMIC(X,0)),U,1)
+14 SET J=$PIECE($GET(^LAB(60,TEST,9999999)),U,2)
IF J=""
QUIT
+15 IF $$LOINC2^BGPMUUT2(J,IEN)
Begin DoDot:5
+16 SET G=(9999999-D)_U_X
QUIT
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT G
