BCHRC6 ; IHS/CMI/LAB - CHR Report 2 ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - tmp to xtmp
;
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 REG
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
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 PROG
S BCHREG=Y,BCHREGN=Y(0)
ZIS ;CALL TO XBDBQUE
S XBRP="^BCHRC6P",XBRC="PROC^BCHRC6",XBRX="XIT^BCHRC6",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 ;
F X=1:1:10 S V="V"_X K @V
K V,BCHSD,BCHBD,BCHBDD,BCHED,BCHEDD,BCHODAT,BCHR,BCHR0,X,P,S,N,BCHQUIT,BCHBTH,BCHDT,BCHNAME,BCHPRG,BCHX
K X,Y
Q
;
INFORM ;
W:$D(IOF) @IOF
W !?20,"********** CHR REPORT NO. 6 **********"
W !!?33,"PROVIDER DATA",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!!
;W "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
;
;
PROC ;EP - PROCESS REFERRAL REPORT
D XTMP^BCHUTIL("BCHRC6","CHR CHR REPORT")
S (BCHBT,BCHBTH)=$H,BCHJOB=$J
S ^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL")=0
D D,EOJ
Q
;
EOJ ;
S BCHET=$H
Q
D ; Run by date of service
S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X
S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D D1
Q
;
D1 ;
S (BCHR,BCHRCNT)=0 F S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROCESS
Q
PROCESS ;
S BCHPAT=$P(BCHR0,U,4)
S BCHNRPAT=$P($G(^BCHR(BCHR,11)),U,12)
;I 'BCHPAT,'BCHNRPAT Q ;no patient
I BCHREG="R",BCHPAT="" Q
I BCHREG="N",BCHNRPAT="" Q
I BCHPAT,BCHNRPAT S BCHNRPAT=""
I BCHPAT Q:'$D(^DPT(BCHPAT,0))
S BCHPROG=$P(BCHR0,U,2)
I BCHPRG,BCHPRG'=BCHPROG Q
S C=$P(BCHR0,U,3),BCHNAME=$P(^VA(200,C,0),U)
I '$D(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME)) S ^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME)=0
S X=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X D
.S S=$P(^BCHRPROB(X,0),U,4) Q:S=""
.I $P(^BCHTSERV(S,0),U,3)="LT" D
..S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,3)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,3)+$P(^BCHRPROB(X,0),U,5)
..S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,3)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,3)+$P(^BCHRPROB(X,0),U,5)
.E S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U)+$P(^BCHRPROB(X,0),U,5) D
..S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U)+$P(^BCHRPROB(X,0),U,5)
.S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)+$P(^BCHRPROB(X,0),U,5)
.S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(^BCHRPROB(X,0),U,5)
.Q
S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,2)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,2)+$P(BCHR0,U,11)
S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)+$P(BCHR0,U,11)
S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(BCHR0,U,11)
S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,2)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,2)+$P(BCHR0,U,11)
S N=$P(BCHR0,U,12),P=$S('N:5,N=1:6,1:7)
S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,P)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,P)+1,$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,P)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,P)+1
I N>1 S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,10)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,10)+N,$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,10)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,10)+N
S $P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,9)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,9)+N,$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,9)=$P(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,9)+N
Q
BCHRC6 ; IHS/CMI/LAB - CHR Report 2 ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - tmp to xtmp
+3 ;
+4 IF '$GET(DUZ(2))
WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!
QUIT
+5 SET BCHJOB=$JOB
SET BCHBTH=$HOROLOG
+6 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 REG
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
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 PROG
+4 SET BCHREG=Y
SET BCHREGN=Y(0)
ZIS ;CALL TO XBDBQUE
+1 SET XBRP="^BCHRC6P"
SET XBRC="PROC^BCHRC6"
SET XBRX="XIT^BCHRC6"
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 FOR X=1:1:10
SET V="V"_X
KILL @V
+2 KILL V,BCHSD,BCHBD,BCHBDD,BCHED,BCHEDD,BCHODAT,BCHR,BCHR0,X,P,S,N,BCHQUIT,BCHBTH,BCHDT,BCHNAME,BCHPRG,BCHX
+3 KILL X,Y
+4 QUIT
+5 ;
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?20,"********** CHR REPORT NO. 6 **********"
+3 WRITE !!?33,"PROVIDER DATA",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!!
+4 ;W "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.",!!
+5 QUIT
+6 ;
+7 ;
PROC ;EP - PROCESS REFERRAL REPORT
+1 DO XTMP^BCHUTIL("BCHRC6","CHR CHR REPORT")
+2 SET (BCHBT,BCHBTH)=$HOROLOG
SET BCHJOB=$JOB
+3 SET ^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL")=0
+4 DO D
DO EOJ
+5 QUIT
+6 ;
EOJ ;
+1 SET BCHET=$HOROLOG
+2 QUIT
D ; Run by date of service
+1 SET X1=BCHBD
SET X2=-1
DO C^%DTC
SET BCHSD=X
+2 SET BCHODAT=BCHSD_".9999"
FOR
SET BCHODAT=$ORDER(^BCHR("B",BCHODAT))
IF BCHODAT=""!((BCHODAT\1)>BCHED)
QUIT
DO D1
+3 QUIT
+4 ;
D1 ;
+1 SET (BCHR,BCHRCNT)=0
FOR
SET BCHR=$ORDER(^BCHR("B",BCHODAT,BCHR))
IF BCHR'=+BCHR
QUIT
IF $DATA(^BCHR(BCHR,0))
IF $PIECE(^(0),U,2)]""
IF $PIECE(^(0),U,3)]""
SET BCHR0=^(0)
DO PROCESS
+2 QUIT
PROCESS ;
+1 SET BCHPAT=$PIECE(BCHR0,U,4)
+2 SET BCHNRPAT=$PIECE($GET(^BCHR(BCHR,11)),U,12)
+3 ;I 'BCHPAT,'BCHNRPAT Q ;no patient
+4 IF BCHREG="R"
IF BCHPAT=""
QUIT
+5 IF BCHREG="N"
IF BCHNRPAT=""
QUIT
+6 IF BCHPAT
IF BCHNRPAT
SET BCHNRPAT=""
+7 IF BCHPAT
IF '$DATA(^DPT(BCHPAT,0))
QUIT
+8 SET BCHPROG=$PIECE(BCHR0,U,2)
+9 IF BCHPRG
IF BCHPRG'=BCHPROG
QUIT
+10 SET C=$PIECE(BCHR0,U,3)
SET BCHNAME=$PIECE(^VA(200,C,0),U)
+11 IF '$DATA(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME))
SET ^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME)=0
+12 SET X=0
FOR
SET X=$ORDER(^BCHRPROB("AD",BCHR,X))
IF X'=+X
QUIT
Begin DoDot:1
+13 SET S=$PIECE(^BCHRPROB(X,0),U,4)
IF S=""
QUIT
+14 IF $PIECE(^BCHTSERV(S,0),U,3)="LT"
Begin DoDot:2
+15 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,3)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,3)+$PIECE(^BCHRPROB(X,0),U,5)
+16 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,3)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,3)+$PIECE(^BCHRPROB(X,0),U,5)
End DoDot:2
+17 IF '$TEST
SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U)+$PIECE(^BCHRPROB(X,0),U,5)
Begin DoDot:2
+18 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U)+$PIECE(^BCHRPROB(X,0),U,5)
End DoDot:2
+19 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)+$PIECE(^BCHRPROB(X,0),U,5)
+20 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)+$PIECE(^BCHRPROB(X,0),U,5)
+21 QUIT
End DoDot:1
+22 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,2)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,2)+$PIECE(BCHR0,U,11)
+23 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,4)+$PIECE(BCHR0,U,11)
+24 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,4)+$PIECE(BCHR0,U,11)
+25 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,2)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,2)+$PIECE(BCHR0,U,11)
+26 SET N=$PIECE(BCHR0,U,12)
SET P=$SELECT('N:5,N=1:6,1:7)
+27 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,P)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,P)+1
SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,P)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,P)+1
+28 IF N>1
SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,10)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,10)+N
SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,10)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,10)+N
+29 SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,9)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"PROVIDER",BCHNAME),U,9)+N
SET $PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,9)=$PIECE(^XTMP("BCHRC6",BCHJOB,BCHBT,"TOTAL"),U,9)+N
+30 QUIT
