- 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 Jan 18, 2025@03:59:30 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