BGP4D21A.m

BGP4D21A ; IHS/CMI/LAB - measure 6 ;

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

 ;

LOINC(A,B) ;EP

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

BLINDPL(P,EDATE) ;EP

 NEW %,X,Y,Z,T,G

 ;check for blindness on problem list

 S T=$O(^ATXAX("B","BGP BILATERAL BLINDNESS DXS",0))

 S (X,G)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D

 .Q:$P(^AUPNPROB(X,0),U,12)="D"  ;deleted problem so skip it

 .Q:$P(^AUPNPROB(X,0),U,12)="I"  ;inactive

 .Q:$P(^AUPNPROB(X,0),U,13)>EDATE  ;date of onset after time period

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE  ;added to problem list after time period

 .S Y=$P(^AUPNPROB(X,0),U)

 .Q:'$$ICD^BGP4UTL2(Y,T,9)

 .S G=1

 .Q

 Q G

BGP4D21A  ; IHS/CMI/LAB - measure 6 ;

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

 +2       ;

LOINC(A,B) ;EP

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

BLINDPL(P,EDATE) ;EP

 +1        NEW %,X,Y,Z,T,G

 +2       ;check for blindness on problem list

 +3        SET T=$ORDER(^ATXAX("B","BGP BILATERAL BLINDNESS DXS",0))

 +4        SET (X,G)=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +5       ;deleted problem so skip it

                   IF $PIECE(^AUPNPROB(X,0),U,12)="D"

                       QUIT 

 +6       ;inactive

                   IF $PIECE(^AUPNPROB(X,0),U,12)="I"

                       QUIT 

 +7       ;date of onset after time period

                   IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE

                       QUIT 

 +8       ;added to problem list after time period

                   IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE

                       QUIT 

 +9                SET Y=$PIECE(^AUPNPROB(X,0),U)

 +10               IF '$$ICD^BGP4UTL2(Y,T,9)

                       QUIT 

 +11               SET G=1

 +12               QUIT 

               End DoDot:1

 +13       QUIT G