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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMDDRB 745 printed Oct 16, 2024@18:50:05 Page 2
DGPMDDRB ;ALB/RMO - ROOM-BED FILE 405.4 DD CALLS; 7 JAN 90
+1 ;;5.3;Registration;;Aug 13, 1993
CK ;Check that no other Room-bed with this name is associated with
+1 ;this Ward. If one is found to exist do not allow this Ward to be added.
+2 SET DGX=$SELECT($DATA(^DG(405.4,DA(1),0)):$PIECE(^(0),"^"),1:"")
IF DGX]""
FOR DGI=0:0
SET DGI=$ORDER(^DG(405.4,"B",DGX,DGI))
if 'DGI
QUIT
IF $DATA(^DG(405.4,DGI,"W","B",X,X))
WRITE !,"Ward is already associated with a Room-bed with this name!"
KILL X
QUIT
+3 KILL DGI,DGX
QUIT
+4 ;
ID ;Write first five Wards Associated with Room-bed
+1 WRITE !?10,"WARD(S): "
SET DGCNT=0
FOR DGI=0:0
SET DGI=$ORDER(^DG(405.4,+Y,"W",DGI))
if 'DGI!(DGCNT=5)
QUIT
IF $DATA(^(DGI,0))
IF $DATA(^DIC(42,+^(0),0))
if DGCNT
WRITE !
WRITE ?23,$PIECE(^(0),"^")
SET DGCNT=DGCNT+1
+2 if 'DGCNT
WRITE ?23,"NONE ASSIGNED"
+3 KILL DGCNT,DGI
QUIT
