APCLADX.m

APCLADX ; IHS/CMI/LAB - AGE BUCKET/DIAGNOSIS REPORT ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 W !!?15,"*****  FREQUENCY OF DIAGNOSES BY AGE REPORT  *****",!!

 D EXIT

GETDATES ;

BD ;get beginning date

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

 I $D(DIRUT) G EXIT

 S APCLBD=Y

ED ;get ending date

 W ! S DIR(0)="DA^"_APCLBD_":DT:EP",DIR("A")="Enter ending Visit Date:  " S Y=APCLBD D DD^%DT S Y="" D ^DIR S:$D(DUOUT) DIRUT=1 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

 ;

FILT ;

 S APCLQUIT=""

 K APCLSEX,APCLDOB1,APCLDOB2,APCLFAC,APCLPROV,APCLCLN,APCLSC,APCLSCP,APCLTYPE,APCLTYPP

 W !!,"When I search the database, I can ""screen"" POVs according to any one of the",!,"following attributes:"

 W !?15,"PATIENT SEX",!?15,"FACILITY OF ENCOUNTER",!?15,"PRIMARY PROVIDER",!?15,"CLINIC TYPE"

 W !?15,"SERVICE CATEGORY (Hospitalizations, Ambulatory, Chart Reviews",!?33," Nursing Home, etc.)",!?15,"VISIT TYPE (IHS, Contract, Tribal, 638, Other, VA)",!

 S DIR(0)="YO",DIR("A")="Want to use one or more of these 'screens'",DIR("B")="NO",DIR("?")="" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR

 G:$D(DIRUT) ED

 G:Y=0 POV

 D ^APCLADX0

 G:$D(DIRUT) FILT

 I APCLQUIT S APCLQUIT="" G FILT

POV ;

 K APCLPRIM,APCLALL

 S DIR(0)="SO^P:Primary Purpose of Visit;A:All Purpose of Visits (Primary and Secondary)",DIR("A")="Report should include"

 S DIR("?")="If you wish to count only the primary purpose of visit enter a 'P'.  To include ALL purpose of visits enter an 'A'.  For outpatient visits (non-H service category) the primary pov is the first one entered." D ^DIR K DIR

 I $D(DIRUT) G FILT

 I Y="A" S APCLALL=""

 I Y="P" S APCLPRIM=""

 ;

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" D ^DIR K DIR

 I $D(DIRUT) G POV

 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 APCLX=""

 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 D EXIT Q

 W !!,$C(7),$C(7),"THIS REPORT SHOULD BE PRINTED ON 132 COLUMN PAPER OR ON A PRINTER THAT IS",!,"SET UP FOR CONDENSED PRINT!!!",!,"IF YOU DO NOT HAVE SUCH A PRINTER AVAILABLE - SEE YOUR SITE MANAGER.",!

 S XBRC="^APCLADX1",XBRP="^APCLADXP",XBNS="APCL",XBRX="EXIT^APCLADX"

 D ^XBDBQUE

 D EXIT

 Q

EXIT ;

 K APCLBD,APCLED,APCLSEX,A,B,C,X,Y,Z,%,APCLFAC,APCLJOB,E,F,G,ZTQUEUED,APCLCLN,APCLTYPE,APCLSC,APCLC,APCLPREC,APCLSD,APCLCATP,APCLCLNP,APCLLOCP,APCLNARR,DIC,DIR,J,K,M,S

 K APCLQUIT,APCLPOV,APCLVSIT,APCLTOT,APCLPROV,APCLVTOT,APCLLINO,L,I,APCLPOVN,APCLV,APCLTYPP,APCLSCP,APCLPRIM,APCLALL

 K APCL132,APCLA,APCLBDD,APCLBIN,APCLCODE,APCLDOB,APCLDOBS,APCLEDD,APCLF2,APCLFACP,APCLFOUN,APCLNN,APCLODAT,APCLPG,APCLPRVP,APCLSEXP,APCLTAB,APCLVDFN,APCLZ

 K APCLBT,APCLGRAN

 Q

 ;

 ;

 ;

 ;

APCLADX   ; IHS/CMI/LAB - AGE BUCKET/DIAGNOSIS REPORT ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2        WRITE !!?15,"*****  FREQUENCY OF DIAGNOSES BY AGE REPORT  *****",!!

 +3        DO EXIT

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

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

           SET DIR("A")="Enter beginning Visit Date"

           DO ^DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO EXIT

 +3        SET APCLBD=Y

