Routine: APCLCP8

APCLCP8 ; IHS/CMI/LAB - GIS/TUCSON PCC REPORT WITH AGE BUCKETS ; 11 Apr 2013  10:33 AM

 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88

 ;This routine will print the PCC Report that uses age buckets

 ;to tabulate sex,tribe or current community by age.

 ;Calls APCLBIN1

 ;Called from option APCL P BIN AGE BUCKETS

START ;

 W:$D(IOF) @IOF

 W !,"This report will present, for all visits on which staff members of",!,"discipline group that you select was a provider, time and patient services",!,"by age and sex.",!

 S Y=DT D DD^%DT S APCLDT=Y

GETGROUP ;

 S DIC="^APCLACTG(",DIC("A")="Enter the Provider Discipline Group you wish to report on: ",DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 W !,"Bye ... " G XIT

 S APCLACTG=+Y

 W !!,"You have selected the ",$P(Y,U,2)," discipline group.",!

 S DIC="^APCLACTG(",DA=+Y D EN^DIQ K DIC,DA

GETDATES ;

BD ;get beginning date

 W ! S DIR(0)="DA^:DT:EP",DIR("A")="Enter beginning Visit Date for Search:  " D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G GETGROUP

 S APCLBD=Y

ED ;get ending date

 W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Visit Date for Search:  " S Y=APCLBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S APCLED=Y

 S X1=APCLBD,X2=-1 D C^%DTC S APCLSD=X

LOC ;get location

 K APCLLOC

 S DIR(0)="S^O:One Location;T:Taxonomy of or Selected Set of Locations;A:All Locations"

 S DIR("A")="Include visits from which set of locations",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) BD

 I Y="A" K APCLLOC G CLINIC

 I Y="O" D O^APCLCP1 G:$D(APCLQ) LOC

 I Y="T" D T^APCLCP1 G:$D(APCLQ) LOC

CLINIC ;

 K APCLCLN

 S DIR(0)="S^O:One Clinic;T:Taxonomy of or Selected Set of Clinics;A:All Clinics"

 S DIR("A")="Include visits from which set of clinics",DIR("B")="A" KILL DA D ^DIR KILL DIR

 G:$D(DIRUT) LOC

 I Y="A" K APCLCLN G BIN

 I Y="O" D OC^APCLCP1 G:$D(APCLQ) CLINIC

 I Y="T" D TC^APCLCP1 G:$D(APCLQ) CLINIC

BIN S APCLBIN="0-0;1-4;5-14;15-19;20-24;25-44;45-64;65-125"

 W !!,"The Age Groups to be used are currently defined as:",! D LIST

 S DIR(0)="YO",DIR("A")="Do you wish to modify these age groups",DIR("B")="No" D ^DIR K DIR

 I $D(DIRUT) G GETDATES

 I Y=0 G ZIS

RUN ;

 K APCLQUIT S APCLY="",APCLA=-1 W ! F  D AGE Q:APCLX=""  I $D(APCLQUIT) G BIN

 D CLOSE I $D(APCLQUIT) G BIN

 D LIST

 G ZIS

AGE ;

 S DIR(0)="NO^0:150:0",DIR("A")="Enter the starting age of the "_$S(APCLY="":"first",1:"next")_" age group" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DUOUT)!($D(DTOUT)) S APCLQUIT="" Q

 S APCLX=Y

 I Y="" Q

 I APCLX?1.3N,APCLX>APCLA D SET Q

 W $C(7) W !,"Make sure the age is higher the beginning age of the previous group.",! G RUN

SET S APCLA=APCLX

 I APCLY="" S APCLY=APCLX Q

 S APCLY=APCLY_"-"_(APCLX-1)_";"_APCLX

CLOSE I APCLY="" Q

