BGP8ELLN.m

BGP8ELLN ; IHS/CMI/LAB - print ind 1 ;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

 ;

 ;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(^BGPELIIR("AP",BGPPC1,BGPPC)) Q:BGPPC=""  D PI1

 Q

PI1 ;

 K BGPEXCT,BGPSDP,BGPCYP,BGPBLP,BGPPRD

 S (BGPCYD,BGPPRD,BGPBLD)=""

 S BGPNF=$P(^BGPELIIR(BGPPC,0),U,9)

 S BGPNP=$P(^DD(90561.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)

 D SETN

 ;S X=$P(^BGPELIIR(BGPPC,0),U,15) D S(X,1,1)

 ;I $P(^BGPELIIR(BGPPC,0),U,16)]"" S X=$P(^BGPELIIR(BGPPC,0),U,16) D S(X,1,1)

 ;I $P(^BGPELIIR(BGPPC,0),U,19)]"" S Y=$P(^BGPELIIR(BGPPC,0),U,19) D S(Y,1,1)

 S Y=$$LABELE^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,"N") 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^BGP8ELL2($J($$CALC(BGPCYN,BGPPRN),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=""

 S $P(BGPX,U,8)=$$SB^BGP8ELL2($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^BGP8ELL1

 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

BGP8ELLN  ; IHS/CMI/LAB - print ind 1 ;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +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(^BGPELIIR("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(^BGPELIIR(BGPPC,0),U,9)

 +4        SET BGPNP=$PIECE(^DD(90561.03,BGPNF,0),U,4)

           SET N=$PIECE(BGPNP,";")

           SET P=$PIECE(BGPNP,";",2)

 +5        DO SETN

 +6       ;S X=$P(^BGPELIIR(BGPPC,0),U,15) D S(X,1,1)

 +7       ;I $P(^BGPELIIR(BGPPC,0),U,16)]"" S X=$P(^BGPELIIR(BGPPC,0),U,16) D S(X,1,1)

 +8       ;I $P(^BGPELIIR(BGPPC,0),U,19)]"" S Y=$P(^BGPELIIR(BGPPC,0),U,19) D S(Y,1,1)

 +9        SET Y=$$LABELE^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,"N")

           DO S(Y,1,1)

 +10       DO H2

 +11       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^BGP8ELL2($JUSTIFY($$CALC(BGPCYN,BGPPRN),6))

           SET $PIECE(BGPX,U,6)=BGPBLN

           SET $PIECE(BGPX,U,7)=""

 +3        SET $PIECE(BGPX,U,8)=$$SB^BGP8ELL2($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^BGP8ELL1

 +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