Routine: BCHRC5

BCHRC5 ; IHS/CMI/LAB - CHR Report 1 ;

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

START ;

 I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q

 S BCHJOB=$J,BCHBTH=$H

 D INFORM

GETDATES ;

BD ;get beginning date

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter BEGINNING Date of Service for Report" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S BCHBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ENDING Date of Service for Report" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S BCHED=Y

 S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X

PROG ;

 S BCHPRG=""

 S DIR(0)="Y",DIR("A")="Include data from ALL CHR Programs",DIR("B")="N",DIR("?")="If you wish to include visits from ALL programs answer Yes.  If you wish to tabulate for only one program enter NO." D ^DIR K DIR

 G:$D(DIRUT) BD

 I Y=1 S BCHPRG="" G CHRT

PROG1 ;enter program

 K X,DIC,DA,DD,DR,Y S DIC("A")="Which CHR Program: ",DIC="^BCHTPROG(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 PROG

 S BCHPRG=+Y

 ;G ZIS

CHRT ;

 K BCHPROVT

 S DIR(0)="S^O:One CHR;A:All CHRs",DIR("A")="Include Data for",DIR("B")="A" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G PROG

 S BCHPROVT=Y

 I BCHPROVT="A" G GETAGE

CHR1 ;

 K DIC

 S DIC=200,DIC(0)="AEMQ",DIC("A")="Enter the CHR: " D ^DIC

 I Y=-1 G CHRT

 S BCHCHR1=+Y

GETAGE ;

 K BCHQUIT

 D PI

 I $D(BCHQUIT) G PROG

REG ;

 S BCHREG="",BCHREGN=""

 S DIR(0)="S^R:Registered Patients;N:Non-Registered Patients;B:Both Registered and Non-Registered Patients",DIR("A")="Include which Patients",DIR("B")="B" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G GETAGE

 S BCHREG=Y,BCHREGN=Y(0)

ZIS ;CALL TO XBDBQUE

 S XBRP="^BCHRC5P",XBRC="^BCHRC51",XBRX="XIT^BCHRC5",XBNS="BCH"

 D ^XBDBQUE

 D XIT

ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q

XIT ;

 K BCHPRG,BCHTOTC,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHC,BCHPROB,BCHPROBN,BCHR,BCHR0,BCHPG,BCHDT,BCHRPT,BCHRAGE,BCHRBIN,BCHDOBS,BCHRNN,BCHRX,BCHRY,BCHRZ,BCHTF

 K BCHTM,DOB,SEX,DFN,M,F,A,I,BCHR11,BCHRA,BCHRDOBS

INFORM ;

 W:$D(IOF) @IOF

 W !?20,"**********  CHR REPORT NO. 5  **********"

 W !!?2,"NUMBER OF SERVICES (LINES OF ASSESSMENT) BY HEALTH PROBLEM, AGE AND SEX",!!,"You must enter the time frame and the program for which the report",!,"will be run."

 W !!,"You can also define your own age groups, if you so desire.",!

 W "If you do, Please LIMIT the # of age groups to 5"

 ;THIS REPORT REQUIRES A PRINTER THAT IS CAPABLE OF PRINTING 132 COLUMN OUTPUT.",!,"SEE YOUR SITE MANAGER IF YOU NEED ASSISTANCE FINDING SUCH A PRINTER.",!!

PI ;EP ;age/sex record counts interactive print ?

 W !!

BIN D SETBIN

 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

 I $D(DIRUT) S BCHQUIT="" Q

 I Y=0 Q

RUN ;

 K BCHQUIT S BCHRY="",BCHRA=-1,BCHRACNT=1 W ! F  D AGE Q:BCHRX=""!(BCHRACNT>4)  I $D(BCHQUIT) G BIN

 D CLOSE I $D(BCHQUIT) G BIN

 D LIST