GC ;

 S DIR(0)="NO^0:150:0",DIR("A")="Enter the highest age for the last group" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DUOUT)!($D(DTOUT)) S APCLQUIT="" Q

 S APCLX=Y I Y="" S APCLX=199

 I APCLX?1.3N,APCLX'<APCLA S APCLY=APCLY_"-"_APCLX,APCLBIN=APCLY Q

 W "  ??",$C(7) G CLOSE

LIST ;

 S %=APCLBIN

 F I=1:1 S X=$P(%,";",I) Q:X=""  W !,$P(X,":")," - ",$P(X,":",2)

W !

SETBIN ;

 S APCLBIN="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.APCLDEMO)

 I APCLDEMO=-1 G BIN

 S XBRP="^APCLCP8P",XBRC="^APCLCP81",XBRX="XIT^APCLCP8",XBNS="APCL"

 D ^XBDBQUE

 D XIT

ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q

XIT ;

 K APCL80S,APCLBDD,APCLBT,APCLDT,APCLED,APCLEDD,APCLLENG,APCLLOC,APCLPG,APCLQUIT,APCL1,APCL2,APCLAP,APCLDISC,APCLODAT,APCLSD,APCLSKIP,APCLVACT,APCLVDFN,APCLVLOC,APCLVREC,APCLVTM,APCLVTT,APCLX,APCLY,APCLPRIM,APCLSITE,APCLBD

 K APCLA,APCLAGE,APCLBIN,APCLCHN,APCLDOB,APCLDOBS,APLCFOUN,APCLJOB,APCLNN,APCLSEX,APCLZ,APCLBT,APCLFOUN,APCLACTG

 K X,X1,X2,IO("Q"),%,Y,DIRUT,POP,ZTSK,ZTQUEUED,T,S,M,TS,H,DIR,DUOUT,DTOUT,DUOUT,DLOUT

O ;EP one location

 K APCLQ

 S DIC="^AUTTLOC(",DIC(0)="AEMQ",DIC("A")="Which LOCATION: " D ^DIC K DIC

 I Y=-1 S APCLQ="" Q

 S APCLLOC(+Y)=""

T ;EP taxonomy

 K APCLQ

 S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("A")="Which TAXONOMY: ",DIC("S")="I $P(^(0),U,15)=9999999.06" D ^DIC K DIC

 I Y=-1 S APCLQ="" Q

 S X=0 F  S X=$O(^ATXAX(+Y,21,"B",X)) Q:X=""  S APCLLOC(X)=""

OC ;EP one location

 K APCLQ

 S DIC="^DIC(40.7,",DIC(0)="AEMQ",DIC("A")="Which CLINIC: " D ^DIC K DIC

 I Y=-1 S APCLQ="" Q

 S APCLCLN(+Y)=""

TC ;EP taxonomy

 K APCLQ

 S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("A")="Which TAXONOMY: ",DIC("S")="I $P(^(0),U,15)=40.7" D ^DIC K DIC

 I Y=-1 S APCLQ="" Q

 S X=0 F  S X=$O(^ATXAX(+Y,21,"B",X)) Q:X=""  S APCLCLN(X)=""

APCLCP8   ; IHS/CMI/LAB - GIS/TUCSON PCC REPORT WITH AGE BUCKETS ; 11 Apr 2013  10:33 AM

 +1       ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88

 +2       ;This routine will print the PCC Report that uses age buckets

 +3       ;to tabulate sex,tribe or current community by age.

 +4       ;

 +5       ;Calls APCLBIN1

 +6       ;Called from option APCL P BIN AGE BUCKETS

 +7       ;

START     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,"This report will present, for all visits on which staff members of",!,"discipline group that you select was a provider, time and patient services",!,"by age and sex.",!

 +3        SET Y=DT

           DO DD^%DT

           SET APCLDT=Y

