DGPMRB ;ALB/MRL,MIR - ROOM-BED DETERMINATION (SINGLE WARD); 9 JAN 89
;;5.3;Registration;**54**;Aug 13, 1993
N I,I1,J,L,M,W,Y
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))
W !!,"CHOOSE FROM",!
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
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
I 'DGA W !!,"There are no available beds on this ward."
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
I '$D(^UTILITY("DGPMLD",$J)) G Q
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."
W ! S DGL=1,DGR=0 F I1=0:0 S DGR=$O(^UTILITY("DGPMLD",$J,DGR)) Q:DGR="" S J=^(DGR) D LOD
G Q
;
ACT S DGU=1,Y=I D OCC I 'DGPMOC S DGU=0
S M=$O(^DGPM("ARM",I,0)) I M,^(M) D LDGER Q
I DGU Q
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
I DGU Q
S DGA=DGA+1 Q
;
AVAIL I +DGPMDD("D")'>DGPMDD,$S('$P(DGPMDD("D"),"^",4):1,$P(DGPMDD("D"),"^",4)>DGPMDD:1,1:0) S DGU=1
Q
;
DIS 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
LOD 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 "."
I DGL W !?3,"[Occupied by lodger patient '",$P(J,"^",4),"' SSN: ",$S($P(J,"^",5)]"":$P(J,"^",5),1:"UNKNOWN"),"]"
I '(DGA#15) D READ
Q
LDGER ;create UTILITY for lodgers
;J=ROOM-BED NAME^DESCRIPTION^T.S
N DFN
Q:'$D(^DGPM(+M,0)) S DFN=+$P(^(0),"^",3)
S ^UTILITY("DGPMLD",$J,DGR)=J
I $D(^DPT(DFN,0)) S ^UTILITY("DGPMLD",$J,DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_$P(^DPT(DFN,0),"^",1)
D PID^VADPT6 S ^(DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_VA("PID")
Q
Q K DGA,DGFL,DGHOW,DGL,DGPMDD,DGR,DGU,VA
Q1 K ^UTILITY("DGPMLD",$J) Q
DD ;
S DGX=X,DGPMOS=+^DGPM(DA,0),D0=+X D RIN^DGPMDDCF K DGPMOS
I X W "...INACTIVE" K X,DGX Q
S X=DGX K DGX
Q
READ ;prompt to continue
W !,"Enter RETURN to continue or '^' to exit: " R DGPMX:DTIME S:'$T!(DGPMX["^") DGFL=1
I DGPMX["?" W !!?5,"Enter either RETURN or '^'",! G READ
K DGPMX Q
;
;
OCC ;is bed occupied
;
; INPUT: DA...ifn of DGPM entry
;OUTPUT: DGPMOC...1 if occupied, 0 if not
;
N DFN S DGPMOC=0
S DFN=$P(^DGPM(DA,0),"^",3) I 'DFN G OCCQ
S DGPMX=$O(^DGPM("ARM",+Y,0)) I '$D(^DGPM(+DGPMX,0)) G OCCQ
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
S DGPMOC=1
OCCQ K DGPMX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMRB 3146 printed Dec 13, 2024@02:49:50 Page 2
DGPMRB ;ALB/MRL,MIR - ROOM-BED DETERMINATION (SINGLE WARD); 9 JAN 89
+1 ;;5.3;Registration;**54**;Aug 13, 1993
+2 NEW I,I1,J,L,M,W,Y
+3 DO Q
SET DGHOW=$SELECT(('$DATA(X)#2):1,X["??":0,1:1)
SET DGPMDD=$SELECT('$DATA(DGSWITCH):+^DGPM(DA,0),1:DT)
SET W=+$PIECE(^DGPM(DA,0),"^",6)
SET (DGL,DGA,DGFL)=0
if '$DATA(^DIC(42,+W,0))
GOTO Q
+4 WRITE !!,"CHOOSE FROM",!
+5 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
DO DIS
+6 IF DGA
WRITE !!,"Select from the above listing the bed you wish to assign this patient."
IF DGHOW
WRITE !,"Enter two question marks for a more detailed list of available beds."
GOTO Q
+7 IF 'DGA
WRITE !!,"There are no available beds on this ward."
+8 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)
WRITE !,"Scheduled Admission for "
if $DATA(^DPT(+J,0))
WRITE $PIECE(^(0),"^",1)," -- ",$PIECE(^(0),"^",9)
SET Y=$PIECE(J,"^",2)
IF J
WRITE " on "
DO DT^DIQ
+9 IF '$DATA(^UTILITY("DGPMLD",$JOB))
GOTO Q
+10 WRITE !,"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."
+11 WRITE !
SET DGL=1
SET DGR=0
FOR I1=0:0
SET DGR=$ORDER(^UTILITY("DGPMLD",$JOB,DGR))
if DGR=""
QUIT
SET J=^(DGR)
DO LOD
+12 GOTO Q
+13 ;
ACT SET DGU=1
SET Y=I
DO OCC
IF 'DGPMOC
SET DGU=0
+1 SET M=$ORDER(^DGPM("ARM",I,0))
IF M
IF ^(M)
DO LDGER
QUIT
+2 IF DGU
QUIT
+3 SET DGU=0
SET X=$ORDER(^DG(405.4,I,"I","AINV",9999999-DGPMDD))
SET X=$ORDER(^(+X,0))
IF $DATA(^DG(405.4,I,"I",+X,0))
SET DGPMDD("D")=^(0)
DO AVAIL
+4 IF DGU
QUIT
+5 SET DGA=DGA+1
QUIT
+6 ;
AVAIL IF +DGPMDD("D")'>DGPMDD
IF $SELECT('$PIECE(DGPMDD("D"),"^",4):1,$PIECE(DGPMDD("D"),"^",4)>DGPMDD:1,1:0)
SET DGU=1
+1 QUIT
+2 ;
DIS if DGA=1
WRITE !?3
IF DGHOW
SET $PIECE(J,"^",1)=$EXTRACT($PIECE(J,"^",1)_" ",1,18)
if $X+$LENGTH($PIECE(J,"^",1))>79
WRITE !?3
WRITE $PIECE(J,"^",1)
QUIT
LOD WRITE !?3,DGR,", (",$SELECT($DATA(^DG(405.6,+$PIECE(J,"^",2),0)):$PIECE(^(0),"^",1),1:"NO DESCRIPTION"),")"
if $DATA(^DIC(45.7,+$PIECE(J,"^",3),0))
WRITE ",",$PIECE(^(0),"^",1)
WRITE "."
+1 IF DGL
WRITE !?3,"[Occupied by lodger patient '",$PIECE(J,"^",4),"' SSN: ",$SELECT($PIECE(J,"^",5)]"":$PIECE(J,"^",5),1:"UNKNOWN"),"]"
+2 IF '(DGA#15)
DO READ
+3 QUIT
LDGER ;create UTILITY for lodgers
+1 ;J=ROOM-BED NAME^DESCRIPTION^T.S
+2 NEW DFN
+3 if '$DATA(^DGPM(+M,0))
QUIT
SET DFN=+$PIECE(^(0),"^",3)
+4 SET ^UTILITY("DGPMLD",$JOB,DGR)=J
+5 IF $DATA(^DPT(DFN,0))
SET ^UTILITY("DGPMLD",$JOB,DGR)=^UTILITY("DGPMLD",$JOB,DGR)_"^"_$PIECE(^DPT(DFN,0),"^",1)
+6 DO PID^VADPT6
SET ^(DGR)=^UTILITY("DGPMLD",$JOB,DGR)_"^"_VA("PID")
+7 QUIT
Q KILL DGA,DGFL,DGHOW,DGL,DGPMDD,DGR,DGU,VA
Q1 KILL ^UTILITY("DGPMLD",$JOB)
QUIT
DD ;
+1 SET DGX=X
SET DGPMOS=+^DGPM(DA,0)
SET D0=+X
DO RIN^DGPMDDCF
KILL DGPMOS
+2 IF X
WRITE "...INACTIVE"
KILL X,DGX
QUIT
+3 SET X=DGX
KILL DGX
+4 QUIT
READ ;prompt to continue
+1 WRITE !,"Enter RETURN to continue or '^' to exit: "
READ DGPMX:DTIME
if '$TEST!(DGPMX["^")
SET DGFL=1
+2 IF DGPMX["?"
WRITE !!?5,"Enter either RETURN or '^'",!
GOTO READ
+3 KILL DGPMX
QUIT
+4 ;
+5 ;
OCC ;is bed occupied
+1 ;
+2 ; INPUT: DA...ifn of DGPM entry
+3 ;OUTPUT: DGPMOC...1 if occupied, 0 if not
+4 ;
+5 NEW DFN
SET DGPMOC=0
+6 SET DFN=$PIECE(^DGPM(DA,0),"^",3)
IF 'DFN
GOTO OCCQ
+7 SET DGPMX=$ORDER(^DGPM("ARM",+Y,0))
IF '$DATA(^DGPM(+DGPMX,0))
GOTO OCCQ
+8 SET DGPMX=^(0)
IF DFN=$PIECE(DGPMX,"^",3)
IF ($DATA(^DG(405.4,+Y,"W","B",+$PIECE(^DGPM(DA,0),"^",6))))
SET DGPMOC=0
GOTO OCCQ
+9 SET DGPMOC=1
OCCQ KILL DGPMX
QUIT
