BGPMUUT5.m

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