- 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 Feb 19, 2025@00:15:52 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