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
Q
;
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
Q
;
;
LIST ;
S %=APCLBIN
F I=1:1 S X=$P(%,";",I) Q:X="" W !,$P(X,":")," - ",$P(X,":",2)
W !
Q
;
SETBIN ;
S APCLBIN="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"
Q
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
Q
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
Q
;
;
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)=""
Q
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)=""
Q
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)=""
Q
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)=""
Q
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
