APCLW1 ; IHS/CMI/LAB - AGE BUCKET/DIAGNOSIS REPORT ;
;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
;
START ;
W !!?15,"***** OVERWEIGHT/OBESITY PREVALENCE REPORT *****",!!
D EXIT
S APCLSEAT="",APCLCMS=""
S APCLTYPE=""
;
S DIR(0)="S^S:Search Template of Patients;P:Search All Patients;R:Case Management System Register"
S DIR("A")=" Select List " D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) EXIT
S APCLTYPE=Y
I APCLTYPE="S" D TEMPLATE
I APCLTYPE="R" D R I APCLSTP G START
;
DATE ;
W !!
S APCLDATE=""
S DIR(0)="D^::EP",DIR("A")="Enter As of Date" KILL DA D ^DIR KILL DIR
G:$D(DIRUT) START
I Y="" G START
I APCLDATE["00" W !!,"cannot be an imprecise date" H 1 W ! G DATE
S APCLDATE=Y
AGE1 ;
S DIR(0)="SO^E:Each Age in Years listed separately;G:Age Groups listed",DIR("A")="Do you want to see the report with",DIR("B")="E" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) START
S APCLAGEG=Y
D @Y I '$D(APCLLOWA)!('$D(APCLHGHA)) G START
G SEX
G ;
K APCLLOWA,APCLHGHA D SETBIN
BIN ;
W !,"The Age Groups to be used are currently defined as:",! D LIST
S DIR(0)="Y",DIR("A")="Do you wish to modify these age groups",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
I Y=0 S APCLLOWA=$P(APCLBIN,"-",1) F I=1:1 S X=$P(APCLBIN,";",I) Q:X="" S APCLHGHA=$P(X,"-",2)
Q:Y=0
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 BIN
Q
E ;
S DIR(0)="N^2:74:0",DIR("A")="Enter the low age",DIR("B")="2" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
S APCLLOWA=Y
S DIR(0)="N^2:74:0",DIR("A")="Enter the high age",DIR("B")="2" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
S APCLHGHA=Y
Q
;
AGE ;
S APCLX=""
S DIR(0)="NO^2:74: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^2:74: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=74
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="2-4;5-14;15-19;20-24;25-44;45-64;65-74"
Q
SEX ;
S DIR(0)="S^M:Males;F:Females;B:Both",DIR("A")="Do you want the report run for",DIR("B")="B" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) START
S APCLSEX=Y
;
INDBEN ;
W !
S DIR(0)="Y",DIR("A")="Do you wish to include ONLY Indian/Alaska Native Beneficiaries",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DUOUT) G SEX
S APCLIBEN=Y
ZIS ;
DEMO ;
D DEMOCHK^APCLUTL(.APCLDEMO)
I APCLDEMO=-1 G INDBEN
S XBRC="^APCLW11",XBRP="^APCLW1P",XBNS="APCL",XBRX="EXIT^APCLW1"
D ^XBDBQUE
D EXIT
Q
EXIT ;
K APCLAGEG,APCLSEX,APCLBIN,APCLX,APCLY,APCLA,APCLQUIT,APCL1YR,APCL3YR,APCL80,APCLA,APCLAGE,APCLAGEP,APCLBBMI,APCLBD,APCLBHGH,APCLBIN,APCLBLOW,APCLBMI,APCLBOBE,APCLBOVR,APCLBTH,APCLBTUP,APCLDATE
K APCLCHT,APCLCWT,APCLDT,APCLER,APCLFBMI,APCLFHGH,APCLFLOW,APCLFOBE,APCLFOVR,APCLFTUP,APCLGHT,APCLGWT,APCLHGHA,APCLJOB,APCLLENG,APCLLOWA,APCLMBMI,APCLMHGH,APCLMHT,APCLMLOW,APCLMOBE,APCLOVRE,APCLMTUP,APCLMWT,APCLNN,APCLPAGE
K APCLPG,APCLQUIT,APCLREF,APCLROHT,APCLROWT,APCLSEX,APCLSEXP,APCLTEXT,APCLX,APCLY,APCLFOBE,APCLMOVR,APCLIBEN,APCLCLAS,APCLWT,APCLHBD
K AUPNSEX,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS
K B,D,DA,DFN,DIC,DIR,DIRUT,J,K,M,P,R,S,T,V,X,X1,X2,Y,Z
K DIR,DA,DIC,J,K,M,S,X,Y,APCLSEAT,APCLTYPE
Q
;
TEMPLATE ;If Template was selected
S APCLSEAT=""
;
W ! S DIC("S")="I $P(^(0),U,4)=9000001!($P(^(0),U,4)=2)" S DIC="^DIBT(",DIC("A")="Enter Patient SEARCH TEMPLATE name: ",DIC(0)="AEMQ" D ^DIC K DIC,DA,DR,DICR
I Y=-1 K APCLTYPE Q
S APCLSEAT=+Y
Q
R ;get register and status
S APCLSTP=""
S APCLCMS=""
S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Register: " D ^DIC
I Y=-1 W !,"No register selected." S APCLSTP=1 Q
S APCLCMS=+Y
;get status
S APCLSTAT=""
S DIR(0)="Y",DIR("A")="Do you want to select register patients with a particular status",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCLSTP=1 Q
I Y=0 S APCLSTAT="" Q
;which status
S DIR(0)="9002241,1",DIR("A")="Which status",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S APCLSTP=1 Q
S APCLSTAT=Y
Q
APCLW1 ; IHS/CMI/LAB - AGE BUCKET/DIAGNOSIS REPORT ;
+1 ;;2.0;IHS PCC SUITE;**2,10**;MAY 14, 2009;Build 88
+2 ;
START ;
+1 WRITE !!?15,"***** OVERWEIGHT/OBESITY PREVALENCE REPORT *****",!!
+2 DO EXIT
+3 SET APCLSEAT=""
SET APCLCMS=""
+4 SET APCLTYPE=""
+5 ;
+6 SET DIR(0)="S^S:Search Template of Patients;P:Search All Patients;R:Case Management System Register"
+7 SET DIR("A")=" Select List "
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+8 IF $DATA(DIRUT)
GOTO EXIT
+9 SET APCLTYPE=Y
+10 IF APCLTYPE="S"
DO TEMPLATE
+11 IF APCLTYPE="R"
DO R
IF APCLSTP
GOTO START
+12 ;
DATE ;
+1 WRITE !!
+2 SET APCLDATE=""
+3 SET DIR(0)="D^::EP"
SET DIR("A")="Enter As of Date"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO START
+5 IF Y=""
GOTO START
+6 IF APCLDATE["00"
WRITE !!,"cannot be an imprecise date"
HANG 1
WRITE !
GOTO DATE
+7 SET APCLDATE=Y
AGE1 ;
+1 SET DIR(0)="SO^E:Each Age in Years listed separately;G:Age Groups listed"
SET DIR("A")="Do you want to see the report with"
SET DIR("B")="E"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO START
+3 SET APCLAGEG=Y
+4 DO @Y
IF '$DATA(APCLLOWA)!('$DATA(APCLHGHA))
GOTO START
+5 GOTO SEX
G ;
+1 KILL APCLLOWA,APCLHGHA
DO SETBIN
BIN ;
+1 WRITE !,"The Age Groups to be used are currently defined as:",!
DO LIST
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to modify these age groups"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 IF Y=0
SET APCLLOWA=$PIECE(APCLBIN,"-",1)
FOR I=1:1
SET X=$PIECE(APCLBIN,";",I)
IF X=""
QUIT
SET APCLHGHA=$PIECE(X,"-",2)
+5 IF Y=0
QUIT
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
GOTO BIN
+4 QUIT
E ;
+1 SET DIR(0)="N^2:74:0"
SET DIR("A")="Enter the low age"
SET DIR("B")="2"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 SET APCLLOWA=Y
+4 SET DIR(0)="N^2:74:0"
SET DIR("A")="Enter the high age"
SET DIR("B")="2"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+5 IF $DATA(DIRUT)
QUIT
+6 SET APCLHGHA=Y
+7 QUIT
+8 ;
AGE ;
+1 SET APCLX=""
+2 SET DIR(0)="NO^2:74: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
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
SET APCLQUIT=""
QUIT
+4 SET APCLX=Y
+5 IF Y=""
QUIT
+6 IF APCLX?1.3N
IF APCLX>APCLA
DO SET
QUIT
+7 WRITE $CHAR(7)
WRITE !,"Make sure the age is higher the beginning age of the previous group.",!
GOTO RUN
+8 ;
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^2:74: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=74
+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="2-4;5-14;15-19;20-24;25-44;45-64;65-74"
+2 QUIT
SEX ;
+1 SET DIR(0)="S^M:Males;F:Females;B:Both"
SET DIR("A")="Do you want the report run for"
SET DIR("B")="B"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO START
+3 SET APCLSEX=Y
+4 ;
INDBEN ;
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Do you wish to include ONLY Indian/Alaska Native Beneficiaries"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DUOUT)
GOTO SEX
+4 SET APCLIBEN=Y
ZIS ;
DEMO ;
+1 DO DEMOCHK^APCLUTL(.APCLDEMO)
+2 IF APCLDEMO=-1
GOTO INDBEN
+3 SET XBRC="^APCLW11"
SET XBRP="^APCLW1P"
SET XBNS="APCL"
SET XBRX="EXIT^APCLW1"
+4 DO ^XBDBQUE
+5 DO EXIT
+6 QUIT
EXIT ;
+1 KILL APCLAGEG,APCLSEX,APCLBIN,APCLX,APCLY,APCLA,APCLQUIT,APCL1YR,APCL3YR,APCL80,APCLA,APCLAGE,APCLAGEP,APCLBBMI,APCLBD,APCLBHGH,APCLBIN,APCLBLOW,APCLBMI,APCLBOBE,APCLBOVR,APCLBTH,APCLBTUP,APCLDATE
+2 KILL APCLCHT,APCLCWT,APCLDT,APCLER,APCLFBMI,APCLFHGH,APCLFLOW,APCLFOBE,APCLFOVR,APCLFTUP,APCLGHT,APCLGWT,APCLHGHA,APCLJOB,APCLLENG,APCLLOWA,APCLMBMI,APCLMHGH,APCLMHT,APCLMLOW,APCLMOBE,APCLOVRE,APCLMTUP,APCLMWT,APCLNN,APCLPAGE
+3 KILL APCLPG,APCLQUIT,APCLREF,APCLROHT,APCLROWT,APCLSEX,APCLSEXP,APCLTEXT,APCLX,APCLY,APCLFOBE,APCLMOVR,APCLIBEN,APCLCLAS,APCLWT,APCLHBD
+4 KILL AUPNSEX,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS
+5 KILL B,D,DA,DFN,DIC,DIR,DIRUT,J,K,M,P,R,S,T,V,X,X1,X2,Y,Z
+6 KILL DIR,DA,DIC,J,K,M,S,X,Y,APCLSEAT,APCLTYPE
+7 QUIT
+8 ;
TEMPLATE ;If Template was selected
+1 SET APCLSEAT=""
+2 ;
+3 WRITE !
SET DIC("S")="I $P(^(0),U,4)=9000001!($P(^(0),U,4)=2)"
SET DIC="^DIBT("
SET DIC("A")="Enter Patient SEARCH TEMPLATE name: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC,DA,DR,DICR
+4 IF Y=-1
KILL APCLTYPE
QUIT
+5 SET APCLSEAT=+Y
+6 QUIT
R ;get register and status
+1 SET APCLSTP=""
+2 SET APCLCMS=""
+3 SET DIC="^ACM(41.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Register: "
DO ^DIC
+4 IF Y=-1
WRITE !,"No register selected."
SET APCLSTP=1
QUIT
+5 SET APCLCMS=+Y
+6 ;get status
+7 SET APCLSTAT=""
+8 SET DIR(0)="Y"
SET DIR("A")="Do you want to select register patients with a particular status"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET APCLSTP=1
QUIT
+10 IF Y=0
SET APCLSTAT=""
QUIT
+11 ;which status
+12 SET DIR(0)="9002241,1"
SET DIR("A")="Which status"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+13 IF $DATA(DIRUT)
SET APCLSTP=1
QUIT
+14 SET APCLSTAT=Y
+15 QUIT
