- 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 Mar 13, 2025@21:54: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
