DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/21/03 8:48am
;;5.3;Registration;**544,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 6/28/2001 added code to screen out inactive wards
; added IHS code for scheduled admissions
PR 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
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
I DGOPT="B" D BEDSPR
Q
SV 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
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
Q
;IHS/ANMC/LJF 6/28/2001 screen for inactive wards
PRINT ;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
I $S('$D(^BDGWD(+W,0)):1,$P($G(^BDGWD(+W,0)),U,3)="I":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
;IHS/ANMC/LJF 6/28/2001 end of mods
S D0=W D WIN^DGPMDDCF I X Q
S (DGA,DGL)=0,DGNM=$P(^DIC(42,+W,0),"^",1) I 'DGPG!($Y>(IOSL-8)) D:DGOPT'="B" HEAD Q:DGFL
ABB ;call in here for abbreviated (single ward) bed availability
ABBREV ;abbreviated bed availability
W:DGOPT'="B" !!,DGNM,": "
EN 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
I DGOPT="B" Q
I 'DGA W ?21,"There are no available beds on this ward."
;IHS/ANMC/LJF 6/28/2001 use IHS file for scheduled admissions
;G LD:'$O(^DGS(41.1,"ARSV",W,0))!'DGSA S DGONE=0
;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
;
G LD:'$O(^BDGSV("AC","A",W,0))!'DGSA S DGONE=0
NEW BDGDT S BDGDT=$$FMADD^XLFDT(DT,14) ;limit to 2 weeks in future
S I=DT-1 F S I=$O(^BDGSV("AC","A",W,I)) Q:'I Q:(I>BDGDT) D
. S J=0 F S J=$O(^BDGSV("AC","A",W,I,J)) Q:'J D
.. W:'DGONE !?3,"Scheduled Admissions for next 2 weeks:" S DGONE=1
.. W !?5,$$GET1^DIQ(9009016.7,J,.01)," -- ",$$GET1^DIQ(9009016.7,J,.011)
.. W " on ",$$GET1^DIQ(9009016.7,J,.02)
;IHS/ANMC/LJF 6/28/2001 end of mods
LD I '$D(^UTILITY("DGPMLD",$J))!'DGLD Q
W !?3,"Lodgers occupy the following beds:"
S DGL=1,DGR=0 F J1=0:0 S DGR=$O(^UTILITY("DGPMLD",$J,DGR)) Q:DGR="" S J=^(DGR) D LOD
K ^UTILITY("DGPMLD",$J) Q
;
ACT S M=$O(^DGPM("ARM",I,0)) I M S DGU=1 Q:'^(M) D LDGER Q
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
I DGU Q
S DGA=DGA+1 Q
;
AVAIL I +DGND'>DGDT,$S('$P(DGND,"^",4):1,$P(DGND,"^",4)>DGDT:1,1:0) S DGU=1
Q
;
DIS ;display available room-beds with/without descriptions
;IHS/ANMC/LJF 6/28/2001 if room used by >1 ward, mark with *
I $O(^DG(405.4,I,"W",+$O(^DG(405.4,I,"W",0)))) D
. S $P(J,U,1)="*"_$P(J,U,1)
;IHS/ANMC/LJF 6/28/2001 end of new code
;
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
W:DGA#2 !?3 I '(DGA#2) W ?40
W $E($P(J,"^",1),1,18) I $D(^DG(405.6,+$P(J,"^",2),0)) W " (",$E($P(^(0),"^",1),1,15),")"
Q
LOD W !?5,DGR," is occupied by ",$P(J,"^",4)," - PT ID: ",$S($P(J,"^",5)]"":$P(J,"^",5),1:"UNKNOWN")
Q
LDGER ;create UTILITY for lodgers
;J=ROOM-BED NAME^DESCRIPTION^T.S
S J=$S($D(^DGPM(+M,0)):$P(^(0),"^",3),1:"")
Q:'$D(^DPT("LD",DGNM,+J))!'$D(^DPT(+J,0)) ;if lodger not on this ward
S ^UTILITY("DGPMLD",$J,DGR)=J_"^^^"_$P(^DPT(+J,0),"^",1)
N DFN S DFN=J D PID^VADPT6 S ^(DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_VA("PID")
Q
HEAD I DGPG,($E(IOST)="C") K DIR S DIR(0)="E" D ^DIR S DGFL='Y Q:DGFL
S DGPG=DGPG+1 W @IOF,!,"BED AVAILABILITY FOR ",DGNOW,?70,"PAGE:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,!
I DGOPT="S" W !?25,"SERVICE: ",$P($P(DGSTR,";"_DGI_":",2),";",1)
Q
SA 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
Q
BEDS ;create TMP for beds - DG*5.3*544
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)
I '$D(^TMP("DGPMBD",$J,$P(J,U),DGNM)) S ^(DGNM)=""
Q
;
BEDSPR ;print report by beds - DG*5.3*544
N DGBDNM,DGBCNT,DGBDESC,DGWCNT,DGBDNM,DGWRD
D HEAD
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 !
. I $Y>(IOSL-8) D HEAD Q:DGFL
. W $E(DGBDNM,1,18) W:DGDESC " ("_$E(DGBDESC,1,15)_")"
. W:DGDESC ?40 W:'DGDESC ?20 W "WARDS: "
. 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
Q:DGFL
W !!?3,$S(DGBCNT:"There are a total of "_DGBCNT_" beds available.",1:"There are no available beds."),!
I $D(^UTILITY("DGPMLD",$J)) D HEAD Q:DGFL D LD
K ^TMP("DGPMBD",$J)
Q
DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/21/03 8:48am
+1 ;;5.3;Registration;**544,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 6/28/2001 added code to screen out inactive wards
+3 ; added IHS code for scheduled admissions
PR DO NOW^%DTC
SET DGDT=%
SET (DGPG,DGFL,DGI)=0
SET Y=DGDT
XECUTE ^DD("DD")
SET DGNOW=Y
IF DGOPT="S"
GOTO SV
IF 'VAUTW
FOR I1=0:0
SET DGI=$ORDER(VAUTW(DGI))
IF DGI=""
QUIT
SET W=VAUTW(DGI)
DO PRINT
IF DGFL
QUIT
+1 IF VAUTW
FOR I1=0:0
SET DGI=$ORDER(^DIC(42,"B",DGI))
IF DGI=""
QUIT
SET J=$ORDER(^(DGI,0))
SET W=J
DO PRINT
IF DGFL
QUIT
+2 IF DGOPT="B"
DO BEDSPR
+3 QUIT
SV IF 'DGSV
FOR I1=0:0
SET DGI=$ORDER(DGSV(DGI))
IF DGI=""!DGFL
QUIT
DO HEAD
FOR DGJ=0:0
SET DGJ=$ORDER(^DIC(42,"D",DGI,DGJ))
IF 'DGJ
QUIT
SET W=DGJ
DO PRINT
IF DGFL
QUIT
+1 IF DGSV
FOR I1=0:0
SET DGI=$ORDER(^DIC(42,"D",DGI))
IF DGI=""!DGFL
QUIT
DO HEAD
FOR DGJ=0:0
SET DGJ=$ORDER(^DIC(42,"D",DGI,DGJ))
IF 'DGJ
QUIT
SET W=DGJ
DO PRINT
IF DGFL
QUIT
+2 QUIT
+3 ;IHS/ANMC/LJF 6/28/2001 screen for inactive wards
PRINT ;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
+1 IF $SELECT('$DATA(^BDGWD(+W,0)):1,$PIECE($GET(^BDGWD(+W,0)),U,3)="I":1,VAUTD:0,'$PIECE(^(0),"^",11)&$DATA(VAUTD(+$ORDER(^DG(40.8,0)))):0,$DATA(VAUTD(+$PIECE(^DIC(42,+W,0),"^",11))):0,1:1)
QUIT
+2 ;IHS/ANMC/LJF 6/28/2001 end of mods
+3 SET D0=W
DO WIN^DGPMDDCF
IF X
QUIT
+4 SET (DGA,DGL)=0
SET DGNM=$PIECE(^DIC(42,+W,0),"^",1)
IF 'DGPG!($Y>(IOSL-8))
IF DGOPT'="B"
DO HEAD
IF DGFL
QUIT
ABB ;call in here for abbreviated (single ward) bed availability
ABBREV ;abbreviated bed availability
+1 IF DGOPT'="B"
WRITE !!,DGNM,": "
EN FOR I=0:0
SET I=$ORDER(^DG(405.4,"W",W,I))
IF I'>0!(DGFL)
QUIT
IF $DATA(^DG(405.4,+I,0))
SET J=^(0)
SET J=$PIECE($PIECE(J,"^",1,3)_"^^^","^",1,3)
SET DGR=$PIECE(J,"^",1)
DO ACT
IF 'DGU
IF DGOPT'="B"
DO DIS
IF DGOPT="B"
DO BEDS
+1 IF DGOPT="B"
QUIT
+2 IF 'DGA
WRITE ?21,"There are no available beds on this ward."
+3 ;IHS/ANMC/LJF 6/28/2001 use IHS file for scheduled admissions
+4 ;G LD:'$O(^DGS(41.1,"ARSV",W,0))!'DGSA S DGONE=0
+5 ;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
+6 ;
+7 IF '$ORDER(^BDGSV("AC","A",W,0))!'DGSA
GOTO LD
SET DGONE=0
+8 ;limit to 2 weeks in future
NEW BDGDT
SET BDGDT=$$FMADD^XLFDT(DT,14)
+9 SET I=DT-1
FOR
SET I=$ORDER(^BDGSV("AC","A",W,I))
IF 'I
QUIT
IF (I>BDGDT)
QUIT
Begin DoDot:1
+10 SET J=0
FOR
SET J=$ORDER(^BDGSV("AC","A",W,I,J))
IF 'J
QUIT
Begin DoDot:2
+11 IF 'DGONE
WRITE !?3,"Scheduled Admissions for next 2 weeks:"
SET DGONE=1
+12 WRITE !?5,$$GET1^DIQ(9009016.7,J,.01)," -- ",$$GET1^DIQ(9009016.7,J,.011)
+13 WRITE " on ",$$GET1^DIQ(9009016.7,J,.02)
End DoDot:2
End DoDot:1
+14 ;IHS/ANMC/LJF 6/28/2001 end of mods
LD IF '$DATA(^UTILITY("DGPMLD",$JOB))!'DGLD
QUIT
+1 WRITE !?3,"Lodgers occupy the following beds:"
+2 SET DGL=1
SET DGR=0
FOR J1=0:0
SET DGR=$ORDER(^UTILITY("DGPMLD",$JOB,DGR))
IF DGR=""
QUIT
SET J=^(DGR)
DO LOD
+3 KILL ^UTILITY("DGPMLD",$JOB)
QUIT
+4 ;
ACT SET M=$ORDER(^DGPM("ARM",I,0))
IF M
SET DGU=1
IF '^(M)
QUIT
DO LDGER
QUIT
+1 SET DGU=0
SET X=$ORDER(^DG(405.4,I,"I","AINV",0))
SET X=$ORDER(^(+X,0))
IF $DATA(^DG(405.4,I,"I",+X,0))
SET DGND=^(0)
DO AVAIL
+2 IF DGU
QUIT
+3 SET DGA=DGA+1
QUIT
+4 ;
AVAIL IF +DGND'>DGDT
IF $SELECT('$PIECE(DGND,"^",4):1,$PIECE(DGND,"^",4)>DGDT:1,1:0)
SET DGU=1
+1 QUIT
+2 ;
DIS ;display available room-beds with/without descriptions
+1 ;IHS/ANMC/LJF 6/28/2001 if room used by >1 ward, mark with *
+2 IF $ORDER(^DG(405.4,I,"W",+$ORDER(^DG(405.4,I,"W",0))))
Begin DoDot:1
+3 SET $PIECE(J,U,1)="*"_$PIECE(J,U,1)
End DoDot:1
+4 ;IHS/ANMC/LJF 6/28/2001 end of new code
+5 ;
+6 IF 'DGDESC
IF DGA=1
WRITE !?3
SET $PIECE(J,"^",1)=$EXTRACT($PIECE(J,"^",1)_" ",1,18)
IF $X+$LENGTH($PIECE(J,"^",1))>79
WRITE !?3
WRITE $PIECE(J,"^",1)
QUIT
+7 IF DGA#2
WRITE !?3
IF '(DGA#2)
WRITE ?40
+8 WRITE $EXTRACT($PIECE(J,"^",1),1,18)
IF $DATA(^DG(405.6,+$PIECE(J,"^",2),0))
WRITE " (",$EXTRACT($PIECE(^(0),"^",1),1,15),")"
+9 QUIT
LOD WRITE !?5,DGR," is occupied by ",$PIECE(J,"^",4)," - PT ID: ",$SELECT($PIECE(J,"^",5)]"":$PIECE(J,"^",5),1:"UNKNOWN")
+1 QUIT
LDGER ;create UTILITY for lodgers
+1 ;J=ROOM-BED NAME^DESCRIPTION^T.S
+2 SET J=$SELECT($DATA(^DGPM(+M,0)):$PIECE(^(0),"^",3),1:"")
+3 ;if lodger not on this ward
IF '$DATA(^DPT("LD",DGNM,+J))!'$DATA(^DPT(+J,0))
QUIT
+4 SET ^UTILITY("DGPMLD",$JOB,DGR)=J_"^^^"_$PIECE(^DPT(+J,0),"^",1)
+5 NEW DFN
SET DFN=J
DO PID^VADPT6
SET ^(DGR)=^UTILITY("DGPMLD",$JOB,DGR)_"^"_VA("PID")
+6 QUIT
HEAD IF DGPG
IF ($EXTRACT(IOST)="C")
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGFL='Y
IF DGFL
QUIT
+1 SET DGPG=DGPG+1
WRITE @IOF,!,"BED AVAILABILITY FOR ",DGNOW,?70,"PAGE:",$JUSTIFY(DGPG,5),!
KILL X
SET $PIECE(X,"-",81)=""
WRITE X,!
+2 IF DGOPT="S"
WRITE !?25,"SERVICE: ",$PIECE($PIECE(DGSTR,";"_DGI_":",2),";",1)
+3 QUIT
SA WRITE !?5
IF $DATA(^DPT(+J,0))
WRITE $PIECE(^(0),"^",1)," -- "
SET DFN=+J
DO PID^VADPT6
WRITE VA("PID")
SET Y=$PIECE(J,"^",2)
IF J
WRITE " on "
DO DT^DIQ
+1 QUIT
BEDS ;create TMP for beds - DG*5.3*544
+1 IF DGDESC
IF '($DATA(^TMP("DGPMBD",$JOB,$PIECE(J,U)))#2)
SET ^TMP("DGPMBD",$JOB,$PIECE(J,U))=$PIECE($GET(^DG(405.6,+$PIECE(J,U,2),0)),U)
+2 IF '$DATA(^TMP("DGPMBD",$JOB,$PIECE(J,U),DGNM))
SET ^(DGNM)=""
+3 QUIT
+4 ;
BEDSPR ;print report by beds - DG*5.3*544
+1 NEW DGBDNM,DGBCNT,DGBDESC,DGWCNT,DGBDNM,DGWRD
+2 DO HEAD
+3 SET DGBCNT=0
SET DGBDNM=""
FOR
SET DGBDNM=$ORDER(^TMP("DGPMBD",$JOB,DGBDNM))
IF DGBDNM=""
QUIT
IF DGFL
QUIT
IF DGDESC
SET DGBDESC=^(DGBDNM)
Begin DoDot:1
+4 IF $Y>(IOSL-8)
DO HEAD
IF DGFL
QUIT
+5 WRITE $EXTRACT(DGBDNM,1,18)
IF DGDESC
WRITE " ("_$EXTRACT(DGBDESC,1,15)_")"
+6 IF DGDESC
WRITE ?40
IF 'DGDESC
WRITE ?20
WRITE "WARDS: "
+7 SET DGWRD=""
SET DGWCNT=0
FOR
SET DGWRD=$ORDER(^TMP("DGPMBD",$JOB,DGBDNM,DGWRD))
IF DGWRD=""
QUIT
IF DGWCNT>0
WRITE ", "
IF ($X+$LENGTH(DGWRD))>80
WRITE !?5
WRITE DGWRD
SET DGWCNT=DGWCNT+1
End DoDot:1
SET DGBCNT=DGBCNT+1
WRITE !
+8 IF DGFL
QUIT
+9 WRITE !!?3,$SELECT(DGBCNT:"There are a total of "_DGBCNT_" beds available.",1:"There are no available beds."),!
+10 IF $DATA(^UTILITY("DGPMLD",$JOB))
DO HEAD
IF DGFL
QUIT
DO LD
+11 KILL ^TMP("DGPMBD",$JOB)
+12 QUIT