ED        ;get ending date

 +1        WRITE !

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

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

           SET Y=APCLBD

           DO DD^%DT

           SET Y=""

           DO ^DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

           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

 +5       ;

FILT      ;

 +1        SET APCLQUIT=""

 +2        KILL APCLSEX,APCLDOB1,APCLDOB2,APCLFAC,APCLPROV,APCLCLN,APCLSC,APCLSCP,APCLTYPE,APCLTYPP

 +3        WRITE !!,"When I search the database, I can ""screen"" POVs according to any one of the",!,"following attributes:"

 +4        WRITE !?15,"PATIENT SEX",!?15,"FACILITY OF ENCOUNTER",!?15,"PRIMARY PROVIDER",!?15,"CLINIC TYPE"

 +5        WRITE !?15,"SERVICE CATEGORY (Hospitalizations, Ambulatory, Chart Reviews",!?33," Nursing Home, etc.)",!?15,"VISIT TYPE (IHS, Contract, Tribal, 638, Other, VA)",!

 +6        SET DIR(0)="YO"

           SET DIR("A")="Want to use one or more of these 'screens'"

           SET DIR("B")="NO"

           SET DIR("?")=""

           DO ^DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

           KILL DIR

 +7        IF $DATA(DIRUT)

               GOTO ED

 +8        IF Y=0

               GOTO POV

 +9        DO ^APCLADX0

 +10       IF $DATA(DIRUT)

               GOTO FILT

 +11       IF APCLQUIT

               SET APCLQUIT=""

               GOTO FILT

POV       ;

 +1        KILL APCLPRIM,APCLALL

 +2        SET DIR(0)="SO^P:Primary Purpose of Visit;A:All Purpose of Visits (Primary and Secondary)"

           SET DIR("A")="Report should include"

 +3        SET DIR("?")="If you wish to count only the primary purpose of visit enter a 'P'.  To include ALL purpose of visits enter an 'A'.  For outpatient visits (non-H service category) the primary pov is the first one entered."

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO FILT

 +5        IF Y="A"

               SET APCLALL=""

 +6        IF Y="P"

               SET APCLPRIM=""

 +7       ;

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"

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO POV

 +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 APCLX=""

 +2        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

 +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^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

               DO EXIT

               QUIT 

 +3        WRITE !!,$CHAR(7),$CHAR(7),"THIS REPORT SHOULD BE PRINTED ON 132 COLUMN PAPER OR ON A PRINTER THAT IS",!,"SET UP FOR CONDENSED PRINT!!!",!,"IF YOU DO NOT HAVE SUCH A PRINTER AVAILABLE - SEE YOUR SITE MANAGER.",!

 +4        SET XBRC="^APCLADX1"

           SET XBRP="^APCLADXP"

           SET XBNS="APCL"

           SET XBRX="EXIT^APCLADX"

 +5        DO ^XBDBQUE

 +6        DO EXIT

 +7        QUIT 

EXIT      ;

 +1        KILL APCLBD,APCLED,APCLSEX,A,B,C,X,Y,Z,%,APCLFAC,APCLJOB,E,F,G,ZTQUEUED,APCLCLN,APCLTYPE,APCLSC,APCLC,APCLPREC,APCLSD,APCLCATP,APCLCLNP,APCLLOCP,APCLNARR,DIC,DIR,J,K,M,S

 +2        KILL APCLQUIT,APCLPOV,APCLVSIT,APCLTOT,APCLPROV,APCLVTOT,APCLLINO,L,I,APCLPOVN,APCLV,APCLTYPP,APCLSCP,APCLPRIM,APCLALL

 +3        KILL APCL132,APCLA,APCLBDD,APCLBIN,APCLCODE,APCLDOB,APCLDOBS,APCLEDD,APCLF2,APCLFACP,APCLFOUN,APCLNN,APCLODAT,APCLPG,APCLPRVP,APCLSEXP,APCLTAB,APCLVDFN,APCLZ

 +4        KILL APCLBT,APCLGRAN

 +5        QUIT 

 +6       ;

 +7       ;

 +8       ;

 +9       ;