DGPMBSP5 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90
;;5.3;Registration;;Aug 13, 1993
;
A Q:'AT
;
S X="A V E R A G E D A I L Y C E N S U S (ADC)"
;
W ! W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
W !?0,"|",?(RM-$L(X)\2),X,?130,"|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
W !?0,"|",?57,"|",?67,"Cumulative FYTD",?93,"||",?103,"Cumulative MONTH",?130,"|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
W !?0,"|","DIVISION",?57,"|",?61,"Hospital|",?77,"NHCU|",?89,"Dom.||",?98,"Hospital|",?114,"NHCU|",?126,"Dom.|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
S D=0
F D1=0:0 S D=$O(ADC(D)) Q:D'>0 I $D(^DG(40.8,+D,0)) S X=^(0),X1=$S($D(^DG(40.8,+D,"CEN",RD,0)):^(0),1:0) D WADC
K I,X,X1,X2,L
Q Q
;
WADC W !?0,"|",$E($P(X,"^"),1,30),?49,"Planned |",$J(+$P(X1,"^",4),11,1),"|",$J(+$P(X1,"^",2),11,1),"|",$J(+$P(X1,"^",10),11,1),"||",$J(+$P(X1,"^",3),11,1),"|",$J(+$P(X1,"^",11),11,1),"|",$J(+$P(X1,"^",12),11,1),"|"
S X2=""
F I=1:1:3 S X=$S($D(ADC(D,I)):ADC(D,I),1:0),$P(X2,"^",I)=+$P(X,"^"),$P(X2,"^",(I+3))=+$P(X,"^",2)
W !?0,"|",?50,"ACTUAL |"
F I=1:1:3 S X=$P(X2,"^",I)/FY("D") W $J(X,11,1),"|"
W "|" F I=4:1:6 S X=$P(X2,"^",I)/FY("DIM") W $J(X,11,1),"|"
W:$Y<131 ?131,"" W $C(13) W:UL["-" ! F L=1:1:131 W UL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSP5 1303 printed Dec 13, 2024@02:49:15 Page 2
DGPMBSP5 ;ALB/LM - BSR PRINT, CONT.; 13 JUNE 90
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
A if 'AT
QUIT
+1 ;
+2 SET X="A V E R A G E D A I L Y C E N S U S (ADC)"
+3 ;
+4 WRITE !
if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+5 WRITE !?0,"|",?(RM-$LENGTH(X)\2),X,?130,"|"
+6 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+7 WRITE !?0,"|",?57,"|",?67,"Cumulative FYTD",?93,"||",?103,"Cumulative MONTH",?130,"|"
+8 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+9 WRITE !?0,"|","DIVISION",?57,"|",?61,"Hospital|",?77,"NHCU|",?89,"Dom.||",?98,"Hospital|",?114,"NHCU|",?126,"Dom.|"
+10 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+11 SET D=0
+12 FOR D1=0:0
SET D=$ORDER(ADC(D))
if D'>0
QUIT
IF $DATA(^DG(40.8,+D,0))
SET X=^(0)
SET X1=$SELECT($DATA(^DG(40.8,+D,"CEN",RD,0)):^(0),1:0)
DO WADC
+13 KILL I,X,X1,X2,L
Q QUIT
+1 ;
WADC WRITE !?0,"|",$EXTRACT($PIECE(X,"^"),1,30),?49,"Planned |",$JUSTIFY(+$PIECE(X1,"^",4),11,1),"|",$JUSTIFY(+$PIECE(X1,"^",2),11,1),"|",$JUSTIFY(+$PIECE(X1,"^",10),11,1),"||",...
... $JUSTIFY(+$PIECE(X1,"^",3),11,1),"|",$JUSTIFY(+$PIECE(X1,"^",11),11,1),"|",$JUSTIFY(+$PIECE(X1,"^",12),11,1),"|"
+1 SET X2=""
+2 FOR I=1:1:3
SET X=$SELECT($DATA(ADC(D,I)):ADC(D,I),1:0)
SET $PIECE(X2,"^",I)=+$PIECE(X,"^")
SET $PIECE(X2,"^",(I+3))=+$PIECE(X,"^",2)
+3 WRITE !?0,"|",?50,"ACTUAL |"
+4 FOR I=1:1:3
SET X=$PIECE(X2,"^",I)/FY("D")
WRITE $JUSTIFY(X,11,1),"|"
+5 WRITE "|"
FOR I=4:1:6
SET X=$PIECE(X2,"^",I)/FY("DIM")
WRITE $JUSTIFY(X,11,1),"|"
+6 if $Y<131
WRITE ?131,""
WRITE $CHAR(13)
if UL["-"
WRITE !
FOR L=1:1:131
WRITE UL
+7 QUIT
