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