- APCLCH1S ; IHS/CMI/LAB - community health profile print ;
- ;;2.0;IHS PCC SUITE;**10,11**;MAY 14, 2009;Build 58
- ;
- ;cmi/anch/maw 9/10/2007 code set versioning in TOP5INJ
- ;
- SETV ;EP
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F")="0^0^0^0^0^0^0^0^0^0^0"
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M")="0^0^0^0^0^0^0^0^0^0^0"
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")="0^0^0^0^0^0^0^0^0^0^0"
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"LIVREG")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"LIVREG")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"HADHC")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"HADHC")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"BIRTHS")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"BIRTHS")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"DEATHS")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"DEATHS")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRA")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRA")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRB")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRB")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCD")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCD")=0
- S:'$D(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"PI")) ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"PI")=0
- Q
- EN ;EP - called from apclch1p
- TOP5INJ ;
- I $Y>(IOSL-6) D HEAD^APCLCH1P Q:$D(APCLQUIT)
- W !!!?5,"The Top 10 Causes of Injury were:",!
- W !?5,APCLCOM,?43,$E($P(^AUTTSU(APCLSU,0),U),1,25)," Service Unit",!
- W ?5,$TR($J("",$L(APCLCOM))," ","-"),?43,$TR($J("",33)," ","-"),!
- K APCLR S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX)) Q:APCLX=""!(C>10) D
- .;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLR(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)
- .;cmi/anch/maw 9/10/2007 split lines below and added csv due to line length
- .S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)) Q:APCLY'=+APCLY D
- ..S C=C+1,APCLR(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)
- K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX)) Q:APCLX=""!(C>10) D
- .;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)
- .S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)
- S (APCLX,APCLC)=0 F S APCLX=$O(APCLR(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
- .I $Y>(IOSL-4) D HEAD^APCLCH1P Q:$D(APCLQUIT) W !,"Top 10 causes of injury (cont.)",!
- .W !?5,$P(APCLR(APCLX),U),?32,"(",$P(APCLR(APCLX),U,2),")" S APCLC=APCLX I $D(APCLS(APCLX)) W ?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
- S APCLX=C F S APCLX=$O(APCLS(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
- .I $Y>(IOSL-4) D HEAD^APCLCH1P Q:$D(APCLQUIT) W !,"Top 10 causes of injury (cont.)",!
- .W !?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
- TOP5DENT ;
- I $Y>(IOSL-6) D HEAD^APCLCH1P Q:$D(APCLQUIT)
- W !!!?5,"The Top Dental Services were:",!
- W !?5,APCLCOM,?43,$E($P(^AUTTSU(APCLSU,0),U),1,25)," Service Unit",!
- W ?5,$TR($J("",$L(APCLCOM))," ","-"),?43,$TR($J("",33)," ","-"),!
- K APCLR S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","DENTALC",APCLX)) Q:APCLX=""!(C>10) D
- .S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","DENTALC",APCLX,APCLY)) Q:APCLY'=+APCLY D
- ..S C=C+1,APCLR(C)=$E($P(^AUTTADA(APCLY,0),U,2),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","DENTALC",APCLX,APCLY)
- K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","DENTALC",APCLX)) Q:APCLX=""!(C>10) D
- .S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","DENTALC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P(^AUTTADA(APCLY,0),U,2),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","DENTALC",APCLX,APCLY)
- S (APCLX,APCLC)=0 F S APCLX=$O(APCLR(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
- .I $Y>(IOSL-4) D HEAD^APCLCH1P Q:$D(APCLQUIT) W !,"Top 10 dental services (cont.)",!
- .W !?5,$P(APCLR(APCLX),U),?32,"(",$P(APCLR(APCLX),U,2),")" S APCLC=APCLX I $D(APCLS(APCLX)) W ?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
- S APCLX=C F S APCLX=$O(APCLS(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
- .I $Y>(IOSL-4) D HEAD^APCLCH1P Q:$D(APCLQUIT) W !,"Top 10 dental services (cont.)",!
- .W !?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
- Q
- APCLCH1S ; IHS/CMI/LAB - community health profile print ;
- +1 ;;2.0;IHS PCC SUITE;**10,11**;MAY 14, 2009;Build 58
- +2 ;
- +3 ;cmi/anch/maw 9/10/2007 code set versioning in TOP5INJ
- +4 ;
- SETV ;EP
- +1 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F")="0^0^0^0^0^0^0^0^0^0^0"
- +2 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M")="0^0^0^0^0^0^0^0^0^0^0"
- +3 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")="0^0^0^0^0^0^0^0^0^0^0"
- +4 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"LIVREG"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"LIVREG")=0
- +5 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"HADHC"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"HADHC")=0
- +6 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"BIRTHS"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"BIRTHS")=0
- +7 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"DEATHS"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"DEATHS")=0
- +8 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRA"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRA")=0
- +9 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRB"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRB")=0
- +10 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCD"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCD")=0
- +11 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"PI"))
- SET ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"PI")=0
- +12 QUIT
- EN ;EP - called from apclch1p
- TOP5INJ ;
- +1 IF $Y>(IOSL-6)
- DO HEAD^APCLCH1P
- IF $DATA(APCLQUIT)
- QUIT
- +2 WRITE !!!?5,"The Top 10 Causes of Injury were:",!
- +3 WRITE !?5,APCLCOM,?43,$EXTRACT($PIECE(^AUTTSU(APCLSU,0),U),1,25)," Service Unit",!
- +4 WRITE ?5,$TRANSLATE($JUSTIFY("",$LENGTH(APCLCOM))," ","-"),?43,$TRANSLATE($JUSTIFY("",33)," ","-"),!
- +5 KILL APCLR
- SET (APCLX,C)=0
- FOR
- SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX))
- IF APCLX=""!(C>10)
- QUIT
- Begin DoDot:1
- +6 ;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLR(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)
- +7 ;cmi/anch/maw 9/10/2007 split lines below and added csv due to line length
- +8 SET APCLY=0
- FOR
- SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY))
- IF APCLY'=+APCLY
- QUIT
- Begin DoDot:2
- +9 SET C=C+1
- SET APCLR(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INJC",APCLX,APCLY)
- End DoDot:2
- End DoDot:1
- +10 KILL APCLS
- SET (APCLX,C)=0
- FOR
- SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX))
- IF APCLX=""!(C>10)
- QUIT
- Begin DoDot:1
- +11 ;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)
- +12 SET APCLY=0
- FOR
- SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY))
- IF APCLY'=+APCLY
- QUIT
- SET C=C+1
- SET APCLS(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INJC",APCLX,APCLY)
- End DoDot:1
- +13 SET (APCLX,APCLC)=0
- FOR
- SET APCLX=$ORDER(APCLR(APCLX))
- IF APCLX'=+APCLX!($DATA(APCLQUIT))
- QUIT
- Begin DoDot:1
- +14 IF $Y>(IOSL-4)
- DO HEAD^APCLCH1P
- IF $DATA(APCLQUIT)
- QUIT
- WRITE !,"Top 10 causes of injury (cont.)",!
- +15 WRITE !?5,$PIECE(APCLR(APCLX),U),?32,"(",$PIECE(APCLR(APCLX),U,2),")"
- SET APCLC=APCLX
- IF $DATA(APCLS(APCLX))
- WRITE ?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
- End DoDot:1
- +16 SET APCLX=C
- FOR
- SET APCLX=$ORDER(APCLS(APCLX))
- IF APCLX'=+APCLX!($DATA(APCLQUIT))
- QUIT
- Begin DoDot:1
- +17 IF $Y>(IOSL-4)
- DO HEAD^APCLCH1P
- IF $DATA(APCLQUIT)
- QUIT
- WRITE !,"Top 10 causes of injury (cont.)",!
- +18 WRITE !?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
- End DoDot:1
- TOP5DENT ;
- +1 IF $Y>(IOSL-6)
- DO HEAD^APCLCH1P
- IF $DATA(APCLQUIT)
- QUIT
- +2 WRITE !!!?5,"The Top Dental Services were:",!
- +3 WRITE !?5,APCLCOM,?43,$EXTRACT($PIECE(^AUTTSU(APCLSU,0),U),1,25)," Service Unit",!
- +4 WRITE ?5,$TRANSLATE($JUSTIFY("",$LENGTH(APCLCOM))," ","-"),?43,$TRANSLATE($JUSTIFY("",33)," ","-"),!
- +5 KILL APCLR
- SET (APCLX,C)=0
- FOR
- SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","DENTALC",APCLX))
- IF APCLX=""!(C>10)
- QUIT
- Begin DoDot:1
- +6 SET APCLY=0
- FOR
- SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","DENTALC",APCLX,APCLY))
- IF APCLY'=+APCLY
- QUIT
- Begin DoDot:2
- +7 SET C=C+1
- SET APCLR(C)=$EXTRACT($PIECE(^AUTTADA(APCLY,0),U,2),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","DENTALC",APCLX,APCLY)
- End DoDot:2
- End DoDot:1
- +8 KILL APCLS
- SET (APCLX,C)=0
- FOR
- SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","DENTALC",APCLX))
- IF APCLX=""!(C>10)
- QUIT
- Begin DoDot:1
- +9 SET APCLY=0
- FOR
- SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","DENTALC",APCLX,APCLY))
- IF APCLY'=+APCLY
- QUIT
- SET C=C+1
- SET APCLS(C)=$EXTRACT($PIECE(^AUTTADA(APCLY,0),U,2),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","DENTALC",APCLX,APCLY)
- End DoDot:1
- +10 SET (APCLX,APCLC)=0
- FOR
- SET APCLX=$ORDER(APCLR(APCLX))
- IF APCLX'=+APCLX!($DATA(APCLQUIT))
- QUIT
- Begin DoDot:1
- +11 IF $Y>(IOSL-4)
- DO HEAD^APCLCH1P
- IF $DATA(APCLQUIT)
- QUIT
- WRITE !,"Top 10 dental services (cont.)",!
- +12 WRITE !?5,$PIECE(APCLR(APCLX),U),?32,"(",$PIECE(APCLR(APCLX),U,2),")"
- SET APCLC=APCLX
- IF $DATA(APCLS(APCLX))
- WRITE ?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
- End DoDot:1
- +13 SET APCLX=C
- FOR
- SET APCLX=$ORDER(APCLS(APCLX))
- IF APCLX'=+APCLX!($DATA(APCLQUIT))
- QUIT
- Begin DoDot:1
- +14 IF $Y>(IOSL-4)
- DO HEAD^APCLCH1P
- IF $DATA(APCLQUIT)
- QUIT
- WRITE !,"Top 10 dental services (cont.)",!
- +15 WRITE !?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
- End DoDot:1
- +16 QUIT
