BGP1DP7 ; IHS/CMI/LAB - print ind 10 ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
;
;this routine for Measure I10 ONLY
I10 ;EP
D H1 S BGPNODEN=1
F BGPPC1="10.1" D PI Q:BGPQUIT
Q
PI ;EP
S BGPDENP=0
K BGPDHOLD
K BGPCYP,BGPBLP,BGPPRP
S BGPPC2=0 F S BGPPC2=$O(^BGPINDBC("AB",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDBC("AB",BGPPC1,BGPPC2,0)) D PI1
Q
PI1 ;
K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
I BGPRTYPE'=4,BGPINDB="G",$P(^BGPINDBC(BGPPC,0),U,5)'=1 Q
I BGPRTYPE=4,$P($G(^BGPINDBC(BGPPC,21)),U,2)=1 Q
I BGPINDB="D",$P(^BGPINDBC(BGPPC,0),U,12)'=1 Q
I BGPINDB="C",$P(^BGPINDBC(BGPPC,0),U,13)'=1 Q
I BGPINDB="W",$P($G(^BGPINDBC(BGPPC,12)),U,2)'=1 Q
I BGPINDB="E",$P($G(^BGPINDBC(BGPPC,12)),U,3)'=1 Q
I BGPINDB="I",$P($G(^BGPINDBC(I,11)),U,1)'=1 Q
I BGPINDB="P",$P($G(^BGPINDBC(I,11)),U,2)'=1 Q
;get numerator value of measure and calc %
S BGPDF=$P(^BGPINDBC(BGPPC,0),U,9)
I $P(^BGPINDBC(BGPPC,0),U,4)[".1" S BGPDHOLD=BGPDF
I $P(^BGPINDBC(BGPPC,0),U,4)'[".1" S BGPDF=BGPDHOLD
S BGPNP=$P(^DD(90545.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
S BGPCYD=$$V^BGP1DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP1DP1C(1,N,P)
S BGPPRD=$$V^BGP1DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP1DP1C(2,N,P)
S BGPBLD=$$V^BGP1DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP1DP1C(3,N,P)
S BGPNF=$P(^BGPINDBC(BGPPC,0),U,9)
S BGPNP=$P(^DD(90545.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
D SETN^BGP1DP1C
;write header for 1.A.1
W:'$G(BGPSUMON) !!,$P(^BGPINDBC(BGPPC,0),U,15)
I $P(^BGPINDBC(BGPPC,0),U,16)]"" W:'$G(BGPSUMON) !?1,$P(^BGPINDBC(BGPPC,0),U,16)
I $P(^BGPINDBC(BGPPC,0),U,19)]"" W:'$G(BGPSUMON) !?1,$P(^BGPINDBC(BGPPC,0),U,19)
D H2
Q
H2 ;EP
S BGPX="",BGPX=$$C(BGPCYN,0,8),$E(BGPX,9)=$S(BGPCYP]"":$J($G(BGPCYP),5,1),1:""),$E(BGPX,16)=$$C(BGPPRN,0,8),$E(BGPX,24)=$S(BGPPRP]"":$J($G(BGPPRP),5,1),1:""),$E(BGPX,32)=$$CALC(BGPCYN,BGPPRN)
S $E(BGPX,39)=$$C(BGPBLN,0,8),$E(BGPX,47)=$S(BGPBLP]"":$J($G(BGPBLP),5,1),1:""),$E(BGPX,55)=$$CALC(BGPCYN,BGPBLN)
W:'$G(BGPSUMON) ?20,BGPX
Q
H1 ;EP
Q:$G(BGPSUMON)
W !!?21,"REPORT",?31,"",?35,"PREV YR",?46,"",?49,"CHG from",?59,"BASE",?69,"",?72,"CHG from"
W !?21,"PERIOD ",?35,"PERIOD ",?49,"PREV YR ",?59,"PERIOD ",?72,"BASE "
Q
CALC(N,O) ;ENTRY POINT
NEW Z
S Z=N-O,Z=$FN(Z,"+,",0)
Q Z
C(X,X2,X3) ;
D COMMA^%DTC
Q X
BGP1DP7 ; IHS/CMI/LAB - print ind 10 ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
+3 ;
+4 ;this routine for Measure I10 ONLY
I10 ;EP
+1 DO H1
SET BGPNODEN=1
+2 FOR BGPPC1="10.1"
DO PI
IF BGPQUIT
QUIT
+3 QUIT
PI ;EP
+1 SET BGPDENP=0
+2 KILL BGPDHOLD
+3 KILL BGPCYP,BGPBLP,BGPPRP
+4 SET BGPPC2=0
FOR
SET BGPPC2=$ORDER(^BGPINDBC("AB",BGPPC1,BGPPC2))
IF BGPPC2=""
QUIT
SET BGPPC=$ORDER(^BGPINDBC("AB",BGPPC1,BGPPC2,0))
DO PI1
+5 QUIT
PI1 ;
+1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
+2 IF BGPRTYPE'=4
IF BGPINDB="G"
IF $PIECE(^BGPINDBC(BGPPC,0),U,5)'=1
QUIT
+3 IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDBC(BGPPC,21)),U,2)=1
QUIT
+4 IF BGPINDB="D"
IF $PIECE(^BGPINDBC(BGPPC,0),U,12)'=1
QUIT
+5 IF BGPINDB="C"
IF $PIECE(^BGPINDBC(BGPPC,0),U,13)'=1
QUIT
+6 IF BGPINDB="W"
IF $PIECE($GET(^BGPINDBC(BGPPC,12)),U,2)'=1
QUIT
+7 IF BGPINDB="E"
IF $PIECE($GET(^BGPINDBC(BGPPC,12)),U,3)'=1
QUIT
+8 IF BGPINDB="I"
IF $PIECE($GET(^BGPINDBC(I,11)),U,1)'=1
QUIT
+9 IF BGPINDB="P"
IF $PIECE($GET(^BGPINDBC(I,11)),U,2)'=1
QUIT
+10 ;get numerator value of measure and calc %
+11 SET BGPDF=$PIECE(^BGPINDBC(BGPPC,0),U,9)
+12 IF $PIECE(^BGPINDBC(BGPPC,0),U,4)[".1"
SET BGPDHOLD=BGPDF
+13 IF $PIECE(^BGPINDBC(BGPPC,0),U,4)'[".1"
SET BGPDF=BGPDHOLD
+14 SET BGPNP=$PIECE(^DD(90545.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+15 SET BGPCYD=$$V^BGP1DP1C(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA^BGP1DP1C(1,N,P)
+16 SET BGPPRD=$$V^BGP1DP1C(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA^BGP1DP1C(2,N,P)
+17 SET BGPBLD=$$V^BGP1DP1C(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA^BGP1DP1C(3,N,P)
+18 SET BGPNF=$PIECE(^BGPINDBC(BGPPC,0),U,9)
+19 SET BGPNP=$PIECE(^DD(90545.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+20 DO SETN^BGP1DP1C
+21 ;write header for 1.A.1
+22 IF '$GET(BGPSUMON)
WRITE !!,$PIECE(^BGPINDBC(BGPPC,0),U,15)
+23 IF $PIECE(^BGPINDBC(BGPPC,0),U,16)]""
IF '$GET(BGPSUMON)
WRITE !?1,$PIECE(^BGPINDBC(BGPPC,0),U,16)
+24 IF $PIECE(^BGPINDBC(BGPPC,0),U,19)]""
IF '$GET(BGPSUMON)
WRITE !?1,$PIECE(^BGPINDBC(BGPPC,0),U,19)
+25 DO H2
+26 QUIT
H2 ;EP
+1 SET BGPX=""
SET BGPX=$$C(BGPCYN,0,8)
SET $EXTRACT(BGPX,9)=$SELECT(BGPCYP]"":$JUSTIFY($GET(BGPCYP),5,1),1:"")
SET $EXTRACT(BGPX,16)=$$C(BGPPRN,0,8)
SET $EXTRACT(BGPX,24)=$SELECT(BGPPRP]"":$JUSTIFY($GET(BGPPRP),5,1),1:"")
SET $EXTRACT(BGPX,32)=$$CALC(BGPCYN,BGPPRN)
+2 SET $EXTRACT(BGPX,39)=$$C(BGPBLN,0,8)
SET $EXTRACT(BGPX,47)=$SELECT(BGPBLP]"":$JUSTIFY($GET(BGPBLP),5,1),1:"")
SET $EXTRACT(BGPX,55)=$$CALC(BGPCYN,BGPBLN)
+3 IF '$GET(BGPSUMON)
WRITE ?20,BGPX
+4 QUIT
H1 ;EP
+1 IF $GET(BGPSUMON)
QUIT
+2 WRITE !!?21,"REPORT",?31,"",?35,"PREV YR",?46,"",?49,"CHG from",?59,"BASE",?69,"",?72,"CHG from"
+3 WRITE !?21,"PERIOD ",?35,"PERIOD ",?49,"PREV YR ",?59,"PERIOD ",?72,"BASE "
+4 QUIT
CALC(N,O) ;ENTRY POINT
+1 NEW Z
+2 SET Z=N-O
SET Z=$FNUMBER(Z,"+,",0)
+3 QUIT Z
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