AGE ;

 S BCHRX=""

 I BCHRA'=-1 W !!,BCHRACNT," Age groups selected so far, no more than 5 are allowed.",!

 S DIR(0)="NO^0:150:0",DIR("A")="Enter the STARTING age of the "_$S(BCHRY="":"FIRST",1:"NEXT")_" age group" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DUOUT)!($D(DTOUT)) S BCHQUIT="" Q

 S BCHRX=Y

 I Y="" Q

 I BCHRX?1.3N,BCHRX>BCHRA D SET Q

 W $C(7) W !,"Make sure the age is higher than the beginning age of the previous group.",! G RUN

SET S BCHRA=BCHRX

 I BCHRY="" S BCHRY=BCHRX Q

 S BCHRY=BCHRY_"-"_(BCHRX-1)_";"_BCHRX,BCHRACNT=BCHRACNT+1

CLOSE I BCHRY="" 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 BCHQUIT="" Q

 S BCHRX=Y I Y="" S BCHRX=199

 I BCHRX?1.3N,BCHRX'<BCHRA S BCHRY=BCHRY_"-"_BCHRX,BCHRBIN=BCHRY Q

 W "  ??",$C(7) G CLOSE

LIST ;

 S %=BCHRBIN

 F I=1:1 S X=$P(%,";",I) Q:X=""  W !,$P(X,"-")," - ",$P(X,"-",2)

W !

SETBIN ;

 S BCHRBIN="0-9;10-19;20-34;35-54;55-199"

BCHRC5    ; IHS/CMI/LAB - CHR Report 1 ;

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;

START     ;

 +1        IF '$GET(DUZ(2))

               WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!

               QUIT

 +2        SET BCHJOB=$JOB

           SET BCHBTH=$HOROLOG

 +3        DO INFORM

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

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

           SET DIR("A")="Enter BEGINNING Date of Service for Report"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        SET BCHBD=Y

ED        ;get ending date

 +1        WRITE !

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

           SET DIR("A")="Enter ENDING Date of Service for Report"

           SET Y=BCHBD

           DO DD^%DT

           SET DIR("B")=Y

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET BCHED=Y

 +4        SET X1=BCHBD

           SET X2=-1

           DO C^%DTC

           SET BCHSD=X

 +5       ;

PROG      ;

 +1        SET BCHPRG=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Include data from ALL CHR Programs"

           SET DIR("B")="N"

           SET DIR("?")="If you wish to include visits from ALL programs answer Yes.  If you wish to tabulate for only one program enter NO."

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO BD

 +4        IF Y=1

               SET BCHPRG=""

               GOTO CHRT

PROG1     ;enter program

 +1        KILL X,DIC,DA,DD,DR,Y

           SET DIC("A")="Which CHR Program: "

           SET DIC="^BCHTPROG("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA

           IF Y<0

               GOTO PROG

 +2        SET BCHPRG=+Y

 +3       ;G ZIS

CHRT      ;

 +1        KILL BCHPROVT

 +2        SET DIR(0)="S^O:One CHR;A:All CHRs"

           SET DIR("A")="Include Data for"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO PROG

 +4        SET BCHPROVT=Y

 +5        IF BCHPROVT="A"

               GOTO GETAGE

CHR1      ;

 +1        KILL DIC

 +2        SET DIC=200

           SET DIC(0)="AEMQ"

           SET DIC("A")="Enter the CHR: "

           DO ^DIC

 +3        IF Y=-1

               GOTO CHRT

 +4        SET BCHCHR1=+Y

GETAGE    ;

 +1        KILL BCHQUIT

 +2        DO PI

 +3        IF $DATA(BCHQUIT)

               GOTO PROG

REG       ;

 +1        SET BCHREG=""

           SET BCHREGN=""

 +2        SET DIR(0)="S^R:Registered Patients;N:Non-Registered Patients;B:Both Registered and Non-Registered Patients"

           SET DIR("A")="Include which Patients"

           SET DIR("B")="B"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO GETAGE

 +4        SET BCHREG=Y

           SET BCHREGN=Y(0)

ZIS       ;CALL TO XBDBQUE

 +1        SET XBRP="^BCHRC5P"

           SET XBRC="^BCHRC51"

           SET XBRX="XIT^BCHRC5"

           SET XBNS="BCH"

 +2        DO ^XBDBQUE

 +3        DO XIT

 +4        QUIT

