source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGSCHAD2.m@ 1104

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