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
Q
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
Q
;
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.",!!
Q
;
;
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
Q
;
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
Q
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
Q
;
;
LIST ;
S %=BCHRBIN
F I=1:1 S X=$P(%,";",I) Q:X="" W !,$P(X,"-")," - ",$P(X,"-",2)
W !
Q
;
SETBIN ;
S BCHRBIN="0-9;10-19;20-34;35-54;55-199"
Q
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
