BGP4D231.m

BGP4D231 ; IHS/CMI/LAB - measure I2 23 Jun 2010 10:08 AM ;

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

WC(P,BDATE,EDATE) ;EP

 I 'P Q ""

 KILL %,BGPARRY,H,E

 S %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPARRY(") S H=$P($G(BGPARRY(1)),U,2)

 I H="" Q H

 I H["?" Q ""

 I $P(^DPT(P,0),U,2)="M",H>40 Q "WC="_H

 I $P(^DPT(P,0),U,2)="F",H>35 Q "WC="_H

 Q ""

TRIG(P,BDATE,EDATE) ;EP

 ;now get all loinc/taxonomy tests

 S T=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))

 S BGPLT=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))

 S R=""

 S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(R]"")  D

 .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(R]"")  D

 ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(R]"")  D

 ...Q:'$D(^AUPNVLAB(X,0))

 ...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D  Q:R]""

 ....S V=$P(^AUPNVLAB(X,0),U,4) Q:V=""  Q:'V  Q:+V<150  S R="TRIG="_V

 ...Q:'T

 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""

 ...Q:'$$LOINC(J,T)

 ...S V=$P(^AUPNVLAB(X,0),U,4)

 ...Q:V=""  Q:V'=+V

 ...Q:+V<150

 ...S R="TRIG="_V

 ...Q

 Q R

 ;

LOINC(A,B) ;

 NEW %

 S %=$P($G(^LAB(95.3,A,9999999)),U,2)

 I %]"",$D(^ATXAX(B,21,"B",%)) Q 1

 S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)

 I $D(^ATXAX(B,21,"B",%)) Q 1

 Q ""

BGP4D231  ; IHS/CMI/LAB - measure I2 23 Jun 2010 10:08 AM ;

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

WC(P,BDATE,EDATE) ;EP

 +1        IF 'P

               QUIT ""

 +2        KILL %,BGPARRY,H,E

 +3        SET %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPARRY(")

           SET H=$PIECE($GET(BGPARRY(1)),U,2)

 +4        IF H=""

               QUIT H

 +5        IF H["?"

               QUIT ""

 +6        IF $PIECE(^DPT(P,0),U,2)="M"

               IF H>40

                   QUIT "WC="_H

 +7        IF $PIECE(^DPT(P,0),U,2)="F"

               IF H>35

                   QUIT "WC="_H

 +8        QUIT ""

TRIG(P,BDATE,EDATE) ;EP

 +1       ;now get all loinc/taxonomy tests

 +2        SET T=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))

 +3        SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))

 +4        SET R=""

 +5        SET B=9999999-BDATE

           SET E=9999999-EDATE

           SET D=E-1

           FOR 

               SET D=$ORDER(^AUPNVLAB("AE",P,D))

               IF D'=+D!(D>B)!(R]"")

                   QUIT 

               Begin DoDot:1

 +6                SET L=0

                   FOR 

                       SET L=$ORDER(^AUPNVLAB("AE",P,D,L))

                       IF L'=+L!(R]"")

                           QUIT 

                       Begin DoDot:2

 +7                        SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))

                               IF X'=+X!(R]"")

                                   QUIT 

                               Begin DoDot:3

 +8                                IF '$DATA(^AUPNVLAB(X,0))

                                       QUIT 

 +9                                IF BGPLT

                                       IF $PIECE(^AUPNVLAB(X,0),U)

                                           IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))

                                               Begin DoDot:4

 +10                                               SET V=$PIECE(^AUPNVLAB(X,0),U,4)

                                                   IF V=""

                                                       QUIT 

                                                   IF 'V

                                                       QUIT 

                                                   IF +V<150

                                                       QUIT 

                                                   SET R="TRIG="_V

                                               End DoDot:4

                                               IF R]""

                                                   QUIT 

 +11                               IF 'T

                                       QUIT 

 +12                               SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)

                                   IF J=""

                                       QUIT 

 +13                               IF '$$LOINC(J,T)

                                       QUIT 

 +14                               SET V=$PIECE(^AUPNVLAB(X,0),U,4)

 +15                               IF V=""

                                       QUIT 

                                   IF V'=+V

                                       QUIT 

 +16                               IF +V<150

                                       QUIT 

 +17                               SET R="TRIG="_V

 +18                               QUIT 

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +19       QUIT R

 +20      ;

LOINC(A,B) ;

 +1        NEW %

 +2        SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)

 +3        IF %]""

               IF $DATA(^ATXAX(B,21,"B",%))

                   QUIT 1

 +4        SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)

 +5        IF $DATA(^ATXAX(B,21,"B",%))

               QUIT 1

 +6        QUIT ""