- 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)
