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
