APCLCH2P ; IHS/CMI/LAB - community health profile print ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in OL, OS ,OT
;
START ;
K APCLQUIT
S APCLPG=0
I '$D(^XTMP("APCLCH2",APCLJOB,APCLBTH)) W !!,"NO DATA TO REPORT" G DONE
D PRN
DONE ;
D DONE^APCLOSUT
K ^XTMP("APCLCH2",APCLJOB,APCLBTH)
Q
PRN ;
S APCLCOM="" F S APCLCOM=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM)) Q:APCLCOM=""!($D(APCLQUIT)) S APCLLFAC=$P(^AUTTCOM(APCLCOM,0),U,15),APCLSFAC=$P(^AUTTCOM(APCLCOM,0),U,16),APCLTFAC=$P(^AUTTCOM(APCLCOM,0),U,17) D PRINT
Q
PRINT ;
D HEAD Q:$D(APCLQUIT)
ODX ;
S APCLTYPE="DX"
D ODXSUB
OL ;
K APCLL S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLL(C)=$E($P(^ICD9(APCLY,0),U,3),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLL(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX,APCLY)_"^"_$P($$ICDDX^ICDEX(APCLY),U,2) ;cmi/anch/maw 9/10/2007 csv
S M=C
OS ;
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLS(C)=$E($P(^ICD9(APCLY,0),U,3),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLS(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX,APCLY)_"^"_$P($$ICDDX^ICDEX(APCLY),U,2) ;;cmi/anch/maw 9/10/2007 csv
S:C>M M=C
OT ;
K APCLT S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..;S C=C+1,APCLT(C)=$E($P(^ICD9(APCLY,0),U,3),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
..S C=C+1,APCLT(C)=$E($P($$ICDDX^ICDEX(APCLY),U,4),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX,APCLY)_"^"_$P($$ICDDX^ICDEX(APCLY),U,2) ;;cmi/anch/maw 9/10/2007 csv
S:C>M M=C
WODX ;write outpatient diagnoses/pov's
F APCLI=1:1:M D Q:$D(APCLQUIT)
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) D ODXSUB
.W !
.I $D(APCLL(APCLI)) W ?3,$E($P(APCLL(APCLI),U),1,20),?25,"(",$P(APCLL(APCLI),U,3),")",?35,$J($P(APCLL(APCLI),U,2),6)
.I $D(APCLS(APCLI)) W ?46,$E($P(APCLS(APCLI),U),1,20),?68,"(",$P(APCLS(APCLI),U,3),")",?78,$J($P(APCLS(APCLI),U,2),6)
.I $D(APCLT(APCLI)) W ?89,$E($P(APCLT(APCLI),U),1,20),?111,"(",$P(APCLT(APCLI),U,3),")",?121,$J($P(APCLT(APCLI),U,2),6)
ODXCAT ;
S APCLTYPE="ODXCAT"
I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT)
S APCLTYPE="CAT" W !!! D ODXSUB
OLCAT ;
K APCLL S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTCATC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTCATC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..S C=C+1,APCLL(C)=$E($P(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTCATC",APCLX,APCLY)
S M=C
OSCAT ;
K APCLS S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTCATC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTCATC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..S C=C+1,APCLS(C)=$E($P(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTCATC",APCLX,APCLY)
S:C>M M=C
OTCAT ;
K APCLT S (APCLX,C)=0 F S APCLX=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTCATC",APCLX)) Q:APCLX=""!(C>14) D
.S APCLY=0 F S APCLY=$O(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTCATC",APCLX,APCLY)) Q:APCLY'=+APCLY D
..S C=C+1,APCLT(C)=$E($P(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTCATC",APCLX,APCLY)
S:C>M M=C
WOCAT ;write outpatient diagnoses/pov's
F APCLI=1:1:M D Q:$D(APCLQUIT)
.I $Y>(IOSL-4) D HEAD Q:$D(APCLQUIT) D ODXSUB
.W !
.I $D(APCLL(APCLI)) W ?3,$E($P(APCLL(APCLI),U),1,30),?35,$J($P(APCLL(APCLI),U,2),6)
.I $D(APCLS(APCLI)) W ?46,$E($P(APCLS(APCLI),U),1,30),?78,$J($P(APCLS(APCLI),U,2),6)
.I $D(APCLT(APCLI)) W ?89,$E($P(APCLT(APCLI),U),1,30),?121,$J($P(APCLT(APCLI),U,2),6)
D INPT^APCLCH2S
Q
ODXSUB ;
S X="OUTPATIENT "_$S(APCLTYPE="DX":"DIAGNOSES",1:"MAJOR DIAGNOSTIC CATEGORIES") W !,?(132-$L(X)/2),X,!
W !?8,$P(^DIC(4,APCLLFAC,0),U),?51,$P(^DIC(4,APCLSFAC,0),U),?94,$P(^DIC(4,APCLTFAC,0),U),!
I APCLTYPE="DX" W !?3,"DIAGNOSIS/POV (ICD CODES)",?46,"DIAGNOSIS/POV (ICD CODES)",?89,"DIAGNOSIS/POV (ICD CODES)",!?3,"-------------",?46,"------------",?89,"------------"
I APCLTYPE="CAT" W !?3,"DIAGNOSTIC CATEGORY",?46,"DIAGNOSTIC CATEGORY",?89,"DIAGNOSTIC CATEGORY",!?3,"-------------------",?46,"-------------------",?89,"-------------------"
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),?61,$$FMTE^XLFDT(DT),?110,"Page ",APCLPG,!
W ?40,"***** DIAGNOSES TALLY BY COMMUNITY/FACILITY *****",!
W ?50,$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED),!
W ?(132-($L($P(^AUTTCOM(APCLCOM,0),U))+12)/2),"COMMUNITY: ",$P(^AUTTCOM(APCLCOM,0),U),!
Q
APCLCH2P ; IHS/CMI/LAB - community health profile print ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in OL, OS ,OT
+4 ;
START ;
+1 KILL APCLQUIT
+2 SET APCLPG=0
+3 IF '$DATA(^XTMP("APCLCH2",APCLJOB,APCLBTH))
WRITE !!,"NO DATA TO REPORT"
GOTO DONE
+4 DO PRN
DONE ;
+1 DO DONE^APCLOSUT
+2 KILL ^XTMP("APCLCH2",APCLJOB,APCLBTH)
+3 QUIT
PRN ;
+1 SET APCLCOM=""
FOR
SET APCLCOM=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM))
IF APCLCOM=""!($DATA(APCLQUIT))
QUIT
SET APCLLFAC=$PIECE(^AUTTCOM(APCLCOM,0),U,15)
SET APCLSFAC=$PIECE(^AUTTCOM(APCLCOM,0),U,16)
SET APCLTFAC=$PIECE(^AUTTCOM(APCLCOM,0),U,17)
DO PRINT
+2 QUIT
PRINT ;
+1 DO HEAD
IF $DATA(APCLQUIT)
QUIT
ODX ;
+1 SET APCLTYPE="DX"
+2 DO ODXSUB
OL ;
+1 KILL APCLL
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 ;S C=C+1,APCLL(C)=$E($P(^ICD9(APCLY,0),U,3),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
+4 ;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLL(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTDXC",APCLX,APCLY)_"^"_$PIECE($$ICDDX^ICDEX(APCLY),U,2)
End DoDot:2
End DoDot:1
+5 SET M=C
OS ;
+1 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 ;S C=C+1,APCLS(C)=$E($P(^ICD9(APCLY,0),U,3),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
+4 ;;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLS(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTDXC",APCLX,APCLY)_"^"_$PIECE($$ICDDX^ICDEX(APCLY),U,2)
End DoDot:2
End DoDot:1
+5 IF C>M
SET M=C
OT ;
+1 KILL APCLT
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 ;S C=C+1,APCLT(C)=$E($P(^ICD9(APCLY,0),U,3),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX,APCLY)_"^"_$P(^ICD9(APCLY,0),U) ;cmi/anch/maw 9/10/2007 orig line
+4 ;;cmi/anch/maw 9/10/2007 csv
SET C=C+1
SET APCLT(C)=$EXTRACT($PIECE($$ICDDX^ICDEX(APCLY),U,4),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTDXC",APCLX,APCLY)_"^"_$PIECE($$ICDDX^ICDEX(APCLY),U,2)
End DoDot:2
End DoDot:1
+5 IF C>M
SET M=C
WODX ;write outpatient diagnoses/pov's
+1 FOR APCLI=1:1:M
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
DO ODXSUB
+3 WRITE !
+4 IF $DATA(APCLL(APCLI))
WRITE ?3,$EXTRACT($PIECE(APCLL(APCLI),U),1,20),?25,"(",$PIECE(APCLL(APCLI),U,3),")",?35,$JUSTIFY($PIECE(APCLL(APCLI),U,2),6)
+5 IF $DATA(APCLS(APCLI))
WRITE ?46,$EXTRACT($PIECE(APCLS(APCLI),U),1,20),?68,"(",$PIECE(APCLS(APCLI),U,3),")",?78,$JUSTIFY($PIECE(APCLS(APCLI),U,2),6)
+6 IF $DATA(APCLT(APCLI))
WRITE ?89,$EXTRACT($PIECE(APCLT(APCLI),U),1,20),?111,"(",$PIECE(APCLT(APCLI),U,3),")",?121,$JUSTIFY($PIECE(APCLT(APCLI),U,2),6)
End DoDot:1
IF $DATA(APCLQUIT)
QUIT
ODXCAT ;
+1 SET APCLTYPE="ODXCAT"
+2 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
+3 SET APCLTYPE="CAT"
WRITE !!!
DO ODXSUB
OLCAT ;
+1 KILL APCLL
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTCATC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTCATC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 SET C=C+1
SET APCLL(C)=$EXTRACT($PIECE(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLLFAC,"OUTCATC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+4 SET M=C
OSCAT ;
+1 KILL APCLS
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTCATC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTCATC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 SET C=C+1
SET APCLS(C)=$EXTRACT($PIECE(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLSFAC,"OUTCATC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+4 IF C>M
SET M=C
OTCAT ;
+1 KILL APCLT
SET (APCLX,C)=0
FOR
SET APCLX=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTCATC",APCLX))
IF APCLX=""!(C>14)
QUIT
Begin DoDot:1
+2 SET APCLY=0
FOR
SET APCLY=$ORDER(^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTCATC",APCLX,APCLY))
IF APCLY'=+APCLY
QUIT
Begin DoDot:2
+3 SET C=C+1
SET APCLT(C)=$EXTRACT($PIECE(^ICM(APCLY,0),U),1,30)_"^"_^XTMP("APCLCH2",APCLJOB,APCLBTH,"DATA",APCLCOM,APCLTFAC,"OUTCATC",APCLX,APCLY)
End DoDot:2
End DoDot:1
+4 IF C>M
SET M=C
WOCAT ;write outpatient diagnoses/pov's
+1 FOR APCLI=1:1:M
Begin DoDot:1
+2 IF $Y>(IOSL-4)
DO HEAD
IF $DATA(APCLQUIT)
QUIT
DO ODXSUB
+3 WRITE !
+4 IF $DATA(APCLL(APCLI))
WRITE ?3,$EXTRACT($PIECE(APCLL(APCLI),U),1,30),?35,$JUSTIFY($PIECE(APCLL(APCLI),U,2),6)
+5 IF $DATA(APCLS(APCLI))
WRITE ?46,$EXTRACT($PIECE(APCLS(APCLI),U),1,30),?78,$JUSTIFY($PIECE(APCLS(APCLI),U,2),6)
+6 IF $DATA(APCLT(APCLI))
WRITE ?89,$EXTRACT($PIECE(APCLT(APCLI),U),1,30),?121,$JUSTIFY($PIECE(APCLT(APCLI),U,2),6)
End DoDot:1
IF $DATA(APCLQUIT)
QUIT
+7 DO INPT^APCLCH2S
+8 QUIT
ODXSUB ;
+1 SET X="OUTPATIENT "_$SELECT(APCLTYPE="DX":"DIAGNOSES",1:"MAJOR DIAGNOSTIC CATEGORIES")
WRITE !,?(132-$LENGTH(X)/2),X,!
+2 WRITE !?8,$PIECE(^DIC(4,APCLLFAC,0),U),?51,$PIECE(^DIC(4,APCLSFAC,0),U),?94,$PIECE(^DIC(4,APCLTFAC,0),U),!
+3 IF APCLTYPE="DX"
WRITE !?3,"DIAGNOSIS/POV (ICD CODES)",?46,"DIAGNOSIS/POV (ICD CODES)",?89,"DIAGNOSIS/POV (ICD CODES)",!?3,"-------------",?46,"------------",?89,"------------"
+4 IF APCLTYPE="CAT"
WRITE !?3,"DIAGNOSTIC CATEGORY",?46,"DIAGNOSTIC CATEGORY",?89,"DIAGNOSTIC CATEGORY",!?3,"-------------------",?46,"-------------------",?89,"-------------------"
+5 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),?61,$$FMTE^XLFDT(DT),?110,"Page ",APCLPG,!
+3 WRITE ?40,"***** DIAGNOSES TALLY BY COMMUNITY/FACILITY *****",!
+4 WRITE ?50,$$FMTE^XLFDT(APCLBD)," to ",$$FMTE^XLFDT(APCLED),!
+5 WRITE ?(132-($LENGTH($PIECE(^AUTTCOM(APCLCOM,0),U))+12)/2),"COMMUNITY: ",$PIECE(^AUTTCOM(APCLCOM,0),U),!
+6 QUIT
