BDGLOS1.m

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)