- 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
