BGP9PDL1.m

BGP9PDL1 ; IHS/CMI/LAB - print ind 1 01 Jul 2008 8:03 PM ; 

 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 ;

 ;

I1 ;EP

 D H1

I1A1 ;001.A, 001.B, 001.C

 I BGPINDT'="E" F BGPPC1="1.1","1.2","1.3" D PI

 I BGPINDT="E" S BGPPC1="1.4" D PI

 D I1AGE^BGP9PDL9

 Q

IREG ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:$P(^BGPINDN(BGPIC,0),U,13) S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I8 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:1 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I9 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:1 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 D ^BGP9PD19

 Q

I12 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:7 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I13 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:3 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 D I1AGE^BGP9PD19

 Q

I14 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:3 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I007 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I008 ;

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IB ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:6 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IH ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:6,10:1:15 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 D I1AGE^BGP9PDLA

 Q

IG ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IF ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:3 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IA ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:18 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

ICRSAMM ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,2) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I031A ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:13 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

ID ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:9 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I0302 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:9 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I0303 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:3 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I0302A ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:4 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IHEDBBH ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:6 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IHEDPBH ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:6 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IHEDCHM ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:6 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IE2 ;

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:1 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IE1 ;

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:1 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IK ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:6 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IOMW ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IRAO ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

II ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IL ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IAS ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:8 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IMS ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IC2 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IAST1 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:12 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IRAA ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IRAR ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IHEDCWP ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

IHEDURI ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

I28 ;EP

 D H1

 S BGPORDP=$P(^BGPINDN(BGPIC,0),U,6) F BGPORDP1=1:1:2 S BGPPC1=BGPORDP_"."_BGPORDP1 D PI

 Q

PI ;EP

 S BGPDENP=0

 S BGPPC2=0 F  S BGPPC2=$O(^BGPINDNC("ABC",BGPPC1,BGPPC2)) Q:BGPPC2=""  S BGPPC=$O(^BGPINDNC("ABC",BGPPC1,BGPPC2,0)) D PI1

 Q

PI1 ;EP

 K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGP9SDPD

 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 BGPRTYPE=4,$P($G(^BGPINDNC(BGPPC,21)),U,2)=1 Q  ;local

 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

 I $P(^BGPINDNC(BGPPC,0),U,4)="E-2.B.3" S X=" " D S(X,1,1) D PI1^BGP9PDL2 Q  ;count only

 S BGPDF=$P(^BGPINDNC(BGPPC,0),U,8)

 ;get denominator value of measure

 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)

 ;write out denominator

 I BGPRTYPE=7,$P(^BGPINDNC(BGPPC,0),U,4)="028.C.4" S BGPDENP=0

 I 'BGPDENP S Y=" " D:$E($P($G(^BGPINDNC(BGPPC,12)),U,4),1,4)'=48.2!($P($G(^BGPINDNC(BGPPC,12)),U,4)="48.2.1")!($P($G(^BGPINDNC(BGPPC,12)),U,4)="43.22.1") S(Y,1,1) D

 .I $P($G(^BGPINDNC(BGPPC,12)),U,14) Q

 .;I $E($P(^BGPINDNC(BGPPC,0),U,4),1,3)="I.B"!($E($P(^BGPINDNC(BGPPC,0),U,4),1,3)="I.F") Q

 .I BGPRTYPE=1,$P($G(^BGPINDNC(BGPPC,20)),U,4)]"" S Y=$P(^BGPINDNC(BGPPC,20),U,4)_" "_$P(^BGPINDNC(BGPPC,20),U,5)_" "_$P(^BGPINDNC(BGPPC,20),U,6) D S(Y,1,1) I 1

 .E  S Y=$P(^BGPINDNC(BGPPC,0),U,17)_" "_$P(^BGPINDNC(BGPPC,0),U,18)_" "_$P(^BGPINDNC(BGPPC,0),U,21) D S(Y,1,1)

 .S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S(Y,,2)

 .S BGPDENP=1

 ;get numerator value of measure and calc %

 I $E($P(^BGPINDNC(BGPPC,0),U,4),1,2)="I." D

 .S BGPDF=$P(^BGPINDNC(BGPPC,0),U,8)

 .;get denominator value of measure

 .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 BGPRTYPE=1,$P($G(^BGPINDNC(BGPPC,20)),U)]"" S X=$P(^BGPINDNC(BGPPC,20),U,1)_" "_$P(^BGPINDNC(BGPPC,20),U,2)_" "_$P(^BGPINDNC(BGPPC,20),U,3) D S(X,1,1) I 1

 E  D

 .I $P(^BGPINDNC(BGPPC,0),U,22) D S(" ",1,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

SETN ;EP - set numerator fields

 S BGPIIDEL=1

 D SETN^BGP9DP1C

 Q

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) ;

 NEW Z

 S Z=N-O,Z=$FN(Z,"+,",1)

 Q Z

