- BCHRP4 ; IHS/CMI/LAB - All visit report driver 26 Apr 2007 10:51 AM ;
- ;;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!!",!! K BCHSITE 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" 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" 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 ;IHS/CMI/LAB - added program screen
- 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="PRINT^BCHRP4",XBRC="PROC^BCHRP4",XBRX="XIT^BCHRP4",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 ;
- D EN^XBVK("BCH")
- K ^TMP($J)
- Q
- ;
- INFORM ;
- W:$D(IOF) @IOF
- W !,"****** REPORT OF # OF CHR PCCs/PATIENTS BY TRIBE ******",!
- W !,"This report will tally records and patients seen by Tribe",!
- Q
- ;
- ;
- PROC ;EP - called from xbdbque
- VD ; Run by visit date
- S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X
- K BCHTOT K ^TMP($J)
- S (BCHTOTR,BCHTOTP)=0
- S BCHODAT=BCHSD_".9999" F S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED) D V1
- Q
- ;
- V1 ;
- S BCHR="" 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=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) D PROC1
- Q
- PROC1 ;
- 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 ;not correct program
- I BCHPAT S T=$$VAL^XBDIQ1(9000001,BCHPAT,1108)
- I BCHNRPAT S T=$$VAL^XBDIQ1(90002.11,BCHNRPAT,.05)
- I T="" S T="UNKNOWN TRIBE"
- S $P(BCHTOT(T),U,1)=$P($G(BCHTOT(T)),U,1)+1,BCHTOTR=BCHTOTR+1
- I BCHPAT D
- .I $D(^TMP($J,"DFN",DFN)) Q ;already counted this patient
- .S ^TMP($J,"DFN",DFN)="" S $P(BCHTOT(T),U,2)=$P($G(BCHTOT(T)),U,2)+1,BCHTOTP=BCHTOTP+1
- I BCHNRPAT D
- .Q:$D(^TMP($J,"NRDFN",BCHNRPAT))
- .S ^TMP($J,"NRDFN",BCHNRPAT)="" S $P(BCHTOT(T),U,2)=$P($G(BCHTOT(T)),U,2)+1,BCHTOTP=BCHTOTP+1
- Q
- PRINT ;EP
- S BCHPG=0 S BCHQUIT=0
- I '$D(BCHTOT) D HEAD W !!,"NO DATA TO REPORT",!! Q
- D HEAD
- S BCHT="" F S BCHT=$O(BCHTOT(BCHT)) Q:BCHT=""!(BCHQUIT) D
- .I $Y>(IOSL-4) D HEAD Q:BCHQUIT
- .W !?3,BCHT,?50,$$C($P(BCHTOT(BCHT),U,1),0,8),?65,$$C($P(BCHTOT(BCHT),U,2),0,8)
- .Q
- I $Y>(IOSL-3) D HEAD
- I BCHQUIT G DONE
- W !!?3,"ALL TRIBES/TOTAL",?50,$$C(BCHTOTR,0,8),?65,$$C(BCHTOTP,0,8)
- DONE ;
- K BCHET
- D DONE^BCHUTIL1
- Q
- C(X,X2,X3) ;
- D COMMA^%DTC
- Q $$STRIP^XLFSTR(X," ")
- HEAD ;
- I 'BCHPG G HEAD1
- I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT=1 Q
- HEAD1 ; if terminal
- W:$D(IOF) @IOF
- HEAD2 ; if printer
- S BCHPG=BCHPG+1
- W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
- W !,$P(^VA(200,DUZ,0),U,2),?33,$$FMTE^XLFDT(DT),?70,"Page ",BCHPG,!
- W $$CTR^BCHRLU($$LOC^BCHRLU),!
- S X="TALLY OF CHR PCCs AND PATIENTS BY TRIBE" W $$CTR^BCHRLU(X,80),!
- S BCHPROGN=$S(BCHPRG:$P(^BCHTPROG(BCHPRG,0),U)_" ("_$P(^(0),U,5)_")",1:"ALL"),X=$L(BCHPROGN)+10
- W ?((80-X)/2),"PROGRAM: ",BCHPROGN,!
- S X=$L("PATIENTS: "_BCHREGN)
- W ?((80-X)/2),"PATIENTS: ",BCHREGN,!
- W ?17,"REPORT DATES: ",$$FMTE^XLFDT(BCHBD)," TO ",$$FMTE^XLFDT(BCHED),!
- W !?50,"# CHR PCCs",?65,"# PATIENTS",!
- W !,$TR($J(" ",80)," ","-")
- Q
- BCHRP4 ; IHS/CMI/LAB - All visit report driver 26 Apr 2007 10:51 AM ;
- +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!!",!!
- KILL BCHSITE
- 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"
- 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"
- 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 ;IHS/CMI/LAB - added program screen
- +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="PRINT^BCHRP4"
- SET XBRC="PROC^BCHRP4"
- SET XBRX="XIT^BCHRP4"
- 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 DO EN^XBVK("BCH")
- +2 KILL ^TMP($JOB)
- +3 QUIT
- +4 ;
- INFORM ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- +2 WRITE !,"****** REPORT OF # OF CHR PCCs/PATIENTS BY TRIBE ******",!
- +3 WRITE !,"This report will tally records and patients seen by Tribe",!
- +4 QUIT
- +5 ;
- +6 ;
- PROC ;EP - called from xbdbque
- VD ; Run by visit date
- +1 SET X1=BCHBD
- SET X2=-1
- DO C^%DTC
- SET BCHSD=X
- +2 KILL BCHTOT
- KILL ^TMP($JOB)
- +3 SET (BCHTOTR,BCHTOTP)=0
- +4 SET BCHODAT=BCHSD_".9999"
- FOR
- SET BCHODAT=$ORDER(^BCHR("B",BCHODAT))
- IF BCHODAT=""!((BCHODAT\1)>BCHED)
- QUIT
- DO V1
- +5 QUIT
- +6 ;
- V1 ;
- +1 SET BCHR=""
- 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=^BCHR(BCHR,0)
- SET DFN=$PIECE(BCHR0,U,4)
- DO PROC1
- +2 QUIT
- PROC1 ;
- +1 SET BCHPAT=$PIECE(BCHR0,U,4)
- +2 SET BCHNRPAT=$PIECE($GET(^BCHR(BCHR,11)),U,12)
- +3 ;no patient
- IF 'BCHPAT
- IF 'BCHNRPAT
- QUIT
- +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 ;not correct program
- IF BCHPRG
- IF BCHPRG'=BCHPROG
- QUIT
- +10 IF BCHPAT
- SET T=$$VAL^XBDIQ1(9000001,BCHPAT,1108)
- +11 IF BCHNRPAT
- SET T=$$VAL^XBDIQ1(90002.11,BCHNRPAT,.05)
- +12 IF T=""
- SET T="UNKNOWN TRIBE"
- +13 SET $PIECE(BCHTOT(T),U,1)=$PIECE($GET(BCHTOT(T)),U,1)+1
- SET BCHTOTR=BCHTOTR+1
- +14 IF BCHPAT
- Begin DoDot:1
- +15 ;already counted this patient
- IF $DATA(^TMP($JOB,"DFN",DFN))
- QUIT
- +16 SET ^TMP($JOB,"DFN",DFN)=""
- SET $PIECE(BCHTOT(T),U,2)=$PIECE($GET(BCHTOT(T)),U,2)+1
- SET BCHTOTP=BCHTOTP+1
- End DoDot:1
- +17 IF BCHNRPAT
- Begin DoDot:1
- +18 IF $DATA(^TMP($JOB,"NRDFN",BCHNRPAT))
- QUIT
- +19 SET ^TMP($JOB,"NRDFN",BCHNRPAT)=""
- SET $PIECE(BCHTOT(T),U,2)=$PIECE($GET(BCHTOT(T)),U,2)+1
- SET BCHTOTP=BCHTOTP+1
- End DoDot:1
- +20 QUIT
- PRINT ;EP
- +1 SET BCHPG=0
- SET BCHQUIT=0
- +2 IF '$DATA(BCHTOT)
- DO HEAD
- WRITE !!,"NO DATA TO REPORT",!!
- QUIT
- +3 DO HEAD
- +4 SET BCHT=""
- FOR
- SET BCHT=$ORDER(BCHTOT(BCHT))
- IF BCHT=""!(BCHQUIT)
- QUIT
- Begin DoDot:1
- +5 IF $Y>(IOSL-4)
- DO HEAD
- IF BCHQUIT
- QUIT
- +6 WRITE !?3,BCHT,?50,$$C($PIECE(BCHTOT(BCHT),U,1),0,8),?65,$$C($PIECE(BCHTOT(BCHT),U,2),0,8)
- +7 QUIT
- End DoDot:1
- +8 IF $Y>(IOSL-3)
- DO HEAD
- +9 IF BCHQUIT
- GOTO DONE
- +10 WRITE !!?3,"ALL TRIBES/TOTAL",?50,$$C(BCHTOTR,0,8),?65,$$C(BCHTOTP,0,8)
- DONE ;
- +1 KILL BCHET
- +2 DO DONE^BCHUTIL1
- +3 QUIT
- C(X,X2,X3) ;
- +1 DO COMMA^%DTC
- +2 QUIT $$STRIP^XLFSTR(X," ")
- HEAD ;
- +1 IF 'BCHPG
- GOTO HEAD1
- +2 IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- WRITE !
- SET DIR(0)="EO"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="^")!($DATA(DTOUT))
- SET BCHQUIT=1
- QUIT
- HEAD1 ; if terminal
- +1 IF $DATA(IOF)
- WRITE @IOF
- HEAD2 ; if printer
- +1 SET BCHPG=BCHPG+1
- +2 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
- +3 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?33,$$FMTE^XLFDT(DT),?70,"Page ",BCHPG,!
- +4 WRITE $$CTR^BCHRLU($$LOC^BCHRLU),!
- +5 SET X="TALLY OF CHR PCCs AND PATIENTS BY TRIBE"
- WRITE $$CTR^BCHRLU(X,80),!
- +6 SET BCHPROGN=$SELECT(BCHPRG:$PIECE(^BCHTPROG(BCHPRG,0),U)_" ("_$PIECE(^(0),U,5)_")",1:"ALL")
- SET X=$LENGTH(BCHPROGN)+10
- +7 WRITE ?((80-X)/2),"PROGRAM: ",BCHPROGN,!
- +8 SET X=$LENGTH("PATIENTS: "_BCHREGN)
- +9 WRITE ?((80-X)/2),"PATIENTS: ",BCHREGN,!
- +10 WRITE ?17,"REPORT DATES: ",$$FMTE^XLFDT(BCHBD)," TO ",$$FMTE^XLFDT(BCHED),!
- +11 WRITE !?50,"# CHR PCCs",?65,"# PATIENTS",!
- +12 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
- +13 QUIT
