BDGIPL31 ; IHS/ANMC/LJF - CALCULATE LIST BY WARD/ROOM ;
;;5.3;PIMS;**1019**;APR 26, 2002;Build 3
;
NEW DGWST
K ^TMP("BDGIPL1",$J)
S DGWST=$P(BDGSRT,U)
;
; do all wards or just one
D AWD:'DGWST,OWD:DGWST
;
; pending surgery patients that have not been released from OR yet
I $O(^SRF("AC",DT-.0001))[DT D PEND
;
Q ;return to INIT^BDGIPL3
;
AWD ; -- all wards
NEW WD,WARD,DFN
; loop thru room file to set up ward/room/bed array
S WD=0 F S WD=$O(^DG(405.4,"W",WD)) Q:'WD D
. I $$ACTWD^BDGPAR(WD) D ROOMS(WD)
;
; loop thru inpatients
S WARD="" F S WARD=$O(^DPT("CN",WARD)) Q:WARD="" D
. S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN D PAT
Q
;
OWD ; -- one ward
NEW WD,WARD,DFN
S WD=DGWST D ROOMS(WD)
S WARD=$$GET1^DIQ(42,WD,.01)
S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN D PAT
Q
;
ROOMS(WD) ; loop thru rooms in a ward
NEW RB,WARD,RMBD,ORDER
S RB=0 F S RB=$O(^DG(405.4,"W",WD,RB)) Q:'RB D:'$$OOSB(RB)
. S WARD=$$GET1^DIQ(42,WD,.01),ORDER=$$GET1^DIQ(42,WD,400)
. S RMBD=$$GET1^DIQ(405.4,RB,.01) ;names
. Q:'$$MULTUSE(WARD,+RB)
. S ^TMP("BDGIPL1",$J,"BED",ORDER,WARD,RMBD)=""
Q
;
PAT ; set inpatients into array by ward/room
NEW RM
S RM=$G(^DPT(DFN,.1))_";"_$G(^DPT(DFN,.101))
;
;--no room-bed
I $P(RM,";",2)="" D Q
. S ^TMP("BDGIPL1",$J,"PAT",RM,DFN)=DFN
;
;--with room-bed
S ^TMP("BDGIPL1",$J,"PAT",RM)=DFN
Q
;
;
OOSB(Y) ; -- bed out of service
Q:'$D(^DG(405.4,Y,"I","AINV")) 0
N X S X=$G(^DG(405.4,Y,"I",+$O(^($O(^("AINV",0)),0)),0)) Q:'X 0
Q $S($P(X,U,4)=DT:0,$P(X,U,4)&($P(X,U,4)<DT):0,X=DT:0,X<DT:1,1:0)
;
INACT(Y) ; -- ward inactive?
Q '$$ACTWD^BDGPAR(Y)
;
MULTUSE(W,R) ; -- don't print if room-bed used by other wards
;
; is there more than one entry in ward multiple, if no quit 1
I '$O(^DG(405.4,R,"W",+$O(^DG(405.4,R,"W",0)))) Q 1
;
; is the room currently occupied by any ward? if no, quit 1
NEW X S X=$O(^DGPM("ARM",R,0)) I 'X Q 1 ;IHS/OIT/CLS 05/20/2014 check all availability 1019
;
; is the room currently occupied? if no, quit 0
NEW X S X=$O(^DPT("RM",$P(^DG(405.4,R,0),U),0)) I 'X Q 0
;
; is this patient in this ward? if no, quit 0
I '$D(^DPT("CN",W,X)) Q 0
;
;quit yes because this multi-use room is occupied by pt. on this ward
Q 1
;
PEND ;EP; -- pending SDA/DSO/DSU patients for ward
NEW SDT,END,IEN,SRV,X,WARD,STAT,AGE,DFN
S SDT=DT-.0001,END=DT+.2400
F S SDT=$O(^SRF("AC",SDT)) Q:'SDT!(SDT>END) D
. S IEN=0 F S IEN=$O(^SRF("AC",SDT,IEN)) Q:'IEN D
.. ;
.. ; only include SDA/SDO/DSU who are scheduled or checked-in
.. Q:$$GET1^DIQ(130,IEN,17)]"" ;has cancel date
.. S STAT=$$GET1^DIQ(130,IEN,.011,"I") ;patient status
.. I (STAT'="DSO"),(STAT'="DSU"),(STAT'="SDA") Q
.. S X=$$GET1^DIQ(130,IEN,9999999.06,"I") I (X'="SC"),(X'="CI") Q
.. ;
.. ; only keep those for appropriate ward
.. S DFN=$$GET1^DIQ(130,IEN,.01,"I"),AGE=$$GET1^DIQ(2,DFN,.033)
.. S SRV=$$GET1^DIQ(130,IEN,.04,"I")
.. S WARD=$$GET1^DIQ(137.45,SRV,$S(AGE<15:9999999.03,1:9999999.02),"I")
.. I SRV,DGWST,WARD Q:WARD'=DGWST ;surgery not associated with ward
.. S WARD=$$GET1^DIQ(137.45,SRV,$S(AGE<15:9999999.03,1:9999999.02))_";"
.. ;
.. NEW DGRR D ENP^XBDIQ1(130,IEN,".01;.04;.14;10;26","DGRR(","I")
.. S X="P"_$P(DGRR(10),"@",2)_";"_DFN ;p+time+dfn
.. S ^TMP("BDGIPL1",$J,"PAT",WARD,X)=DFN_U_DGRR(.01)_U_STAT_U_DGRR(.04)_U_DGRR(26)_U_DGRR(.14)_U_DGRR(10,"I")
Q
BDGIPL31 ; IHS/ANMC/LJF - CALCULATE LIST BY WARD/ROOM ;
+1 ;;5.3;PIMS;**1019**;APR 26, 2002;Build 3
+2 ;
+3 NEW DGWST
+4 KILL ^TMP("BDGIPL1",$JOB)
+5 SET DGWST=$PIECE(BDGSRT,U)
+6 ;
+7 ; do all wards or just one
+8 IF 'DGWST
DO AWD
IF DGWST
DO OWD
+9 ;
+10 ; pending surgery patients that have not been released from OR yet
+11 IF $ORDER(^SRF("AC",DT-.0001))[DT
DO PEND
+12 ;
+13 ;return to INIT^BDGIPL3
QUIT
+14 ;
AWD ; -- all wards
+1 NEW WD,WARD,DFN
+2 ; loop thru room file to set up ward/room/bed array
+3 SET WD=0
FOR
SET WD=$ORDER(^DG(405.4,"W",WD))
IF 'WD
QUIT
Begin DoDot:1
+4 IF $$ACTWD^BDGPAR(WD)
DO ROOMS(WD)
End DoDot:1
+5 ;
+6 ; loop thru inpatients
+7 SET WARD=""
FOR
SET WARD=$ORDER(^DPT("CN",WARD))
IF WARD=""
QUIT
Begin DoDot:1
+8 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
DO PAT
End DoDot:1
+9 QUIT
+10 ;
OWD ; -- one ward
+1 NEW WD,WARD,DFN
+2 SET WD=DGWST
DO ROOMS(WD)
+3 SET WARD=$$GET1^DIQ(42,WD,.01)
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
DO PAT
+5 QUIT
+6 ;
ROOMS(WD) ; loop thru rooms in a ward
+1 NEW RB,WARD,RMBD,ORDER
+2 SET RB=0
FOR
SET RB=$ORDER(^DG(405.4,"W",WD,RB))
IF 'RB
QUIT
IF '$$OOSB(RB)
Begin DoDot:1
+3 SET WARD=$$GET1^DIQ(42,WD,.01)
SET ORDER=$$GET1^DIQ(42,WD,400)
+4 ;names
SET RMBD=$$GET1^DIQ(405.4,RB,.01)
+5 IF '$$MULTUSE(WARD,+RB)
QUIT
+6 SET ^TMP("BDGIPL1",$JOB,"BED",ORDER,WARD,RMBD)=""
End DoDot:1
+7 QUIT
+8 ;
PAT ; set inpatients into array by ward/room
+1 NEW RM
+2 SET RM=$GET(^DPT(DFN,.1))_";"_$GET(^DPT(DFN,.101))
+3 ;
+4 ;--no room-bed
+5 IF $PIECE(RM,";",2)=""
Begin DoDot:1
+6 SET ^TMP("BDGIPL1",$JOB,"PAT",RM,DFN)=DFN
End DoDot:1
QUIT
+7 ;
+8 ;--with room-bed
+9 SET ^TMP("BDGIPL1",$JOB,"PAT",RM)=DFN
+10 QUIT
+11 ;
+12 ;
OOSB(Y) ; -- bed out of service
+1 IF '$DATA(^DG(405.4,Y,"I","AINV"))
QUIT 0
+2 NEW X
SET X=$GET(^DG(405.4,Y,"I",+$ORDER(^($ORDER(^("AINV",0)),0)),0))
IF 'X
QUIT 0
+3 QUIT $SELECT($PIECE(X,U,4)=DT:0,$PIECE(X,U,4)&($PIECE(X,U,4)<DT):0,X=DT:0,X<DT:1,1:0)
+4 ;
INACT(Y) ; -- ward inactive?
+1 QUIT '$$ACTWD^BDGPAR(Y)
+2 ;
MULTUSE(W,R) ; -- don't print if room-bed used by other wards
+1 ;
+2 ; is there more than one entry in ward multiple, if no quit 1
+3 IF '$ORDER(^DG(405.4,R,"W",+$ORDER(^DG(405.4,R,"W",0))))
QUIT 1
+4 ;
+5 ; is the room currently occupied by any ward? if no, quit 1
+6 ;IHS/OIT/CLS 05/20/2014 check all availability 1019
NEW X
SET X=$ORDER(^DGPM("ARM",R,0))
IF 'X
QUIT 1
+7 ;
+8 ; is the room currently occupied? if no, quit 0
+9 NEW X
SET X=$ORDER(^DPT("RM",$PIECE(^DG(405.4,R,0),U),0))
IF 'X
QUIT 0
+10 ;
+11 ; is this patient in this ward? if no, quit 0
+12 IF '$DATA(^DPT("CN",W,X))
QUIT 0
+13 ;
+14 ;quit yes because this multi-use room is occupied by pt. on this ward
+15 QUIT 1
+16 ;
PEND ;EP; -- pending SDA/DSO/DSU patients for ward
+1 NEW SDT,END,IEN,SRV,X,WARD,STAT,AGE,DFN
+2 SET SDT=DT-.0001
SET END=DT+.2400
+3 FOR
SET SDT=$ORDER(^SRF("AC",SDT))
IF 'SDT!(SDT>END)
QUIT
Begin DoDot:1
+4 SET IEN=0
FOR
SET IEN=$ORDER(^SRF("AC",SDT,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 ;
+6 ; only include SDA/SDO/DSU who are scheduled or checked-in
+7 ;has cancel date
IF $$GET1^DIQ(130,IEN,17)]""
QUIT
+8 ;patient status
SET STAT=$$GET1^DIQ(130,IEN,.011,"I")
+9 IF (STAT'="DSO")
IF (STAT'="DSU")
IF (STAT'="SDA")
QUIT
+10 SET X=$$GET1^DIQ(130,IEN,9999999.06,"I")
IF (X'="SC")
IF (X'="CI")
QUIT
+11 ;
+12 ; only keep those for appropriate ward
+13 SET DFN=$$GET1^DIQ(130,IEN,.01,"I")
SET AGE=$$GET1^DIQ(2,DFN,.033)
+14 SET SRV=$$GET1^DIQ(130,IEN,.04,"I")
+15 SET WARD=$$GET1^DIQ(137.45,SRV,$SELECT(AGE<15:9999999.03,1:9999999.02),"I")
+16 ;surgery not associated with ward
IF SRV
IF DGWST
IF WARD
IF WARD'=DGWST
QUIT
+17 SET WARD=$$GET1^DIQ(137.45,SRV,$SELECT(AGE<15:9999999.03,1:9999999.02))_";"
+18 ;
+19 NEW DGRR
DO ENP^XBDIQ1(130,IEN,".01;.04;.14;10;26","DGRR(","I")
+20 ;p+time+dfn
SET X="P"_$PIECE(DGRR(10),"@",2)_";"_DFN
+21 SET ^TMP("BDGIPL1",$JOB,"PAT",WARD,X)=DFN_U_DGRR(.01)_U_STAT_U_DGRR(.04)_U_DGRR(26)_U_DGRR(.14)_U_DGRR(10,"I")
End DoDot:2
End DoDot:1
+22 QUIT
