12 lines
734 B
Mathematica
12 lines
734 B
Mathematica
DGPMDDRB ;ALB/RMO - ROOM-BED FILE 405.4 DD CALLS; 7 JAN 90
|
|
;;5.3;Registration;;Aug 13, 1993
|
|
CK ;Check that no other Room-bed with this name is associated with
|
|
;this Ward. If one is found to exist do not allow this Ward to be added.
|
|
S DGX=$S($D(^DG(405.4,DA(1),0)):$P(^(0),"^"),1:"") I DGX]"" F DGI=0:0 S DGI=$O(^DG(405.4,"B",DGX,DGI)) Q:'DGI I $D(^DG(405.4,DGI,"W","B",X,X)) W !,"Ward is already associated with a Room-bed with this name!" K X Q
|
|
K DGI,DGX Q
|
|
;
|
|
ID ;Write first five Wards Associated with Room-bed
|
|
W !?10,"WARD(S): " S DGCNT=0 F DGI=0:0 S DGI=$O(^DG(405.4,+Y,"W",DGI)) Q:'DGI!(DGCNT=5) I $D(^(DGI,0)),$D(^DIC(42,+^(0),0)) W:DGCNT ! W ?23,$P(^(0),"^") S DGCNT=DGCNT+1
|
|
W:'DGCNT ?23,"NONE ASSIGNED"
|
|
K DGCNT,DGI Q
|