H3 ;EP

 S X="Age Distribution" D S(X,1,1) S X=" " D S(X,1,1)

 S Y="<15" D S(Y,1,2)

 S Y="15-19" D S(Y,,3)

 S Y="20-24" D S(Y,,4)

 S Y="25-34" D S(Y,,5)

 S Y="35-44" D S(Y,,6)

 S Y="45-54" D S(Y,,7)

 S Y="55-64" D S(Y,,8)

 S Y=">64 yrs" D S(Y,,9)

 Q

SB(X) ;EP - Strip leading and trailing blanks from X.

 NEW %

 X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)

 Q X

H2 ;EP

 S BGPX="",BGPX=BGPCYN,$P(BGPX,U,2)=$$SB($J(BGPCYP,5,1)),$P(BGPX,U,3)=BGPPRN,$P(BGPX,U,4)=$$SB($J(BGPPRP,5,1)),$P(BGPX,U,5)=$$SB($J($$CALC(BGPCYP,BGPPRP),6)),$P(BGPX,U,6)=BGPBLN,$P(BGPX,U,7)=$$SB($J(BGPBLP,5,1))

 S $P(BGPX,U,8)=$$SB($J($$CALC(BGPCYP,BGPBLP),6))

 D S(BGPX,,2)

 Q

H1 ;EP

 S Y="" D S(Y,1,1)

 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

BGP9PDL1  ; IHS/CMI/LAB - print ind 1 01 Jul 2008 8:03 PM ; 

 +1       ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 +2       ;

 +3       ;

I1        ;EP

 +1        DO H1

I1A1      ;001.A, 001.B, 001.C

 +1        IF BGPINDT'="E"

               FOR BGPPC1="1.1","1.2","1.3"

                   DO PI

 +2        IF BGPINDT="E"

               SET BGPPC1="1.4"

               DO PI

 +3        DO I1AGE^BGP9PDL9

 +4        QUIT 

IREG      ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:$PIECE(^BGPINDN(BGPIC,0),U,13)

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I8        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:1

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I9        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:1

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        DO ^BGP9PD19

 +4        QUIT 

I12       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:7

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I13       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:3

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        DO I1AGE^BGP9PD19

 +4        QUIT 

I14       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:3

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I007      ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I008      ;

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IB        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:6

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IH        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:6,10:1:15

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        DO I1AGE^BGP9PDLA

 +4        QUIT 

IG        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IF        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:3

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IA        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:18

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

ICRSAMM   ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,2)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I031A     ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:13

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

ID        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:9

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I0302     ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:9

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I0303     ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:3

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I0302A    ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:4

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IHEDBBH   ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:6

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IHEDPBH   ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:6

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IHEDCHM   ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:6

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IE2       ;

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:1

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IE1       ;

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:1

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IK        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:6

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IOMW      ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IRAO      ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

II        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IL        ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IAS       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:8

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IMS       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IC2       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IAST1     ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:12

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IRAA      ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IRAR      ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IHEDCWP   ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

IHEDURI   ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

I28       ;EP

 +1        DO H1

 +2        SET BGPORDP=$PIECE(^BGPINDN(BGPIC,0),U,6)

           FOR BGPORDP1=1:1:2

               SET BGPPC1=BGPORDP_"."_BGPORDP1

               DO PI

 +3        QUIT 

PI        ;EP

 +1        SET BGPDENP=0

 +2        SET BGPPC2=0

           FOR 

               SET BGPPC2=$ORDER(^BGPINDNC("ABC",BGPPC1,BGPPC2))

               IF BGPPC2=""

                   QUIT 

               SET BGPPC=$ORDER(^BGPINDNC("ABC",BGPPC1,BGPPC2,0))

               DO PI1

 +3        QUIT 

PI1       ;EP

 +1        KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGP9SDPD

 +2       ;not on national

           IF BGPRTYPE=1

               IF $PIECE(^BGPINDNC(BGPPC,0),U,5)'=1

                   QUIT 

 +3       ;not on other national

           IF BGPRTYPE=7

               IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,12)'=1

                   QUIT 

 +4       ;local

           IF BGPRTYPE=4

               IF $PIECE($GET(^BGPINDNC(BGPPC,21)),U,2)=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"