Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGADS

BDGADS.m

Go to the documentation of this file. 
  1. BDGADS ; IHS/ANMC/LJF - A&D SUMMARY PRINT ; 
  1.  ;;5.3;PIMS;**1013**;APR 26, 2002
  1.  ;
  1.  ; Assumes VA variables RD and GL and set
  1.  ;
  1.  I $E(IOST,1,2)="P-" S BDGT=RD D INIT,PRINT Q
  1.  ;
  1. EN ; -- main entry point for BDG A&D SUMMARY
  1.  NEW VALMCNT,BDGT
  1.  D TERM^VALM0,CLEAR^VALM1
  1.  S BDGT=RD                                         ;reset run date
  1.  D EN^VALM("BDG A&D SUMMARY")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
  1.  S X="ADMISSIONS & DISCHARGES for "_$$GET1^DIQ(4,DUZ(2),.01)
  1.  S VALMHDR(2)=$$SP(79-$L(X)\2)_X
  1.  S X="For "_$$DOW^XLFDT(BDGT)_" "_$$FMTE^XLFDT(BDGT,2)
  1.  S VALMHDR(3)=$$SP(79-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  NEW SRV,PREV,SRVN,TOT
  1.  K ^TMP("BDGADS",$J)
  1.  S VALMCNT=0
  1.  S PREV=$$FMADD^XLFDT(BDGT,-1)                     ;previous date
  1.  ;S TOT=0 F I="O","I","N" S TOT(I)=""       ;initialize totals orig
  1.  S TOT=0 F I="O","I","N","D" S TOT(I)=""       ;initialize totals ihs/cmi/maw 09/13/2011 PATCH 1013
  1.  ;
  1.  D HDG     ;display column headings
  1.  ;
  1.  ; first gathers stats for inpatient services
  1.  ;  loop in alphabetical order
  1.  S SRVN=0 F  S SRVN=$O(^DIC(45.7,"B",SRVN)) Q:SRVN=""  D
  1.  . Q:SRVN["[OBSERVATION"  Q:SRVN="NEWBORN"
  1.  . Q:SRVN="DAY SURGERY"  ;ihs/cmi/maw 09/13/2011 PATCH 1013
  1.  . ;
  1.  . S SRV=0 F  S SRV=$O(^DIC(45.7,"B",SRVN,SRV)) Q:'SRV  D
  1.  .. Q:'$$ACTSRV^BDGPAR(SRV,BDGT)        ;quit if not active on run date
  1.  .. D LINE
  1.  ;
  1.  ; next gather observation services
  1.  S SRVN=0 F  S SRVN=$O(^DIC(45.7,"B",SRVN)) Q:SRVN=""  D
  1.  . Q:SRVN'["[OBSERVATION"  Q:SRVN="NEWBORN"
  1.  . Q:SRVN="DAY SURGERY"  ;ihs/cmi/maw 09/13/2011 PATCH 1013
  1.  . ;
  1.  . S SRV=0 F  S SRV=$O(^DIC(45.7,"B",SRVN,SRV)) Q:'SRV  D
  1.  .. Q:'$$ACTSRV^BDGPAR(SRV,BDGT)        ;quit if not active on run date
  1.  .. D LINE
  1.  ;
  1.  ; next gather day surgery services
  1.  S SRVN=0 F  S SRVN=$O(^DIC(45.7,"B",SRVN)) Q:SRVN=""  D
  1.  . Q:SRVN'="DAY SURGERY"  ;ihs/cmi/maw 09/13/2011 PATCH 1013
  1.  . ;
  1.  . S SRV=0 F  S SRV=$O(^DIC(45.7,"B",SRVN,SRV)) Q:'SRV  D
  1.  .. Q:'$$ACTSRV^BDGPAR(SRV,BDGT)        ;quit if not active on run date
  1.  .. D LINE
  1.  ;
  1.  ; now newborn totals
  1.  D SET("",.VALMCNT)
  1.  S SRVN="NEWBORN",SRV=$O(^DIC(45.7,"B",SRVN,0)) I SRV D
  1.  . Q:'$$ACTSRV^BDGPAR(SRV,BDGT)         ;quit if not active on run date
  1.  . D LINE
  1.  ;
  1.  D TOTALS,SET("",.VALMCNT)
  1.  D PATDATA^BDGADS1
  1.  Q
  1.  ;
  1. TOTALS ; set up total display lines
  1.  NEW LINE,I,X
  1.  D SET($$REPEAT^XLFSTR("=",79),.VALMCNT)
  1.  ;
  1.  I TOT("I")]"" D                   ;if inpatient numbers exist
  1.  . S LINE="Inpatient Totals:",X=0
  1.  . F I=24:8 S X=X+1 Q:X=8  S LINE=$$PAD(LINE,I)_$J($P(TOT("I"),U,X),4)
  1.  . D SET(LINE,.VALMCNT)
  1.  ;
  1.  I TOT("O")]"" D                   ;if observation numbers exist
  1.  . S LINE="Observation Totals:",X=0
  1.  . F I=24:8 S X=X+1 Q:X=8  S LINE=$$PAD(LINE,I)_$J($P(TOT("O"),U,X),4)
  1.  . D SET(LINE,.VALMCNT)
  1.  ;
  1.  I TOT("D")]"" D                   ;if day surgery numbers exist
  1.  . S LINE="Day Surgery Totals:",X=0
  1.  . F I=24:8 S X=X+1 Q:X=8  S LINE=$$PAD(LINE,I)_$J($P(TOT("D"),U,X),4)
  1.  . D SET(LINE,.VALMCNT)
  1.  ;
  1.  S LINE="Total:",X=0
  1.  F I=24:8 S X=X+1 Q:X=8  S LINE=$$PAD(LINE,I)_$J($P(TOT,U,X),4)
  1.  D SET(LINE,.VALMCNT)
  1.  ;
  1.  I TOT("N")]"" D
  1.  . S LINE="Newborn Totals:",X=0
  1.  . F I=24:8 S X=X+1 Q:X=8  S LINE=$$PAD(LINE,I)_$J($P(TOT("N"),U,X),4)
  1.  . D SET(LINE,.VALMCNT)
  1.  ;
  1.  Q
  1.  ;
  1. LINE ; build display line
  1.  NEW DATA,REMA,REMP,LINE,TYPE,CNT,I
  1.  S DATA=$G(^BDGCTX(SRV,1,BDGT,0))            ;data for run date
  1.  S REMA=$P($G(^BDGCTX(SRV,1,PREV,0)),U,2)    ;prev day adults
  1.  S REMP=$P($G(^BDGCTX(SRV,1,PREV,0)),U,12)   ;prev day peds
  1.  ;S TYPE=$S(SRVN["OBSERVATION":"O",SRVN="NEWBORN":"N",1:"I")  orig
  1.  S TYPE=$S(SRVN["OBSERVATION":"O",SRVN="NEWBORN":"N",SRVN="DAY SURGERY":"D",1:"I")  ;ihs/cmi/maw 09/13/2011 PATCH 1013
  1.  ;
  1.  ; count up adult & peds numbers
  1.  S CNT(1)=REMA+REMP                            ;prev remaining
  1.  S CNT(2)=$P(DATA,U,3)+$P(DATA,U,13)           ;admits
  1.  S CNT(3)=$P(DATA,U,5)+$P(DATA,U,15)           ;trans in
  1.  S CNT(4)=$P(DATA,U,6)+$P(DATA,U,16)           ;trans out
  1.  S CNT(5)=$P(DATA,U,7)+$P(DATA,U,17)           ;death
  1.  S CNT(6)=$P(DATA,U,4)+$P(DATA,U,14)           ;discharges
  1.  S CNT(7)=$P(DATA,U,2)+$P(DATA,U,12)           ;remaining
  1.  ;
  1.  ; build columns across page
  1.  S LINE=$E(SRVN,1,23),X=0
  1.  F I=24:8 S X=X+1 Q:X=8  S LINE=$$PAD(LINE,I)_$J(CNT(X),4)
  1.  D SET(LINE,.VALMCNT)
  1.  ;
  1.  ; increment totals
  1.  F I=1:1:7 S $P(TOT(TYPE),U,I)=$P(TOT(TYPE),U,I)+CNT(I)
  1.  I TYPE'="N" F I=1:1:7 S $P(TOT,U,I)=$P($G(TOT),U,I)+CNT(I)
  1.  Q
  1.  ;
  1. SET(DATA,NUM) ; put display line into array
  1.  S NUM=NUM+1
  1.  S ^TMP("BDGADS",$J,NUM,0)=DATA
  1.  Q
  1.  ;
  1. HDG ; set up column headings
  1.  NEW LINE
  1.  S LINE=$$PAD("SERVICE",21)_"REMAINING   ADMIT     TRANSFERS    DEATHS  DISCH  REMAINING"
  1.  D SET(LINE,.VALMCNT)
  1.  S LINE=$$PAD($$SP(21)_"(Prev Day)",42)_"IN     OUT"
  1.  D SET(LINE,.VALMCNT)
  1.  Q
  1.  ;
  1. PRINT ; print report to paper
  1.  NEW BDGX,BDGPG
  1.  U IO D INIT^BDGF,PHDG
  1.  ;
  1.  ; loop thru display array
  1.  S BDGX=0 F  S BDGX=$O(^TMP("BDGADS",$J,BDGX)) Q:'BDGX  D
  1.  . I $Y>(IOSL-4) D PHDG
  1.  . W !,^TMP("BDGADS",$J,BDGX,0)
  1.  D ^%ZISC,PRTKL^BDGF,EXIT
  1.  Q
  1.  ;
  1. PHDG ; heading for paper report
  1.  S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
  1.  W !,BDGUSR,?11,"***",$$CONF^BDGF,"***"
  1.  S X="ADMISSIONS & DISCHARGES for "_$$GET1^DIQ(4,DUZ(2),.01)
  1.  W !,BDGDATE,?(80-$L(X)\2),X,?70,"Page: ",BDGPG
  1.  S X="For "_$$DOW^XLFDT(BDGT)_" "_$$FMTE^XLFDT(BDGT,2)
  1.  W !,BDGTIME,?(80-$L(X)\2),X
  1.  W !,$$REPEAT^XLFSTR("=",80)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGADS",$J) K BDGREP
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)