- 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
