- BGP6DP7 ; IHS/CMI/LAB - print ind 10 ;
- ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
- ;
- ;
- ;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(^BGPINDMC("AB",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDMC("AB",BGPPC1,BGPPC2,0)) D PI1
- Q
- PI1 ;
- K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- I BGPRTYPE'=4,BGPINDM="G",$P(^BGPINDMC(BGPPC,0),U,5)'=1 Q
- I BGPRTYPE=4,$P($G(^BGPINDMC(BGPPC,21)),U,2)=1 Q
- I BGPINDM="D",$P(^BGPINDMC(BGPPC,0),U,12)'=1 Q
- I BGPINDM="C",$P(^BGPINDMC(BGPPC,0),U,13)'=1 Q
- I BGPINDM="W",$P($G(^BGPINDMC(BGPPC,12)),U,2)'=1 Q
- I BGPINDM="E",$P($G(^BGPINDMC(BGPPC,12)),U,3)'=1 Q
- I BGPINDM="I",$P($G(^BGPINDMC(I,11)),U,1)'=1 Q
- I BGPINDM="P",$P($G(^BGPINDMC(I,11)),U,2)'=1 Q
- ;get numerator value of measure and calc %
- S BGPDF=$P(^BGPINDMC(BGPPC,0),U,9)
- I $P(^BGPINDMC(BGPPC,0),U,4)[".1" S BGPDHOLD=BGPDF
- I $P(^BGPINDMC(BGPPC,0),U,4)'[".1" S BGPDF=BGPDHOLD
- S BGPNP=$P(^DD(90556.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S BGPCYD=$$V^BGP6DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP6DP1C(1,N,P)
- S BGPPRD=$$V^BGP6DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP6DP1C(2,N,P)
- S BGPBLD=$$V^BGP6DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP6DP1C(3,N,P)
- S BGPNF=$P(^BGPINDMC(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90556.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- D SETN^BGP6DP1C
- ;write header for 1.A.1
- I '$G(BGPSUMON) D
- .S X=$$LABEL^BGP6UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$G(BGPINDM),"N")
- .W !,$P(X,U,1)
- .F I=2:1 S Y=$P(X,U,I) Q:Y="" W !," ",Y
- 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
- BGP6DP7 ; IHS/CMI/LAB - print ind 10 ;
- +1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
- +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(^BGPINDMC("AB",BGPPC1,BGPPC2))
- IF BGPPC2=""
- QUIT
- SET BGPPC=$ORDER(^BGPINDMC("AB",BGPPC1,BGPPC2,0))
- DO PI1
- +5 QUIT
- PI1 ;
- +1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- +2 IF BGPRTYPE'=4
- IF BGPINDM="G"
- IF $PIECE(^BGPINDMC(BGPPC,0),U,5)'=1
- QUIT
- +3 IF BGPRTYPE=4
- IF $PIECE($GET(^BGPINDMC(BGPPC,21)),U,2)=1
- QUIT
- +4 IF BGPINDM="D"
- IF $PIECE(^BGPINDMC(BGPPC,0),U,12)'=1
- QUIT
- +5 IF BGPINDM="C"
- IF $PIECE(^BGPINDMC(BGPPC,0),U,13)'=1
- QUIT
- +6 IF BGPINDM="W"
- IF $PIECE($GET(^BGPINDMC(BGPPC,12)),U,2)'=1
- QUIT
- +7 IF BGPINDM="E"
- IF $PIECE($GET(^BGPINDMC(BGPPC,12)),U,3)'=1
- QUIT
- +8 IF BGPINDM="I"
- IF $PIECE($GET(^BGPINDMC(I,11)),U,1)'=1
- QUIT
- +9 IF BGPINDM="P"
- IF $PIECE($GET(^BGPINDMC(I,11)),U,2)'=1
- QUIT
- +10 ;get numerator value of measure and calc %
- +11 SET BGPDF=$PIECE(^BGPINDMC(BGPPC,0),U,9)
- +12 IF $PIECE(^BGPINDMC(BGPPC,0),U,4)[".1"
- SET BGPDHOLD=BGPDF
- +13 IF $PIECE(^BGPINDMC(BGPPC,0),U,4)'[".1"
- SET BGPDF=BGPDHOLD
- +14 SET BGPNP=$PIECE(^DD(90556.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +15 SET BGPCYD=$$V^BGP6DP1C(1,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP6DP1C(1,N,P)
- +16 SET BGPPRD=$$V^BGP6DP1C(2,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP6DP1C(2,N,P)
- +17 SET BGPBLD=$$V^BGP6DP1C(3,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP6DP1C(3,N,P)
- +18 SET BGPNF=$PIECE(^BGPINDMC(BGPPC,0),U,9)
- +19 SET BGPNP=$PIECE(^DD(90556.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +20 DO SETN^BGP6DP1C
- +21 ;write header for 1.A.1
- +22 IF '$GET(BGPSUMON)
- Begin DoDot:1
- +23 SET X=$$LABEL^BGP6UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$GET(BGPINDM),"N")
- +24 WRITE !,$PIECE(X,U,1)
- +25 FOR I=2:1
- SET Y=$PIECE(X,U,I)
- IF Y=""
- QUIT
- WRITE !," ",Y
- End DoDot:1
- +26 DO H2
- +27 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
