BDGSTAT1.m

BDGSTAT1 ; IHS/ANMC/LJF - AVERAGE DAILY PATIENT LOAD ; 

 ;;5.3;PIMS;;APR 26, 2002

 ;

 ;

SELECT ; -- have user select report by ward or by service

 NEW BDGFRM,BDGBD,BDGED,BDGIA

 S BDGFRM=$$READ^BDGF("SO^1:By Ward;2:By Service","Select Format")

 Q:BDGFRM<1

 S BDGIA=$$READ^BDGF("Y","Include INACTIVE "_$S(BDGFRM=1:"Wards",1:"Services"),"NO")

 ;

 S BDGBD=$$READ^BDGF("DO^::EX","Select Beginning Date") Q:BDGBD<1

 S BDGED=$$READ^BDGF("DO^::EX","Select Ending Date") Q:BDGED<1

 ;

 ;

 D ZIS^BDGF("PQ","EN^BDGSTAT1","ADPL REPORT","BDGFRM;BDGBD;BDGED;BDGIA")

 Q

 ;

 ;

EN ;EP; entry point from queuing

 I $E(IOST,1,2)="P-" D INIT,PRINT Q

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BDG STAT ADPL"_BDGFRM)

 D CLEAR^VALM1

 Q

 ;

HDR ; -- header code

 NEW X

 S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)

 S VALMHDR(1)=$$SP(75-$L(X)\2)_X

 Q

 ;

INIT ; -- init variables and list array

 NEW BDGDAYS

 K ^TMP("BDGSTAT1",$J)

 S VALMCNT=0

 S BDGDAYS=$$FMDIFF^XLFDT(BDGED,BDGBD)+1   ;# of days in date range

 ;

 D @BDGFRM         ;gather ward or service stats for date range

 ;

 I '$D(^TMP("BDGSTAT1",$J)) D SET("No data found",.VALMCNT)

 ;

 Q

 ;

1 ; step thru ADT Census-Ward file for date range

 NEW WARD,WRDNM,DATE,BDGA,X,LINE,TOTAL

 S WARD=0

 F  S WARD=$O(^BDGCWD(WARD)) Q:'WARD  D

 . I BDGIA=0,'$D(^BDGWD(WARD)) Q          ;old ward, no longer used

 . I BDGIA=0,$$GET1^DIQ(9009016.5,WARD,.03)="INACTIVE" Q

 . S WRDNM=$$GET1^DIQ(42,WARD,.01)        ;ward name

 . ;

 . S DATE=BDGBD-.001

 . F  S DATE=$O(^BDGCWD(WARD,1,DATE)) Q:DATE>BDGED  Q:'DATE  D

 .. ; count patients remaining and one day patients

 .. S X=$P($G(^BDGCWD(WARD,1,DATE,0)),U,2)+$P($G(^(0)),U,8)

 .. ; increment array for total inpatient days

 .. S BDGA(WRDNM)=$G(BDGA(WRDNM))+X

 ;

 ; put sorted data into display array

 S WARD=0 F  S WARD=$O(BDGA(WARD)) Q:WARD=""  D

 . S LINE=$$PAD(WARD,40)_$J(BDGA(WARD),5)

 . S LINE=$$PAD(LINE,65)_$J(BDGA(WARD)/BDGDAYS,5,2)

 . D SET(LINE,.VALMCNT)

 . ;

 . ; increment totals

 . S TOTAL=$G(TOTAL)+BDGA(WARD)

 ;

 ; put totals line into display array

 I $G(TOTAL) D

 . S LINE=$$PAD($$PAD("TOTALS",40)_$J(TOTAL,5),65)_$J(TOTAL/BDGDAYS,5,2)

 . D SET($$REPEAT^XLFSTR("=",80),.VALMCNT),SET(LINE,.VALMCNT)

 Q

 ;

