BDGLOS1 ; IHS/ANMC/LJF - LOS BY WARD BY MONTH ; [ 09/30/2004 11:32 AM ]
;;5.3;PIMS;**1001,1019**;APR 26, 2002;Build 3
;
EN ; -- main entry point for BDG LOS BY WARD & MONTH
NEW VALMCNT
I $E(IOST,1,2)="P-" D INIT,PRINT Q ;if printing to paper
D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG LOS BY WARD & MONTH")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
NEW X S X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
S VALMHDR(2)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW DFN,CA,DATE,IEN,WARD,ENDDT,BEGIN,MONTH,END,LOS,LINE,NAME,BDGEDT
K ^TMP("BDGLOS1",$J),^TMP("BDGLOS1A",$J)
S VALMCNT=0
S BDGEDT=$$FMADD^XLFDT(BDGED,1)
;
; first find all inpatients during date range
S DFN=0 F S DFN=$O(^DGPM("APCA",DFN)) Q:'DFN D
. S CA=0 F S CA=$O(^DGPM("APCA",DFN,CA)) Q:'CA D
.. ;
.. Q:'$G(^DGPM(CA,0)) ;bad xref entry
.. I $$DSCH(CA)<BDGBD Q ;if patient discharged before begin date
.. I +^DGPM(CA,0)>BDGED Q ;if patient admitted after end date
.. ;
.. ; for each inpatient, find all wards & their los
.. S DATE=0
.. F S DATE=$O(^DGPM("APCA",DFN,CA,DATE)) Q:'DATE Q:(DATE>BDGED) D
... S IEN=0 F S IEN=$O(^DGPM("APCA",DFN,CA,DATE,IEN)) Q:'IEN D
.... ;
.... Q:'$G(^DGPM(IEN,0)) ;bad xref entry
.... Q:$P(^DGPM(IEN,0),U,2)=3 ;discharge movement
.... S WARD=$$GET1^DIQ(405,IEN,.06) ;find ward for this movement
.... Q:WARD="" ;ihs/cmi/maw 01/29/2016 PATCH 1019
.... S ENDDT=$$NEXTDT(DFN,CA,DATE) ;find date pat left ward
.... S NAME=$$GET1^DIQ(2,DFN,.01) ;patient name
.... ;
.... ;IHS/ITSC/WAR 9/30/04 PATCH #1001 resolve incorrect display of
.... ; a Pt's LOS. Was displaying each month instead of combining
.... S BDGADT=$E(DATE,1,5)
.... ;
.... ; loop thru months for date pair
.... S BEGIN=DATE F Q:BEGIN>ENDDT D
..... S MONTH=$E(BEGIN,1,5)
..... ;
..... ; if pat left ward in same month
..... I $E(BEGIN,1,5)=$E(ENDDT,1,5) D Q ;same month
...... S LOS=$$FMDIFF^XLFDT(ENDDT,BEGIN) ;difference
...... I DATE=ENDDT S LOS=1 ;if 1 day admit
...... I LOS S ^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA)=$G(^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA))+LOS
...... S BEGIN=9999999 ;end loop
..... ;
..... ; else find days for first month
..... ;IHS/ITSC/WAR 8/11/04 PATCH #1001 per /IHS/ANMC/DLG 05AUG2004
..... ; problem with leap-year required a change and in DAYS subrtn
..... ;S END=MONTH_$$DAYS(+$E(MONTH,4,5))
..... S END=MONTH_$$DAYS(MONTH) ; pass the year and month
..... S END=$$FMADD^XLFDT(END,1)
..... S LOS=$$FMDIFF^XLFDT(END,BEGIN)
..... ;IHS/ITSC/WAR 9/30/04 PATCH #1001 see above note, dated same
..... ;I LOS S ^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA)=$G(^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA))+LOS
..... I LOS S ^TMP("BDGLOS1A",$J,BDGADT,WARD,NAME,CA)=$G(^TMP("BDGLOS1A",$J,BDGADT,WARD,NAME,CA))+LOS
..... ;
..... ; then for all others until discharge or end of date range
..... S BEGIN=END ;beginning of next month
;
S MONTH=0
F S MONTH=$O(^TMP("BDGLOS1A",$J,MONTH)) Q:'MONTH D
. S WARD=0
. F S WARD=$O(^TMP("BDGLOS1A",$J,MONTH,WARD)) Q:WARD="" D
.. S NAME=0
.. F S NAME=$O(^TMP("BDGLOS1A",$J,MONTH,WARD,NAME)) Q:NAME="" D
... S CA=0
... F S CA=$O(^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA)) Q:'CA D
.... S LOS=^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA) ;length of stay
.... ;
.... S LINE=$$FMTE^XLFDT(MONTH_"00") ;month - external format
.... S LINE=$$PAD(LINE,12)_$E(WARD,1,6) ;then ward
.... S LINE=$$PAD(LINE,20)_$E(NAME,1,18) ;then patient
.... S DFN=$$GET1^DIQ(405,CA,.03,"I")
.... S LINE=$$PAD(LINE,40)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart #
.... S LINE=$$PAD(LINE,50)_$P($$GET1^DIQ(405,CA,.01),"@") ;admit date
.... S LINE=$$PAD(LINE,65)_$J(LOS,4) ;# of days
.... D SET(LINE,.VALMCNT)
;
I '$D(^TMP("BDGLOS1",$J)) D SET("NO DATA FOUND",.VALMCNT)
K ^TMP("BDGLOS1A",$J)
Q
;
DSCH(ADM) ; return discharge date for admission ADM
NEW X
S X=$P($G(^DGPM(ADM,0)),U,17) I X="" Q 9999999 ;still inpatient
Q $S($G(^DGPM(X,0)):+^(0),1:9999999)
;
NEXTDT(PAT,ADM,LAST) ; return date when patient left ward
NEW DATE
S DATE=$O(^DGPM("APCA",PAT,ADM,LAST))
I 'DATE S DATE=$$DSCH(ADM) ;if last mvmt, return discharge date
Q $S(DATE>BDGED:BDGEDT,1:DATE) ;only go as far as date range
;
;IHS/ITSC/WAR 8/11/04 PATCH #1001 per /IHS/ANMC/DLG 05AUG2004
DAYS(YRMONTH) ; return # of days in particular year/month
; /IHS/ANMC/DLG 05AUG2004 Fix the leap year bug
; Original line-label and following line are below:
;DAYS(M) ; return # of days in particular month
; I M=2,$E($$FMADD^XLFDT(M_"28",1),6,7)=29 Q 29 ;leap year
;
NEW M
S M=+$E(YRMONTH,4,5)
I M=2,$E($$FMADD^XLFDT(YRMONTH_"28",1),6,7)=29 Q 29 ;leap year
; /IHS/ANMC/DLG end of changes
Q $P($T(DAY),";;",M+1)
;
DAY ;;31;;28;;31;;30;;31;;30;;31;;31;;30;;31;;30;;31
;
SET(DATA,NUM) ; puts display data into array
S NUM=NUM+1
S ^TMP("BDGLOS1",$J,NUM,0)=DATA
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGLOS1",$J)
K BDGBD,BDGED
Q
;
EXPND ; -- expand code
Q
;
PRINT ; print to paper
NEW BDGN
U IO
D HDG S BDGN=0
F S BDGN=$O(^TMP("BDGLOS1",$J,BDGN)) Q:'BDGN D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGLOS1",$J,BDGN,0)
D ^%ZISC,EXIT
Q
;
HDG ; heading if printing to paper
W @IOF
NEW X S X="LENGTH OF STAY BY MONTH AND WARD" W !?80-$L(X)\2,X
D HDR S X=0 F S X=$O(VALMHDR(X)) Q:'X W !,VALMHDR(X)
W !,$$REPEAT^XLFSTR("=",80)
W !,"Month",?12,"Ward",?20,"Patient Name",?40,"Chart #"
W ?50,"Admit Date",?65,"Length of Stay",!,$$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)
BDGLOS1 ; IHS/ANMC/LJF - LOS BY WARD BY MONTH ; [ 09/30/2004 11:32 AM ]
+1 ;;5.3;PIMS;**1001,1019**;APR 26, 2002;Build 3
+2 ;
EN ; -- main entry point for BDG LOS BY WARD & MONTH
+1 NEW VALMCNT
+2 ;if printing to paper
IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+3 DO TERM^VALM0
DO CLEAR^VALM1
+4 DO EN^VALM("BDG LOS BY WARD & MONTH")
+5 DO CLEAR^VALM1
+6 QUIT
+7 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+2 NEW X
SET X=$$FMTE^XLFDT(BDGBD)_" to "_$$FMTE^XLFDT(BDGED)
+3 SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 NEW DFN,CA,DATE,IEN,WARD,ENDDT,BEGIN,MONTH,END,LOS,LINE,NAME,BDGEDT
+2 KILL ^TMP("BDGLOS1",$JOB),^TMP("BDGLOS1A",$JOB)
+3 SET VALMCNT=0
+4 SET BDGEDT=$$FMADD^XLFDT(BDGED,1)
+5 ;
+6 ; first find all inpatients during date range
+7 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("APCA",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+8 SET CA=0
FOR
SET CA=$ORDER(^DGPM("APCA",DFN,CA))
IF 'CA
QUIT
Begin DoDot:2
+9 ;
+10 ;bad xref entry
IF '$GET(^DGPM(CA,0))
QUIT
+11 ;if patient discharged before begin date
IF $$DSCH(CA)<BDGBD
QUIT
+12 ;if patient admitted after end date
IF +^DGPM(CA,0)>BDGED
QUIT
+13 ;
+14 ; for each inpatient, find all wards & their los
+15 SET DATE=0
+16 FOR
SET DATE=$ORDER(^DGPM("APCA",DFN,CA,DATE))
IF 'DATE
QUIT
IF (DATE>BDGED)
QUIT
Begin DoDot:3
+17 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("APCA",DFN,CA,DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:4
+18 ;
+19 ;bad xref entry
IF '$GET(^DGPM(IEN,0))
QUIT
+20 ;discharge movement
IF $PIECE(^DGPM(IEN,0),U,2)=3
QUIT
+21 ;find ward for this movement
SET WARD=$$GET1^DIQ(405,IEN,.06)
+22 ;ihs/cmi/maw 01/29/2016 PATCH 1019
IF WARD=""
QUIT
+23 ;find date pat left ward
SET ENDDT=$$NEXTDT(DFN,CA,DATE)
+24 ;patient name
SET NAME=$$GET1^DIQ(2,DFN,.01)
+25 ;
+26 ;IHS/ITSC/WAR 9/30/04 PATCH #1001 resolve incorrect display of
+27 ; a Pt's LOS. Was displaying each month instead of combining
+28 SET BDGADT=$EXTRACT(DATE,1,5)
+29 ;
+30 ; loop thru months for date pair
+31 SET BEGIN=DATE
FOR
IF BEGIN>ENDDT
QUIT
Begin DoDot:5
+32 SET MONTH=$EXTRACT(BEGIN,1,5)
+33 ;
+34 ; if pat left ward in same month
+35 ;same month
IF $EXTRACT(BEGIN,1,5)=$EXTRACT(ENDDT,1,5)
Begin DoDot:6
+36 ;difference
SET LOS=$$FMDIFF^XLFDT(ENDDT,BEGIN)
+37 ;if 1 day admit
IF DATE=ENDDT
SET LOS=1
+38 IF LOS
SET ^TMP("BDGLOS1A",$JOB,MONTH,WARD,NAME,CA)=$GET(^TMP("BDGLOS1A",$JOB,MONTH,WARD,NAME,CA))+LOS
+39 ;end loop
SET BEGIN=9999999
End DoDot:6
QUIT
+40 ;
+41 ; else find days for first month
+42 ;IHS/ITSC/WAR 8/11/04 PATCH #1001 per /IHS/ANMC/DLG 05AUG2004
+43 ; problem with leap-year required a change and in DAYS subrtn
+44 ;S END=MONTH_$$DAYS(+$E(MONTH,4,5))
+45 ; pass the year and month
SET END=MONTH_$$DAYS(MONTH)
+46 SET END=$$FMADD^XLFDT(END,1)
+47 SET LOS=$$FMDIFF^XLFDT(END,BEGIN)
+48 ;IHS/ITSC/WAR 9/30/04 PATCH #1001 see above note, dated same
+49 ;I LOS S ^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA)=$G(^TMP("BDGLOS1A",$J,MONTH,WARD,NAME,CA))+LOS
+50 IF LOS
SET ^TMP("BDGLOS1A",$JOB,BDGADT,WARD,NAME,CA)=$GET(^TMP("BDGLOS1A",$JOB,BDGADT,WARD,NAME,CA))+LOS
+51 ;
+52 ; then for all others until discharge or end of date range
+53 ;beginning of next month
SET BEGIN=END
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+54 ;
+55 SET MONTH=0
+56 FOR
SET MONTH=$ORDER(^TMP("BDGLOS1A",$JOB,MONTH))
IF 'MONTH
QUIT
Begin DoDot:1
+57 SET WARD=0
+58 FOR
SET WARD=$ORDER(^TMP("BDGLOS1A",$JOB,MONTH,WARD))
IF WARD=""
QUIT
Begin DoDot:2
+59 SET NAME=0
+60 FOR
SET NAME=$ORDER(^TMP("BDGLOS1A",$JOB,MONTH,WARD,NAME))
IF NAME=""
QUIT
Begin DoDot:3
+61 SET CA=0
+62 FOR
SET CA=$ORDER(^TMP("BDGLOS1A",$JOB,MONTH,WARD,NAME,CA))
IF 'CA
QUIT
Begin DoDot:4
+63 ;length of stay
SET LOS=^TMP("BDGLOS1A",$JOB,MONTH,WARD,NAME,CA)
+64 ;
+65 ;month - external format
SET LINE=$$FMTE^XLFDT(MONTH_"00")
+66 ;then ward
SET LINE=$$PAD(LINE,12)_$EXTRACT(WARD,1,6)
+67 ;then patient
SET LINE=$$PAD(LINE,20)_$EXTRACT(NAME,1,18)
+68 SET DFN=$$GET1^DIQ(405,CA,.03,"I")
+69 ;chart #
SET LINE=$$PAD(LINE,40)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+70 ;admit date
SET LINE=$$PAD(LINE,50)_$PIECE($$GET1^DIQ(405,CA,.01),"@")
+71 ;# of days
SET LINE=$$PAD(LINE,65)_$JUSTIFY(LOS,4)
+72 DO SET(LINE,.VALMCNT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+73 ;
+74 IF '$DATA(^TMP("BDGLOS1",$JOB))
DO SET("NO DATA FOUND",.VALMCNT)
+75 KILL ^TMP("BDGLOS1A",$JOB)
+76 QUIT
+77 ;
DSCH(ADM) ; return discharge date for admission ADM
+1 NEW X
+2 ;still inpatient
SET X=$PIECE($GET(^DGPM(ADM,0)),U,17)
IF X=""
QUIT 9999999
+3 QUIT $SELECT($GET(^DGPM(X,0)):+^(0),1:9999999)
+4 ;
NEXTDT(PAT,ADM,LAST) ; return date when patient left ward
+1 NEW DATE
+2 SET DATE=$ORDER(^DGPM("APCA",PAT,ADM,LAST))
+3 ;if last mvmt, return discharge date
IF 'DATE
SET DATE=$$DSCH(ADM)
+4 ;only go as far as date range
QUIT $SELECT(DATE>BDGED:BDGEDT,1:DATE)
+5 ;
+6 ;IHS/ITSC/WAR 8/11/04 PATCH #1001 per /IHS/ANMC/DLG 05AUG2004
DAYS(YRMONTH) ; return # of days in particular year/month
+1 ; /IHS/ANMC/DLG 05AUG2004 Fix the leap year bug
+2 ; Original line-label and following line are below:
+3 ;DAYS(M) ; return # of days in particular month
+4 ; I M=2,$E($$FMADD^XLFDT(M_"28",1),6,7)=29 Q 29 ;leap year
+5 ;
+6 NEW M
+7 SET M=+$EXTRACT(YRMONTH,4,5)
+8 ;leap year
IF M=2
IF $EXTRACT($$FMADD^XLFDT(YRMONTH_"28",1),6,7)=29
QUIT 29
+9 ; /IHS/ANMC/DLG end of changes
+10 QUIT $PIECE($TEXT(DAY),";;",M+1)
+11 ;
DAY ;;31;;28;;31;;30;;31;;30;;31;;31;;30;;31;;30;;31
+1 ;
SET(DATA,NUM) ; puts display data into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGLOS1",$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("BDGLOS1",$JOB)
+2 KILL BDGBD,BDGED
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PRINT ; print to paper
+1 NEW BDGN
+2 USE IO
+3 DO HDG
SET BDGN=0
+4 FOR
SET BDGN=$ORDER(^TMP("BDGLOS1",$JOB,BDGN))
IF 'BDGN
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGLOS1",$JOB,BDGN,0)
End DoDot:1
+7 DO ^%ZISC
DO EXIT
+8 QUIT
+9 ;
HDG ; heading if printing to paper
+1 WRITE @IOF
+2 NEW X
SET X="LENGTH OF STAY BY MONTH AND WARD"
WRITE !?80-$LENGTH(X)\2,X
+3 DO HDR
SET X=0
FOR
SET X=$ORDER(VALMHDR(X))
IF 'X
QUIT
WRITE !,VALMHDR(X)
+4 WRITE !,$$REPEAT^XLFSTR("=",80)
+5 WRITE !,"Month",?12,"Ward",?20,"Patient Name",?40,"Chart #"
+6 WRITE ?50,"Admit Date",?65,"Length of Stay",!,$$REPEAT^XLFSTR("-",80),!
+7 QUIT
+8 ;
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)
