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

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

initial load of FOIAVistA 6/30/08 version
File size: 3.0 KB
Line 
1DGPMRB ;ALB/MRL,MIR - ROOM-BED DETERMINATION (SINGLE WARD); 9 JAN 89
2 ;;5.3;Registration;**54**;Aug 13, 1993
3 N I,I1,J,L,M,W,Y
4 D Q S DGHOW=$S(('$D(X)#2):1,X["??":0,1:1),DGPMDD=$S('$D(DGSWITCH):+^DGPM(DA,0),1:DT),W=+$P(^DGPM(DA,0),"^",6),(DGL,DGA,DGFL)=0 G Q:'$D(^DIC(42,+W,0))
5 W !!,"CHOOSE FROM",!
6 F I=0:0 S I=$O(^DG(405.4,"W",W,I)) Q:I'>0!(DGFL) I $D(^DG(405.4,+I,0)) S J=^(0),J=$P($P(J,"^",1,3)_"^^^","^",1,3),DGR=$P(J,"^",1) D ACT I 'DGU D DIS
7 I DGA W !!,"Select from the above listing the bed you wish to assign this patient." I DGHOW W !,"Enter two question marks for a more detailed list of available beds." G Q
8 I 'DGA W !!,"There are no available beds on this ward."
9 F I=0:0 S I=$O(^DGS(41.1,"ARSV",W,I)) Q:'I I $D(^DGS(41.1,I,0)) S J=^(0) I '$P(J,"^",13),($P(J,"^",2)'<DT),'$P(J,"^",17) W !,"Scheduled Admission for " W:$D(^DPT(+J,0)) $P(^(0),"^",1)," -- ",$P(^(0),"^",9) S Y=$P(J,"^",2) I J W " on " D DT^DIQ
10 I '$D(^UTILITY("DGPMLD",$J)) G Q
11 W !,"There are beds on this ward which are assigned to ""lodger"" patients. In order",!,"to use these beds you will need to either ""check-out"" the lodger occupying",!,"the bed or move him to another available bed."
12 W ! S DGL=1,DGR=0 F I1=0:0 S DGR=$O(^UTILITY("DGPMLD",$J,DGR)) Q:DGR="" S J=^(DGR) D LOD
13 G Q
14 ;
15ACT S DGU=1,Y=I D OCC I 'DGPMOC S DGU=0
16 S M=$O(^DGPM("ARM",I,0)) I M,^(M) D LDGER Q
17 I DGU Q
18 S DGU=0,X=$O(^DG(405.4,I,"I","AINV",9999999-DGPMDD)),X=$O(^(+X,0)) I $D(^DG(405.4,I,"I",+X,0)) S DGPMDD("D")=^(0) D AVAIL
19 I DGU Q
20 S DGA=DGA+1 Q
21 ;
22AVAIL I +DGPMDD("D")'>DGPMDD,$S('$P(DGPMDD("D"),"^",4):1,$P(DGPMDD("D"),"^",4)>DGPMDD:1,1:0) S DGU=1
23 Q
24 ;
25DIS W:DGA=1 !?3 I DGHOW S $P(J,"^",1)=$E($P(J,"^",1)_" ",1,18) W:$X+$L($P(J,"^",1))>79 !?3 W $P(J,"^",1) Q
26LOD W !?3,DGR,", (",$S($D(^DG(405.6,+$P(J,"^",2),0)):$P(^(0),"^",1),1:"NO DESCRIPTION"),")" W:$D(^DIC(45.7,+$P(J,"^",3),0)) ",",$P(^(0),"^",1) W "."
27 I DGL W !?3,"[Occupied by lodger patient '",$P(J,"^",4),"' SSN: ",$S($P(J,"^",5)]"":$P(J,"^",5),1:"UNKNOWN"),"]"
28 I '(DGA#15) D READ
29 Q
30LDGER ;create UTILITY for lodgers
31 ;J=ROOM-BED NAME^DESCRIPTION^T.S
32 N DFN
33 Q:'$D(^DGPM(+M,0)) S DFN=+$P(^(0),"^",3)
34 S ^UTILITY("DGPMLD",$J,DGR)=J
35 I $D(^DPT(DFN,0)) S ^UTILITY("DGPMLD",$J,DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_$P(^DPT(DFN,0),"^",1)
36 D PID^VADPT6 S ^(DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_VA("PID")
37 Q
38Q K DGA,DGFL,DGHOW,DGL,DGPMDD,DGR,DGU,VA
39Q1 K ^UTILITY("DGPMLD",$J) Q
40DD ;
41 S DGX=X,DGPMOS=+^DGPM(DA,0),D0=+X D RIN^DGPMDDCF K DGPMOS
42 I X W "...INACTIVE" K X,DGX Q
43 S X=DGX K DGX
44 Q
45READ ;prompt to continue
46 W !,"Enter RETURN to continue or '^' to exit: " R DGPMX:DTIME S:'$T!(DGPMX["^") DGFL=1
47 I DGPMX["?" W !!?5,"Enter either RETURN or '^'",! G READ
48 K DGPMX Q
49 ;
50 ;
51OCC ;is bed occupied
52 ;
53 ; INPUT: DA...ifn of DGPM entry
54 ;OUTPUT: DGPMOC...1 if occupied, 0 if not
55 ;
56 N DFN S DGPMOC=0
57 S DFN=$P(^DGPM(DA,0),"^",3) I 'DFN G OCCQ
58 S DGPMX=$O(^DGPM("ARM",+Y,0)) I '$D(^DGPM(+DGPMX,0)) G OCCQ
59 S DGPMX=^(0) I DFN=$P(DGPMX,"^",3),($D(^DG(405.4,+Y,"W","B",+$P(^DGPM(DA,0),"^",6)))) S DGPMOC=0 G OCCQ
60 S DGPMOC=1
61OCCQ K DGPMX Q
Note: See TracBrowser for help on using the repository browser.