DGPMBSP3 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 1/13/05 3:48pm
;;5.3;Registration;**59,85,529,592,641**;Aug 13, 1993
;
A S NTOTAL="",(ORDER,CW,CB,CUM,BD,CT)=0
; ^UTILITY("DGWOR",$J,ORDER)=19 PIECE PRINT/STATS LINE
F O1=0:0 S ORDER=$O(^UTILITY("DGWOR",$J,ORDER)) Q:ORDER'>0 S DGWOR=^(ORDER),BDAY=$S($D(^UTILITY("DGWBD",$J,ORDER)):^(ORDER),1:0) D WR
K BD,BDAY,C,CB,CW,I,I1,L,N,N1,ORDER,O1,TL,W,X,X1,Y,T,T1,T2,T3,TN,TX,TY,DGWOR,DGWON,DGWNN,DGWTOR
Q Q
;
; $P(BDAY,"^",3) = Display on BSR
WR I $P(BDAY,"^",3) W ! F W=1:1:18 W ?+$P(TAB,"^",W),$J($P(DGWOR,"^",W),$P(JUS,"^",W))
; $P(BDAY,"^",2) = Include Stats
I $P(BDAY,"^",2) D CUM F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(DGWOR,"^",N1)
Q:$O(^UTILITY("DGWTOR",$J,ORDER,0))'>0
S TL=0
; ^UTILITY("DGWTOR",$J,ORDER,TOTAL LEVEL)=TOTAL NAME ^ PRINT IN CUM TOTALS (ORDER TOTAL)
F TL1=0:0 S TL=$O(^UTILITY("DGWTOR",$J,ORDER,TL)) Q:TL'>0 S DGWTOR=^(TL) D TL
Q
;
CUM S CW=CW+1 ; Count Ward
S CB=CB+$P(BDAY,"^",4) ; Cum Beds
S BD=BD+BDAY ; Total Elapsed Fiscal Days
S DGWON=$S($D(^UTILITY("DGWON",$J,ORDER)):^(ORDER),1:0) ; Last year 0 Node for ward (Old Node)
S DGWNN=$S($D(^UTILITY("DGWNN",$J,ORDER)):^(ORDER),1:0) ; RD's 0 Node for Ward (New Node)
S C=0
F I=17,29,23,5,6,8,3 F I1=DGWON,DGWNN S C=C+1,$P(CUM,"^",C)=$P(CUM,"^",C)+$P(I1,"^",I)
; CUM=old cum adm^new cum adm^old IWT^new IWT^old cum inter svc xfrs in^new cum inter svc xfers in^old cum disch^new cum disch^old cum inter xfers^new cum inter xfers^old inter svc xfers^new inter svc xfers^old cum bed^new cum bed
Q
;
TL S TC(TL,ORDER)=CUM
S TL(TL,ORDER)=NTOTAL
S TB(TL,ORDER)=BD_"^"_CW_"^"_CB ; TOTAL ELAPSED FISCAL DAYS ^ COUNT WARD ^ CUM BED
I TL=1 S W=NTOTAL,T2=ORDER D TWR Q
S NTOTAL="",T=0
F T1=0:0 S T=$O(TL(TL-1,T)) Q:T'>0!(T>ORDER) S T2=T,TN=TL(TL-1,T),TX=TB(TL-1,T),TY=TC(TL-1,T) D MTL
S:$P(DGWTOR,"^",2) CUM(T2,TL)=$P(DGWTOR,"^")_"^"_TC(TL,T2),CT=CT+1 ; CT=CUM TOTAL
S CUM="",(W,TL(TL,T2))=NTOTAL D TWR
Q
;
TWR N DGDNTD
S DGDNTD=$S($P(DGWTOR,"^")["DON'T DISPLAY":1,1:0)
I DGDNTD,TL=1 W:UL["-" ! F L=1:1:131 W UL
I 'DGDNTD D
.W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
.W !
.D PTOT ; print line on BSR
; code below updates cums
S (CB,BD,CW,NTOTAL)=""
I $S('$P(DGWTOR,"^",2):1,TL'=1:1,1:0) S CUM="" Q
S CUM(ORDER,TL)=$P(DGWTOR,"^")_"^"_CUM
S CUM=""
S CT=CT+1 ; CUM TOTAL
Q
;
PTOT ; Calc Vacant, Overcapacity Beds for Totals
S $P(W,"^",11)=$S(+$P(W,"^",13)>+$P(W,"^",6):($P(W,"^",13)-$P(W,"^",6)),1:0) ; Vacant Beds = Operating Beds - Patients Remaining
S $P(W,"^",14)=$S(+$P(W,"^",6)>+$P(W,"^",13):($P(W,"^",6)-$P(W,"^",13)),1:0) ; Overcapacity = Patients Remaining - Operating Beds
W $P(DGWTOR,"^") ; Total (level name)
F I=3:1:15 W ?+$P(TAB,"^",I),$J($P(W,"^",I),$P(JUS,"^",I))
S X(16)=($P(W,"^",18)/FY("D")) ; Cum Pat Days/Days into fiscal year
S X(17)=$S($P(TB(TL,T2),"^",3)'>0:0,1:((X(16)*100)/($P(TB(TL,T2),"^",3)/FY("D")))) ; ADC/(Cum Bed Total/Days into fiscal year)
S X(16)=$J(X(16),0,1) ; Cum ADC
S X(17)=$J(X(17),0,1)_"%" ; Cum Occ Rate
S X(18)=$P(W,"^",18) ; Cum Pat Days
F I=16:1:18 W ?+$P(TAB,"^",I),$J(X(I),$P(JUS,"^",I))
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
I $Y>$S($D(IOSL):(IOSL-5),1:61) D HEAD^DGPMBSP,HEAD2^DGPMBSP
Q
;
MTL F N1=3:1:15,18 S $P(NTOTAL,"^",N1)=$P(NTOTAL,"^",N1)+$P(TN,"^",N1)
S T3=$O(TB(TL,T))
I T'>T3 S T2=T3
F N1=1:1:3 S $P(TB(TL,T2),"^",N1)=$P(TB(TL,T2),"^",N1)+$P(TX,"^",N1)
I $P(DGWTOR,"^",2) F N1=1:1:15 S $P(TC(TL,T2),"^",N1)=$P(TC(TL,T2),"^",N1)+$P(TY,"^",N1)
K TC(TL-1,T),TL(TL-1,T),TB(TL-1,T),N1,T3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSP3 3651 printed Dec 13, 2024@02:49:13 Page 2
DGPMBSP3 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90 ; 1/13/05 3:48pm
+1 ;;5.3;Registration;**59,85,529,592,641**;Aug 13, 1993
+2 ;
A SET NTOTAL=""
SET (ORDER,CW,CB,CUM,BD,CT)=0
+1 ; ^UTILITY("DGWOR",$J,ORDER)=19 PIECE PRINT/STATS LINE
+2 FOR O1=0:0
SET ORDER=$ORDER(^UTILITY("DGWOR",$JOB,ORDER))
if ORDER'>0
QUIT
SET DGWOR=^(ORDER)
SET BDAY=$SELECT($DATA(^UTILITY("DGWBD",$JOB,ORDER)):^(ORDER),1:0)
DO WR
+3 KILL BD,BDAY,C,CB,CW,I,I1,L,N,N1,ORDER,O1,TL,W,X,X1,Y,T,T1,T2,T3,TN,TX,TY,DGWOR,DGWON,DGWNN,DGWTOR
Q QUIT
+1 ;
+2 ; $P(BDAY,"^",3) = Display on BSR
WR IF $PIECE(BDAY,"^",3)
WRITE !
FOR W=1:1:18
WRITE ?+$PIECE(TAB,"^",W),$JUSTIFY($PIECE(DGWOR,"^",W),$PIECE(JUS,"^",W))
+1 ; $P(BDAY,"^",2) = Include Stats
+2 IF $PIECE(BDAY,"^",2)
DO CUM
FOR N1=3:1:15,18
SET $PIECE(NTOTAL,"^",N1)=$PIECE(NTOTAL,"^",N1)+$PIECE(DGWOR,"^",N1)
+3 if $ORDER(^UTILITY("DGWTOR",$JOB,ORDER,0))'>0
QUIT
+4 SET TL=0
+5 ; ^UTILITY("DGWTOR",$J,ORDER,TOTAL LEVEL)=TOTAL NAME ^ PRINT IN CUM TOTALS (ORDER TOTAL)
+6 FOR TL1=0:0
SET TL=$ORDER(^UTILITY("DGWTOR",$JOB,ORDER,TL))
if TL'>0
QUIT
SET DGWTOR=^(TL)
DO TL
+7 QUIT
+8 ;
CUM ; Count Ward
SET CW=CW+1
+1 ; Cum Beds
SET CB=CB+$PIECE(BDAY,"^",4)
+2 ; Total Elapsed Fiscal Days
SET BD=BD+BDAY
+3 ; Last year 0 Node for ward (Old Node)
SET DGWON=$SELECT($DATA(^UTILITY("DGWON",$JOB,ORDER)):^(ORDER),1:0)
+4 ; RD's 0 Node for Ward (New Node)
SET DGWNN=$SELECT($DATA(^UTILITY("DGWNN",$JOB,ORDER)):^(ORDER),1:0)
+5 SET C=0
+6 FOR I=17,29,23,5,6,8,3
FOR I1=DGWON,DGWNN
SET C=C+1
SET $PIECE(CUM,"^",C)=$PIECE(CUM,"^",C)+$PIECE(I1,"^",I)
+7 ; CUM=old cum adm^new cum adm^old IWT^new IWT^old cum inter svc xfrs in^new cum inter svc xfers in^old cum disch^new cum disch^old cum inter xfers^new cum inter xfers^old inter svc xfers^new inter svc xfers^old cum bed^new cum bed
+8 QUIT
+9 ;
TL SET TC(TL,ORDER)=CUM
+1 SET TL(TL,ORDER)=NTOTAL
+2 ; TOTAL ELAPSED FISCAL DAYS ^ COUNT WARD ^ CUM BED
SET TB(TL,ORDER)=BD_"^"_CW_"^"_CB
+3 IF TL=1
SET W=NTOTAL
SET T2=ORDER
DO TWR
QUIT
+4 SET NTOTAL=""
SET T=0
+5 FOR T1=0:0
SET T=$ORDER(TL(TL-1,T))
if T'>0!(T>ORDER)
QUIT
SET T2=T
SET TN=TL(TL-1,T)
SET TX=TB(TL-1,T)
SET TY=TC(TL-1,T)
DO MTL
+6 ; CT=CUM TOTAL
if $PIECE(DGWTOR,"^",2)
SET CUM(T2,TL)=$PIECE(DGWTOR,"^")_"^"_TC(TL,T2)
SET CT=CT+1
+7 SET CUM=""
SET (W,TL(TL,T2))=NTOTAL
DO TWR
+8 QUIT
+9 ;
TWR NEW DGDNTD
+1 SET DGDNTD=$SELECT($PIECE(DGWTOR,"^")["DON'T DISPLAY":1,1:0)
+2 IF DGDNTD
IF TL=1
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+3 IF 'DGDNTD
Begin DoDot:1
+4 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+5 WRITE !
+6 ; print line on BSR
DO PTOT
End DoDot:1
+7 ; code below updates cums
+8 SET (CB,BD,CW,NTOTAL)=""
+9 IF $SELECT('$PIECE(DGWTOR,"^",2):1,TL'=1:1,1:0)
SET CUM=""
QUIT
+10 SET CUM(ORDER,TL)=$PIECE(DGWTOR,"^")_"^"_CUM
+11 SET CUM=""
+12 ; CUM TOTAL
SET CT=CT+1
+13 QUIT
+14 ;
PTOT ; Calc Vacant, Overcapacity Beds for Totals
+1 ; Vacant Beds = Operating Beds - Patients Remaining
SET $PIECE(W,"^",11)=$SELECT(+$PIECE(W,"^",13)>+$PIECE(W,"^",6):($PIECE(W,"^",13)-$PIECE(W,"^",6)),1:0)
+2 ; Overcapacity = Patients Remaining - Operating Beds
SET $PIECE(W,"^",14)=$SELECT(+$PIECE(W,"^",6)>+$PIECE(W,"^",13):($PIECE(W,"^",6)-$PIECE(W,"^",13)),1:0)
+3 ; Total (level name)
WRITE $PIECE(DGWTOR,"^")
+4 FOR I=3:1:15
WRITE ?+$PIECE(TAB,"^",I),$JUSTIFY($PIECE(W,"^",I),$PIECE(JUS,"^",I))
+5 ; Cum Pat Days/Days into fiscal year
SET X(16)=($PIECE(W,"^",18)/FY("D"))
+6 ; ADC/(Cum Bed Total/Days into fiscal year)
SET X(17)=$SELECT($PIECE(TB(TL,T2),"^",3)'>0:0,1:((X(16)*100)/($PIECE(TB(TL,T2),"^",3)/FY("D"))))
+7 ; Cum ADC
SET X(16)=$JUSTIFY(X(16),0,1)
+8 ; Cum Occ Rate
SET X(17)=$JUSTIFY(X(17),0,1)_"%"
+9 ; Cum Pat Days
SET X(18)=$PIECE(W,"^",18)
+10 FOR I=16:1:18
WRITE ?+$PIECE(TAB,"^",I),$JUSTIFY(X(I),$PIECE(JUS,"^",I))
+11 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+12 IF $Y>$SELECT($DATA(IOSL):(IOSL-5),1:61)
DO HEAD^DGPMBSP
DO HEAD2^DGPMBSP
+13 QUIT
+14 ;
MTL FOR N1=3:1:15,18
SET $PIECE(NTOTAL,"^",N1)=$PIECE(NTOTAL,"^",N1)+$PIECE(TN,"^",N1)
+1 SET T3=$ORDER(TB(TL,T))
+2 IF T'>T3
SET T2=T3
+3 FOR N1=1:1:3
SET $PIECE(TB(TL,T2),"^",N1)=$PIECE(TB(TL,T2),"^",N1)+$PIECE(TX,"^",N1)
+4 IF $PIECE(DGWTOR,"^",2)
FOR N1=1:1:15
SET $PIECE(TC(TL,T2),"^",N1)=$PIECE(TC(TL,T2),"^",N1)+$PIECE(TY,"^",N1)
+5 KILL TC(TL-1,T),TL(TL-1,T),TB(TL-1,T),N1,T3
+6 QUIT
