BDGSD1 ; IHS/ANMC/LJF - APPTS FOR CURRENT INPTS ;
;;5.3;PIMS;;APR 26, 2002
;
ASK ;EP; ask user questions
; Called by ^BDGSD when choice 2 is selected
NEW VAUTD,VAUTNI,VAUTC,VAUTW,BDGBD,BDGED
D ASK2^SDDIV Q:Y<0 S VAUTNI=1 D WARD^VAUTOMA
S VAUTNI=2 D CLINIC^VAUTOMA
S BDGBD=$$READ^BDGF("DO^::EX","Select Beginning Date") Q:BDGBD<1
S BDGED=$$READ^BDGF("DOA^"_BDGBD_"::EX","Select Ending Date: ")
Q:BDGED<1
;
I $$BROWSE^BDGF="B" D EN Q
D ZIS^BDGF("PQ","EN^BDGSD1","APPTS FOR CURRENT INPTS","VAU*;BDG*")
Q
;
EN ; -- main entry point for BDG INPT APPTS
I $E(IOST,1,2)="P-" D INIT,PRINT Q ;if printing to paper
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG INPT APPTS")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(10)_"*** "_$$CONF^BDGF_" ***"
S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
S VALMHDR(2)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
S VALMCNT=0
K ^TMP("BDGSD1",$J),^TMP("BDGSD1A",$J)
;
; find all patients in selected wards with appts
NEW WARD,DFN,DATE,CLINIC,END
S WARD=0 F S WARD=$O(^DPT("CN",WARD)) Q:WARD="" D
. I ('VAUTW),'$D(VAUTW(WARD)) Q ;not in selected list
. S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN D
.. ;
.. ; see if patient has appts within date range
.. S DATE=BDGBD-.0001,END=BDGED+.24
.. F S DATE=$O(^DPT(DFN,"S",DATE)) Q:'DATE Q:(DATE>END) D
... ;
... S CLINIC=+$G(^DPT(DFN,"S",DATE,0)) Q:'CLINIC
... I 'VAUTC,'$D(VAUTC(CLINIC)) Q ;clinic not selected
... ;
... ; sort by ward then date/time
... S ^TMP("BDGSD1A",$J,WARD,DATE,DFN)=""
;
;
; put sorted list into display array
NEW WARD,DATE,DFN,LAST,LINE,NODE,X
S WARD=0 F S WARD=$O(^TMP("BDGSD1A",$J,WARD)) Q:WARD="" D
. ;
. ; display ward heading
. S X="*** "_WARD_" Ward ***" D SET($$SP(79-$L(X)\2)_X,.VALMCNT)
. ;
. S (DATE,LAST)=0
. F S DATE=$O(^TMP("BDGSD1A",$J,WARD,DATE)) Q:'DATE D
.. ;
.. ; display date when it changed
.. I $P(DATE,".")'=LAST D SET($$FMTE^XLFDT(DATE,"D"),.VALMCNT)
.. S LAST=DATE\1
.. ;
.. S DFN=0 F S DFN=$O(^TMP("BDGSD1A",$J,WARD,DATE,DFN)) Q:'DFN D
... ;
... ; main data line
... S NODE=$G(^DPT(DFN,"S",DATE,0)) ;appt data
... S LINE=$$PAD($$SP(3)_$$TIME^BDGF(DATE),13) ;appt time
... S LINE=LINE_$E($$GET1^DIQ(2,DFN,.01),1,20) ;patient name
... S LINE=$$PAD(LINE,35)_$J($$HRCN^BDGF2(DFN,DUZ(2)),7) ;chart #
... S LINE=$$PAD(LINE,48)_$$GET1^DIQ(44,+NODE,.01) ;clinic
... D SET(LINE,.VALMCNT)
... ;
... ; other info line
... S LINE=$$SP(14)_$$OI^BSDU2(DFN,+NODE,DATE) ;other info
... S LINE=$$PAD(LINE,52)_"Appt Made "_$$FMTE^XLFDT($P(NODE,U,19),2)
... D SET(LINE,.VALMCNT)
... ;
... ; ancillary tests, if any
... I ($P(NODE,U,3)]"")!($P(NODE,U,4)]"")!($P(NODE,U,5)]"") D
.... S LINE=$$SP(10)
.... S X=$P(NODE,U,3) I X]"" S LINE=LINE_"Lab@"_$$FMTE^XLFDT(X)_" "
.... S X=$P(NODE,U,4) I X]"" S LINE=LINE_"Xray@"_$$FMTE^XLFDT(X)_" "
.... S X=$P(NODE,U,5) I X]"" S LINE=LINE_"EKG@"_$$FMTE^XLFDT(X)
.... D SET(LINE,.VALMCNT)
... ;
... D SET("",.VALMCNT) ;blank line between patients
;
I '$D(^TMP("BDGSD1",$J)) D SET("No data found",.VALMCNT)
;
K ^TMP("BDGSD1A",$J)
Q
;
SET(DATA,NUM) ; put display line into array
S NUM=NUM+1
S ^TMP("BDGSD1",$J,NUM,0)=DATA
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGSD1",$J) K BDGBD,BDGED,VAUTD,VAUTC,VAUTW
Q
;
EXPND ; -- expand code
Q
;
PRINT ; print to paper
NEW LINE,BDGPG
U IO D INIT^BDGF,HDG
S LINE=0 F S LINE=$O(^TMP("BDGSD1",$J,LINE)) Q:'LINE D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGSD1",$J,LINE,0)
D ^%ZISC,PRTKL^BDGF,EXIT
Q
;
HDG ; heading when printing to paper
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?16,$$CONF^BDGF
W !,BDGTIME,?23,"Appointments for Current Inpatients",?71,"Page: ",BDGPG
NEW X S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
W !,BDGDATE,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !,"Appt",?13,"Patient Name",?35,"Chart #",?49,"Clinic"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BDGSD1 ; IHS/ANMC/LJF - APPTS FOR CURRENT INPTS ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
ASK ;EP; ask user questions
+1 ; Called by ^BDGSD when choice 2 is selected
+2 NEW VAUTD,VAUTNI,VAUTC,VAUTW,BDGBD,BDGED
+3 DO ASK2^SDDIV
IF Y<0
QUIT
SET VAUTNI=1
DO WARD^VAUTOMA
+4 SET VAUTNI=2
DO CLINIC^VAUTOMA
+5 SET BDGBD=$$READ^BDGF("DO^::EX","Select Beginning Date")
IF BDGBD<1
QUIT
+6 SET BDGED=$$READ^BDGF("DOA^"_BDGBD_"::EX","Select Ending Date: ")
+7 IF BDGED<1
QUIT
+8 ;
+9 IF $$BROWSE^BDGF="B"
DO EN
QUIT
+10 DO ZIS^BDGF("PQ","EN^BDGSD1","APPTS FOR CURRENT INPTS","VAU*;BDG*")
+11 QUIT
+12 ;
EN ; -- main entry point for BDG INPT APPTS
+1 ;if printing to paper
IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG INPT APPTS")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(10)_"*** "_$$CONF^BDGF_" ***"
+3 SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+4 SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 SET VALMCNT=0
+2 KILL ^TMP("BDGSD1",$JOB),^TMP("BDGSD1A",$JOB)
+3 ;
+4 ; find all patients in selected wards with appts
+5 NEW WARD,DFN,DATE,CLINIC,END
+6 SET WARD=0
FOR
SET WARD=$ORDER(^DPT("CN",WARD))
IF WARD=""
QUIT
Begin DoDot:1
+7 ;not in selected list
IF ('VAUTW)
IF '$DATA(VAUTW(WARD))
QUIT
+8 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+9 ;
+10 ; see if patient has appts within date range
+11 SET DATE=BDGBD-.0001
SET END=BDGED+.24
+12 FOR
SET DATE=$ORDER(^DPT(DFN,"S",DATE))
IF 'DATE
QUIT
IF (DATE>END)
QUIT
Begin DoDot:3
+13 ;
+14 SET CLINIC=+$GET(^DPT(DFN,"S",DATE,0))
IF 'CLINIC
QUIT
+15 ;clinic not selected
IF 'VAUTC
IF '$DATA(VAUTC(CLINIC))
QUIT
+16 ;
+17 ; sort by ward then date/time
+18 SET ^TMP("BDGSD1A",$JOB,WARD,DATE,DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 ;
+21 ; put sorted list into display array
+22 NEW WARD,DATE,DFN,LAST,LINE,NODE,X
+23 SET WARD=0
FOR
SET WARD=$ORDER(^TMP("BDGSD1A",$JOB,WARD))
IF WARD=""
QUIT
Begin DoDot:1
+24 ;
+25 ; display ward heading
+26 SET X="*** "_WARD_" Ward ***"
DO SET($$SP(79-$LENGTH(X)\2)_X,.VALMCNT)
+27 ;
+28 SET (DATE,LAST)=0
+29 FOR
SET DATE=$ORDER(^TMP("BDGSD1A",$JOB,WARD,DATE))
IF 'DATE
QUIT
Begin DoDot:2
+30 ;
+31 ; display date when it changed
+32 IF $PIECE(DATE,".")'=LAST
DO SET($$FMTE^XLFDT(DATE,"D"),.VALMCNT)
+33 SET LAST=DATE\1
+34 ;
+35 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGSD1A",$JOB,WARD,DATE,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+36 ;
+37 ; main data line
+38 ;appt data
SET NODE=$GET(^DPT(DFN,"S",DATE,0))
+39 ;appt time
SET LINE=$$PAD($$SP(3)_$$TIME^BDGF(DATE),13)
+40 ;patient name
SET LINE=LINE_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+41 ;chart #
SET LINE=$$PAD(LINE,35)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),7)
+42 ;clinic
SET LINE=$$PAD(LINE,48)_$$GET1^DIQ(44,+NODE,.01)
+43 DO SET(LINE,.VALMCNT)
+44 ;
+45 ; other info line
+46 ;other info
SET LINE=$$SP(14)_$$OI^BSDU2(DFN,+NODE,DATE)
+47 SET LINE=$$PAD(LINE,52)_"Appt Made "_$$FMTE^XLFDT($PIECE(NODE,U,19),2)
+48 DO SET(LINE,.VALMCNT)
+49 ;
+50 ; ancillary tests, if any
+51 IF ($PIECE(NODE,U,3)]"")!($PIECE(NODE,U,4)]"")!($PIECE(NODE,U,5)]"")
Begin DoDot:4
+52 SET LINE=$$SP(10)
+53 SET X=$PIECE(NODE,U,3)
IF X]""
SET LINE=LINE_"Lab@"_$$FMTE^XLFDT(X)_" "
+54 SET X=$PIECE(NODE,U,4)
IF X]""
SET LINE=LINE_"Xray@"_$$FMTE^XLFDT(X)_" "
+55 SET X=$PIECE(NODE,U,5)
IF X]""
SET LINE=LINE_"EKG@"_$$FMTE^XLFDT(X)
+56 DO SET(LINE,.VALMCNT)
End DoDot:4
+57 ;
+58 ;blank line between patients
DO SET("",.VALMCNT)
End DoDot:3
End DoDot:2
End DoDot:1
+59 ;
+60 IF '$DATA(^TMP("BDGSD1",$JOB))
DO SET("No data found",.VALMCNT)
+61 ;
+62 KILL ^TMP("BDGSD1A",$JOB)
+63 QUIT
+64 ;
SET(DATA,NUM) ; put display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGSD1",$JOB,NUM,0)=DATA
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGSD1",$JOB)
KILL BDGBD,BDGED,VAUTD,VAUTC,VAUTW
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PRINT ; print to paper
+1 NEW LINE,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("BDGSD1",$JOB,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
DO HDG
+5 WRITE !,^TMP("BDGSD1",$JOB,LINE,0)
End DoDot:1
+6 DO ^%ZISC
DO PRTKL^BDGF
DO EXIT
+7 QUIT
+8 ;
HDG ; heading when printing to paper
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?16,$$CONF^BDGF
+3 WRITE !,BDGTIME,?23,"Appointments for Current Inpatients",?71,"Page: ",BDGPG
+4 NEW X
SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+5 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X
+6 WRITE !,$$REPEAT^XLFSTR("-",80)
+7 WRITE !,"Appt",?13,"Patient Name",?35,"Chart #",?49,"Clinic"
+8 WRITE !,$$REPEAT^XLFSTR("=",80)
+9 QUIT
+10 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
