BGP9ELLN ; IHS/CMI/LAB - print ind 1 ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
;this routine for Measure I23 ONLY
IELDPHA ;EP
D H1
F BGPPC1="24.1","24.2" S X="" D S(X,1,1) D PI
Q
PI ;EP
S BGPPC=0 F S BGPPC=$O(^BGPELIIN("AP",BGPPC1,BGPPC)) Q:BGPPC="" D PI1
Q
PI1 ;
K BGPEXCT,BGPSDP,BGPCYP,BGPBLP,BGPPRD
S (BGPCYD,BGPPRD,BGPBLD)=""
S BGPNF=$P(^BGPELIIN(BGPPC,0),U,9)
S BGPNP=$P(^DD(90538.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
D SETN
S X=$P(^BGPELIIN(BGPPC,0),U,15) D S(X,1,1)
I $P(^BGPELIIN(BGPPC,0),U,16)]"" S X=$P(^BGPELIIN(BGPPC,0),U,16) D S(X,1,1)
I $P(^BGPELIIN(BGPPC,0),U,19)]"" S Y=$P(^BGPELIIN(BGPPC,0),U,19) D S(Y,1,1)
D H2^BGP9ELL2
Q
H2 ;
S BGPX="",BGPX=BGPCYN
S $P(BGPX,U,2)="",$P(BGPX,U,3)=BGPPRN,$P(BGPX,U,4)="",$P(BGPX,U,5)=$$SB^BGP9ELL2($J($$CALC(BGPCYN,BGPPRN),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=""
S $P(BGPX,U,8)=$$SB^BGP9ELL2($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
SETN ;EP set numerator fields
D SETN^BGP9ELL1
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
BGP9ELLN ; IHS/CMI/LAB - print ind 1 ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
+3 ;
+4 ;this routine for Measure I23 ONLY
IELDPHA ;EP
+1 DO H1
+2 FOR BGPPC1="24.1","24.2"
SET X=""
DO S(X,1,1)
DO PI
+3 QUIT
PI ;EP
+1 SET BGPPC=0
FOR
SET BGPPC=$ORDER(^BGPELIIN("AP",BGPPC1,BGPPC))
IF BGPPC=""
QUIT
DO PI1
+2 QUIT
PI1 ;
+1 KILL BGPEXCT,BGPSDP,BGPCYP,BGPBLP,BGPPRD
+2 SET (BGPCYD,BGPPRD,BGPBLD)=""
+3 SET BGPNF=$PIECE(^BGPELIIN(BGPPC,0),U,9)
+4 SET BGPNP=$PIECE(^DD(90538.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+5 DO SETN
+6 SET X=$PIECE(^BGPELIIN(BGPPC,0),U,15)
DO S(X,1,1)
+7 IF $PIECE(^BGPELIIN(BGPPC,0),U,16)]""
SET X=$PIECE(^BGPELIIN(BGPPC,0),U,16)
DO S(X,1,1)
+8 IF $PIECE(^BGPELIIN(BGPPC,0),U,19)]""
SET Y=$PIECE(^BGPELIIN(BGPPC,0),U,19)
DO S(Y,1,1)
+9 DO H2^BGP9ELL2
+10 QUIT
H2 ;
+1 SET BGPX=""
SET BGPX=BGPCYN
+2 SET $PIECE(BGPX,U,2)=""
SET $PIECE(BGPX,U,3)=BGPPRN
SET $PIECE(BGPX,U,4)=""
SET $PIECE(BGPX,U,5)=$$SB^BGP9ELL2($JUSTIFY($$CALC(BGPCYN,BGPPRN),6))
SET $PIECE(BGPX,U,6)=BGPBLN
SET $PIECE(BGPX,U,7)=""
+3 SET $PIECE(BGPX,U,8)=$$SB^BGP9ELL2($JUSTIFY($$CALC(BGPCYN,BGPBLN),6))
+4 DO S(BGPX,,2)
+5 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
SETN ;EP set numerator fields
+1 DO SETN^BGP9ELL1
+2 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
