APCLCH1P ; IHS/CMI/LAB - community health profile print ;
;;2.0;IHS PCC SUITE;**7,10,11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in TOP15ODX, TOP15IDX, SURGPROC
;
START ;
S APCLPG=0
I '$D(^XTMP("APCLCH1",APCLJOB,APCLBTH)) W !!,"NO DATA TO REPORT" G DONE
D PRN
DONE ;
D DONE^APCLOSUT
K ^XTMP("APCLCH1",APCLJOB,APCLBTH)
Q
PRN ;
S APCLCOM="" F S APCLCOM=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM)) Q:APCLCOM=""!($D(APCLQUIT)) D PRINT
Q
PRINT ;
D HEAD Q:$D(APCLQUIT)
W !?5,"There are ",^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"LIVREG")," living patients registered at ",$P(^DIC(4,DUZ(2),0),U),"."
W !?5,^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"HADHC")," received health care services during this time period."
I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
W !?5,^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRA")," are currently enrolled in Medicare Part A; "
W ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRB")," in Medicare Part B; "
W !?5,^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCD")," in Medicaid; and "
W ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"PI")," have Private Insurance.",!
I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
W !?5,"There were ",^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"BIRTHS")," births and ",^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"DEATHS")," deaths during this period.",!
AGEDIST ;
I $Y>(IOSL-7) D HEAD Q:$D(APCLQUIT)
W !?30,"AGE/SEX Distribution as of ",$$FMTE^XLFDT(APCLED),!
S T=9 F I=1:1 S J=$P(APCLAGEP,";",I) Q:J="" W ?T,J S T=T+6
W !?9,$TR($J("",70)," ","-")
W !?2,"MALE" S T=9 F I=1:1 S J=$P(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M"),U,I) Q:J="" W ?T,$J(J,5) S T=T+6
W !,"FEMALE" S T=9 F I=1:1 S J=$P(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F"),U,I) Q:J="" W ?T,$J(J,5) S T=T+6
W !,"UNKNOWN" S T=9 F I=1:1 S J=$P($G(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")),U,I) Q:J="" W ?T,$J(J,5) S T=T+6
W !?1,"TOTAL"
S T=9
F I=1:1 S J=$P(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F"),U,I) Q:J="" D
.S J=J+$P(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M"),U,I)+$P($G(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")),U,I) W ?T,$J(J,5) S T=T+6
TOP15ODX ;
I $Y>(IOSL-6) D HEAD Q:$D(APCLQUIT)
W !!!?5,"The Top 15 Purposes of Direct and Contract Outpatient Visits were:",!
W ?15,"Both Primary and Secondary Diagnoses are included",!
W !?5,APCLCOM,?43,$E($P(^AUTTSU(APCLSU,0),U),1,25)," Service Unit",!
W ?5,$TR($J("",$L(APCLCOM))," ","-"),?43,$TR($J("",35)," ","-"),!
K APCLR S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX)) Q:APCLX=""!(C>15)!($D(APCLQUIT)) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLR(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX,APCLY) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLR(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX,APCLY) ;cmi/anch/maw 9/10/2007 code set versioning
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","OUTDXC",APCLX)) Q:APCLX=""!(C>15)!($D(APCLQUIT)) D
.;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","OUTDXC",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","OUTDXC",APCLX,APCLY) ;cmi/anch/maw orig line
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","OUTDXC",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","OUTDXC",APCLX,APCLY) ;cmi/anch/maw csv
S (APCLX,APCLC)=0 F S APCLX=$O(APCLR(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) W !,"Top 15 outpatient purpose of visits (cont.)",!
.W !?5,$P(APCLR(APCLX),U),?33,"(",$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 Q:$D(APCLQUIT) W !,"Top 15 outpatient purpose of visits (cont.)",!
.W !?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
TOP15IDX ;
I $Y>(IOSL-6) D HEAD Q:$D(APCLQUIT)
W !!!?5,"The Top 15 Inpatient Diagnoses 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","INDXC",APCLX)) Q:APCLX=""!(C>15)!($D(APCLQUIT))!($D(APCLQUIT)) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLR(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INDXC",APCLX,APCLY) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLR(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INDXC",APCLX,APCLY) ;cmi/anch/maw 9/10/2007 csv
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INDXC",APCLX)) Q:APCLX=""!(C>15)!($D(APCLQUIT)) D
.;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INDXC",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","INDXC",APCLX,APCLY) ;cmi/anch/maw orig line
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INDXC",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","INDXC",APCLX,APCLY) ;cmi/anch/maw csv
S (APCLX,APCLC)=0 F S APCLX=$O(APCLR(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) W !,"Top 15 inpatient diagnoses (cont.)",!
.W !?5,$P(APCLR(APCLX),U),?33,"(",$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 Q:$D(APCLQUIT) W !,"Top 15 inpatient diagnoses (cont.)",!
.W !?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
SURGPROC ;
I $Y>(IOSL-6) D HEAD Q:$D(APCLQUIT)
W !!!?5,"The Leading Surgical Procedures 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","SURG PROCC",APCLX)) Q:APCLX=""!(C>15)!($D(APCLQUIT)) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","SURG PROCC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLR(C)=$E($P(^ICD0(APCLY,0),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","SURG PROCC",APCLX,APCLY) ;cmi/anch/maw 9/12/2007 orig line
..S C=C+1,APCLR(C)=$E($P($$ICDOP^ICDEX(APCLY,,,"I"),U,5),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","SURG PROCC",APCLX,APCLY) ;cmi/anch/maw 9/12/2007 csv
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX)) Q:APCLX=""!(C>15)!($D(APCLQUIT)) D
.;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P(^ICD0(APCLY,0),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY) ;cmi/maw orig
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P($$ICDOP^ICDEX(APCLY,,,"I"),U,5),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY) ;maw csv
S (APCLX,APCLC)=0 F S APCLX=$O(APCLR(APCLX)) Q:APCLX'=+APCLX!($D(APCLQUIT)) D
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) W !,"Top 15 surgical procedures (cont.)",!
.W !?5,$P(APCLR(APCLX),U),?33,"(",$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 Q:$D(APCLQUIT) W !,"Top 15 surgical procedures (cont.)",!
.W !?43,$P(APCLS(APCLX),U),?70,"(",$P(APCLS(APCLX),U,2),")"
D EN^APCLCH1S
Q:$D(APCLQUIT)
W !!,"End of Report. This report is based on visit data processed on the ",!,$P(^DIC(4,DUZ(2),0),U)," computer.",!
Q
HEAD ;EP
G:'APCLPG HEAD1
K DIR I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLQUIT="" Q
HEAD1 ;
W:$D(IOF) @IOF S APCLPG=APCLPG+1
W !?3,$P(^VA(200,DUZ,0),U,2),?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG,!
W ?21,"***** COMMUNITY HEALTH PROFILE *****",!
W ?25,$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED),!
I $G(APCLSEAT) W $$CJ^XLFSTR("Search Template of Patients Used: "_$P(^DIBT(APCLSEAT,0),U,1),80),!
W ?(80-$L(APCLCOM))/2,APCLCOM,!
Q
APCLCH1P ; IHS/CMI/LAB - community health profile print ;
+1 ;;2.0;IHS PCC SUITE;**7,10,11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in TOP15ODX, TOP15IDX, SURGPROC
+4 ;
START ;
+1 SET APCLPG=0
+2 IF '$DATA(^XTMP("APCLCH1",APCLJOB,APCLBTH))
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
+3 DO PRN
DONE ;
+1 DO DONE^APCLOSUT
+2 KILL ^XTMP("APCLCH1",APCLJOB,APCLBTH)
+3 QUIT
PRN ;
+1 SET APCLCOM=""
FOR
SET APCLCOM=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM))
IF APCLCOM=""!($DATA(APCLQUIT))
QUIT
DO PRINT
+2 QUIT
PRINT ;
+1 DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !?5,"There are ",^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"LIVREG")," living patients registered at ",$PIECE(^DIC(4,DUZ(2),0),U),"."
+3 WRITE !?5,^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"HADHC")," received health care services during this time period."
+4 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+5 WRITE !?5,^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRA")," are currently enrolled in Medicare Part A; "
+6 WRITE ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCRB")," in Medicare Part B; "
+7 WRITE !?5,^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"MCD")," in Medicaid; and "
+8 WRITE ^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"PI")," have Private Insurance.",!
+9 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+10 WRITE !?5,"There were ",^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"BIRTHS")," births and ",^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"DEATHS")," deaths during this period.",!
AGEDIST ;
+1 IF $Y>(IOSL-7)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !?30,"AGE/SEX Distribution as of ",$$FMTE^XLFDT(APCLED),!
+3 SET T=9
FOR I=1:1
SET J=$PIECE(APCLAGEP,";",I)
IF J=""
QUIT
WRITE ?T,J
SET T=T+6
+4 WRITE !?9,$TRANSLATE($JUSTIFY("",70)," ","-")
+5 WRITE !?2,"MALE"
SET T=9
FOR I=1:1
SET J=$PIECE(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M"),U,I)
IF J=""
QUIT
WRITE ?T,$JUSTIFY(J,5)
SET T=T+6
+6 WRITE !,"FEMALE"
SET T=9
FOR I=1:1
SET J=$PIECE(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F"),U,I)
IF J=""
QUIT
WRITE ?T,$JUSTIFY(J,5)
SET T=T+6
+7 WRITE !,"UNKNOWN"
SET T=9
FOR I=1:1
SET J=$PIECE($GET(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")),U,I)
IF J=""
QUIT
WRITE ?T,$JUSTIFY(J,5)
SET T=T+6
+8 WRITE !?1,"TOTAL"
+9 SET T=9
+10 FOR I=1:1
SET J=$PIECE(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","F"),U,I)
IF J=""
QUIT
Begin DoDot:1
+11 SET J=J+$PIECE(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","M"),U,I)+$PIECE($GET(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"AGE DIST","U")),U,I)
WRITE ?T,$JUSTIFY(J,5)
SET T=T+6
End DoDot:1
TOP15ODX ;
+1 IF $Y>(IOSL-6)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !!!?5,"The Top 15 Purposes of Direct and Contract Outpatient Visits were:",!
+3 WRITE ?15,"Both Primary and Secondary Diagnoses are included",!
+4 WRITE !?5,APCLCOM,?43,$EXTRACT($PIECE(^AUTTSU(APCLSU,0),U),1,25)," Service Unit",!
+5 WRITE ?5,$TRANSLATE($JUSTIFY("",$LENGTH(APCLCOM))," ","-"),?43,$TRANSLATE($JUSTIFY("",35)," ","-"),!
+6 KILL APCLR
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX))
IF APCLX=""!(C>15)!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+7 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+8 ;S C=C+1,APCLR(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX,APCLY) ;cmi/anch/maw 9/10/2007 orig line
+9 ;cmi/anch/maw 9/10/2007 code set versioning
SET C=C+1
SET APCLR(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","OUTDXC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+10 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","OUTDXC",APCLX))
IF APCLX=""!(C>15)!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+11 ;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","OUTDXC",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","OUTDXC",APCLX,APCLY) ;cmi/anch/maw orig line
+12 ;cmi/anch/maw csv
SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","OUTDXC",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","OUTDXC",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
IF $DATA(APCLQUIT)
QUIT
WRITE !,"Top 15 outpatient purpose of visits (cont.)",!
+15 WRITE !?5,$PIECE(APCLR(APCLX),U),?33,"(",$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
IF $DATA(APCLQUIT)
QUIT
WRITE !,"Top 15 outpatient purpose of visits (cont.)",!
+18 WRITE !?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
End DoDot:1
TOP15IDX ;
+1 IF $Y>(IOSL-6)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !!!?5,"The Top 15 Inpatient Diagnoses 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","INDXC",APCLX))
IF APCLX=""!(C>15)!($DATA(APCLQUIT))!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+6 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+7 ;S C=C+1,APCLR(C)=$E($P(^ICD9(APCLY,0),U,3),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INDXC",APCLX,APCLY) ;cmi/anch/maw 9/10/2007 orig line
+8 ;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLR(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","INDXC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+9 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INDXC",APCLX))
IF APCLX=""!(C>15)!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+10 ;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INDXC",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","INDXC",APCLX,APCLY) ;cmi/anch/maw orig line
+11 ;cmi/anch/maw csv
SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","INDXC",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","INDXC",APCLX,APCLY)
End DoDot:1
+12 SET (APCLX,APCLC)=0
FOR
SET APCLX=$ORDER(APCLR(APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
WRITE !,"Top 15 inpatient diagnoses (cont.)",!
+14 WRITE !?5,$PIECE(APCLR(APCLX),U),?33,"(",$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
+15 SET APCLX=C
FOR
SET APCLX=$ORDER(APCLS(APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+16 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
WRITE !,"Top 15 inpatient diagnoses (cont.)",!
+17 WRITE !?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
End DoDot:1
SURGPROC ;
+1 IF $Y>(IOSL-6)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+2 WRITE !!!?5,"The Leading Surgical Procedures 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","SURG PROCC",APCLX))
IF APCLX=""!(C>15)!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+6 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","SURG PROCC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+7 ;S C=C+1,APCLR(C)=$E($P(^ICD0(APCLY,0),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","SURG PROCC",APCLX,APCLY) ;cmi/anch/maw 9/12/2007 orig line
+8 ;cmi/anch/maw 9/12/2007 csv
SET C=C+1
SET APCLR(C)=$EXTRACT($PIECE($$ICDOP^ICDEX(APCLY,,,"I"),U,5),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"RP",APCLCOM,"REPORT","SURG PROCC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+9 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX))
IF APCLX=""!(C>15)!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+10 ;S APCLY=0 F S APCLY=$O(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY)) Q:APCLY'=+APCLY S C=C+1,APCLS(C)=$E($P(^ICD0(APCLY,0),U,4),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY) ;cmi/maw orig
+11 ;maw csv
SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
SET C=C+1
SET APCLS(C)=$EXTRACT($PIECE($$ICDOP^ICDEX(APCLY,,,"I"),U,5),1,25)_"^"_^XTMP("APCLCH1",APCLJOB,APCLBTH,"SU","SURG PROCC",APCLX,APCLY)
End DoDot:1
+12 SET (APCLX,APCLC)=0
FOR
SET APCLX=$ORDER(APCLR(APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+13 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
WRITE !,"Top 15 surgical procedures (cont.)",!
+14 WRITE !?5,$PIECE(APCLR(APCLX),U),?33,"(",$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
+15 SET APCLX=C
FOR
SET APCLX=$ORDER(APCLS(APCLX))
IF APCLX'=+APCLX!($DATA(APCLQUIT))
QUIT
Begin DoDot:1
+16 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
WRITE !,"Top 15 surgical procedures (cont.)",!
+17 WRITE !?43,$PIECE(APCLS(APCLX),U),?70,"(",$PIECE(APCLS(APCLX),U,2),")"
End DoDot:1
+18 DO EN^APCLCH1S
+19 IF $DATA(APCLQUIT)
QUIT
+20 WRITE !!,"End of Report. This report is based on visit data processed on the ",!,$PIECE(^DIC(4,DUZ(2),0),U)," computer.",!
+21 QUIT
HEAD ;EP
+1 IF 'APCLPG
GOTO HEAD1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET APCLPG=APCLPG+1
+2 WRITE !?3,$PIECE(^VA(200,DUZ,0),U,2),?58,$$FMTE^XLFDT(DT),?72,"Page ",APCLPG,!
+3 WRITE ?21,"***** COMMUNITY HEALTH PROFILE *****",!
+4 WRITE ?25,$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED),!
+5 IF $GET(APCLSEAT)
WRITE $$CJ^XLFSTR("Search Template of Patients Used: "_$PIECE(^DIBT(APCLSEAT,0),U,1),80),!
+6 WRITE ?(80-$LENGTH(APCLCOM))/2,APCLCOM,!
+7 QUIT
