BCHRPT ; IHS/CMI/LAB - APC visit counts by selected vars ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
START ;
D HOME^%ZIS
K BCHQUIT
I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q
I $D(BCHRPTC) D
.S BCHRPTI=$P(^BCHRCNT(BCHRPTC,0),U,2),BCHRPTPA=$P(^(0),U,3),BCHRPTP=$P(^(0),U,4),BCHRPTST=$P(^BCHRCNT(BCHRPTC,0),U,7) S:BCHRPTST]"" BCHRPTST=$TR(BCHRPTST,"~","^")
.S BCHRPRCR=$P(^BCHRCNT(BCHRPTC,0),U,5) S:BCHRPRCR]"" BCHRPRCR=$TR(BCHRPRCR,"~","^")
I BCHRPTI]"" S BCHRPTI=$TR(BCHRPTI,"~","^") D @(BCHRPTI) ;inform user what report will do
G:$D(BCHQUIT) XIT
S BCHTCW=0,BCHPCNT=0
S BCHPTVS="V",BCHXREF=$S(BCHPTVS="V":"C",1:"PO")
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 S Y=BCHBD D DD^%DT S BCHBDD=Y S Y=BCHED D DD^%DT S BCHEDD=Y
D ADD ;add report to temporary fileman report file
I $D(BCHQUIT) W !!,"Unable to create report temporary file entry!!," G XIT
;
D SHOW
SCREEN ;
D SMENU^BCHRPT0
S DIR(0)="LO^1:"_BCHHIGH,DIR("A")="Select records based on which of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" D SHOW G PRINT
I $D(DIRUT) D DEL G START
;process all items in Y
D SELECT^BCHRPT1
D SHOW
W !! S DIR(0)="Y",DIR("A")=" Would you like to select additional RECORD criteria",DIR("B")="NO" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR
G:$D(DIRUT) START
I Y=0 K ^BCHTRPT(BCHRPT,12) G PRINT
G SCREEN
;
PRINT ;print portion of report
I $G(BCHRPTP)]"" S BCHRPTPA=$TR(BCHRPTPA,"~","^"),BCHRPTP=$TR(BCHRPTP,"~","^") D:$G(BCHRPTPA)]"" @(BCHRPTPA) G:$D(BCHQUIT) START G SORT
D PMENU^BCHRPT0
S DIR(0)="LO^1:"_BCHHIGH,DIR("A")="Select print item(s)" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" G SORT
I $D(DIRUT) D DEL G START
W !!?15,"Total Report width (including column margins - 2 spaces): ",BCHTCW
D PSELECT^BCHRPT1
D SHOWP
W !! S DIR(0)="Y",DIR("A")=" Would you like to select additional PRINT items",DIR("B")="NO" D ^DIR K DIR
S:$D(DUOUT) DIRUT=1
G:$D(DIRUT) START
I Y=0 G SORT
G PRINT
SORT ;
I '$D(^BCHTRPT(BCHRPT,12)),'$D(BCHRPTP) W !!,"NO PRINT FIELDS SELECTED!!",$C(7),$C(7) D DEL G START
I '$P(^BCHRCNT(BCHRPTC,0),U,8) G ZIS
S BCHSORT=""
D SHOWR
D RMENU^BCHRPT0
W ! S DIR(0)="NO^1:"_BCHHIGH_":0",DIR("A")="Sort records by which of the above" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !!,"No sort criteria selected ... will sort by record date." S BCHSORT=19,BCHSORV="Date of Service" H 3 G ZIS
I $D(DIRUT) D DEL G START
S BCHSORT=BCHSEL(+Y),BCHSORV=$P(^BCHSORT(BCHSORT,0),U)
PAGE ;
K BCHSPAG
S DIR(0)="Y",DIR("A")="Do you want a separate page for each "_BCHSORV,DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G SORT
S BCHSPAG=Y
ZIS ;call to XBDBQUE
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) Q
S BCHREG=Y,BCHREGN=Y(0)
D KILLVARS
S XBRP=BCHRPTP,XBRC=$S($G(BCHRPRCR)]"":BCHRPRCR,1:"^BCHRPT4"),XBRX="XIT^BCHRPT",XBNS="BCH"
D ^XBDBQUE
D XIT
Q
SHOW ;
W:$D(IOF) @IOF
I $D(BCHDONE) S BCHLHDR="REPORT SUMMARY" W ?((80-$L(BCHLHDR))/2),BCHLHDR,!
W !?6,"Record selection criteria:"
W !,"Date of Service range: ",BCHBDD," to ",BCHEDD,"."
Q:'$D(^BCHTRPT(BCHRPT,11))
S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI D
.I $Y>(IOSL-5) D PAUSE^BCHRPTU W @IOF
.W !?12,$P(^BCHSORT(BCHI,0),U),": "
.K BCHQ S Y=0,C=0 F S Y=$O(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S C=C+1 W:C'=1&(Y'="") " ; " Q:Y=""!($D(BCHQ)) S X=Y X:$D(^BCHSORT(BCHI,2)) ^(2) D
..W X
.K BCHQ
K C
Q
SHOWP ;
I '$D(BCHDONE) W:$D(IOF) @IOF
W !!?6,"PRINT Field(s) Selected:"
;Q:'$D(^BCHTRPT(BCHRPT,12))
S (BCHI,BCHTCW)=0 F S BCHI=$O(^BCHTRPT(BCHRPT,12,BCHI)) Q:BCHI'=+BCHI S BCHCRIT=$P(^BCHTRPT(BCHRPT,12,BCHI,0),U) D
.W !?12,$P(^BCHSORT(BCHCRIT,0),U)," - column width ",$P(^BCHTRPT(BCHRPT,12,BCHI,0),U,2) S BCHTCW=BCHTCW+$P(^(0),U,2)+2
.I $Y>(IOSL-5) D PAUSE^BCHRPTU W:$D(IOF) @IOF
W !!?12,"Total Report width (including column margins - 2 spaces): ",BCHTCW
Q
SHOWR ;
I '$D(BCHDONE) W:$D(IOF) @IOF
W !!?6,"Record SORTING Criteria"
Q:'$G(BCHTRPT)
W !!?12,"Records will be sorted by: ",$P(^BCHSORT(BCHTRPT,0),U),!
Q
DEL ;EP - delete entry in temp file
I $G(BCHRPT) S DIK="^BCHTRPT(",DA=BCHRPT D ^DIK K DIK,DA,DIC
Q
KILLVARS ;
K BCHDISP,BCHSEL
Q
XIT ;
D KILL^BCHRPTX
Q
ADD ;EP
S %H=$H D YX^%DTC S X=$P(^VA(200,DUZ,0),U)_"-"_Y,DIC(0)="L",DIC="^BCHTRPT(",DLAYGO=90002.42,DIADD=1 D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S BCHQUIT=1 Q
S BCHRPT=+Y
K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
;DELETE ALL 11 MULTIPLE HERE
K ^BCHTRPT(BCHRPT,11)
Q
BCHRPT ; IHS/CMI/LAB - APC visit counts by selected vars ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
START ;
+1 DO HOME^%ZIS
+2 KILL BCHQUIT
+3 IF '$GET(DUZ(2))
WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!
QUIT
+4 IF $DATA(BCHRPTC)
Begin DoDot:1
+5 SET BCHRPTI=$PIECE(^BCHRCNT(BCHRPTC,0),U,2)
SET BCHRPTPA=$PIECE(^(0),U,3)
SET BCHRPTP=$PIECE(^(0),U,4)
SET BCHRPTST=$PIECE(^BCHRCNT(BCHRPTC,0),U,7)
IF BCHRPTST]""
SET BCHRPTST=$TRANSLATE(BCHRPTST,"~","^")
+6 SET BCHRPRCR=$PIECE(^BCHRCNT(BCHRPTC,0),U,5)
IF BCHRPRCR]""
SET BCHRPRCR=$TRANSLATE(BCHRPRCR,"~","^")
End DoDot:1
+7 ;inform user what report will do
IF BCHRPTI]""
SET BCHRPTI=$TRANSLATE(BCHRPTI,"~","^")
DO @(BCHRPTI)
+8 IF $DATA(BCHQUIT)
GOTO XIT
+9 SET BCHTCW=0
SET BCHPCNT=0
+10 SET BCHPTVS="V"
SET BCHXREF=$SELECT(BCHPTVS="V":"C",1:"PO")
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
SET Y=BCHBD
DO DD^%DT
SET BCHBDD=Y
SET Y=BCHED
DO DD^%DT
SET BCHEDD=Y
+5 ;add report to temporary fileman report file
DO ADD
+6 IF $DATA(BCHQUIT)
WRITE !!,"Unable to create report temporary file entry!!,"
GOTO XIT
+7 ;
+8 DO SHOW
SCREEN ;
+1 DO SMENU^BCHRPT0
+2 SET DIR(0)="LO^1:"_BCHHIGH
SET DIR("A")="Select records based on which of the above"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF Y=""
DO SHOW
GOTO PRINT
+4 IF $DATA(DIRUT)
DO DEL
GOTO START
+5 ;process all items in Y
+6 DO SELECT^BCHRPT1
+7 DO SHOW
+8 WRITE !!
SET DIR(0)="Y"
SET DIR("A")=" Would you like to select additional RECORD criteria"
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DUOUT)
SET DIRUT=1
KILL DIR
+9 IF $DATA(DIRUT)
GOTO START
+10 IF Y=0
KILL ^BCHTRPT(BCHRPT,12)
GOTO PRINT
+11 GOTO SCREEN
+12 ;
PRINT ;print portion of report
+1 IF $GET(BCHRPTP)]""
SET BCHRPTPA=$TRANSLATE(BCHRPTPA,"~","^")
SET BCHRPTP=$TRANSLATE(BCHRPTP,"~","^")
IF $GET(BCHRPTPA)]""
DO @(BCHRPTPA)
IF $DATA(BCHQUIT)
GOTO START
GOTO SORT
+2 DO PMENU^BCHRPT0
+3 SET DIR(0)="LO^1:"_BCHHIGH
SET DIR("A")="Select print item(s)"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
GOTO SORT
+5 IF $DATA(DIRUT)
DO DEL
GOTO START
+6 WRITE !!?15,"Total Report width (including column margins - 2 spaces): ",BCHTCW
+7 DO PSELECT^BCHRPT1
+8 DO SHOWP
+9 WRITE !!
SET DIR(0)="Y"
SET DIR("A")=" Would you like to select additional PRINT items"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+10 IF $DATA(DUOUT)
SET DIRUT=1
+11 IF $DATA(DIRUT)
GOTO START
+12 IF Y=0
GOTO SORT
+13 GOTO PRINT
SORT ;
+1 IF '$DATA(^BCHTRPT(BCHRPT,12))
IF '$DATA(BCHRPTP)
WRITE !!,"NO PRINT FIELDS SELECTED!!",$CHAR(7),$CHAR(7)
DO DEL
GOTO START
+2 IF '$PIECE(^BCHRCNT(BCHRPTC,0),U,8)
GOTO ZIS
+3 SET BCHSORT=""
+4 DO SHOWR
+5 DO RMENU^BCHRPT0
+6 WRITE !
SET DIR(0)="NO^1:"_BCHHIGH_":0"
SET DIR("A")="Sort records by which of the above"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+7 IF Y=""
WRITE !!,"No sort criteria selected ... will sort by record date."
SET BCHSORT=19
SET BCHSORV="Date of Service"
HANG 3
GOTO ZIS
+8 IF $DATA(DIRUT)
DO DEL
GOTO START
+9 SET BCHSORT=BCHSEL(+Y)
SET BCHSORV=$PIECE(^BCHSORT(BCHSORT,0),U)
PAGE ;
+1 KILL BCHSPAG
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want a separate page for each "_BCHSORV
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
GOTO SORT
+4 SET BCHSPAG=Y
ZIS ;call to XBDBQUE
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)
QUIT
+4 SET BCHREG=Y
SET BCHREGN=Y(0)
+5 DO KILLVARS
+6 SET XBRP=BCHRPTP
SET XBRC=$SELECT($GET(BCHRPRCR)]"":BCHRPRCR,1:"^BCHRPT4")
SET XBRX="XIT^BCHRPT"
SET XBNS="BCH"
+7 DO ^XBDBQUE
+8 DO XIT
+9 QUIT
SHOW ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 IF $DATA(BCHDONE)
SET BCHLHDR="REPORT SUMMARY"
WRITE ?((80-$LENGTH(BCHLHDR))/2),BCHLHDR,!
+3 WRITE !?6,"Record selection criteria:"
+4 WRITE !,"Date of Service range: ",BCHBDD," to ",BCHEDD,"."
+5 IF '$DATA(^BCHTRPT(BCHRPT,11))
QUIT
+6 SET BCHI=0
FOR
SET BCHI=$ORDER(^BCHTRPT(BCHRPT,11,BCHI))
IF BCHI'=+BCHI
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-5)
DO PAUSE^BCHRPTU
WRITE @IOF
+8 WRITE !?12,$PIECE(^BCHSORT(BCHI,0),U),": "
+9 KILL BCHQ
SET Y=0
SET C=0
FOR
SET Y=$ORDER(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y))
SET C=C+1
IF C'=1&(Y'="")
WRITE " ; "
IF Y=""!($DATA(BCHQ))
QUIT
SET X=Y
IF $DATA(^BCHSORT(BCHI,2))
XECUTE ^(2)
Begin DoDot:2
+10 WRITE X
End DoDot:2
+11 KILL BCHQ
End DoDot:1
+12 KILL C
+13 QUIT
SHOWP ;
+1 IF '$DATA(BCHDONE)
IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!?6,"PRINT Field(s) Selected:"
+3 ;Q:'$D(^BCHTRPT(BCHRPT,12))
+4 SET (BCHI,BCHTCW)=0
FOR
SET BCHI=$ORDER(^BCHTRPT(BCHRPT,12,BCHI))
IF BCHI'=+BCHI
QUIT
SET BCHCRIT=$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U)
Begin DoDot:1
+5 WRITE !?12,$PIECE(^BCHSORT(BCHCRIT,0),U)," - column width ",$PIECE(^BCHTRPT(BCHRPT,12,BCHI,0),U,2)
SET BCHTCW=BCHTCW+$PIECE(^(0),U,2)+2
+6 IF $Y>(IOSL-5)
DO PAUSE^BCHRPTU
IF $DATA(IOF)
WRITE @IOF
End DoDot:1
+7 WRITE !!?12,"Total Report width (including column margins - 2 spaces): ",BCHTCW
+8 QUIT
SHOWR ;
+1 IF '$DATA(BCHDONE)
IF $DATA(IOF)
WRITE @IOF
+2 WRITE !!?6,"Record SORTING Criteria"
+3 IF '$GET(BCHTRPT)
QUIT
+4 WRITE !!?12,"Records will be sorted by: ",$PIECE(^BCHSORT(BCHTRPT,0),U),!
+5 QUIT
DEL ;EP - delete entry in temp file
+1 IF $GET(BCHRPT)
SET DIK="^BCHTRPT("
SET DA=BCHRPT
DO ^DIK
KILL DIK,DA,DIC
+2 QUIT
KILLVARS ;
+1 KILL BCHDISP,BCHSEL
+2 QUIT
XIT ;
+1 DO KILL^BCHRPTX
+2 QUIT
ADD ;EP
+1 SET %H=$HOROLOG
DO YX^%DTC
SET X=$PIECE(^VA(200,DUZ,0),U)_"-"_Y
SET DIC(0)="L"
SET DIC="^BCHTRPT("
SET DLAYGO=90002.42
SET DIADD=1
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET BCHQUIT=1
QUIT
+2 SET BCHRPT=+Y
+3 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
+4 ;DELETE ALL 11 MULTIPLE HERE
+5 KILL ^BCHTRPT(BCHRPT,11)
+6 QUIT
