APCLW1.m

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