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

Last change on this file since 811 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1DGPMDDOS ;ALB/MIR - OUT-OF-SERVICE BEDS/WARDS ; 29 MAY 90 @1400
2 ;;5.3;Registration;**161**;Aug 13, 1993
3 ;called from DDs of files 42 and 405.4 in the out-of-service multiples
4 ;and computed out-of-service fields
5 ;FOR WARDS
6WOOS ;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
7 I '$D(DGNEW) W !,"Must use supervisor options to place ward out-of-service!" G NOPE
8 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
9 S DGX=$O(^DIC(42,DA(1),"OOS","B",X)) I DGX,DGNEW W !,"Not before last out-of-service episode" G NOPE
10 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
11 I $D(^DGPM("CN",$P(^DIC(42,DA(1),0),"^",1))) W !,*7," WARNING...there are patients on this ward"
12 K DGX Q
13WRTS ;can't be after next out-of-service or before present out-of-service
14 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
15 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
16 K DGX Q
17WOUT W !,"Ward was already placed out of service on ",$$FMTE^XLFDT(DGX,"5DZ")
18NOPE K X,DGX Q
19 ;
20 ;
21 ;ROOM-BEDS
22ROOS ;no if before last return to service or next out of service or if last out-of service was not returned to service
23 I '$D(DGNEW) W !,"Must use supervisor options to place room-bed out-of-service!" G NOPE
24 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
25 S DGX=$O(^DG(405.4,DA(1),"I","B",X)) I DGX,DGNEW W !,"Not before last out-of-service episode" G NOPE
26 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"
27 I $D(^DGPM("ARM",DA(1))) W !,*7," WARNING...there is a patient occupying this bed"
28 K DGX Q
29RRTS ;can't be after next out-of-service or before present out-of-service
30 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
31 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
32 K DGX Q
33ROUT W !,"Room-bed was already placed out of service on ",$$FMTE^XLFDT(DGX,"5DZ"),"." G NOPE
34 ;
35 ;
36WARD ;called from ward out-of-service option
37 D Q S DIC="^DIC(42,",DIC(0)="AEQM" D ^DIC S DA(1)=+Y G Q:Y'>0
38 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
39 S DGNEW=0,DIE=DIC,DIE("NO^")="",DR=".01:.04;.06;S Y=$S(X:.07,1:.11);.11;S Y="""";.07" D ^DIE
40 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
41 G WARD
42Q K DA,DGIFN,DGNEW,DIC,DIE,DLAYGO,DR,X,Y Q
43BED ;called from bed out-of-service option
44 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"
45 W !,"enter the current number of beds out-of-service for the ward you wish."
46BEDSEL W !!
47 D Q S DIC="^DG(405.4,",DIC(0)="AEQM" D ^DIC S (DGIFN,DA(1))=+Y G Q:Y'>0
48 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
49 S DGNEW=0,DIE=DIC,DIE("NO^")="",DR=".01:.04" D ^DIE
50 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
51 G BEDSEL
Note: See TracBrowser for help on using the repository browser.