BDGILD62 ; IHS/ANMC/LJF - TRANSFERS BETWEEN FACILITIES(PRINT) ;
;;5.3;PIMS;;APR 26, 2002
;
I BDGTYP>1 D STAT
I BDGTYP'=2 D LISTS
Q
;
STAT ; gather stats by facility
NEW FAC,SRV,LINE,BDGTI,BDGTO
S (BDGTI,BDGTO)=0 ;zero out totals
S FAC=0 F S FAC=$O(DGCT(FAC)) Q:FAC="" D
. S LINE=$E(FAC,1,24) ;print facility
. S SRV=0 F S SRV=$O(DGCT(FAC,SRV)) Q:SRV="" D
.. S LINE=$$PAD(LINE,26)_SRV ; service
.. ; print transfer counts and increment totals
.. S LINE=$$PAD(LINE,55)_$J($P(DGCT(FAC,SRV),U),3)
.. S BDGTI=BDGTI+$P(DGCT(FAC,SRV),U)
.. S LINE=$$PAD(LINE,70)_$J($P(DGCT(FAC,SRV),U,2),3)
.. S BDGTO=BDGTO+$P(DGCT(FAC,SRV),U,2)
.. D SET(LINE,.VALMCNT) S LINE=""
;
; gather transfer totals
D SET($$REPEAT^XLFSTR("-",80),.VALMCNT)
S LINE=$$PAD($$PAD($$SP(30)_"TOTALS:",55)_$J(BDGTI,3),70)_$J(BDGTO,3)
D SET(LINE,.VALMCNT),SET("",.VALMCNT)
Q
;
LISTS ; gather patient lists
NEW DATE,SRV,FAC,IEN,DFN
;
; admissions by date, service, then facility
D SET($$SP(30)_"ADMISSIONS",.VALMCNT)
S DATE=0 F S DATE=$O(^TMP("BDGILD6A",$J,DATE)) Q:DATE="" D
. S SRV=0 F S SRV=$O(^TMP("BDGILD6A",$J,DATE,SRV)) Q:SRV="" D
.. S FAC=0 F S FAC=$O(^TMP("BDGILD6A",$J,DATE,SRV,FAC)) Q:FAC="" D
... S IEN=0
... F S IEN=$O(^TMP("BDGILD6A",$J,DATE,SRV,FAC,IEN)) Q:'IEN D
.... S DFN=^TMP("BDGILD6A",$J,DATE,SRV,FAC,IEN)
.... D LINE
;
; discharges by date, service, then facility
D SET("",.VALMCNT),SET($$SP(30)_"DISCHARGES",.VALMCNT)
S DATE=0 F S DATE=$O(^TMP("BDGILD6D",$J,DATE)) Q:DATE="" D
. S SRV=0 F S SRV=$O(^TMP("BDGILD6D",$J,DATE,SRV)) Q:SRV="" D
.. S FAC=0 F S FAC=$O(^TMP("BDGILD6D",$J,DATE,SRV,FAC)) Q:FAC="" D
... S IEN=0
... F S IEN=$O(^TMP("BDGILD6D",$J,DATE,SRV,FAC,IEN)) Q:'IEN D
.... S DFN=^TMP("BDGILD6D",$J,DATE,SRV,FAC,IEN)
.... D LINE
;
K ^TMP("BDGILD6A",$J),^TMP("BDGILD6D",$J)
Q
;
LINE ; build patient data line
S LINE=$$PAD($$NUMDATE^BDGF(DATE),17)_$E($$GET1^DIQ(2,DFN,.01),1,20)
S LINE=$$PAD(LINE,40)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)
S LINE=$$PAD($$PAD(LINE,52)_SRV,60)_$E(FAC,1,18)
D SET(LINE,.VALMCNT)
Q
;
SET(DATA,NUM) ; put display line into array
S NUM=NUM+1
S ^TMP("BDGILD6",$J,NUM,0)=DATA
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)
BDGILD62 ; IHS/ANMC/LJF - TRANSFERS BETWEEN FACILITIES(PRINT) ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 IF BDGTYP>1
DO STAT
+4 IF BDGTYP'=2
DO LISTS
+5 QUIT
+6 ;
STAT ; gather stats by facility
+1 NEW FAC,SRV,LINE,BDGTI,BDGTO
+2 ;zero out totals
SET (BDGTI,BDGTO)=0
+3 SET FAC=0
FOR
SET FAC=$ORDER(DGCT(FAC))
IF FAC=""
QUIT
Begin DoDot:1
+4 ;print facility
SET LINE=$EXTRACT(FAC,1,24)
+5 SET SRV=0
FOR
SET SRV=$ORDER(DGCT(FAC,SRV))
IF SRV=""
QUIT
Begin DoDot:2
+6 ; service
SET LINE=$$PAD(LINE,26)_SRV
+7 ; print transfer counts and increment totals
+8 SET LINE=$$PAD(LINE,55)_$JUSTIFY($PIECE(DGCT(FAC,SRV),U),3)
+9 SET BDGTI=BDGTI+$PIECE(DGCT(FAC,SRV),U)
+10 SET LINE=$$PAD(LINE,70)_$JUSTIFY($PIECE(DGCT(FAC,SRV),U,2),3)
+11 SET BDGTO=BDGTO+$PIECE(DGCT(FAC,SRV),U,2)
+12 DO SET(LINE,.VALMCNT)
SET LINE=""
End DoDot:2
End DoDot:1
+13 ;
+14 ; gather transfer totals
+15 DO SET($$REPEAT^XLFSTR("-",80),.VALMCNT)
+16 SET LINE=$$PAD($$PAD($$SP(30)_"TOTALS:",55)_$JUSTIFY(BDGTI,3),70)_$JUSTIFY(BDGTO,3)
+17 DO SET(LINE,.VALMCNT)
DO SET("",.VALMCNT)
+18 QUIT
+19 ;
LISTS ; gather patient lists
+1 NEW DATE,SRV,FAC,IEN,DFN
+2 ;
+3 ; admissions by date, service, then facility
+4 DO SET($$SP(30)_"ADMISSIONS",.VALMCNT)
+5 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGILD6A",$JOB,DATE))
IF DATE=""
QUIT
Begin DoDot:1
+6 SET SRV=0
FOR
SET SRV=$ORDER(^TMP("BDGILD6A",$JOB,DATE,SRV))
IF SRV=""
QUIT
Begin DoDot:2
+7 SET FAC=0
FOR
SET FAC=$ORDER(^TMP("BDGILD6A",$JOB,DATE,SRV,FAC))
IF FAC=""
QUIT
Begin DoDot:3
+8 SET IEN=0
+9 FOR
SET IEN=$ORDER(^TMP("BDGILD6A",$JOB,DATE,SRV,FAC,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+10 SET DFN=^TMP("BDGILD6A",$JOB,DATE,SRV,FAC,IEN)
+11 DO LINE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;
+13 ; discharges by date, service, then facility
+14 DO SET("",.VALMCNT)
DO SET($$SP(30)_"DISCHARGES",.VALMCNT)
+15 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGILD6D",$JOB,DATE))
IF DATE=""
QUIT
Begin DoDot:1
+16 SET SRV=0
FOR
SET SRV=$ORDER(^TMP("BDGILD6D",$JOB,DATE,SRV))
IF SRV=""
QUIT
Begin DoDot:2
+17 SET FAC=0
FOR
SET FAC=$ORDER(^TMP("BDGILD6D",$JOB,DATE,SRV,FAC))
IF FAC=""
QUIT
Begin DoDot:3
+18 SET IEN=0
+19 FOR
SET IEN=$ORDER(^TMP("BDGILD6D",$JOB,DATE,SRV,FAC,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+20 SET DFN=^TMP("BDGILD6D",$JOB,DATE,SRV,FAC,IEN)
+21 DO LINE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 KILL ^TMP("BDGILD6A",$JOB),^TMP("BDGILD6D",$JOB)
+24 QUIT
+25 ;
LINE ; build patient data line
+1 SET LINE=$$PAD($$NUMDATE^BDGF(DATE),17)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+2 SET LINE=$$PAD(LINE,40)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+3 SET LINE=$$PAD($$PAD(LINE,52)_SRV,60)_$EXTRACT(FAC,1,18)
+4 DO SET(LINE,.VALMCNT)
+5 QUIT
+6 ;
SET(DATA,NUM) ; put display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGILD6",$JOB,NUM,0)=DATA
+3 QUIT
+4 ;
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)
