APCLAGE ; IHS/CMI/LAB - Age bucker driver ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;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 ;
S APCLPG=0
W:$D(IOF) @IOF
K ^TMP("APCLAGE",$J)
W !,"This report will present, for all Living Patients registered at the facility",!,"that you select, age groups for a selected attribute.",!
S Y=DT D DD^%DT S APCLDT=Y
F ;
S DIC("A")="Include Patients Registered at Which Facility: ",DIC="^AUTTLOC(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 EOJ
S APCLSITE=+Y
S DIR(0)="S^1:SEX;2:CURRENT COMMUNITY;3:TRIBE OF MEMBERSHIP",DIR("A")="Present Age groups by" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G F
I $T(@Y)="" D HELP G MENU
S APCLZ=$T(@X)
;
BIN D SETBIN
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 MENU
I Y=0 G PRNT
W !!,$C(7),"WARNING: If you use more than 8 age groups the report will wrap around",!,"the page. Only 8 will fit on an 80 column screen or page!!",!
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 PRNT
;
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,APCLX)="" 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,APCLAGEG=APCLY Q
W " ??",$C(7) G CLOSE
Q
;
;
LIST ;
S %=APCLAGEG
F I=1:1 S X=$P(%,";",I) Q:X="" W !,$P(X,":")," - ",$P(X,":",2)
W !
Q
;
PRNT ;
S APCLTEMP=$P(APCLZ,";;",3) I APCLTEMP="" W !!,$C(7),$C(7),"TEMPLATE MISSING",! D EOJ Q
S DIS(0)="I 1",DIS(1)="I '$D(^DPT(D0,.35)),$D(^AUPNPAT(D0,41,APCLSITE))",DIS(2)="I $D(^DPT(D0,.35)),$P(^DPT(D0,.35),U)="""",$D(^AUPNPAT(D0,41,APCLSITE))"
S FLDS="["_APCLTEMP_"]"
S L=0,FR="",BY="@NUMBER",DIC=$P(APCLZ,";;",4),APCLHDR=$P(APCLZ,";;",2)
D EN1^DIP
EOJ ;ENTRY POINT
K ^TMP("APCLAGE",$J)
K APCLAGEG
W:$D(IOF) @IOF
K APCLSITE,APCLTEMP,APCLX,APCLY,APCLHDR,APCLHDRL,APCLA,APCLZ,APCLDT,APCLQUIT,APCLPG
K %,X,Y,%F,Z,DCC,DHD,DIS,DISH,DIPT,DINS,DR,FLDS,TO,BY,FR
Q
;
;
HDR ;EP -Header
S APCLPG=APCLPG+1
S APCLHDRL=(13+$L(APCLHDR))
W ?((80-APCLHDRL)/2),APCLHDR," By AGE GROUP",?71,"Page ",APCLPG,!
S APCLHDRL=(34+$L($P(^DIC(4,APCLSITE,0),U)))
W ?((80-APCLHDRL)/2),"All Living Patients Registered at ",$P(^DIC(4,APCLSITE,0),U),!
W ?(80-$L(APCLDT)/2),APCLDT,!
W !?35,"AGE GROUPS",!
Q
HELP ;
W !,"Choose a number from the menu presented. The item selected will be ",!,"displayed in a matrix by age groups.",!
Q
SETBIN ;
S APCLAGEG="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"
Q
;
1 ;;SEX;;APCL P BIN SEX;;^DPT(
2 ;;CURRENT COMMUNITY;;APCL P BIN CURRENT COMM;;^AUPNPAT(
3 ;;TRIBE OF MEMBERSHIP;;APCL P BIN TRIBE;;^AUPNPAT(
APCLAGE ; IHS/CMI/LAB - Age bucker driver ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+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 SET APCLPG=0
+2 IF $DATA(IOF)
WRITE @IOF
+3 KILL ^TMP("APCLAGE",$JOB)
+4 WRITE !,"This report will present, for all Living Patients registered at the facility",!,"that you select, age groups for a selected attribute.",!
+5 SET Y=DT
DO DD^%DT
SET APCLDT=Y
F ;
+1 SET DIC("A")="Include Patients Registered at Which Facility: "
SET DIC="^AUTTLOC("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA
IF Y<0
GOTO EOJ
+2 SET APCLSITE=+Y
+1 SET DIR(0)="S^1:SEX;2:CURRENT COMMUNITY;3:TRIBE OF MEMBERSHIP"
SET DIR("A")="Present Age groups by"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO F
+3 IF $TEXT(@Y)=""
DO HELP
GOTO MENU
+4 SET APCLZ=$TEXT(@X)
+5 ;
BIN DO SETBIN
+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 MENU
+4 IF Y=0
GOTO PRNT
+5 WRITE !!,$CHAR(7),"WARNING: If you use more than 8 age groups the report will wrap around",!,"the page. Only 8 will fit on an 80 column screen or page!!",!
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 PRNT
+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,APCLX)=""
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 APCLAGEG=APCLY
QUIT
+5 WRITE " ??",$CHAR(7)
GOTO CLOSE
+6 QUIT
+7 ;
+8 ;
LIST ;
+1 SET %=APCLAGEG
+2 FOR I=1:1
SET X=$PIECE(%,";",I)
IF X=""
QUIT
WRITE !,$PIECE(X,":")," - ",$PIECE(X,":",2)
+3 WRITE !
+4 QUIT
+5 ;
PRNT ;
+1 SET APCLTEMP=$PIECE(APCLZ,";;",3)
IF APCLTEMP=""
WRITE !!,$CHAR(7),$CHAR(7),"TEMPLATE MISSING",!
DO EOJ
QUIT
+2 SET DIS(0)="I 1"
SET DIS(1)="I '$D(^DPT(D0,.35)),$D(^AUPNPAT(D0,41,APCLSITE))"
SET DIS(2)="I $D(^DPT(D0,.35)),$P(^DPT(D0,.35),U)="""",$D(^AUPNPAT(D0,41,APCLSITE))"
+3 SET FLDS="["_APCLTEMP_"]"
+4 SET L=0
SET FR=""
SET BY="@NUMBER"
SET DIC=$PIECE(APCLZ,";;",4)
SET APCLHDR=$PIECE(APCLZ,";;",2)
+5 DO EN1^DIP
EOJ ;ENTRY POINT
+1 KILL ^TMP("APCLAGE",$JOB)
+2 KILL APCLAGEG
+3 IF $DATA(IOF)
WRITE @IOF
+4 KILL APCLSITE,APCLTEMP,APCLX,APCLY,APCLHDR,APCLHDRL,APCLA,APCLZ,APCLDT,APCLQUIT,APCLPG
+5 KILL %,X,Y,%F,Z,DCC,DHD,DIS,DISH,DIPT,DINS,DR,FLDS,TO,BY,FR
+6 QUIT
+7 ;
+8 ;
HDR ;EP -Header
+1 SET APCLPG=APCLPG+1
+2 SET APCLHDRL=(13+$LENGTH(APCLHDR))
+3 WRITE ?((80-APCLHDRL)/2),APCLHDR," By AGE GROUP",?71,"Page ",APCLPG,!
+4 SET APCLHDRL=(34+$LENGTH($PIECE(^DIC(4,APCLSITE,0),U)))
+5 WRITE ?((80-APCLHDRL)/2),"All Living Patients Registered at ",$PIECE(^DIC(4,APCLSITE,0),U),!
+6 WRITE ?(80-$LENGTH(APCLDT)/2),APCLDT,!
+7 WRITE !?35,"AGE GROUPS",!
+8 QUIT
HELP ;
+1 WRITE !,"Choose a number from the menu presented. The item selected will be ",!,"displayed in a matrix by age groups.",!
+2 QUIT
SETBIN ;
+1 SET APCLAGEG="0:0;1:4;5:14;15:19;20:24;25:44;45:64;65:125"
+2 QUIT
+3 ;
1 ;;SEX;;APCL P BIN SEX;;^DPT(
2 ;;CURRENT COMMUNITY;;APCL P BIN CURRENT COMM;;^AUPNPAT(
3 ;;TRIBE OF MEMBERSHIP;;APCL P BIN TRIBE;;^AUPNPAT(
