Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPMRB

DGPMRB.m

Go to the documentation of this file.
  1. DGPMRB ;ALB/MRL,MIR - ROOM-BED DETERMINATION (SINGLE WARD); 9 JAN 89
  1. ;;5.3;Registration;**54**;Aug 13, 1993
  1. N I,I1,J,L,M,W,Y
  1. 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))
  1. W !!,"CHOOSE FROM",!
  1. 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
  1. 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
  1. I 'DGA W !!,"There are no available beds on this ward."
  1. 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
  1. I '$D(^UTILITY("DGPMLD",$J)) G Q
  1. 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."
  1. W ! S DGL=1,DGR=0 F I1=0:0 S DGR=$O(^UTILITY("DGPMLD",$J,DGR)) Q:DGR="" S J=^(DGR) D LOD
  1. G Q
  1. ;
  1. ACT S DGU=1,Y=I D OCC I 'DGPMOC S DGU=0
  1. S M=$O(^DGPM("ARM",I,0)) I M,^(M) D LDGER Q
  1. I DGU Q
  1. 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
  1. I DGU Q
  1. S DGA=DGA+1 Q
  1. ;
  1. AVAIL I +DGPMDD("D")'>DGPMDD,$S('$P(DGPMDD("D"),"^",4):1,$P(DGPMDD("D"),"^",4)>DGPMDD:1,1:0) S DGU=1
  1. Q
  1. ;
  1. 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
  1. 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 "."
  1. I DGL W !?3,"[Occupied by lodger patient '",$P(J,"^",4),"' SSN: ",$S($P(J,"^",5)]"":$P(J,"^",5),1:"UNKNOWN"),"]"
  1. I '(DGA#15) D READ
  1. Q
  1. LDGER ;create UTILITY for lodgers
  1. ;J=ROOM-BED NAME^DESCRIPTION^T.S
  1. N DFN
  1. Q:'$D(^DGPM(+M,0)) S DFN=+$P(^(0),"^",3)
  1. S ^UTILITY("DGPMLD",$J,DGR)=J
  1. I $D(^DPT(DFN,0)) S ^UTILITY("DGPMLD",$J,DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_$P(^DPT(DFN,0),"^",1)
  1. D PID^VADPT6 S ^(DGR)=^UTILITY("DGPMLD",$J,DGR)_"^"_VA("PID")
  1. Q
  1. Q K DGA,DGFL,DGHOW,DGL,DGPMDD,DGR,DGU,VA
  1. Q1 K ^UTILITY("DGPMLD",$J) Q
  1. DD ;
  1. S DGX=X,DGPMOS=+^DGPM(DA,0),D0=+X D RIN^DGPMDDCF K DGPMOS
  1. I X W "...INACTIVE" K X,DGX Q
  1. S X=DGX K DGX
  1. Q
  1. READ ;prompt to continue
  1. W !,"Enter RETURN to continue or '^' to exit: " R DGPMX:DTIME S:'$T!(DGPMX["^") DGFL=1
  1. I DGPMX["?" W !!?5,"Enter either RETURN or '^'",! G READ
  1. K DGPMX Q
  1. ;
  1. ;
  1. OCC ;is bed occupied
  1. ;
  1. ; INPUT: DA...ifn of DGPM entry
  1. ;OUTPUT: DGPMOC...1 if occupied, 0 if not
  1. ;
  1. N DFN S DGPMOC=0
  1. S DFN=$P(^DGPM(DA,0),"^",3) I 'DFN G OCCQ
  1. S DGPMX=$O(^DGPM("ARM",+Y,0)) I '$D(^DGPM(+DGPMX,0)) G OCCQ
  1. 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
  1. S DGPMOC=1
  1. OCCQ K DGPMX Q