ERR        WRITE $CHAR(7),$CHAR(7),!,"Must be a valid date and be Today or earlier. Time not allowed!"

           QUIT

XIT       ;

 +1        KILL BCHPRG,BCHTOTC,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHC,BCHPROB,BCHPROBN,BCHR,BCHR0,BCHPG,BCHDT,BCHRPT,BCHRAGE,BCHRBIN,BCHDOBS,BCHRNN,BCHRX,BCHRY,BCHRZ,BCHTF

 +2        KILL BCHTM,DOB,SEX,DFN,M,F,A,I,BCHR11,BCHRA,BCHRDOBS

 +3        QUIT

 +4       ;

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !?20,"**********  CHR REPORT NO. 5  **********"

 +3        WRITE !!?2,"NUMBER OF SERVICES (LINES OF ASSESSMENT) BY HEALTH PROBLEM, AGE AND SEX",!!,"You must enter the time frame and the program for which the report",!,"will be run."

 +4        WRITE !!,"You can also define your own age groups, if you so desire.",!

 +5        WRITE "If you do, Please LIMIT the # of age groups to 5"

 +6       ;THIS REPORT REQUIRES A PRINTER THAT IS CAPABLE OF PRINTING 132 COLUMN OUTPUT.",!,"SEE YOUR SITE MANAGER IF YOU NEED ASSISTANCE FINDING SUCH A PRINTER.",!!

 +7        QUIT

 +8       ;

 +9       ;

PI        ;EP ;age/sex record counts interactive print ?

 +1        WRITE !!

BIN        DO SETBIN

 +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

 +3        IF $DATA(DIRUT)

               SET BCHQUIT=""

               QUIT

 +4        IF Y=0

               QUIT

RUN       ;

 +1        KILL BCHQUIT

           SET BCHRY=""

           SET BCHRA=-1

           SET BCHRACNT=1

           WRITE !

FOR

               DO AGE

               IF BCHRX=""!(BCHRACNT>4)

                   QUIT

               IF $DATA(BCHQUIT)

                   GOTO BIN

 +2        DO CLOSE

           IF $DATA(BCHQUIT)

               GOTO BIN

 +3        DO LIST

 +4        QUIT

 +5       ;

AGE       ;

 +1        SET BCHRX=""

 +2        IF BCHRA'=-1

               WRITE !!,BCHRACNT," Age groups selected so far, no more than 5 are allowed.",!

 +3        SET DIR(0)="NO^0:150:0"

           SET DIR("A")="Enter the STARTING age of the "_$SELECT(BCHRY="":"FIRST",1:"NEXT")_" age group"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +4        IF $DATA(DUOUT)!($DATA(DTOUT))

               SET BCHQUIT=""

               QUIT

 +5        SET BCHRX=Y

 +6        IF Y=""

               QUIT

 +7        IF BCHRX?1.3N

               IF BCHRX>BCHRA

                   DO SET

                   QUIT

 +8        WRITE $CHAR(7)

           WRITE !,"Make sure the age is higher than the beginning age of the previous group.",!

           GOTO RUN

 +9       ;

SET        SET BCHRA=BCHRX

 +1        IF BCHRY=""

               SET BCHRY=BCHRX

               QUIT

 +2        SET BCHRY=BCHRY_"-"_(BCHRX-1)_";"_BCHRX

           SET BCHRACNT=BCHRACNT+1

 +3        QUIT

CLOSE      IF BCHRY=""

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

               QUIT

 +3        SET BCHRX=Y

           IF Y=""

               SET BCHRX=199

 +4        IF BCHRX?1.3N

               IF BCHRX'<BCHRA

                   SET BCHRY=BCHRY_"-"_BCHRX

                   SET BCHRBIN=BCHRY

                   QUIT

 +5        WRITE "  ??",$CHAR(7)

           GOTO CLOSE

 +6        QUIT

 +7       ;

 +8       ;

LIST      ;

 +1        SET %=BCHRBIN

 +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 BCHRBIN="0-9;10-19;20-34;35-54;55-199"

 +2        QUIT

BCHRC5.m