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

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

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/21/03 8:48am
2 ;;5.3;Registration;**544**;Aug 13, 1993
3PR D NOW^%DTC S DGDT=%,(DGPG,DGFL,DGI)=0,Y=DGDT X ^DD("DD") S DGNOW=Y G:DGOPT="S" SV I 'VAUTW F I1=0:0 S DGI=$O(VAUTW(DGI)) Q:DGI="" S W=VAUTW(DGI) D PRINT Q:DGFL
4 I VAUTW F I1=0:0 S DGI=$O(^DIC(42,"B",DGI)) Q:DGI="" S J=$O(^(DGI,0)) S W=J D PRINT Q:DGFL
5 I DGOPT="B" D BEDSPR
6 Q
7SV I 'DGSV F I1=0:0 S DGI=$O(DGSV(DGI)) Q:DGI=""!DGFL D HEAD F DGJ=0:0 S DGJ=$O(^DIC(42,"D",DGI,DGJ)) Q:'DGJ S W=DGJ D PRINT Q:DGFL
8 I DGSV F I1=0:0 S DGI=$O(^DIC(42,"D",DGI)) Q:DGI=""!DGFL D HEAD F DGJ=0:0 S DGJ=$O(^DIC(42,"D",DGI,DGJ)) Q:'DGJ S W=DGJ D PRINT Q:DGFL
9 Q
10PRINT I $S('$D(^DIC(42,+W,0)):1,VAUTD:0,'$P(^(0),"^",11)&$D(VAUTD(+$O(^DG(40.8,0)))):0,$D(VAUTD(+$P(^DIC(42,+W,0),"^",11))):0,1:1) Q
11 S D0=W D WIN^DGPMDDCF I X Q
12 S (DGA,DGL)=0,DGNM=$P(^DIC(42,+W,0),"^",1) I 'DGPG!($Y>(IOSL-8)) D:DGOPT'="B" HEAD Q:DGFL
13ABB ;call in here for abbreviated (single ward) bed availability
14ABBREV ;abbreviated bed availability
15 W:DGOPT'="B" !!,DGNM,": "
16EN 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:DGOPT'="B" DIS I DGOPT="B" D BEDS
17 I DGOPT="B" Q
18 I 'DGA W ?21,"There are no available beds on this ward."
19 G LD:'$O(^DGS(41.1,"ARSV",W,0))!'DGSA S DGONE=0
20 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:'DGONE !?3,"Future Scheduled Admissions:" S DGONE=1 D SA
21LD I '$D(^UTILITY("DGPMLD",$J))!'DGLD Q
22 W !?3,"Lodgers occupy the following beds:"
23 S DGL=1,DGR=0 F J1=0:0 S DGR=$O(^UTILITY("DGPMLD",$J,DGR)) Q:DGR="" S J=^(DGR) D LOD
24 K ^UTILITY("DGPMLD",$J) Q
25 ;
26ACT S M=$O(^DGPM("ARM",I,0)) I M S DGU=1 Q:'^(M) D LDGER Q
27 S DGU=0,X=$O(^DG(405.4,I,"I","AINV",0)),X=$O(^(+X,0)) I $D(^DG(405.4,I,"I",+X,0)) S DGND=^(0) D AVAIL
28 I DGU Q
29 S DGA=DGA+1 Q
30 ;
31AVAIL I +DGND'>DGDT,$S('$P(DGND,"^",4):1,$P(DGND,"^",4)>DGDT:1,1:0) S DGU=1
32 Q
33 ;
34DIS ;display available room-beds with/without descriptions
35 I 'DGDESC W:DGA=1 !?3 S $P(J,"^",1)=$E($P(J,"^",1)_" ",1,18) W:$X+$L($P(J,"^",1))>79 !?3 W $P(J,"^",1) Q
36 W:DGA#2 !?3 I '(DGA#2) W ?40
37 W $E($P(J,"^",1),1,18) I $D(^DG(405.6,+$P(J,"^",2),0)) W " (",$E($P(^(0),"^",1),1,15),")"
38 Q
39LOD W !?5,DGR," is occupied by ",$P(J,"^",4)," - PT ID: ",$S($P(J,"^",5)]"":$P(J,"^",5),1:"UNKNOWN")
40 Q
41LDGER ;create UTILITY for lodgers
42 ;J=ROOM-BED NAME^DESCRIPTION^T.S
43 S J=$S($D(^DGPM(+M,0)):$P(^(0),"^",3),1:"")
44 Q:'$D(^DPT("LD",DGNM,+J))!'$D(^DPT(+J,0)) ;if lodger not on this ward
45 S ^UTILITY("DGPMLD",$J,DGR)=J_"^^^"_$P(^DPT(+J,0),"^",1)
46 N DFN S DFN=J D PID^VADPT6 S ^(DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_VA("PID")
47 Q
48HEAD I DGPG,($E(IOST)="C") K DIR S DIR(0)="E" D ^DIR S DGFL='Y Q:DGFL
49 S DGPG=DGPG+1 W @IOF,!,"BED AVAILABILITY FOR ",DGNOW,?70,"PAGE:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,!
50 I DGOPT="S" W !?25,"SERVICE: ",$P($P(DGSTR,";"_DGI_":",2),";",1)
51 Q
52SA W !?5 W:$D(^DPT(+J,0)) $P(^(0),"^",1)," -- " S DFN=+J D PID^VADPT6 W VA("PID") S Y=$P(J,"^",2) I J W " on " D DT^DIQ
53 Q
54BEDS ;create TMP for beds - DG*5.3*544
55 I DGDESC,'($D(^TMP("DGPMBD",$J,$P(J,U)))#2) S ^TMP("DGPMBD",$J,$P(J,U))=$P($G(^DG(405.6,+$P(J,U,2),0)),U)
56 I '$D(^TMP("DGPMBD",$J,$P(J,U),DGNM)) S ^(DGNM)=""
57 Q
58 ;
59BEDSPR ;print report by beds - DG*5.3*544
60 N DGBDNM,DGBCNT,DGBDESC,DGWCNT,DGBDNM,DGWRD
61 D HEAD
62 S DGBCNT=0,DGBDNM="" F S DGBDNM=$O(^TMP("DGPMBD",$J,DGBDNM)) Q:DGBDNM="" Q:DGFL S:DGDESC DGBDESC=^(DGBDNM) D S DGBCNT=DGBCNT+1 W !
63 . I $Y>(IOSL-8) D HEAD Q:DGFL
64 . W $E(DGBDNM,1,18) W:DGDESC " ("_$E(DGBDESC,1,15)_")"
65 . W:DGDESC ?40 W:'DGDESC ?20 W "WARDS: "
66 . S DGWRD="",DGWCNT=0 F S DGWRD=$O(^TMP("DGPMBD",$J,DGBDNM,DGWRD)) Q:DGWRD="" W:DGWCNT>0 ", " W:($X+$L(DGWRD))>80 !?5 W DGWRD S DGWCNT=DGWCNT+1
67 Q:DGFL
68 W !!?3,$S(DGBCNT:"There are a total of "_DGBCNT_" beds available.",1:"There are no available beds."),!
69 I $D(^UTILITY("DGPMLD",$J)) D HEAD Q:DGFL D LD
70 K ^TMP("DGPMBD",$J)
71 Q
Note: See TracBrowser for help on using the repository browser.