DGSCHAD2 ;ALB/MRL - SCHEDULED ADMISSIONS STATISTICS ; 06 MAY 87
;;5.3;Registration;;Aug 13, 1993
D OLD G Q:DGERR
F W ! S %DT("A")="Start with SCHEDULED ADMISSION DATE: ",%DT("B")=DGOLD,%DT="EAX" D ^%DT K %DT G Q:Y'>0 S DGFR=Y
W ! S Y=$S(DT<DGOLD1:DGOLD1,1:DT) X ^DD("DD") S %DT("A")=" Go To SCHEDULED ADMISSION DATE: ",%DT("B")=Y,%DT="EAX",%DT(0)=DGFR D ^%DT K %DT G Q:Y'>0 S DGTO=Y
W !!,*7,"*** Margin width for this report is 132 ***" S DGPGM="S^DGSCHAD2",DGVAR="DGFR^DGTO^DUZ" D ZIS^DGUTQ G Q:POP U IO
S K ^UTILITY($J,"DGSA") D:'$D(DT) DT^DICRW S U="^",Y=DT X ^DD("DD") S DGPR="Printed: "_Y,DGW=0 I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
S Y=DGFR X ^DD("DD") S DGHD="Scheduled Admission Statistics for "_$S(DGTO>DGFR:"period covering ",1:"")_Y I DGTO>DGFR S Y=DGTO X ^DD("DD") S DGHD=DGHD_" through "_Y
S DGTO=DGTO_".9999",X1=DGFR,X2=-1 D C^%DTC S DGFR=X_".9999" D DIV^DGUTL S:DGDIV]"" DGDIV=$P(DGDIV,"^",2)
F I=0:0 S DGFR=$O(^DGS(41.1,"C",DGFR)) Q:'DGFR!(DGFR>DGTO) F I1=0:0 S I1=$O(^DGS(41.1,"C",DGFR,I1)) Q:'I1 I $D(^DGS(41.1,I1,0)) S DGD=^(0) D SET
G Q:'$D(^UTILITY($J,"DGSA"))
S DGDIV=0 F I=0:0 S DGDIV=$O(^UTILITY($J,"DGSA",DGDIV)),DGHOW=0 Q:DGDIV="" D H F I1=0:0 S DGHOW=$O(^UTILITY($J,"DGSA",DGDIV,DGHOW)),DGHOW1=0 D:DGHOW="" DTOT Q:DGHOW="" D S1 W ! S DGW=1,DGD=^UTILITY($J,"DGSA",DGDIV,DGHOW) D W1 W !
G Q
DTOT S DGW=2,DGD=^UTILITY($J,"DGSA",DGDIV) D W1 W ! Q
S1 S X=$S(DGHOW="T":"TREATING SPECIALTY",DGHOW="W":"WARD LOCATION",1:DGHOW) W !,X S X1="",$P(X1,"-",$L(X)+1)="" W !,X1 F I2=0:0 S DGHOW1=$O(^UTILITY($J,"DGSA",DGDIV,DGHOW,DGHOW1)) Q:DGHOW1="" S DGD=^(DGHOW1) D W
Q
SET S DGDIV1=$S($L(DGDIV):DGDIV,$D(^DG(40.8,+$P(DGD,"^",12),0)):$P(^(0),"^",1),1:"UNSPECIFIED"),DGHOW=$S($P(DGD,"^",10)]"":$P(DGD,"^",10),1:"UNSPECIFIED")
S DGHOW1=$S($P(DGD,"^",10)="T":$S($D(^DIC(45.7,+$P(DGD,"^",9),0)):$P(^(0),"^",1),1:"UNSPECIFIED"),$P(DGD,"^",10)="W":$S($D(^DIC(42,+$P(DGD,"^",8),0)):$P(^(0),"^",1),1:"UNSPECIFIED"),1:"UNSPECIFIED")
S:'$D(^UTILITY($J,"DGSA",DGDIV1)) ^(DGDIV1)="" S:'$D(^UTILITY($J,"DGSA",DGDIV1,DGHOW)) ^(DGHOW)="" S:'$D(^UTILITY($J,"DGSA",DGDIV1,DGHOW,DGHOW1)) ^(DGHOW1)=""
S X=1,X1=$S($P(DGD,"^",13)]"":2,1:0),X2=$S('X1:0,'+$P(DGD,"^",15):15,+$P(DGD,"^",15)>4:15,1:+$P(DGD,"^",15)+10)
F DGST=X,X1,X2 I DGST S $P(^UTILITY($J,"DGSA",DGDIV1,DGHOW,DGHOW1),"^",DGST)=$P(^UTILITY($J,"DGSA",DGDIV1,DGHOW,DGHOW1),"^",DGST)+1
F DGST=X,X1,X2 I DGST S $P(^UTILITY($J,"DGSA",DGDIV1,DGHOW),"^",DGST)=$P(^UTILITY($J,"DGSA",DGDIV1,DGHOW),"^",DGST)+1
F DGST=X,X1,X2 I DGST S $P(^UTILITY($J,"DGSA",DGDIV1),"^",DGST)=$P(^UTILITY($J,"DGSA",DGDIV1),"^",DGST)+1
Q
W I $Y>$S($D(IOSL):(IOSL-6),1:60) D H
W1 I DGW S DGL="",$P(DGL,"-",131)="" W DGL,!,$S(DGW=1:"SUB-",1:"DIVISION "),"TOTAL"
W:'DGW !,DGHOW1 W ?35,$J(+$P(DGD,"^",1),9),?47,$J(+$P(DGD,"^",2),9),?72,$J(+$P(DGD,"^",11),5),?82,$J(+$P(DGD,"^",12),5),?93,$J(+$P(DGD,"^",13),5),?108,$J(+$P(DGD,"^",14),5),?123,$J(+$P(DGD,"^",15),5) S DGW=0 Q
H W @IOF,!,DGDIV_", "_DGHD,?112,DGPR,!!?75," C A N C E L L A T I O N R E A S O N" S X="",$P(X,"-",62)="" W !?70,X,!?35,"TOTAL",?47,"TOTAL",?70,"|",?93,"REFUSED",?108,"NO BEDS"
W !,"WARD/TREATING SPECIALTY",?35,"SCHEDULED",?47,"CANCELLED",?70,"| EXPIRED",?82,"OVERDUE",?93,"ADMISSION",?108,"AVAILABLE",?123,"OTHER",! F DGL=1:1:131 W "="
Q
OLD S (DGERR,DGOLD)=0 D:'$D(DT) DT^DICRW S Y=$O(^DGS(41.1,"C",0)) I Y>0 S Y=$P(Y,".",1),DGOLD1=Y X ^DD("DD") W !!,"OLDEST SCHEDULED ADMISSION ON FILE IS FOR ",Y,"." S DGOLD=Y Q
E S DGERR=1 W !!,"NO SCHEDULED ADMISSIONS ON FILE!!",*7 Q
Q K ^UTILITY($J,"DGSA"),%DT,DGERR,DGD,DGDIV,DGDIV1,DGFR,DGHD,DGHOW,DGHOW1,DGL,DGOLD,DGOLD1,DGPGM,DGPR,DGST,DGTO,DGVAR,DGW,I,I1,I2,X,X1,X2,Y D CLOSE^DGUTQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSCHAD2 3700 printed Oct 16, 2024@18:59:21 Page 2
DGSCHAD2 ;ALB/MRL - SCHEDULED ADMISSIONS STATISTICS ; 06 MAY 87
+1 ;;5.3;Registration;;Aug 13, 1993
+2 DO OLD
if DGERR
GOTO Q
F WRITE !
SET %DT("A")="Start with SCHEDULED ADMISSION DATE: "
SET %DT("B")=DGOLD
SET %DT="EAX"
DO ^%DT
KILL %DT
if Y'>0
GOTO Q
SET DGFR=Y
+1 WRITE !
SET Y=$SELECT(DT<DGOLD1:DGOLD1,1:DT)
XECUTE ^DD("DD")
SET %DT("A")=" Go To SCHEDULED ADMISSION DATE: "
SET %DT("B")=Y
SET %DT="EAX"
SET %DT(0)=DGFR
DO ^%DT
KILL %DT
if Y'>0
GOTO Q
SET DGTO=Y
+2 WRITE !!,*7,"*** Margin width for this report is 132 ***"
SET DGPGM="S^DGSCHAD2"
SET DGVAR="DGFR^DGTO^DUZ"
DO ZIS^DGUTQ
if POP
GOTO Q
USE IO
S KILL ^UTILITY($JOB,"DGSA")
if '$DATA(DT)
DO DT^DICRW
SET U="^"
SET Y=DT
XECUTE ^DD("DD")
SET DGPR="Printed: "_Y
SET DGW=0
IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+1 SET Y=DGFR
XECUTE ^DD("DD")
SET DGHD="Scheduled Admission Statistics for "_$SELECT(DGTO>DGFR:"period covering ",1:"")_Y
IF DGTO>DGFR
SET Y=DGTO
XECUTE ^DD("DD")
SET DGHD=DGHD_" through "_Y
+2 SET DGTO=DGTO_".9999"
SET X1=DGFR
SET X2=-1
DO C^%DTC
SET DGFR=X_".9999"
DO DIV^DGUTL
if DGDIV]""
SET DGDIV=$PIECE(DGDIV,"^",2)
+3 FOR I=0:0
SET DGFR=$ORDER(^DGS(41.1,"C",DGFR))
if 'DGFR!(DGFR>DGTO)
QUIT
FOR I1=0:0
SET I1=$ORDER(^DGS(41.1,"C",DGFR,I1))
if 'I1
QUIT
IF $DATA(^DGS(41.1,I1,0))
SET DGD=^(0)
DO SET
+4 if '$DATA(^UTILITY($JOB,"DGSA"))
GOTO Q
+5 SET DGDIV=0
FOR I=0:0
SET DGDIV=$ORDER(^UTILITY($JOB,"DGSA",DGDIV))
SET DGHOW=0
if DGDIV=""
QUIT
DO H
FOR I1=0:0
SET DGHOW=$ORDER(^UTILITY($JOB,"DGSA",DGDIV,DGHOW))
SET DGHOW1=0
if DGHOW=""
DO DTOT
if DGHOW=""
QUIT
DO S1
WRITE !
SET DGW=1
SET DGD=^UTILITY($JOB,"DGSA",DGDIV,DGHOW)
DO W1
WRITE !
+6 GOTO Q
DTOT SET DGW=2
SET DGD=^UTILITY($JOB,"DGSA",DGDIV)
DO W1
WRITE !
QUIT
S1 SET X=$SELECT(DGHOW="T":"TREATING SPECIALTY",DGHOW="W":"WARD LOCATION",1:DGHOW)
WRITE !,X
SET X1=""
SET $PIECE(X1,"-",$LENGTH(X)+1)=""
WRITE !,X1
FOR I2=0:0
SET DGHOW1=$ORDER(^UTILITY($JOB,"DGSA",DGDIV,DGHOW,DGHOW1))
if DGHOW1=""
QUIT
SET DGD=^(DGHOW1)
DO W
+1 QUIT
SET SET DGDIV1=$SELECT($LENGTH(DGDIV):DGDIV,$DATA(^DG(40.8,+$PIECE(DGD,"^",12),0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED")
SET DGHOW=$SELECT($PIECE(DGD,"^",10)]"":$PIECE(DGD,"^",10),1:"UNSPECIFIED")
+1 SET DGHOW1=$SELECT($PIECE(DGD,"^",10)="T":$SELECT($DATA(^DIC(45.7,+$PIECE(DGD,"^",9),0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED"),$PIECE(DGD,"^",10)="W":$SELECT($DATA(^DIC(42,+$PIECE(DGD,"^",8),0)):$PIECE(^(0),"^",1),1:"UNSPECIFIED"),1:"UNSPECIFIED"
)
+2 if '$DATA(^UTILITY($JOB,"DGSA",DGDIV1))
SET ^(DGDIV1)=""
if '$DATA(^UTILITY($JOB,"DGSA",DGDIV1,DGHOW))
SET ^(DGHOW)=""
if '$DATA(^UTILITY($JOB,"DGSA",DGDIV1,DGHOW,DGHOW1))
SET ^(DGHOW1)=""
+3 SET X=1
SET X1=$SELECT($PIECE(DGD,"^",13)]"":2,1:0)
SET X2=$SELECT('X1:0,'+$PIECE(DGD,"^",15):15,+$PIECE(DGD,"^",15)>4:15,1:+$PIECE(DGD,"^",15)+10)
+4 FOR DGST=X,X1,X2
IF DGST
SET $PIECE(^UTILITY($JOB,"DGSA",DGDIV1,DGHOW,DGHOW1),"^",DGST)=$PIECE(^UTILITY($JOB,"DGSA",DGDIV1,DGHOW,DGHOW1),"^",DGST)+1
+5 FOR DGST=X,X1,X2
IF DGST
SET $PIECE(^UTILITY($JOB,"DGSA",DGDIV1,DGHOW),"^",DGST)=$PIECE(^UTILITY($JOB,"DGSA",DGDIV1,DGHOW),"^",DGST)+1
+6 FOR DGST=X,X1,X2
IF DGST
SET $PIECE(^UTILITY($JOB,"DGSA",DGDIV1),"^",DGST)=$PIECE(^UTILITY($JOB,"DGSA",DGDIV1),"^",DGST)+1
+7 QUIT
W IF $Y>$SELECT($DATA(IOSL):(IOSL-6),1:60)
DO H
W1 IF DGW
SET DGL=""
SET $PIECE(DGL,"-",131)=""
WRITE DGL,!,$SELECT(DGW=1:"SUB-",1:"DIVISION "),"TOTAL"
+1 if 'DGW
WRITE !,DGHOW1
WRITE ?35,$JUSTIFY(+$PIECE(DGD,"^",1),9),?47,$JUSTIFY(+$PIECE(DGD,"^",2),9),?72,$JUSTIFY(+$PIECE(DGD,"^",11),5),?82,$JUSTIFY(+$PIECE(DGD,"^",12),5),?93,$JUSTIFY(+$PIECE(DGD,"^",13),5),?108,$JUSTIFY(+$PIECE(DGD,"^",14),5),?123,$JUSTIFY(+...
... $PIECE(DGD,"^",15),5)
SET DGW=0
QUIT
H WRITE @IOF,!,DGDIV_", "_DGHD,?112,DGPR,!!?75," C A N C E L L A T I O N R E A S O N"
SET X=""
SET $PIECE(X,"-",62)=""
WRITE !?70,X,!?35,"TOTAL",?47,"TOTAL",?70,"|",?93,"REFUSED",?108,"NO BEDS"
+1 WRITE !,"WARD/TREATING SPECIALTY",?35,"SCHEDULED",?47,"CANCELLED",?70,"| EXPIRED",?82,"OVERDUE",?93,"ADMISSION",?108,"AVAILABLE",?123,"OTHER",!
FOR DGL=1:1:131
WRITE "="
+2 QUIT
OLD SET (DGERR,DGOLD)=0
if '$DATA(DT)
DO DT^DICRW
SET Y=$ORDER(^DGS(41.1,"C",0))
IF Y>0
SET Y=$PIECE(Y,".",1)
SET DGOLD1=Y
XECUTE ^DD("DD")
WRITE !!,"OLDEST SCHEDULED ADMISSION ON FILE IS FOR ",Y,"."
SET DGOLD=Y
QUIT
+1 IF '$TEST
SET DGERR=1
WRITE !!,"NO SCHEDULED ADMISSIONS ON FILE!!",*7
QUIT
Q KILL ^UTILITY($JOB,"DGSA"),%DT,DGERR,DGD,DGDIV,DGDIV1,DGFR,DGHD,DGHOW,DGHOW1,DGL,DGOLD,DGOLD1,DGPGM,DGPR,DGST,DGTO,DGVAR,DGW,I,I1,I2,X,X1,X2,Y
DO CLOSE^DGUTQ
QUIT
