- 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 Apr 23, 2025@19:03:17 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
