- BGP4ELP1 ; IHS/CMI/LAB - print ind 1 ;
- ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- ;
- ;
- I1 ;EP ; diabetes prevalence
- D H1^BGP4DPH ;column headers
- I1A1 ;001.A, 001.B, 001.C
- F BGPPC1="1.1","1.2","1.3" Q:BGPQUIT D PI
- D I1AGE
- Q
- I2 ;EP
- I $Y>(BGPIOSL-13) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0)
- D H1^BGP4DPH
- F BGPPC1="2.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL12
- Q
- I3 ;EP
- I $Y>(BGPIOSL-13) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0)
- D H1^BGP4DPH
- F BGPPC1="3.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL13
- Q
- I4 ;EP
- I $Y>(BGPIOSL-13) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0)
- D H1^BGP4DPH
- F BGPPC1="4.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL14
- Q
- I5 ;EP
- I $Y>(BGPIOSL-13) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0)
- D H1^BGP4DPH
- F BGPPC1="5.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL15
- Q
- I6 ;EP
- I $Y>(BGPIOSL-13) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0)
- D H1^BGP4DPH
- F BGPPC1="6.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL16
- Q
- I7 ;EP
- D H1^BGP4DPH
- F BGPPC1="7.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL17
- Q
- I8 ;
- D H1^BGP4DPH
- F BGPPC1="8.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL18
- Q
- I9 ;EP
- D H1^BGP4DPH
- F BGPPC1="9.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL19
- Q
- I10 ;EP
- D H1^BGP4DPH
- F BGPPC1="10.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL10
- Q
- I11 ;EP
- D H1^BGP4DPH
- F BGPPC1="11.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1A
- Q
- I12 ;EP
- D H1^BGP4DPH
- F BGPPC1="12.1","12.2","12.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1B
- Q
- I13 ;EP
- D H1^BGP4DPH
- F BGPPC1="13.1","13.2","13.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1C
- Q
- I14 ;EP
- D H1^BGP4DPH
- F BGPPC1="14.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1D
- Q
- I15 ;EP
- D H1^BGP4DPH
- F BGPPC1="15.1","15.2","15.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1E
- Q
- I16 ;EP
- D H1^BGP4DPH
- F BGPPC1="16.1","16.2","16.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1F
- Q
- I17 ;EP
- D H1^BGP4DPH
- F BGPPC1="17.1","17.2","17.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1G
- Q
- I18 ;EP
- D H1^BGP4DPH
- F BGPPC1="18.1","18.2","18.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1H
- Q
- I19 ;EP
- D H1^BGP4DPH
- F BGPPC1="19.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1I
- Q
- EFR ;EP
- D H1^BGP4DPH
- S BGPPC0=$P(^BGPELIJ(BGPIC,0),U,6)
- F BGPPCX=1,2,3 S BGPPC1=BGPPC0_"."_BGPPCX Q:BGPQUIT D PI
- D I1AGE^BGP4EL1O
- Q
- IEDA ;EP
- D H1^BGP4DPH
- S BGPPC0=$P(^BGPELIJ(BGPIC,0),U,6)
- F BGPPCX=1,2,3 S BGPPC1=BGPPC0_"."_BGPPCX Q:BGPQUIT D PI
- D I1AGE^BGP4EL1P
- Q
- IELDFSA ;EP
- D H1^BGP4DPH
- F BGPPC1="22.1","22.2","22.3" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1J
- Q
- IELDASA ;EP
- D H1^BGP4DPH
- F BGPPC1="23.1" Q:BGPQUIT D PI
- S BGPNODEN=1 S BGPPC1="23.2" Q:BGPQUIT D PI K BGPNODEN
- D I1AGE^BGP4EL1K
- Q
- IELDPHA ;EP
- D IELDPHA^BGP4EL1L
- Q
- IRAO ;EP
- D H1^BGP4DPH
- F BGPPC1="20.1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1M
- Q
- IRAA ;EP
- D H1^BGP4DPH
- F BGPPC1=$P(^BGPELIJ(BGPIC,0),U,6)_".1" Q:BGPQUIT D PI
- D I1AGE^BGP4EL1N
- Q
- AWV ;EP
- D H1^BGP4DPH
- K BGPNODEN
- F BGPPC9=1:1:3 S BGPPC1="28."_BGPPC9 Q:BGPQUIT D PI
- D ^BGP4EL1T
- Q
- PCV ;EP
- D H1^BGP4DPH
- S BGPNODEN=1 F BGPPC9=1:1:7 S BGPPC1="27."_BGPPC9 Q:BGPQUIT S BGPNODEN=1 D PI K BGPNODEN
- I BGPQUIT K BGPNODEN Q
- D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0) D H1^BGP4DPH
- S BGPNODEN=1 F BGPPC9=8:1:15 S BGPPC1="27."_BGPPC9 Q:BGPQUIT S BGPNODEN=1 D PI K BGPNODEN
- I BGPQUIT K BGPNODEN Q
- D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0) D H1^BGP4DPH
- S BGPNODEN=1 F BGPPC9=16:1:22 S BGPPC1="27."_BGPPC9 Q:BGPQUIT S BGPNODEN=1 D PI K BGPNODEN
- I BGPQUIT K BGPNODEN Q
- D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0) D H1^BGP4DPH
- S BGPNODEN=1 F BGPPC9=23:1:30 S BGPPC1="27."_BGPPC9 Q:BGPQUIT S BGPNODEN=1 D PI K BGPNODEN
- I BGPQUIT K BGPNODEN Q
- K BGPNODEN
- ;F BGPPC9=31:1:33 S BGPPC1="27."_BGPPC9 Q:BGPQUIT D PI
- ;D ^BGP4EL1S
- Q
- PI ;EP
- S BGPDENP=0
- S BGPPC2=0 F S BGPPC2=$O(^BGPELIIJ("ABC",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPELIIJ("ABC",BGPPC1,BGPPC2,0)) D PI1
- Q
- PI1 ;
- S BGPDF=$P(^BGPELIIJ(BGPPC,0),U,8)
- ;get denominator value of measure
- S BGPNP=$P(^DD(90553.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- S BGPCYD=$$V(1,BGPRPT,N,P)
- S BGPPRD=$$V(2,BGPRPT,N,P)
- S BGPBLD=$$V(3,BGPRPT,N,P)
- ;write out denominator
- I 'BGPDENP D
- .Q:$G(BGPNODEN) ;no denominator to display
- .I $Y>(BGPIOSL-13) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0) D H1^BGP4DPH
- .W !!,$P(^BGPELIIJ(BGPPC,0),U,17)
- .I $P(^BGPELIIJ(BGPPC,0),U,18)]"" D
- ..W !,$P(^BGPELIIJ(BGPPC,0),U,18)
- .I $P(^BGPELIIJ(BGPPC,0),U,21)]"" D
- ..W !,$P(^BGPELIIJ(BGPPC,0),U,21)
- .W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
- .S BGPDENP=1
- S BGPNF=$P(^BGPELIIJ(BGPPC,0),U,9)
- S BGPNP=$P(^DD(90553.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
- D SETN
- ;write header
- I $Y>(IOSL-5) D HEADER^BGP4DPH Q:BGPQUIT W !!,^BGPELIJ(BGPIC,53,1,0) D H1^BGP4DPH
- I $P(^BGPELIIJ(BGPPC,0),U,22) W !
- W !,$P(^BGPELIIJ(BGPPC,0),U,15)
- I $P(^BGPELIIJ(BGPPC,0),U,16)]"" W !?1,$P(^BGPELIIJ(BGPPC,0),U,16)
- I $P(^BGPELIIJ(BGPPC,0),U,19)]"" W !?1,$P(^BGPELIIJ(BGPPC,0),U,19)
- D H2^BGP4DPH
- Q
- SETN ;EP set numerator fields
- S BGPCYN=$$V(1,BGPRPT,N,P)
- S BGPPRN=$$V(2,BGPRPT,N,P)
- S BGPBLN=$$V(3,BGPRPT,N,P)
- S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
- S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
- S BGPBLP=$S(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
- Q
- I1AGE ; special age tallies
- D I1AGE^BGP4EL11
- Q
- SL(V) ;
- I V="" S V=0
- Q $$STRIP^XLFSTR($J(V,5,1)," ")
- V(T,R,N,P) ;EP
- I $G(BGPAREAA) G VA
- I T=1 Q $P($G(^BGPELDCJ(R,N)),U,P)
- I T=2 Q $P($G(^BGPELDPJ(R,N)),U,P)
- I T=3 Q $P($G(^BGPELDBJ(R,N)),U,P)
- Q ""
- VA ;
- NEW X,V,C S X=0,C="" F S X=$O(BGPSUL(X)) Q:X'=+X D
- .I T=1 S C=C+$P($G(^BGPELDCJ(X,N)),U,P)
- .I T=2 S C=C+$P($G(^BGPELDPJ(X,N)),U,P)
- .I T=3 S C=C+$P($G(^BGPELDBJ(X,N)),U,P)
- .Q
- Q C
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q X
- BGP4ELP1 ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
- +2 ;
- +3 ;
- I1 ;EP ; diabetes prevalence
- +1 ;column headers
- DO H1^BGP4DPH
- I1A1 ;001.A, 001.B, 001.C
- +1 FOR BGPPC1="1.1","1.2","1.3"
- IF BGPQUIT
- QUIT
- DO PI
- +2 DO I1AGE
- +3 QUIT
- I2 ;EP
- +1 IF $Y>(BGPIOSL-13)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- +2 DO H1^BGP4DPH
- +3 FOR BGPPC1="2.1"
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL12
- +5 QUIT
- I3 ;EP
- +1 IF $Y>(BGPIOSL-13)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- +2 DO H1^BGP4DPH
- +3 FOR BGPPC1="3.1"
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL13
- +5 QUIT
- I4 ;EP
- +1 IF $Y>(BGPIOSL-13)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- +2 DO H1^BGP4DPH
- +3 FOR BGPPC1="4.1"
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL14
- +5 QUIT
- I5 ;EP
- +1 IF $Y>(BGPIOSL-13)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- +2 DO H1^BGP4DPH
- +3 FOR BGPPC1="5.1"
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL15
- +5 QUIT
- I6 ;EP
- +1 IF $Y>(BGPIOSL-13)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- +2 DO H1^BGP4DPH
- +3 FOR BGPPC1="6.1"
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL16
- +5 QUIT
- I7 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="7.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL17
- +4 QUIT
- I8 ;
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="8.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL18
- +4 QUIT
- I9 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="9.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL19
- +4 QUIT
- I10 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="10.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL10
- +4 QUIT
- I11 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="11.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1A
- +4 QUIT
- I12 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="12.1","12.2","12.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1B
- +4 QUIT
- I13 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="13.1","13.2","13.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1C
- +4 QUIT
- I14 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="14.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1D
- +4 QUIT
- I15 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="15.1","15.2","15.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1E
- +4 QUIT
- I16 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="16.1","16.2","16.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1F
- +4 QUIT
- I17 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="17.1","17.2","17.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1G
- +4 QUIT
- I18 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="18.1","18.2","18.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1H
- +4 QUIT
- I19 ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="19.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1I
- +4 QUIT
- EFR ;EP
- +1 DO H1^BGP4DPH
- +2 SET BGPPC0=$PIECE(^BGPELIJ(BGPIC,0),U,6)
- +3 FOR BGPPCX=1,2,3
- SET BGPPC1=BGPPC0_"."_BGPPCX
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL1O
- +5 QUIT
- IEDA ;EP
- +1 DO H1^BGP4DPH
- +2 SET BGPPC0=$PIECE(^BGPELIJ(BGPIC,0),U,6)
- +3 FOR BGPPCX=1,2,3
- SET BGPPC1=BGPPC0_"."_BGPPCX
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO I1AGE^BGP4EL1P
- +5 QUIT
- IELDFSA ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="22.1","22.2","22.3"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1J
- +4 QUIT
- IELDASA ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="23.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 SET BGPNODEN=1
- SET BGPPC1="23.2"
- IF BGPQUIT
- QUIT
- DO PI
- KILL BGPNODEN
- +4 DO I1AGE^BGP4EL1K
- +5 QUIT
- IELDPHA ;EP
- +1 DO IELDPHA^BGP4EL1L
- +2 QUIT
- IRAO ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1="20.1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1M
- +4 QUIT
- IRAA ;EP
- +1 DO H1^BGP4DPH
- +2 FOR BGPPC1=$PIECE(^BGPELIJ(BGPIC,0),U,6)_".1"
- IF BGPQUIT
- QUIT
- DO PI
- +3 DO I1AGE^BGP4EL1N
- +4 QUIT
- AWV ;EP
- +1 DO H1^BGP4DPH
- +2 KILL BGPNODEN
- +3 FOR BGPPC9=1:1:3
- SET BGPPC1="28."_BGPPC9
- IF BGPQUIT
- QUIT
- DO PI
- +4 DO ^BGP4EL1T
- +5 QUIT
- PCV ;EP
- +1 DO H1^BGP4DPH
- +2 SET BGPNODEN=1
- FOR BGPPC9=1:1:7
- SET BGPPC1="27."_BGPPC9
- IF BGPQUIT
- QUIT
- SET BGPNODEN=1
- DO PI
- KILL BGPNODEN
- +3 IF BGPQUIT
- KILL BGPNODEN
- QUIT
- +4 DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- DO H1^BGP4DPH
- +5 SET BGPNODEN=1
- FOR BGPPC9=8:1:15
- SET BGPPC1="27."_BGPPC9
- IF BGPQUIT
- QUIT
- SET BGPNODEN=1
- DO PI
- KILL BGPNODEN
- +6 IF BGPQUIT
- KILL BGPNODEN
- QUIT
- +7 DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- DO H1^BGP4DPH
- +8 SET BGPNODEN=1
- FOR BGPPC9=16:1:22
- SET BGPPC1="27."_BGPPC9
- IF BGPQUIT
- QUIT
- SET BGPNODEN=1
- DO PI
- KILL BGPNODEN
- +9 IF BGPQUIT
- KILL BGPNODEN
- QUIT
- +10 DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- DO H1^BGP4DPH
- +11 SET BGPNODEN=1
- FOR BGPPC9=23:1:30
- SET BGPPC1="27."_BGPPC9
- IF BGPQUIT
- QUIT
- SET BGPNODEN=1
- DO PI
- KILL BGPNODEN
- +12 IF BGPQUIT
- KILL BGPNODEN
- QUIT
- +13 KILL BGPNODEN
- +14 ;F BGPPC9=31:1:33 S BGPPC1="27."_BGPPC9 Q:BGPQUIT D PI
- +15 ;D ^BGP4EL1S
- +16 QUIT
- PI ;EP
- +1 SET BGPDENP=0
- +2 SET BGPPC2=0
- FOR
- SET BGPPC2=$ORDER(^BGPELIIJ("ABC",BGPPC1,BGPPC2))
- IF BGPPC2=""
- QUIT
- SET BGPPC=$ORDER(^BGPELIIJ("ABC",BGPPC1,BGPPC2,0))
- DO PI1
- +3 QUIT
- PI1 ;
- +1 SET BGPDF=$PIECE(^BGPELIIJ(BGPPC,0),U,8)
- +2 ;get denominator value of measure
- +3 SET BGPNP=$PIECE(^DD(90553.03,BGPDF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +4 SET BGPCYD=$$V(1,BGPRPT,N,P)
- +5 SET BGPPRD=$$V(2,BGPRPT,N,P)
- +6 SET BGPBLD=$$V(3,BGPRPT,N,P)
- +7 ;write out denominator
- +8 IF 'BGPDENP
- Begin DoDot:1
- +9 ;no denominator to display
- IF $GET(BGPNODEN)
- QUIT
- +10 IF $Y>(BGPIOSL-13)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- DO H1^BGP4DPH
- +11 WRITE !!,$PIECE(^BGPELIIJ(BGPPC,0),U,17)
- +12 IF $PIECE(^BGPELIIJ(BGPPC,0),U,18)]""
- Begin DoDot:2
- +13 WRITE !,$PIECE(^BGPELIIJ(BGPPC,0),U,18)
- End DoDot:2
- +14 IF $PIECE(^BGPELIIJ(BGPPC,0),U,21)]""
- Begin DoDot:2
- +15 WRITE !,$PIECE(^BGPELIIJ(BGPPC,0),U,21)
- End DoDot:2
- +16 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
- +17 SET BGPDENP=1
- End DoDot:1
- +18 SET BGPNF=$PIECE(^BGPELIIJ(BGPPC,0),U,9)
- +19 SET BGPNP=$PIECE(^DD(90553.03,BGPNF,0),U,4)
- SET N=$PIECE(BGPNP,";")
- SET P=$PIECE(BGPNP,";",2)
- +20 DO SETN
- +21 ;write header
- +22 IF $Y>(IOSL-5)
- DO HEADER^BGP4DPH
- IF BGPQUIT
- QUIT
- WRITE !!,^BGPELIJ(BGPIC,53,1,0)
- DO H1^BGP4DPH
- +23 IF $PIECE(^BGPELIIJ(BGPPC,0),U,22)
- WRITE !
- +24 WRITE !,$PIECE(^BGPELIIJ(BGPPC,0),U,15)
- +25 IF $PIECE(^BGPELIIJ(BGPPC,0),U,16)]""
- WRITE !?1,$PIECE(^BGPELIIJ(BGPPC,0),U,16)
- +26 IF $PIECE(^BGPELIIJ(BGPPC,0),U,19)]""
- WRITE !?1,$PIECE(^BGPELIIJ(BGPPC,0),U,19)
- +27 DO H2^BGP4DPH
- +28 QUIT
- SETN ;EP set numerator fields
- +1 SET BGPCYN=$$V(1,BGPRPT,N,P)
- +2 SET BGPPRN=$$V(2,BGPRPT,N,P)
- +3 SET BGPBLN=$$V(3,BGPRPT,N,P)
- +4 SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
- +5 SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
- +6 SET BGPBLP=$SELECT(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
- +7 QUIT
- I1AGE ; special age tallies
- +1 DO I1AGE^BGP4EL11
- +2 QUIT
- SL(V) ;
- +1 IF V=""
- SET V=0
- +2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
- V(T,R,N,P) ;EP
- +1 IF $GET(BGPAREAA)
- GOTO VA
- +2 IF T=1
- QUIT $PIECE($GET(^BGPELDCJ(R,N)),U,P)
- +3 IF T=2
- QUIT $PIECE($GET(^BGPELDPJ(R,N)),U,P)
- +4 IF T=3
- QUIT $PIECE($GET(^BGPELDBJ(R,N)),U,P)
- +5 QUIT ""
- VA ;
- +1 NEW X,V,C
- SET X=0
- SET C=""
- FOR
- SET X=$ORDER(BGPSUL(X))
- IF X'=+X
- QUIT
- Begin DoDot:1
- +2 IF T=1
- SET C=C+$PIECE($GET(^BGPELDCJ(X,N)),U,P)
- +3 IF T=2
- SET C=C+$PIECE($GET(^BGPELDPJ(X,N)),U,P)
- +4 IF T=3
- SET C=C+$PIECE($GET(^BGPELDBJ(X,N)),U,P)
- +5 QUIT
- End DoDot:1
- +6 QUIT C
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT X