- 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