2 ; step thru ADT Census-Treating Specialty file by date

 NEW SRV,DATE,SRVNM,BDGA,X,LINE,TOTAL,SUBTOT

 S SRV=0

 F  S SRV=$O(^BDGCTX(SRV)) Q:'SRV  D

 . ;

 . ; quit if not including inactive services; check begin & end dates

 . I BDGIA=0,('$$ACTSRV^BDGPAR(SRV,BDGBD)),('$$ACTSRV^BDGPAR(SRV,BDGED)) Q

 . S SRVNM=$$GET1^DIQ(45.7,SRV,.01)           ;service name

 . ;

 . S DATE=BDGBD-.001

 . F  S DATE=$O(^BDGCTX(SRV,1,DATE)) Q:DATE>BDGED  Q:'DATE  D

 .. ;

 .. ; count patients remaining and one day patients

 .. S X=$G(^BDGCTX(SRV,1,DATE,0))

 .. ;

 .. ; increment by adult vs. peds for total inpt days

 .. S BDGA(SRVNM,"A")=$G(BDGA(SRVNM,"A"))+$P(X,U,2)+$P(X,U,8)

 .. S BDGA(SRVNM,"P")=$G(BDGA(SRVNM,"P"))+$P(X,U,12)+$P(X,U,18)

 ;

 ; put sorted data into display array

 S SRV=0 F  S SRV=$O(BDGA(SRV)) Q:SRV=""  D

 . S LINE=$$PAD(SRV,35)_$J(+$G(BDGA(SRV,"A")),5)     ;adult inpt days

 . S LINE=$$PAD(LINE,45)_$J(+$G(BDGA(SRV,"P")),5)    ;peds inpt days

 . S SUBTOT=$G(BDGA(SRV,"A"))+$G(BDGA(SRV,"P"))      ;total inpt days

 . S LINE=$$PAD($$PAD(LINE,55)_$J(SUBTOT,5),70)_$J(SUBTOT/BDGDAYS,5,2)

 . D SET(LINE,.VALMCNT)

 . ;

 . ; increment totals

 . S TOTAL("A")=$G(TOTAL("A"))+$G(BDGA(SRV,"A"))

 . S TOTAL("P")=$G(TOTAL("P"))+$G(BDGA(SRV,"P"))

 . S TOTAL=$G(TOTAL)+SUBTOT

 ;

 ; put totals line into display array

 S LINE=$$PAD("TOTALS",35)_$J(+$G(TOTAL("A")),5)     ;adult

 S LINE=$$PAD(LINE,45)_$J(+$G(TOTAL("P")),5)         ;peds

 S LINE=$$PAD(LINE,55)_$J($G(TOTAL),5)               ;total

 S LINE=$$PAD(LINE,70)_$J($G(TOTAL)/BDGDAYS,5,2)     ;adpl

 D SET($$REPEAT^XLFSTR("=",80),.VALMCNT),SET(LINE,.VALMCNT)

 Q

 ;

SET(DATA,NUM) ; put data line into display array

 S NUM=NUM+1

 S ^TMP("BDGSTAT1",$J,NUM,0)=DATA

 Q

 ;

PRINT ; print report to paper

 NEW BDGLN,BDGPG

 U IO D INIT^BDGF,HDG

 S BDGLN=0

 F  S BDGLN=$O(^TMP("BDGSTAT1",$J,BDGLN)) Q:'BDGLN  D

 . I $Y>(IOSL-4) D HDG

 . W !,^TMP("BDGSTAT1",$J,BDGLN,0)

 D ^%ZISC,PRTKL^BDGF,EXIT

 Q

 ;

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

 Q

 ;

EXIT ; -- exit code

 Q

 ;

EXPND ; -- expand code

 Q

 ;

 ;

HDG ; print heading on paper

 S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF

 NEW X

 S X="AVERAGE DAILY PATIENT LOAD by "_$S(BDGFRM=1:"WARD",1:"SERVICE")

 W !,BDGTIME,?80-$L(X)/2,X,?71,"Page: ",BDGPG

 S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)

 W !,BDGDATE,?(80-$L(X)\2),X,?76,BDGUSR

 W !,$$REPEAT^XLFSTR("-",80)

 I BDGFRM=1 W !,"Ward",?40,"Patient Days",?65,"ADPL"

 I BDGFRM=2 W !,"Service",?25,"Pat. Days:  Adult",?45,"Peds",?55,"Total",?70,"ADPL"

 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)

BDGSTAT1  ; IHS/ANMC/LJF - AVERAGE DAILY PATIENT LOAD ; 

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

 +3       ;

SELECT    ; -- have user select report by ward or by service

 +1        NEW BDGFRM,BDGBD,BDGED,BDGIA

 +2        SET BDGFRM=$$READ^BDGF("SO^1:By Ward;2:By Service","Select Format")

 +3        IF BDGFRM<1

               QUIT 

 +4        SET BDGIA=$$READ^BDGF("Y","Include INACTIVE "_$SELECT(BDGFRM=1:"Wards",1:"Services"),"NO")

 +5       ;

 +6        SET BDGBD=$$READ^BDGF("DO^::EX","Select Beginning Date")

           IF BDGBD<1

               QUIT 

 +7        SET BDGED=$$READ^BDGF("DO^::EX","Select Ending Date")

           IF BDGED<1

               QUIT 

 +8       ;

 +9       ;

 +10       DO ZIS^BDGF("PQ","EN^BDGSTAT1","ADPL REPORT","BDGFRM;BDGBD;BDGED;BDGIA")

 +11       QUIT 

 +12      ;

 +13      ;