GETGROUP  ;

 +1        SET DIC="^APCLACTG("

           SET DIC("A")="Enter the Provider Discipline Group you wish to report on: "

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +2        IF Y=-1

               WRITE !,"Bye ... "

               GOTO XIT

 +3        SET APCLACTG=+Y

 +4        WRITE !!,"You have selected the ",$PIECE(Y,U,2)," discipline group.",!

 +5        SET DIC="^APCLACTG("

           SET DA=+Y

           DO EN^DIQ

           KILL DIC,DA

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

           SET DIR(0)="DA^:DT:EP"

           SET DIR("A")="Enter beginning Visit Date for Search:  "

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO GETGROUP

 +3        SET APCLBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="DA^"_APCLBD_":DT:EP"

           SET DIR("A")="Enter ending Visit Date for Search:  "

           SET Y=APCLBD

           DO DD^%DT

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET APCLED=Y

 +4        SET X1=APCLBD

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X

LOC       ;get location

 +1        KILL APCLLOC

 +2        SET DIR(0)="S^O:One Location;T:Taxonomy of or Selected Set of Locations;A:All Locations"

 +3        SET DIR("A")="Include visits from which set of locations"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO BD

 +5        IF Y="A"

               KILL APCLLOC

               GOTO CLINIC

 +6        IF Y="O"

               DO O^APCLCP1

               IF $DATA(APCLQ)

                   GOTO LOC

 +7        IF Y="T"

               DO T^APCLCP1

               IF $DATA(APCLQ)

                   GOTO LOC

CLINIC    ;

 +1        KILL APCLCLN

 +2        SET DIR(0)="S^O:One Clinic;T:Taxonomy of or Selected Set of Clinics;A:All Clinics"

 +3        SET DIR("A")="Include visits from which set of clinics"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO LOC

 +5        IF Y="A"

               KILL APCLCLN

               GOTO BIN

 +6        IF Y="O"

               DO OC^APCLCP1

               IF $DATA(APCLQ)

                   GOTO CLINIC

 +7        IF Y="T"

               DO TC^APCLCP1

               IF $DATA(APCLQ)

                   GOTO CLINIC

 +8       ;

BIN        SET APCLBIN="0-0;1-4;5-14;15-19;20-24;25-44;45-64;65-125"

 +1        WRITE !!,"The Age Groups to be used are currently defined as:",!

           DO LIST

 +2        SET DIR(0)="YO"

           SET DIR("A")="Do you wish to modify these age groups"

           SET DIR("B")="No"

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        IF Y=0

               GOTO ZIS

RUN       ;

 +1        KILL APCLQUIT

           SET APCLY=""

           SET APCLA=-1

           WRITE !

FOR

               DO AGE

               IF APCLX=""

                   QUIT

               IF $DATA(APCLQUIT)

                   GOTO BIN

 +2        DO CLOSE

           IF $DATA(APCLQUIT)

               GOTO BIN

 +3        DO LIST

 +4        GOTO ZIS

 +5       ;

AGE       ;

 +1        SET DIR(0)="NO^0:150:0"

           SET DIR("A")="Enter the starting age of the "_$SELECT(APCLY="":"first",1:"next")_" age group"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET APCLQUIT=""

               QUIT

 +3        SET APCLX=Y

 +4        IF Y=""

               QUIT

 +5        IF APCLX?1.3N

               IF APCLX>APCLA

                   DO SET

                   QUIT

 +6        WRITE $CHAR(7)

           WRITE !,"Make sure the age is higher the beginning age of the previous group.",!

           GOTO RUN

 +7       ;

SET        SET APCLA=APCLX

 +1        IF APCLY=""

               SET APCLY=APCLX

               QUIT

 +2        SET APCLY=APCLY_"-"_(APCLX-1)_";"_APCLX

 +3        QUIT

 +4       ;

CLOSE      IF APCLY=""

               QUIT

