- DGPMDDOS ;ALB/MIR - OUT-OF-SERVICE BEDS/WARDS ; 29 MAY 90 @1400
- ;;5.3;Registration;**161,1015**;Aug 13, 1993;Build 21
- ;called from DDs of files 42 and 405.4 in the out-of-service multiples
- ;and computed out-of-service fields
- ;FOR WARDS
- WOOS ;no if before last return to service or next out of service or if last out-of service was not returned to service or after return to service
- I '$D(DGNEW) W !,"Must use supervisor options to place ward out-of-service!" G NOPE
- S DGX=$O(^DIC(42,DA(1),"OOS","AINV",9999998.9-X)),DGX=$O(^(+DGX,0)) I $S(DGNEW:1,DGX=DA:0,1:1),$D(^DIC(42,DA(1),"OOS",+DGX,0)) S DGX=^(0) G:'$P(DGX,"^",4) WOUT I $P(DGX,"^",4)>X W !,*7,"Not before last return to service date" G NOPE
- S DGX=$O(^DIC(42,DA(1),"OOS","B",X)) I DGX,DGNEW W !,"Not before last out-of-service episode" G NOPE
- I 'DGNEW,$D(^DIC(42,DA(1),"OOS",DA,0)),$P(^(0),"^",4),(X>$P(^(0),"^",4)) W !,*7,"Not after return to service date" G NOPE
- I $D(^DGPM("CN",$P(^DIC(42,DA(1),0),"^",1))) W !,*7," WARNING...there are patients on this ward"
- K DGX Q
- WRTS ;can't be after next out-of-service or before present out-of-service
- S DGX=$S($D(^DIC(42,DA(1),"OOS",DA,0)):^(0),1:"") I X<DGX W !,*7,"Must be after out-of-service date" G NOPE
- I DGX S DGX=$O(^DIC(42,DA(1),"OOS","B",+DGX)) I X>DGX,DGX W !,*7,"Not after next out-of-service date" G NOPE
- K DGX Q
- WOUT W !,"Ward was already placed out of service on ",$$FMTE^XLFDT(DGX,"5DZ")
- NOPE K X,DGX Q
- ;
- ;
- ;ROOM-BEDS
- ROOS ;no if before last return to service or next out of service or if last out-of service was not returned to service
- I '$D(DGNEW) W !,"Must use supervisor options to place room-bed out-of-service!" G NOPE
- S DGX=$O(^DG(405.4,DA(1),"I","AINV",9999998.9-X)),DGX=$O(^(+DGX,0)) I $S(DGNEW:1,DGX=DA:0,1:1),$D(^DG(405.4,DA(1),"I",+DGX,0)) S DGX=^(0) G:'$P(DGX,"^",4) WOUT I $P(DGX,"^",4)>X W !,*7,"Not before last return to service date" G NOPE
- S DGX=$O(^DG(405.4,DA(1),"I","B",X)) I DGX,DGNEW W !,"Not before last out-of-service episode" G NOPE
- I 'DGNEW,$D(^DG(405.4,DA(1),"I",DA,0)),$P(^(0),"^",4),(X>$P(^(0),"^",4)) W !,*7,"Not after return to service date"
- I $D(^DGPM("ARM",DA(1))) W !,*7," WARNING...there is a patient occupying this bed"
- K DGX Q
- RRTS ;can't be after next out-of-service or before present out-of-service
- S DGX=$S($D(^DG(405.4,DA(1),"I",DA,0)):^(0),1:"") I X<DGX W !,*7,"Must be after out-of-service date" G NOPE
- I DGX S DGX=$O(^DG(405.4,DA(1),"I","B",+DGX)) I X>DGX,DGX W !,*7,"Not after next out-of-service date" G NOPE
- K DGX Q
- ROUT W !,"Room-bed was already placed out of service on ",$$FMTE^XLFDT(DGX,"5DZ"),"." G NOPE
- ;
- ;
- WARD ;called from ward out-of-service option
- D Q S DIC="^DIC(42,",DIC(0)="AEQM" D ^DIC S DA(1)=+Y G Q:Y'>0
- S DGNEW=1,DIC="^DIC(42,"_DA(1)_",""OOS"",",DIC(0)="AELQM",DA(1)=DA(1),DLAYGO=42.08 S:'$D(^DIC(42,DA(1),"OOS",0)) ^(0)="^42.08D^^" D ^DIC S DA=+Y I Y<0 D Q Q
- S DGNEW=0,DIE=DIC,DIE("NO^")="",DR=".01:.04;.06;S Y=$S(X:.07,1:.11);.11;S Y="""";.07" D ^DIE
- I $D(DA),$D(^DIC(42,DA(1),"OOS",DA,0)) S X=^(0) I '$P(^(0),"^",2) W !,*7,"Incomplete entry...deleted" S DIK=DIE D ^DIK D Q Q
- G WARD
- Q K DA,DGIFN,DGNEW,DIC,DIE,DLAYGO,DR,X,Y Q
- BED ;called from bed out-of-service option
- W !!,"This option is used to inactivate a bed for bed availability purposes only.",!,"If you want this bed to also show as statistically out-of-service on the",!,"G&L, you must also utilize the 'Edit Ward Out-of-Service Dates' option and"
- W !,"enter the current number of beds out-of-service for the ward you wish."
- BEDSEL W !!
- D Q S DIC="^DG(405.4,",DIC(0)="AEQM" D ^DIC S (DGIFN,DA(1))=+Y G Q:Y'>0
- S DGNEW=1,DIC="^DG(405.4,"_DA(1)_",""I"",",DIC(0)="AELQM",DA(1)=DA(1),DLAYGO=405.42 S:'$D(^DG(405.4,DA(1),"I",0)) ^(0)="^405.42ID^^" D ^DIC S DA=+Y I Y<0 D Q Q
- S DGNEW=0,DIE=DIC,DIE("NO^")="",DR=".01:.04" D ^DIE
- I $D(DA),$D(^DG(405.4,DA(1),"I",DA,0)) S X=^(0) I '$P(^(0),"^",2) W !,*7,"Incomplete entry...deleted" S DIK=DIE D ^DIK D Q Q
- G BEDSEL
- DGPMDDOS ;ALB/MIR - OUT-OF-SERVICE BEDS/WARDS ; 29 MAY 90 @1400
- +1 ;;5.3;Registration;**161,1015**;Aug 13, 1993;Build 21
- +2 ;called from DDs of files 42 and 405.4 in the out-of-service multiples
- +3 ;and computed out-of-service fields
- +4 ;FOR WARDS
- WOOS ;no if before last return to service or next out of service or if last out-of service was not returned to service or after return to service
- +1 IF '$DATA(DGNEW)
- WRITE !,"Must use supervisor options to place ward out-of-service!"
- GOTO NOPE
- +2 SET DGX=$ORDER(^DIC(42,DA(1),"OOS","AINV",9999998.9-X))
- SET DGX=$ORDER(^(+DGX,0))
- IF $SELECT(DGNEW:1,DGX=DA:0,1:1)
- IF $DATA(^DIC(42,DA(1),"OOS",+DGX,0))
- SET DGX=^(0)
- IF '$PIECE(DGX,"^",4)
- GOTO WOUT
- IF $PIECE(DGX,"^",4)>X
- WRITE !,*7,"Not before last return to service date"
- GOTO NOPE
- +3 SET DGX=$ORDER(^DIC(42,DA(1),"OOS","B",X))
- IF DGX
- IF DGNEW
- WRITE !,"Not before last out-of-service episode"
- GOTO NOPE
- +4 IF 'DGNEW
- IF $DATA(^DIC(42,DA(1),"OOS",DA,0))
- IF $PIECE(^(0),"^",4)
- IF (X>$PIECE(^(0),"^",4))
- WRITE !,*7,"Not after return to service date"
- GOTO NOPE
- +5 IF $DATA(^DGPM("CN",$PIECE(^DIC(42,DA(1),0),"^",1)))
- WRITE !,*7," WARNING...there are patients on this ward"
- +6 KILL DGX
- QUIT
- WRTS ;can't be after next out-of-service or before present out-of-service
- +1 SET DGX=$SELECT($DATA(^DIC(42,DA(1),"OOS",DA,0)):^(0),1:"")
- IF X<DGX
- WRITE !,*7,"Must be after out-of-service date"
- GOTO NOPE
- +2 IF DGX
- SET DGX=$ORDER(^DIC(42,DA(1),"OOS","B",+DGX))
- IF X>DGX
- IF DGX
- WRITE !,*7,"Not after next out-of-service date"
- GOTO NOPE
- +3 KILL DGX
- QUIT
- WOUT WRITE !,"Ward was already placed out of service on ",$$FMTE^XLFDT(DGX,"5DZ")
- NOPE KILL X,DGX
- QUIT
- +1 ;
- +2 ;
- +3 ;ROOM-BEDS
- ROOS ;no if before last return to service or next out of service or if last out-of service was not returned to service
- +1 IF '$DATA(DGNEW)
- WRITE !,"Must use supervisor options to place room-bed out-of-service!"
- GOTO NOPE
- +2 SET DGX=$ORDER(^DG(405.4,DA(1),"I","AINV",9999998.9-X))
- SET DGX=$ORDER(^(+DGX,0))
- IF $SELECT(DGNEW:1,DGX=DA:0,1:1)
- IF $DATA(^DG(405.4,DA(1),"I",+DGX,0))
- SET DGX=^(0)
- IF '$PIECE(DGX,"^",4)
- GOTO WOUT
- IF $PIECE(DGX,"^",4)>X
- WRITE !,*7,"Not before last return to service date"
- GOTO NOPE
- +3 SET DGX=$ORDER(^DG(405.4,DA(1),"I","B",X))
- IF DGX
- IF DGNEW
- WRITE !,"Not before last out-of-service episode"
- GOTO NOPE
- +4 IF 'DGNEW
- IF $DATA(^DG(405.4,DA(1),"I",DA,0))
- IF $PIECE(^(0),"^",4)
- IF (X>$PIECE(^(0),"^",4))
- WRITE !,*7,"Not after return to service date"
- +5 IF $DATA(^DGPM("ARM",DA(1)))
- WRITE !,*7," WARNING...there is a patient occupying this bed"
- +6 KILL DGX
- QUIT
- RRTS ;can't be after next out-of-service or before present out-of-service
- +1 SET DGX=$SELECT($DATA(^DG(405.4,DA(1),"I",DA,0)):^(0),1:"")
- IF X<DGX
- WRITE !,*7,"Must be after out-of-service date"
- GOTO NOPE
- +2 IF DGX
- SET DGX=$ORDER(^DG(405.4,DA(1),"I","B",+DGX))
- IF X>DGX
- IF DGX
- WRITE !,*7,"Not after next out-of-service date"
- GOTO NOPE
- +3 KILL DGX
- QUIT
- ROUT WRITE !,"Room-bed was already placed out of service on ",$$FMTE^XLFDT(DGX,"5DZ"),"."
- GOTO NOPE
- +1 ;
- +2 ;
- WARD ;called from ward out-of-service option
- +1 DO Q
- SET DIC="^DIC(42,"
- SET DIC(0)="AEQM"
- DO ^DIC
- SET DA(1)=+Y
- IF Y'>0
- GOTO Q
- +2 SET DGNEW=1
- SET DIC="^DIC(42,"_DA(1)_",""OOS"","
- SET DIC(0)="AELQM"
- SET DA(1)=DA(1)
- SET DLAYGO=42.08
- IF '$DATA(^DIC(42,DA(1),"OOS",0))
- SET ^(0)="^42.08D^^"
- DO ^DIC
- SET DA=+Y
- IF Y<0
- DO Q
- QUIT
- +3 SET DGNEW=0
- SET DIE=DIC
- SET DIE("NO^")=""
- SET DR=".01:.04;.06;S Y=$S(X:.07,1:.11);.11;S Y="""";.07"
- DO ^DIE
- +4 IF $DATA(DA)
- IF $DATA(^DIC(42,DA(1),"OOS",DA,0))
- SET X=^(0)
- IF '$PIECE(^(0),"^",2)
- WRITE !,*7,"Incomplete entry...deleted"
- SET DIK=DIE
- DO ^DIK
- DO Q
- QUIT
- +5 GOTO WARD
- Q KILL DA,DGIFN,DGNEW,DIC,DIE,DLAYGO,DR,X,Y
- QUIT
- BED ;called from bed out-of-service option
- +1 WRITE !!,"This option is used to inactivate a bed for bed availability purposes only.",!,"If you want this bed to also show as statistically out-of-service on the",!,"G&L, you must also utilize the 'Edit Ward Out-of-Service Dates' option and"
- +2 WRITE !,"enter the current number of beds out-of-service for the ward you wish."
- BEDSEL WRITE !!
- +1 DO Q
- SET DIC="^DG(405.4,"
- SET DIC(0)="AEQM"
- DO ^DIC
- SET (DGIFN,DA(1))=+Y
- IF Y'>0
- GOTO Q
- +2 SET DGNEW=1
- SET DIC="^DG(405.4,"_DA(1)_",""I"","
- SET DIC(0)="AELQM"
- SET DA(1)=DA(1)
- SET DLAYGO=405.42
- IF '$DATA(^DG(405.4,DA(1),"I",0))
- SET ^(0)="^405.42ID^^"
- DO ^DIC
- SET DA=+Y
- IF Y<0
- DO Q
- QUIT
- +3 SET DGNEW=0
- SET DIE=DIC
- SET DIE("NO^")=""
- SET DR=".01:.04"
- DO ^DIE
- +4 IF $DATA(DA)
- IF $DATA(^DG(405.4,DA(1),"I",DA,0))
- SET X=^(0)
- IF '$PIECE(^(0),"^",2)
- WRITE !,*7,"Incomplete entry...deleted"
- SET DIK=DIE
- DO ^DIK
- DO Q
- QUIT
- +5 GOTO BEDSEL