EN        ;EP; entry point from queuing

 +1        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 STAT ADPL"_BDGFRM)

 +4        DO CLEAR^VALM1

 +5        QUIT 

 +6       ;

HDR       ; -- header code

 +1        NEW X

 +2        SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)

 +3        SET VALMHDR(1)=$$SP(75-$LENGTH(X)\2)_X

 +4        QUIT 

 +5       ;

INIT      ; -- init variables and list array

 +1        NEW BDGDAYS

 +2        KILL ^TMP("BDGSTAT1",$JOB)

 +3        SET VALMCNT=0

 +4       ;# of days in date range

           SET BDGDAYS=$$FMDIFF^XLFDT(BDGED,BDGBD)+1

 +5       ;

 +6       ;gather ward or service stats for date range

           DO @BDGFRM

 +7       ;

 +8        IF '$DATA(^TMP("BDGSTAT1",$JOB))

               DO SET("No data found",.VALMCNT)

 +9       ;

 +10       QUIT 

 +11      ;

1         ; step thru ADT Census-Ward file for date range

 +1        NEW WARD,WRDNM,DATE,BDGA,X,LINE,TOTAL

 +2        SET WARD=0

 +3        FOR 

               SET WARD=$ORDER(^BDGCWD(WARD))

               IF 'WARD

                   QUIT 

               Begin DoDot:1

 +4       ;old ward, no longer used

                   IF BDGIA=0

                       IF '$DATA(^BDGWD(WARD))

                           QUIT 

 +5                IF BDGIA=0

                       IF $$GET1^DIQ(9009016.5,WARD,.03)="INACTIVE"

                           QUIT 

 +6       ;ward name

                   SET WRDNM=$$GET1^DIQ(42,WARD,.01)

 +7       ;

 +8                SET DATE=BDGBD-.001

 +9                FOR 

                       SET DATE=$ORDER(^BDGCWD(WARD,1,DATE))

                       IF DATE>BDGED

                           QUIT 

                       IF 'DATE

                           QUIT 

                       Begin DoDot:2

 +10      ; count patients remaining and one day patients

 +11                       SET X=$PIECE($GET(^BDGCWD(WARD,1,DATE,0)),U,2)+$PIECE($GET(^(0)),U,8)

 +12      ; increment array for total inpatient days

 +13                       SET BDGA(WRDNM)=$GET(BDGA(WRDNM))+X

                       End DoDot:2

               End DoDot:1

 +14      ;

 +15      ; put sorted data into display array

 +16       SET WARD=0

           FOR 

               SET WARD=$ORDER(BDGA(WARD))

               IF WARD=""

                   QUIT 

               Begin DoDot:1

 +17               SET LINE=$$PAD(WARD,40)_$JUSTIFY(BDGA(WARD),5)

 +18               SET LINE=$$PAD(LINE,65)_$JUSTIFY(BDGA(WARD)/BDGDAYS,5,2)

 +19               DO SET(LINE,.VALMCNT)

 +20      ;

 +21      ; increment totals

 +22               SET TOTAL=$GET(TOTAL)+BDGA(WARD)

               End DoDot:1

 +23      ;

 +24      ; put totals line into display array

 +25       IF $GET(TOTAL)

               Begin DoDot:1

 +26               SET LINE=$$PAD($$PAD("TOTALS",40)_$JUSTIFY(TOTAL,5),65)_$JUSTIFY(TOTAL/BDGDAYS,5,2)

 +27               DO SET($$REPEAT^XLFSTR("=",80),.VALMCNT)

                   DO SET(LINE,.VALMCNT)

               End DoDot:1

 +28       QUIT 

 +29      ;

