Routine: BGP1DCEI

BGP1DCEI ; IHS/CMI/LAB - calculate HEDIS measures ;

 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33

CALCIND ;EP

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

 .K BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 .K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30

 .K BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13

 .K BGPNUMV,BGPMEDS,BGPDAE,BGPMEDS1

 .K ^TMP($J)

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

 .K BGPG,BGPC,BGPALLED,BGPVAL,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 .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(^BGPELIIB("B",BGPIC,BGPI)) Q:BGPI'=+BGPI  D

 ..S (BGPNUM,BGPDEN)=0

 ..X ^BGPELIIB(BGPI,1)

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

 ..;set field counter

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

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

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

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

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

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

 .K BGPNUMV

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

 .K BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPD18,BGPD19,BGPD20,BGPD21,BGPD22,BGPD23,BGPD24,BGPD25,BGPD26

 .K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30

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

BGP1DCEI  ; IHS/CMI/LAB - calculate HEDIS measures ;

 +1       ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33

 +2       ;

CALCIND   ;EP

 +1        SET BGPIC=0

FOR

               SET BGPIC=$ORDER(BGPIND(BGPIC))

               IF BGPIC'=+BGPIC

                   QUIT

               Begin DoDot:1

 +2                KILL BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 +3                KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30

 +4                KILL BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13

 +5                KILL BGPNUMV,BGPMEDS,BGPDAE,BGPMEDS1

 +6                KILL ^TMP($JOB)

 +7                IF $DATA(^BGPELIB(BGPIC,1))

                       XECUTE ^BGPELIB(BGPIC,1)

 +8                KILL BGPG,BGPC,BGPALLED,BGPVAL,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

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

                   IF $DATA(BGPSTOP)

                       QUIT

 +10      ;loop each individual to set numerator and denominator

 +11               SET BGPI=0

FOR

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

                       IF BGPI'=+BGPI

                           QUIT

                       Begin DoDot:2

 +12                       SET (BGPNUM,BGPDEN)=0

 +13                       XECUTE ^BGPELIIB(BGPI,1)

 +14      ;denominator 1 or 0

                           XECUTE ^BGPELIIB(BGPI,2)

 +15      ;set field counter

 +16                       SET BGPNF=$PIECE(^BGPELIIB(BGPI,0),U,9)

 +17                       SET BGPN=$PIECE(^DD(90547.03,BGPNF,0),U,4)

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

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

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

 +19                       SET BGPDF=$PIECE(^BGPELIIB(BGPI,0),U,8)

 +20                       SET BGPN=$PIECE(^DD(90547.03,BGPDF,0),U,4)

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

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

 +21                       IF BGPDEN'="NO"

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

                       End DoDot:2

 +22               KILL BGPNUMV

 +23               IF $DATA(BGPLIST(BGPIC))

                       DO STMP^BGP1EUTL

 +24               KILL BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPD18,BGPD19,BGPD20,BGPD21,BGPD22,BGPD23,BGPD24,BGPD25,BGPD26

 +25               KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30

               End DoDot:1

 +26       QUIT

 +27      ;

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

BGP1DCEI.m