DGPMBSP6 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90
;;5.3;Registration;**170**;Aug 13, 1993
;
A Q:'CT
N FY0
;
S X="C U M U L A T I V E T O T A L S"
;
W ! W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
S X1=RM-$L(X)\2
W !?0,"|",?X1,X,?130,"|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
W !?0,"|",?26,"|",?40,"| Interward",?54,"|Interservice",?68,"|",?82,"| Interward",?96,"|Interservice",?110,"|",?117,"Patient",?130,"|"
W !?0,"|",?26,"| Admissions",?40,"| Gains",?54,"| Gains",?68,"| Discharges",?82,"| Losses",?96,"| Losses",?110,"| Days",?130,"|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
W !?0,"|",?26,"|"
S FY0=FY("Y")-1 S:FY0=-1 FY0="99" S:$L(FY0)=1 FY0="0"_FY0
F C=1:1:14 W $S(C<13:"",1:" ")," FY-",$S('(C#2):FY("Y"),1:FY0)_"|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
S I=0
1 F I1=0:0 S I=$O(CUM(I)),J=0 Q:I'>0 F J1=0:0 S J=$O(CUM(I,J)) Q:J'>0 D 2
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
;
Q Q
;
2 S X=CUM(I,J),Z=+$O(^DIC(42,"AGL",I,0)),Z=$S('$D(^DIC(42,+Z,1,J,0)):$P(X,"^"),$P(^DIC(42,+Z,1,J,0),"^",5)]"":$P(^DIC(42,+Z,1,J,0),"^",5),1:$P(X,"^"))
W !?0,"|",$E(Z,1,23),?26,"|" F K=2:1:15 S X1=$S(K<14:6,1:9) W $J(+$P(X,"^",K),X1),"|"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSP6 1272 printed Sep 23, 2025@20:25:08 Page 2
DGPMBSP6 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90
+1 ;;5.3;Registration;**170**;Aug 13, 1993
+2 ;
A if 'CT
QUIT
+1 NEW FY0
+2 ;
+3 SET X="C U M U L A T I V E T O T A L S"
+4 ;
+5 WRITE !
if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+6 SET X1=RM-$LENGTH(X)\2
+7 WRITE !?0,"|",?X1,X,?130,"|"
+8 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+9 WRITE !?0,"|",?26,"|",?40,"| Interward",?54,"|Interservice",?68,"|",?82,"| Interward",?96,"|Interservice",?110,"|",?117,"Patient",?130,"|"
+10 WRITE !?0,"|",?26,"| Admissions",?40,"| Gains",?54,"| Gains",?68,"| Discharges",?82,"| Losses",?96,"| Losses",?110,"| Days",?130,"|"
+11 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+12 WRITE !?0,"|",?26,"|"
+13 SET FY0=FY("Y")-1
if FY0=-1
SET FY0="99"
if $LENGTH(FY0)=1
SET FY0="0"_FY0
+14 FOR C=1:1:14
WRITE $SELECT(C<13:"",1:" ")," FY-",$SELECT('(C#2):FY("Y"),1:FY0)_"|"
+15 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+16 SET I=0
1 FOR I1=0:0
SET I=$ORDER(CUM(I))
SET J=0
if I'>0
QUIT
FOR J1=0:0
SET J=$ORDER(CUM(I,J))
if J'>0
QUIT
DO 2
+1 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+2 ;
Q QUIT
+1 ;
2 SET X=CUM(I,J)
SET Z=+$ORDER(^DIC(42,"AGL",I,0))
SET Z=$SELECT('$DATA(^DIC(42,+Z,1,J,0)):$PIECE(X,"^"),$PIECE(^DIC(42,+Z,1,J,0),"^",5)]"":$PIECE(^DIC(42,+Z,1,J,0),"^",5),1:$PIECE(X,"^"))
+1 WRITE !?0,"|",$EXTRACT(Z,1,23),?26,"|"
FOR K=2:1:15
SET X1=$SELECT(K<14:6,1:9)
WRITE $JUSTIFY(+$PIECE(X,"^",K),X1),"|"
+2 QUIT
