- BGP8EOCI ; IHS/CMI/LAB - calculate HEDIS measures ;
- ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
- ;
- 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(^BGPEOME(BGPIC,1)) X ^BGPEOME(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(^BGPEOMIE("B",BGPIC,BGPI)) Q:BGPI'=+BGPI D
- ..S (BGPNUM,BGPDEN)=0
- ..X ^BGPEOMIE(BGPI,1)
- ..X ^BGPEOMIE(BGPI,2) ;denominator 1 or 0
- ..;set field counter
- ..S BGPNF=$P(^BGPEOMIE(BGPI,0),U,5)
- ..S BGPN=$P(^DD(90535.1,BGPNF,0),U,4),N=$P(BGPN,";"),P=$P(BGPN,";",2)
- ..D S(BGPRPT,BGPGBL,N,P,BGPNUM)
- ..S BGPDF=$P(^BGPEOMIE(BGPI,0),U,4)
- ..S BGPN=$P(^DD(90535.1,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^BGP8EOUT
- .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
- Q
- ;
- 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
- Q
- D(D) ;
- I D="" Q ""
- Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
- BGP8EOCI ; IHS/CMI/LAB - calculate HEDIS measures ;
- +1 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
- +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(^BGPEOME(BGPIC,1))
- XECUTE ^BGPEOME(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(^BGPEOMIE("B",BGPIC,BGPI))
- IF BGPI'=+BGPI
- QUIT
- Begin DoDot:2
- +12 SET (BGPNUM,BGPDEN)=0
- +13 XECUTE ^BGPEOMIE(BGPI,1)
- +14 ;denominator 1 or 0
- XECUTE ^BGPEOMIE(BGPI,2)
- +15 ;set field counter
- +16 SET BGPNF=$PIECE(^BGPEOMIE(BGPI,0),U,5)
- +17 SET BGPN=$PIECE(^DD(90535.1,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(^BGPEOMIE(BGPI,0),U,4)
- +20 SET BGPN=$PIECE(^DD(90535.1,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^BGP8EOUT
- +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))