GC        ;

 +1        SET DIR(0)="NO^0:150:0"

           SET DIR("A")="Enter the highest age for the last group"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET APCLQUIT=""

               QUIT

 +3        SET APCLX=Y

           IF Y=""

               SET APCLX=199

 +4        IF APCLX?1.3N

               IF APCLX'<APCLA

                   SET APCLY=APCLY_"-"_APCLX

                   SET APCLBIN=APCLY

                   QUIT

 +5        WRITE "  ??",$CHAR(7)

           GOTO CLOSE

 +6        QUIT

 +7       ;

 +8       ;

LIST      ;

 +1        SET %=APCLBIN

 +2        FOR I=1:1

               SET X=$PIECE(%,";",I)

               IF X=""

                   QUIT

               WRITE !,$PIECE(X,":")," - ",$PIECE(X,":",2)

 +3        WRITE !

 +4        QUIT

 +5       ;

SETBIN    ;

 +1        SET APCLBIN="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"

 +2        QUIT

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.APCLDEMO)

 +2        IF APCLDEMO=-1

               GOTO BIN

 +3        SET XBRP="^APCLCP8P"

           SET XBRC="^APCLCP81"

           SET XBRX="XIT^APCLCP8"

           SET XBNS="APCL"

 +4        DO ^XBDBQUE

 +5        DO XIT

 +6        QUIT

ERR        WRITE $CHAR(7),$CHAR(7),!,"Must be a valid date and be Today or earlier. Time not allowed!"

           QUIT

 +1       ;

XIT       ;

 +1        KILL APCL80S,APCLBDD,APCLBT,APCLDT,APCLED,APCLEDD,APCLLENG,APCLLOC,APCLPG,APCLQUIT,APCL1,APCL2,APCLAP,APCLDISC,APCLODAT,APCLSD,APCLSKIP,APCLVACT,APCLVDFN,APCLVLOC,APCLVREC,APCLVTM,APCLVTT,APCLX,APCLY,APCLPRIM,APCLSITE,APCLBD

 +2        KILL APCLA,APCLAGE,APCLBIN,APCLCHN,APCLDOB,APCLDOBS,APLCFOUN,APCLJOB,APCLNN,APCLSEX,APCLZ,APCLBT,APCLFOUN,APCLACTG

 +3        KILL X,X1,X2,IO("Q"),%,Y,DIRUT,POP,ZTSK,ZTQUEUED,T,S,M,TS,H,DIR,DUOUT,DTOUT,DUOUT,DLOUT

 +4        QUIT

 +5       ;

 +6       ;

O         ;EP one location

 +1        KILL APCLQ

 +2        SET DIC="^AUTTLOC("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which LOCATION: "

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               SET APCLQ=""

               QUIT

 +4        SET APCLLOC(+Y)=""

 +5        QUIT

T         ;EP taxonomy

 +1        KILL APCLQ

 +2        SET DIC="^ATXAX("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which TAXONOMY: "

           SET DIC("S")="I $P(^(0),U,15)=9999999.06"

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               SET APCLQ=""

               QUIT

 +4        SET X=0

FOR

               SET X=$ORDER(^ATXAX(+Y,21,"B",X))

               IF X=""

                   QUIT

               SET APCLLOC(X)=""

 +5        QUIT

OC        ;EP one location

 +1        KILL APCLQ

 +2        SET DIC="^DIC(40.7,"

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which CLINIC: "

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               SET APCLQ=""

               QUIT

 +4        SET APCLCLN(+Y)=""

 +5        QUIT

TC        ;EP taxonomy

 +1        KILL APCLQ

 +2        SET DIC="^ATXAX("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Which TAXONOMY: "

           SET DIC("S")="I $P(^(0),U,15)=40.7"

           DO ^DIC

           KILL DIC

 +3        IF Y=-1

               SET APCLQ=""

               QUIT

 +4        SET X=0

FOR

               SET X=$ORDER(^ATXAX(+Y,21,"B",X))

               IF X=""

                   QUIT

               SET APCLCLN(X)=""

 +5        QUIT

APCLCP8.m