Routine: BGP4DCHI

BGP4DCHI ; IHS/CMI/LAB - calculate HEDIS indicators ;

 ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

CALCIND ;EP

 S BGPIC=0 F  S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC'=+BGPIC  D

 .K BGPSTOP

 .I $D(^BGPHEIF(BGPIC,1)) X ^BGPHEIF(BGPIC,1)

 .K BGPG,BGPC,BGPALLED

 .I $D(BGPSTOP) Q  ;no need to set since no num/denom

 .;loop each individual to set numerator and denominator

 .S BGPI=0 F  S BGPI=$O(^BGPHEIIF("B",BGPIC,BGPI)) Q:BGPI'=+BGPI  D

 ..S (BGPNUM,BGPDEN)=0

 ..X ^BGPHEIIF(BGPI,1)

 ..X ^BGPHEIIF(BGPI,2) ;denominator 1 or 0

 ..;set field counter

 ..S BGPNF=$P(^BGPHEIIF(BGPI,0),U,9)

 ..S BGPN=$P(^DD(90370.03,BGPNF,0),U,4),N=$P(BGPN,";"),P=$P(BGPN,";",2)

 ..D S(BGPRPT,BGPGBL,N,P,BGPNUM)

 ..S BGPDF=$P(^BGPHEIIF(BGPI,0),U,8)

 ..S BGPN=$P(^DD(90370.03,BGPDF,0),U,4),N=$P(BGPN,";"),P=$P(BGPN,";",2)

 ..I BGPDEN'="NO" D S(BGPRPT,BGPGBL,N,P,BGPDEN)

 .I $D(BGPLIST(BGPIC)) D STMP^BGP4HUTL

S(R,G,N,P,V) ;

 I 'V Q  ;no value to add

 S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)+V

D(D) ;

 I D="" Q ""

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))

BGP4DCHI  ; IHS/CMI/LAB - calculate HEDIS indicators ;

 +1       ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007

 +2       ;

CALCIND   ;EP

 +1        SET BGPIC=0

FOR

               SET BGPIC=$ORDER(BGPIND(BGPIC))

               IF BGPIC'=+BGPIC

                   QUIT

               Begin DoDot:1

 +2                KILL BGPSTOP

 +3                IF $DATA(^BGPHEIF(BGPIC,1))

                       XECUTE ^BGPHEIF(BGPIC,1)

 +4                KILL BGPG,BGPC,BGPALLED

 +5       ;no need to set since no num/denom

                   IF $DATA(BGPSTOP)

                       QUIT

 +6       ;loop each individual to set numerator and denominator

 +7                SET BGPI=0

FOR

                       SET BGPI=$ORDER(^BGPHEIIF("B",BGPIC,BGPI))

                       IF BGPI'=+BGPI

                           QUIT

                       Begin DoDot:2

 +8                        SET (BGPNUM,BGPDEN)=0

 +9                        XECUTE ^BGPHEIIF(BGPI,1)

 +10      ;denominator 1 or 0

                           XECUTE ^BGPHEIIF(BGPI,2)

 +11      ;set field counter

 +12                       SET BGPNF=$PIECE(^BGPHEIIF(BGPI,0),U,9)

 +13                       SET BGPN=$PIECE(^DD(90370.03,BGPNF,0),U,4)

                           SET N=$PIECE(BGPN,";")

                           SET P=$PIECE(BGPN,";",2)

 +14                       DO S(BGPRPT,BGPGBL,N,P,BGPNUM)

 +15                       SET BGPDF=$PIECE(^BGPHEIIF(BGPI,0),U,8)

 +16                       SET BGPN=$PIECE(^DD(90370.03,BGPDF,0),U,4)

                           SET N=$PIECE(BGPN,";")

                           SET P=$PIECE(BGPN,";",2)

 +17                       IF BGPDEN'="NO"

                               DO S(BGPRPT,BGPGBL,N,P,BGPDEN)

                       End DoDot:2

 +18               IF $DATA(BGPLIST(BGPIC))

                       DO STMP^BGP4HUTL

               End DoDot:1

 +19       QUIT

 +20      ;

S(R,G,N,P,V) ;

 +1       ;no value to add

           IF 'V

               QUIT

 +2        SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)+V

 +3        QUIT

D(D)      ;

 +1        IF D=""

               QUIT ""

 +2        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))

BGP4DCHI.m