APCLCH2P.m

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