BDGCCEN ; IHS/ANMC/LJF - CURRENT INPT CENSUS ; [ 05/28/2002 10:15 AM ]
;;5.3;PIMS;**1003**;mAY 28, 2004
;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time to header on paper
;
NEW X S X=$$BROWSE^BDGF I X="B" D EN Q
I X=U Q
;4/26/02 WAR - Commented out next line per LJF1
;D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS Q
;IHS/ANMC/LJF 5/22/2002 (Next line per Linda's LJF2 5/22/02)
;D ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS")
D ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS","")
Q
;
;
EN ;EP; -- main entry point for BDG CURRENT CENSUS
I $E(IOST,1,2)="P-" D INIT,PRINT Q
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG CURRENT CENSUS")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
Q
;
INIT ; -- init variables and list array
NEW WD,CNT,PT,S,TOTAL,SRV,ARRAY,NUM,X,TOTAL1,LINE,FIRST,TOTAL2
K ^TMP("BDGCCEN",$J)
S VALMCNT=0
;
; loop thru current inpatients by ward and count
S WD=0 F S WD=$O(^DPT("CN",WD)) Q:WD="" D
. S NUM=$G(NUM)+1
. S (CNT,PT)=0 F S PT=$O(^DPT("CN",WD,PT)) Q:'PT S CNT=CNT+1
. S ARRAY(NUM)=WD_U_CNT,TOTAL=$G(TOTAL)+CNT
;
; loop thru current inpatients by service and count
S S=0 F S S=$O(^DPT("ATR",S)) Q:S="" D
. S (CNT,PT)=0 F S PT=$O(^DPT("ATR",S,PT)) Q:'PT S CNT=CNT+1
. S X=$$GET1^DIQ(45.7,S,.01) I X["OBSERVATION" S X="ZZ"_X
. S SRV(X)=CNT,TOTAL1=$G(TOTAL1)+CNT
;
S (S,NUM)=0 F S S=$O(SRV(S)) Q:S="" D
. S X=S I X["ZZ" S X=$P(X,"ZZ",2) ;put observation srvs last
. S NUM=NUM+1,$P(ARRAY(NUM),U,3)=X_U_SRV(S)
;
; take array with counts and set into display array
S X=0,FIRST=1 F S X=$O(ARRAY(X)) Q:'X D
. ;
. ; separate observation services from others by a dashed line
. I $P(ARRAY(X),U,3)["OBSERVATION" D
.. S TOTAL2=$G(TOTAL2)+$P(ARRAY(X),U,4) ;total observations
.. I FIRST D SET($$SP(35)_$$REPEAT^XLFSTR("-",33),.VALMCNT) S FIRST=0
. ;
. S LINE=$$PAD($$SP(2)_$P(ARRAY(X),U),20)_$J($P(ARRAY(X),U,2),5)
. S LINE=$$PAD(LINE,34)_$P(ARRAY(X),U,3)
. S LINE=$$PAD(LINE,60)_$J($P(ARRAY(X),U,4),5)
. D SET(LINE,.VALMCNT)
;
; add totals to display array
S LINE=$$SP(20)_$$REPEAT^XLFSTR("_",8)
S LINE=$$PAD(LINE,60)_$$REPEAT^XLFSTR("_",8)
D SET(LINE,.VALMCNT)
;
S LINE=$$PAD($$SP(20)_$J(+$G(TOTAL),5),60)_$J(+$G(TOTAL1),5)
D SET(LINE,.VALMCNT)
;
I $G(TOTAL2) D ;if have observation pt count
. S LINE=$$PAD($$SP(40)_"(Observation Pts =",60)_$J(TOTAL2,5)_" )"
. D SET(LINE,.VALMCNT)
;
Q
;
SET(LINE,NUM) ; put display line into array
S NUM=NUM+1
S ^TMP("BDGCCEN",$J,NUM,0)=LINE
Q
;
PRINT ; print report to paper
NEW BDGX,BDGLN,WARD
;U IO
U IO D HDG ;IHS/ANMC/LJF 5/22/2002 (per Linda's LJF2 5/22/02)
;
; loop thru display array
S BDGX=0 F S BDGX=$O(^TMP("BDGCCEN",$J,BDGX)) Q:'BDGX D
. I $Y>(IOSL-4) D HDG
. S BDGLN=^TMP("BDGCCEN",$J,BDGX,0)
. W !,BDGLN
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
;
;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time; centered better
;D HDR W @IOF,?24,"Current Inpatient Census"
NEW X W @IOF S X="Current Inpatient Census for "_$$FMTE^XLFDT($$NOW^XLFDT) W ?(80-$L(X)\2),X
;F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
S X="** "_$$CONF^BDGF_" **" W !,?(80-$L(X)\2),X
;
W !,$$REPEAT^XLFSTR("-",80)
W !?2,"Ward",?20,"# of Pts",?34,"Service",?60,"# of Pts"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGCCEN",$J)
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)
BDGCCEN ; IHS/ANMC/LJF - CURRENT INPT CENSUS ; [ 05/28/2002 10:15 AM ]
+1 ;;5.3;PIMS;**1003**;mAY 28, 2004
+2 ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time to header on paper
+3 ;
+4 NEW X
SET X=$$BROWSE^BDGF
IF X="B"
DO EN
QUIT
+5 IF X=U
QUIT
+6 ;4/26/02 WAR - Commented out next line per LJF1
+7 ;D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS Q
+8 ;IHS/ANMC/LJF 5/22/2002 (Next line per Linda's LJF2 5/22/02)
+9 ;D ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS")
+10 DO ZIS^BDGF("QP","EN^BDGCCEN","CURRENT INPT CENSUS","")
+11 QUIT
+12 ;
+13 ;
EN ;EP; -- main entry point for BDG CURRENT CENSUS
+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 CURRENT CENSUS")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 NEW WD,CNT,PT,S,TOTAL,SRV,ARRAY,NUM,X,TOTAL1,LINE,FIRST,TOTAL2
+2 KILL ^TMP("BDGCCEN",$JOB)
+3 SET VALMCNT=0
+4 ;
+5 ; loop thru current inpatients by ward and count
+6 SET WD=0
FOR
SET WD=$ORDER(^DPT("CN",WD))
IF WD=""
QUIT
Begin DoDot:1
+7 SET NUM=$GET(NUM)+1
+8 SET (CNT,PT)=0
FOR
SET PT=$ORDER(^DPT("CN",WD,PT))
IF 'PT
QUIT
SET CNT=CNT+1
+9 SET ARRAY(NUM)=WD_U_CNT
SET TOTAL=$GET(TOTAL)+CNT
End DoDot:1
+10 ;
+11 ; loop thru current inpatients by service and count
+12 SET S=0
FOR
SET S=$ORDER(^DPT("ATR",S))
IF S=""
QUIT
Begin DoDot:1
+13 SET (CNT,PT)=0
FOR
SET PT=$ORDER(^DPT("ATR",S,PT))
IF 'PT
QUIT
SET CNT=CNT+1
+14 SET X=$$GET1^DIQ(45.7,S,.01)
IF X["OBSERVATION"
SET X="ZZ"_X
+15 SET SRV(X)=CNT
SET TOTAL1=$GET(TOTAL1)+CNT
End DoDot:1
+16 ;
+17 SET (S,NUM)=0
FOR
SET S=$ORDER(SRV(S))
IF S=""
QUIT
Begin DoDot:1
+18 ;put observation srvs last
SET X=S
IF X["ZZ"
SET X=$PIECE(X,"ZZ",2)
+19 SET NUM=NUM+1
SET $PIECE(ARRAY(NUM),U,3)=X_U_SRV(S)
End DoDot:1
+20 ;
+21 ; take array with counts and set into display array
+22 SET X=0
SET FIRST=1
FOR
SET X=$ORDER(ARRAY(X))
IF 'X
QUIT
Begin DoDot:1
+23 ;
+24 ; separate observation services from others by a dashed line
+25 IF $PIECE(ARRAY(X),U,3)["OBSERVATION"
Begin DoDot:2
+26 ;total observations
SET TOTAL2=$GET(TOTAL2)+$PIECE(ARRAY(X),U,4)
+27 IF FIRST
DO SET($$SP(35)_$$REPEAT^XLFSTR("-",33),.VALMCNT)
SET FIRST=0
End DoDot:2
+28 ;
+29 SET LINE=$$PAD($$SP(2)_$PIECE(ARRAY(X),U),20)_$JUSTIFY($PIECE(ARRAY(X),U,2),5)
+30 SET LINE=$$PAD(LINE,34)_$PIECE(ARRAY(X),U,3)
+31 SET LINE=$$PAD(LINE,60)_$JUSTIFY($PIECE(ARRAY(X),U,4),5)
+32 DO SET(LINE,.VALMCNT)
End DoDot:1
+33 ;
+34 ; add totals to display array
+35 SET LINE=$$SP(20)_$$REPEAT^XLFSTR("_",8)
+36 SET LINE=$$PAD(LINE,60)_$$REPEAT^XLFSTR("_",8)
+37 DO SET(LINE,.VALMCNT)
+38 ;
+39 SET LINE=$$PAD($$SP(20)_$JUSTIFY(+$GET(TOTAL),5),60)_$JUSTIFY(+$GET(TOTAL1),5)
+40 DO SET(LINE,.VALMCNT)
+41 ;
+42 ;if have observation pt count
IF $GET(TOTAL2)
Begin DoDot:1
+43 SET LINE=$$PAD($$SP(40)_"(Observation Pts =",60)_$JUSTIFY(TOTAL2,5)_" )"
+44 DO SET(LINE,.VALMCNT)
End DoDot:1
+45 ;
+46 QUIT
+47 ;
SET(LINE,NUM) ; put display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGCCEN",$JOB,NUM,0)=LINE
+3 QUIT
+4 ;
PRINT ; print report to paper
+1 NEW BDGX,BDGLN,WARD
+2 ;U IO
+3 ;IHS/ANMC/LJF 5/22/2002 (per Linda's LJF2 5/22/02)
USE IO
DO HDG
+4 ;
+5 ; loop thru display array
+6 SET BDGX=0
FOR
SET BDGX=$ORDER(^TMP("BDGCCEN",$JOB,BDGX))
IF 'BDGX
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-4)
DO HDG
+8 SET BDGLN=^TMP("BDGCCEN",$JOB,BDGX,0)
+9 WRITE !,BDGLN
End DoDot:1
+10 DO ^%ZISC
DO EXIT
+11 QUIT
+12 ;
HDG ; heading for paper report
+1 ;
+2 ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 added date/time; centered better
+3 ;D HDR W @IOF,?24,"Current Inpatient Census"
+4 NEW X
WRITE @IOF
SET X="Current Inpatient Census for "_$$FMTE^XLFDT($$NOW^XLFDT)
WRITE ?(80-$LENGTH(X)\2),X
+5 ;F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
+6 SET X="** "_$$CONF^BDGF_" **"
WRITE !,?(80-$LENGTH(X)\2),X
+7 ;
+8 WRITE !,$$REPEAT^XLFSTR("-",80)
+9 WRITE !?2,"Ward",?20,"# of Pts",?34,"Service",?60,"# of Pts"
+10 WRITE !,$$REPEAT^XLFSTR("=",80)
+11 QUIT
+12 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGCCEN",$JOB)
+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)
