- DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/21/03 8:48am
- ;;5.3;Registration;**544**;Aug 13, 1993
- 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
- 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
- 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."
- 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
- 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMRBA1 4082 printed Jan 18, 2025@03:50:32 Page 2
- DGPMRBA1 ;ALB/MIR - PRINT FROM BED AVAILABILITY ; 10/21/03 8:48am
- +1 ;;5.3;Registration;**544**;Aug 13, 1993
- 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
- PRINT IF $SELECT('$DATA(^DIC(42,+W,0)):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
- +1 SET D0=W
- DO WIN^DGPMDDCF
- IF X
- QUIT
- +2 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 if '$ORDER(^DGS(41.1,"ARSV",W,0))!'DGSA
- GOTO LD
- SET DGONE=0
- +4 FOR I=0:0
- SET I=$ORDER(^DGS(41.1,"ARSV",W,I))
- if 'I
- QUIT
- IF $DATA(^DGS(41.1,I,0))
- SET J=^(0)
- IF '$PIECE(J,"^",13)
- IF ($PIECE(J,"^",2)'<DT)
- IF '$PIECE(J,"^",17)
- if 'DGONE
- WRITE !?3,"Future Scheduled Admissions:"
- SET DGONE=1
- DO SA
- 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 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
- +2 if DGA#2
- WRITE !?3
- IF '(DGA#2)
- WRITE ?40
- +3 WRITE $EXTRACT($PIECE(J,"^",1),1,18)
- IF $DATA(^DG(405.6,+$PIECE(J,"^",2),0))
- WRITE " (",$EXTRACT($PIECE(^(0),"^",1),1,15),")"
- +4 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