- BGP9PDL3 ; IHS/CMI/LAB - print ind 1 ;
- ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- ;
- ;
- ;this routine for Measure I23 ONLY
- I023 ;EP
- S BGPORXX=$P(^BGPINDN(BGPIC,0),U,6)
- D H1^BGP9PDL1
- F BGPPC1=BGPORXX_".1" D PI^BGP9PDL1
- ;D H1
- S X=" " D S(X,1,1)
- F BGPPC1=BGPORXX_".2.1",BGPORXX_".2.2",BGPORXX_".2.3",BGPORXX_".2.4",BGPORXX_".2.5",BGPORXX_".2.6" D PI
- S X=" " D S(X,1,1)
- F BGPPC1=BGPORXX_".3.1",BGPORXX_".3.2",BGPORXX_".3.3",BGPORXX_".3.4",BGPORXX_".3.5",BGPORXX_".3.6" D PI
- Q
- PI ;EP
- K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- S BGPPC=$O(^BGPINDNC("OR",BGPPC1,0))
- I BGPRTYPE=1,$P(^BGPINDNC(BGPPC,0),U,5)'=1 Q ;not on national
- I BGPRTYPE=7,$P($G(^BGPINDNC(BGPPC,12)),U,12)'=1 Q ;not on other national
- I BGPINDT="D",$P(^BGPINDNC(BGPPC,0),U,12)'=1 Q
- I BGPINDT="C",$P(^BGPINDNC(BGPPC,0),U,13)'=1 Q
- I BGPINDT="W",$P($G(^BGPINDNC(BGPPC,12)),U,2)'=1 Q
- I BGPINDT="E",$P($G(^BGPINDNC(BGPPC,12)),U,3)'=1 Q
- ;get numerator value of measure and calc %
- S BGPPC=BGPPC D
- .S BGPDF=$P(^BGPINDNC(BGPPC,0),U,9)
- .;I $P(^BGPINDNC(BGPPC,0),U,4)[".3" S BGPDF=23.503
- .;I $P(^BGPINDNC(BGPPC,0),U,4)[".4" S BGPDF=23.504
- .S BGPNP=$P(^DD(90536.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- .S BGPCYD=$$V^BGP9DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP9DP1C(1,N,P)
- .S BGPPRD=$$V^BGP9DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP9DP1C(2,N,P)
- .S BGPBLD=$$V^BGP9DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP9DP1C(3,N,P)
- .S BGPNF=$P(^BGPINDNC(BGPPC,0),U,9)
- .S BGPNP=$P(^DD(90536.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- .D SETN
- .I $P($G(^BGPINDNC(BGPPC,14)),U) D
- ..S ^TMP($J,"SUMMARYDEL",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- ..Q:'$G(BGPAREAA)
- ..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
- ...S ^TMP($J,"SUMMARYDEL DETAIL PAGE",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(BGPPC,14),U,6),BGPPC,X)=$P($G(BGPSDP(X,1)),U,2)_U_$P($G(BGPSDP(X,2)),U,2)_U_$P($G(BGPSDP(X,3)),U,2)_U_BGPCYN
- .;NON
- .I $P($G(^BGPINDNC(BGPPC,15)),U) D
- ..S ^TMP($J,"SUMMARYDEL NON",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,15),U,5),0),U,3),$P(^BGPINDNC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- ..I $G(BGPAREAA) D ;SDPX
- ...S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D ;SDPX
- ....S ^TMP($J,"SUMMARYDEL DETAIL PAGE NON",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,15),U,5),0),U,3),$P(^BGPINDNC(BGPPC,15),U,6),BGPPC,X)=$P($G(BGPSDPN(X,1)),U,2)_U_$P($G(BGPSDPN(X,2)),U,2)_U_$P($G(BGPSDPN(X,3)),U,2)_U_BGPCYN
- .;DEVEL
- .I $P($G(^BGPINDNC(BGPPC,22)),U) D
- ..S ^TMP($J,"SUMMARYDEL DEVEL",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,22),U,5),0),U,3),$P(^BGPINDNC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- ..I $G(BGPAREAA) D ;SDPX
- ...S X=0 F S X=$O(BGPSDPD(X)) Q:X'=+X D ;SDPX
- ....S ^TMP($J,"SUMMARYDEL DETAIL PAGE DEVEL",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,22),U,5),0),U,3),$P(^BGPINDNC(BGPPC,22),U,6),BGPPC,X)=$P($G(BGPSDPD(X,1)),U,2)_U_$P($G(BGPSDPD(X,2)),U,2)_U_$P($G(BGPSDPD(X,3)),U,2)_U_BGPCYN
- .;OTHER
- .I $P($G(^BGPINDNC(BGPPC,19)),U) D
- ..S ^TMP($J,"SUMMARYDEL OTHER",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- ..I $G(BGPAREAA) D ;SDPX
- ...S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D ;SDPX
- ....S ^TMP($J,"SUMMARYDEL DETAIL PAGE OTHER",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(BGPPC,19),U,6),BGPPC,X)=$P($G(BGPSDPO(X,1)),U,2)_U_$P($G(BGPSDPO(X,2)),U,2)_U_$P($G(BGPSDPO(X,3)),U,2)_U_BGPCYN
- .;write header for 1.A.1
- .S X=$P(^BGPINDNC(BGPPC,0),U,15)_" "_$P(^BGPINDNC(BGPPC,0),U,16)_" "_$P(^BGPINDNC(BGPPC,0),U,19) D S(X,1,1)
- .D H2
- Q
- H2 ;
- S BGPX="",BGPX=BGPCYN,$P(BGPX,U,2)="",$P(BGPX,U,3)=BGPPRN,$P(BGPX,U,4)="",$P(BGPX,U,5)=$$SB($J($$CALC(BGPCYN,BGPPRN),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=""
- S $P(BGPX,U,8)=$$SB($J($$CALC(BGPCYN,BGPBLN),6))
- D S(BGPX,,2)
- Q
- H1 ;EP
- S Y="REPORT" D S(Y,1,2)
- S Y=" " D S(Y,,3)
- S Y="PREV YR" D S(Y,,4)
- S Y=" " D S(Y,,5)
- S Y="CHG from" D S(Y,,6)
- S Y="BASE" D S(Y,,7)
- S Y=" " D S(Y,,8)
- S Y="CHG from" D S(Y,,9)
- S Y="PERIOD" D S(Y,1,2)
- S Y="PERIOD" D S(Y,,4)
- S Y="PREV YR " D S(Y,,6)
- S Y="PERIOD" D S(Y,,7)
- S Y="BASE " D S(Y,,9)
- Q
- SL(V) ;
- I V="" S V=0
- Q $$STRIP^XLFSTR($J(V,5,1)," ")
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- S(Y,F,P) ;set up array
- I '$G(F) S F=0
- S %=$P(^TMP($J,"BGPDEL",0),U)+F,$P(^TMP($J,"BGPDEL",0),U)=%
- I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""
- S $P(^TMP($J,"BGPDEL",%),U,P)=Y
- Q
- CALC(N,O) ;ENTRY POINT
- NEW Z
- S Z=N-O,Z=$FN(Z,"+,",0)
- Q Z
- SB(X) ;EP - Strip leading and trailing blanks from X.
- X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
- Q X
- SETN ;set numerator fields
- S BGPIIDEL=1,BGPNOSUM=1
- D SETN^BGP9DP1C
- ;I $P(^BGPINDNC(BGPPC,0),U,4)[".1"
- K BGPNOSUM,BGPIIDEL
- S (BGPCYP,BGPPRP,BGPBLP)=""
- Q
- BGP9PDL3 ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- +2 ;
- +3 ;
- +4 ;this routine for Measure I23 ONLY
- I023 ;EP
- +1 SET BGPORXX=$PIECE(^BGPINDN(BGPIC,0),U,6)
- +2 DO H1^BGP9PDL1
- +3 FOR BGPPC1=BGPORXX_".1"
- DO PI^BGP9PDL1
- +4 ;D H1
- +5 SET X=" "
- DO S(X,1,1)
- +6 FOR BGPPC1=BGPORXX_".2.1",BGPORXX_".2.2",BGPORXX_".2.3",BGPORXX_".2.4",BGPORXX_".2.5",BGPORXX_".2.6"
- DO PI
- +7 SET X=" "
- DO S(X,1,1)
- +8 FOR BGPPC1=BGPORXX_".3.1",BGPORXX_".3.2",BGPORXX_".3.3",BGPORXX_".3.4",BGPORXX_".3.5",BGPORXX_".3.6"
- DO PI
- +9 QUIT
- PI ;EP
- +1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
- +2 SET BGPPC=$ORDER(^BGPINDNC("OR",BGPPC1,0))
- +3 ;not on national
- IF BGPRTYPE=1
- IF $PIECE(^BGPINDNC(BGPPC,0),U,5)'=1
- QUIT
- +4 ;not on other national
- IF BGPRTYPE=7
- IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,12)'=1
- QUIT
- +5 IF BGPINDT="D"
- IF $PIECE(^BGPINDNC(BGPPC,0),U,12)'=1
- QUIT
- +6 IF BGPINDT="C"
- IF $PIECE(^BGPINDNC(BGPPC,0),U,13)'=1
- QUIT
- +7 IF BGPINDT="W"
- IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,2)'=1
- QUIT
- +8 IF BGPINDT="E"
- IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,3)'=1
- QUIT
- +9 ;get numerator value of measure and calc %
- +10 SET BGPPC=BGPPC
- Begin DoDot:1
- +11 SET BGPDF=$PIECE(^BGPINDNC(BGPPC,0),U,9)
- +12 ;I $P(^BGPINDNC(BGPPC,0),U,4)[".3" S BGPDF=23.503
- +13 ;I $P(^BGPINDNC(BGPPC,0),U,4)[".4" S BGPDF=23.504
- +14 SET BGPNP=$PIECE(^DD(90536.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +15 SET BGPCYD=$$V^BGP9DP1C(1,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP9DP1C(1,N,P)
- +16 SET BGPPRD=$$V^BGP9DP1C(2,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP9DP1C(2,N,P)
- +17 SET BGPBLD=$$V^BGP9DP1C(3,BGPRPT,N,P,1)
- IF $GET(BGPAREAA)
- DO SETEXA^BGP9DP1C(3,N,P)
- +18 SET BGPNF=$PIECE(^BGPINDNC(BGPPC,0),U,9)
- +19 SET BGPNP=$PIECE(^DD(90536.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +20 DO SETN
- +21 IF $PIECE($GET(^BGPINDNC(BGPPC,14)),U)
- Begin DoDot:2
- +22 SET ^TMP($JOB,"SUMMARYDEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +23 IF '$GET(BGPAREAA)
- QUIT
- +24 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDP(X))
- IF X'=+X
- QUIT
- Begin DoDot:3
- +25 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,14),U,6),BGPPC,X)=$PIECE($GET(BGPSDP(X,1)),U,2)_U_$PIECE($GET(BGPSDP(X,2)),U,2)_U_$PIECE($GET(BGPSDP(X,3))
- ,U,2)_U_BGPCYN
- End DoDot:3
- End DoDot:2
- +26 ;NON
- +27 IF $PIECE($GET(^BGPINDNC(BGPPC,15)),U)
- Begin DoDot:2
- +28 SET ^TMP($JOB,"SUMMARYDEL NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +29 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:3
- +30 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPN(X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +31 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,15),U,6),BGPPC,X)=$PIECE($GET(BGPSDPN(X,1)),U,2)_U_$PIECE($GET(BGPSDPN(X,2)),U,2)_U_$PIECE($GE
- T(BGPSDPN(X,3)),U,2)_U_BGPCYN
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +32 ;DEVEL
- +33 IF $PIECE($GET(^BGPINDNC(BGPPC,22)),U)
- Begin DoDot:2
- +34 SET ^TMP($JOB,"SUMMARYDEL DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +35 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:3
- +36 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPD(X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +37 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,22),U,6),BGPPC,X)=$PIECE($GET(BGPSDPD(X,1)),U,2)_U_$PIECE($GET(BGPSDPD(X,2)),U,2)_U_$PIECE($
- GET(BGPSDPD(X,3)),U,2)_U_BGPCYN
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +38 ;OTHER
- +39 IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U)
- Begin DoDot:2
- +40 SET ^TMP($JOB,"SUMMARYDEL OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
- +41 ;SDPX
- IF $GET(BGPAREAA)
- Begin DoDot:3
- +42 ;SDPX
- SET X=0
- FOR
- SET X=$ORDER(BGPSDPO(X))
- IF X'=+X
- QUIT
- Begin DoDot:4
- +43 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,19),U,6),BGPPC,X)=$PIECE($GET(BGPSDPO(X,1)),U,2)_U_$PIECE($GET(BGPSDPO(X,2)),U,2)_U_$PIECE($
- GET(BGPSDPO(X,3)),U,2)_U_BGPCYN
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +44 ;write header for 1.A.1
- +45 SET X=$PIECE(^BGPINDNC(BGPPC,0),U,15)_" "_$PIECE(^BGPINDNC(BGPPC,0),U,16)_" "_$PIECE(^BGPINDNC(BGPPC,0),U,19)
- DO S(X,1,1)
- +46 DO H2
- End DoDot:1
- +47 QUIT
- H2 ;
- +1 SET BGPX=""
- SET BGPX=BGPCYN
- SET $PIECE(BGPX,U,2)=""
- SET $PIECE(BGPX,U,3)=BGPPRN
- SET $PIECE(BGPX,U,4)=""
- SET $PIECE(BGPX,U,5)=$$SB($JUSTIFY($$CALC(BGPCYN,BGPPRN),6))
- SET $PIECE(BGPX,U,6)=BGPBLN
- SET $PIECE(BGPX,U,7)=""
- +2 SET $PIECE(BGPX,U,8)=$$SB($JUSTIFY($$CALC(BGPCYN,BGPBLN),6))
- +3 DO S(BGPX,,2)
- +4 QUIT
- H1 ;EP
- +1 SET Y="REPORT"
- DO S(Y,1,2)
- +2 SET Y=" "
- DO S(Y,,3)
- +3 SET Y="PREV YR"
- DO S(Y,,4)
- +4 SET Y=" "
- DO S(Y,,5)
- +5 SET Y="CHG from"
- DO S(Y,,6)
- +6 SET Y="BASE"
- DO S(Y,,7)
- +7 SET Y=" "
- DO S(Y,,8)
- +8 SET Y="CHG from"
- DO S(Y,,9)
- +9 SET Y="PERIOD"
- DO S(Y,1,2)
- +10 SET Y="PERIOD"
- DO S(Y,,4)
- +11 SET Y="PREV YR "
- DO S(Y,,6)
- +12 SET Y="PERIOD"
- DO S(Y,,7)
- +13 SET Y="BASE "
- DO S(Y,,9)
- +14 QUIT
- SL(V) ;
- +1 IF V=""
- SET V=0
- +2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X
- S(Y,F,P) ;set up array
- +1 IF '$GET(F)
- SET F=0
- +2 SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)+F
- SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%
- +3 IF '$DATA(^TMP($JOB,"BGPDEL",%))
- SET ^TMP($JOB,"BGPDEL",%)=""
- +4 SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=Y
- +5 QUIT
- CALC(N,O) ;ENTRY POINT
- +1 NEW Z
- +2 SET Z=N-O
- SET Z=$FNUMBER(Z,"+,",0)
- +3 QUIT Z
- SB(X) ;EP - Strip leading and trailing blanks from X.
- +1 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
- +2 QUIT X
- SETN ;set numerator fields
- +1 SET BGPIIDEL=1
- SET BGPNOSUM=1
- +2 DO SETN^BGP9DP1C
- +3 ;I $P(^BGPINDNC(BGPPC,0),U,4)[".1"
- +4 KILL BGPNOSUM,BGPIIDEL
- +5 SET (BGPCYP,BGPPRP,BGPBLP)=""
- +6 QUIT