2         ; step thru ADT Census-Treating Specialty file by date

 +1        NEW SRV,DATE,SRVNM,BDGA,X,LINE,TOTAL,SUBTOT

 +2        SET SRV=0

 +3        FOR 

               SET SRV=$ORDER(^BDGCTX(SRV))

               IF 'SRV

                   QUIT 

               Begin DoDot:1

 +4       ;

 +5       ; quit if not including inactive services; check begin & end dates

 +6                IF BDGIA=0

                       IF ('$$ACTSRV^BDGPAR(SRV,BDGBD))

                           IF ('$$ACTSRV^BDGPAR(SRV,BDGED))

                               QUIT 

 +7       ;service name

                   SET SRVNM=$$GET1^DIQ(45.7,SRV,.01)

 +8       ;

 +9                SET DATE=BDGBD-.001

 +10               FOR 

                       SET DATE=$ORDER(^BDGCTX(SRV,1,DATE))

                       IF DATE>BDGED

                           QUIT 

                       IF 'DATE

                           QUIT 

                       Begin DoDot:2

 +11      ;

 +12      ; count patients remaining and one day patients

 +13                       SET X=$GET(^BDGCTX(SRV,1,DATE,0))

 +14      ;

 +15      ; increment by adult vs. peds for total inpt days

 +16                       SET BDGA(SRVNM,"A")=$GET(BDGA(SRVNM,"A"))+$PIECE(X,U,2)+$PIECE(X,U,8)

 +17                       SET BDGA(SRVNM,"P")=$GET(BDGA(SRVNM,"P"))+$PIECE(X,U,12)+$PIECE(X,U,18)

                       End DoDot:2

               End DoDot:1

 +18      ;

 +19      ; put sorted data into display array

 +20       SET SRV=0

           FOR 

               SET SRV=$ORDER(BDGA(SRV))

               IF SRV=""

                   QUIT 

               Begin DoDot:1

 +21      ;adult inpt days

                   SET LINE=$$PAD(SRV,35)_$JUSTIFY(+$GET(BDGA(SRV,"A")),5)

 +22      ;peds inpt days

                   SET LINE=$$PAD(LINE,45)_$JUSTIFY(+$GET(BDGA(SRV,"P")),5)

 +23      ;total inpt days

                   SET SUBTOT=$GET(BDGA(SRV,"A"))+$GET(BDGA(SRV,"P"))

 +24               SET LINE=$$PAD($$PAD(LINE,55)_$JUSTIFY(SUBTOT,5),70)_$JUSTIFY(SUBTOT/BDGDAYS,5,2)

 +25               DO SET(LINE,.VALMCNT)

 +26      ;

 +27      ; increment totals

 +28               SET TOTAL("A")=$GET(TOTAL("A"))+$GET(BDGA(SRV,"A"))

 +29               SET TOTAL("P")=$GET(TOTAL("P"))+$GET(BDGA(SRV,"P"))

 +30               SET TOTAL=$GET(TOTAL)+SUBTOT

               End DoDot:1

 +31      ;

 +32      ; put totals line into display array

 +33      ;adult

           SET LINE=$$PAD("TOTALS",35)_$JUSTIFY(+$GET(TOTAL("A")),5)

 +34      ;peds

           SET LINE=$$PAD(LINE,45)_$JUSTIFY(+$GET(TOTAL("P")),5)

 +35      ;total

           SET LINE=$$PAD(LINE,55)_$JUSTIFY($GET(TOTAL),5)

 +36      ;adpl

           SET LINE=$$PAD(LINE,70)_$JUSTIFY($GET(TOTAL)/BDGDAYS,5,2)

 +37       DO SET($$REPEAT^XLFSTR("=",80),.VALMCNT)

           DO SET(LINE,.VALMCNT)

 +38       QUIT 

 +39      ;

SET(DATA,NUM) ; put data line into display array

 +1        SET NUM=NUM+1

 +2        SET ^TMP("BDGSTAT1",$JOB,NUM,0)=DATA

 +3        QUIT 

 +4       ;

PRINT     ; print report to paper

 +1        NEW BDGLN,BDGPG

 +2        USE IO

           DO INIT^BDGF

           DO HDG

 +3        SET BDGLN=0

 +4        FOR 

               SET BDGLN=$ORDER(^TMP("BDGSTAT1",$JOB,BDGLN))

               IF 'BDGLN

                   QUIT 

               Begin DoDot:1

 +5                IF $Y>(IOSL-4)

                       DO HDG

 +6                WRITE !,^TMP("BDGSTAT1",$JOB,BDGLN,0)

               End DoDot:1

 +7        DO ^%ZISC

           DO PRTKL^BDGF

           DO EXIT

 +8        QUIT 

 +9       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT 

 +3       ;

EXIT      ; -- exit code

 +1        QUIT 

 +2       ;

EXPND     ; -- expand code

 +1        QUIT 

 +2       ;

 +3       ;

HDG       ; print heading on paper

 +1        SET BDGPG=$GET(BDGPG)+1

           IF BDGPG>1

               WRITE @IOF

 +2        NEW X

 +3        SET X="AVERAGE DAILY PATIENT LOAD by "_$SELECT(BDGFRM=1:"WARD",1:"SERVICE")

 +4        WRITE !,BDGTIME,?80-$LENGTH(X)/2,X,?71,"Page: ",BDGPG

 +5        SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)

 +6        WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?76,BDGUSR

 +7        WRITE !,$$REPEAT^XLFSTR("-",80)

 +8        IF BDGFRM=1

               WRITE !,"Ward",?40,"Patient Days",?65,"ADPL"

 +9        IF BDGFRM=2

               WRITE !,"Service",?25,"Pat. Days:  Adult",?45,"Peds",?55,"Total",?70,"ADPL"

 +10       WRITE !,$$REPEAT^XLFSTR("=",80)

 +11       QUIT 

 +12      ;

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)