- BGP7ELLN ; IHS/CMI/LAB - print ind 1 ;
- ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- ;
- ;
- ;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(^BGPELIIG("AP",BGPPC1,BGPPC)) Q:BGPPC="" D PI1
- Q
- PI1 ;
- K BGPEXCT,BGPSDP,BGPCYP,BGPBLP,BGPPRD
- S (BGPCYD,BGPPRD,BGPBLD)=""
- S BGPNF=$P(^BGPELIIG(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90559.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- D SETN
- S X=$P(^BGPELIIG(BGPPC,0),U,15) D S(X,1,1)
- I $P(^BGPELIIG(BGPPC,0),U,16)]"" S X=$P(^BGPELIIG(BGPPC,0),U,16) D S(X,1,1)
- I $P(^BGPELIIG(BGPPC,0),U,19)]"" S Y=$P(^BGPELIIG(BGPPC,0),U,19) D S(Y,1,1)
- D H2
- 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^BGP7ELL2($J($$CALC(BGPCYN,BGPPRN),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=""
- S $P(BGPX,U,8)=$$SB^BGP7ELL2($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^BGP7ELL1
- 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
- BGP7ELLN ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- +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(^BGPELIIG("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(^BGPELIIG(BGPPC,0),U,9)
- +4 SET BGPNP=$PIECE(^DD(90559.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +5 DO SETN
- +6 SET X=$PIECE(^BGPELIIG(BGPPC,0),U,15)
- DO S(X,1,1)
- +7 IF $PIECE(^BGPELIIG(BGPPC,0),U,16)]""
- SET X=$PIECE(^BGPELIIG(BGPPC,0),U,16)
- DO S(X,1,1)
- +8 IF $PIECE(^BGPELIIG(BGPPC,0),U,19)]""
- SET Y=$PIECE(^BGPELIIG(BGPPC,0),U,19)
- DO S(Y,1,1)
- +9 DO H2
- +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^BGP7ELL2($JUSTIFY($$CALC(BGPCYN,BGPPRN),6))
- SET $PIECE(BGPX,U,6)=BGPBLN
- SET $PIECE(BGPX,U,7)=""
- +3 SET $PIECE(BGPX,U,8)=$$SB^BGP7ELL2($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^BGP7ELL1
- +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
