BDGCEN30 ; IHS/ANMC/LJF - BED MOVEMENT LISTING ;
;;5.3;PIMS;;APR 26, 2002
;
LOOP ; loop thru movements and sort
NEW DGDT,DFN,IFN,SUB
;
; admissions, then transfers, then discharges
F SUB="AMV1","AMV2","AMV3" D
. S DGDT=BDGBD-.0001
. F S DGDT=$O(^DGPM(SUB,DGDT)) Q:'DGDT!(DGDT>BDGED) D
.. S DFN=0 F S DFN=$O(^DGPM(SUB,DGDT,DFN)) Q:'DFN D
... S IFN=0 F S IFN=$O(^DGPM(SUB,DGDT,DFN,IFN)) Q:'IFN D
.... S X=+$P($G(^DGPM(IFN,0)),U,14) ;pass admission ien
.... D DATA(X,DGDT,DFN,SUB,IFN)
Q
;
DATA(ADM,DATE,PAT,SUB,IFN) ; -- find data on entry and put into ^tmp
NEW NAME,WARD,X,OLD,NEW,QUIT
;
I BDGWD'="A" S QUIT=0 D Q:QUIT
. S NEW=$$GET1^DIQ(405,IFN,.06,"I") ;new ward
. S X=$$PRIORMVT^BDGF1(DATE,ADM,PAT) ;last physical movement
. I X S OLD=$$GET1^DIQ(405,X,.06,"I") ;last ward
. I SUB="AMV1",NEW'=BDGWD S QUIT=1 ;admission
. I SUB="AMV3",OLD'=BDGWD S QUIT=1 ;discharge
. I (NEW'=BDGWD)&(OLD'=BDGWD) S QUIT=1 ;transfers
;
S NAME=$$GET1^DIQ(2,PAT,.01) ;patient name
S X=$$PRIORMVT^BDGF1(DATE,ADM,PAT) ;last physical movement
Q:'X S WARD=$$GET1^DIQ(405,X,.06) ;last ward
S X=$$PRIORTXN^BDGF1(DATE,ADM,PAT) Q:'X ;last service transfers ien
;
; if newborn
I $$GET1^DIQ(405,X,.09)="NEWBORN" D Q
. ;
. ; and if death
. I $$GET1^DIQ(405,IFN,.04)["DEATH" D Q
.. S ^TMP("BDGCEN31",$J,WARD,"NBDT",DATE,NAME,DFN)="" Q
. ;
. ; if ward transfer
. I SUB="AMV2" D Q
.. ; if all wards selected
.. I BDGWD="A" D Q
... S ^TMP("BDGCEN31",$J,WARD,SUB,DATE,NAME,DFN)="" ;transfer out
... S X=$$GET1^DIQ(405,IFN,.06) ;new ward
... S ^TMP("BDGCEN31",$J,X,"NBTI",DATE,NAME,DFN)="" ;transfer in
.. ;
.. ; if just one ward selected
.. I OLD=BDGWD S ^TMP("BDGCEN31",$J,WARD,SUB,DATE,NAME,DFN)=""
.. S X=$$GET1^DIQ(405,IFN,.06) ;new ward
.. I NEW=BDGWD S ^TMP("BDGCEN31",$J,X,"NBTI",DATE,NAME,DFN)=""
. ;
. ; or other newborn transaction
. S ^TMP("BDGCEN31",$J,WARD,"NB"_SUB,DATE,NAME,DFN)=""
. ;
;
; else if other service
; and if death
I $$GET1^DIQ(405,IFN,.04)["DEATH" D Q
. S ^TMP("BDGCEN31",$J,WARD,"DT"_SUB,DATE,NAME,DFN)="" Q
;
; if ward transfer
I SUB="AMV2" D Q
. ; if all wards selected
. I BDGWD="A" D Q
.. S ^TMP("BDGCEN31",$J,WARD,SUB,DATE,NAME,DFN)="" ;transfer out
.. S X=$$GET1^DIQ(405,IFN,.06) ;new ward
.. S ^TMP("BDGCEN31",$J,X,"TI",DATE,NAME,DFN)="" ;transfer in
. ;
. ; if just one ward selected
. I OLD=BDGWD S ^TMP("BDGCEN31",$J,WARD,SUB,DATE,NAME,DFN)=""
. S X=$$GET1^DIQ(405,IFN,.06) ;new ward
. I NEW=BDGWD S ^TMP("BDGCEN31",$J,X,"TI",DATE,NAME,DFN)=""
;
; or other transaction
S ^TMP("BDGCEN31",$J,WARD,SUB,DATE,NAME,DFN)=""
Q
;
;
; Subscripts available for print routine:
; AMV1 = admission
; NBAMV1 = newborn admission
; AMV2 = transfer out
; NBAMV2 = newborn transfer out
; TI = transfer in
; NBTI = newborn transfer in
; AMV3 = discharge
; NBAMV2 = neborn discharge
; DT = death
; NBDT = newborn death
BDGCEN30 ; IHS/ANMC/LJF - BED MOVEMENT LISTING ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
LOOP ; loop thru movements and sort
+1 NEW DGDT,DFN,IFN,SUB
+2 ;
+3 ; admissions, then transfers, then discharges
+4 FOR SUB="AMV1","AMV2","AMV3"
Begin DoDot:1
+5 SET DGDT=BDGBD-.0001
+6 FOR
SET DGDT=$ORDER(^DGPM(SUB,DGDT))
IF 'DGDT!(DGDT>BDGED)
QUIT
Begin DoDot:2
+7 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM(SUB,DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+8 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM(SUB,DGDT,DFN,IFN))
IF 'IFN
QUIT
Begin DoDot:4
+9 ;pass admission ien
SET X=+$PIECE($GET(^DGPM(IFN,0)),U,14)
+10 DO DATA(X,DGDT,DFN,SUB,IFN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
DATA(ADM,DATE,PAT,SUB,IFN) ; -- find data on entry and put into ^tmp
+1 NEW NAME,WARD,X,OLD,NEW,QUIT
+2 ;
+3 IF BDGWD'="A"
SET QUIT=0
Begin DoDot:1
+4 ;new ward
SET NEW=$$GET1^DIQ(405,IFN,.06,"I")
+5 ;last physical movement
SET X=$$PRIORMVT^BDGF1(DATE,ADM,PAT)
+6 ;last ward
IF X
SET OLD=$$GET1^DIQ(405,X,.06,"I")
+7 ;admission
IF SUB="AMV1"
IF NEW'=BDGWD
SET QUIT=1
+8 ;discharge
IF SUB="AMV3"
IF OLD'=BDGWD
SET QUIT=1
+9 ;transfers
IF (NEW'=BDGWD)&(OLD'=BDGWD)
SET QUIT=1
End DoDot:1
IF QUIT
QUIT
+10 ;
+11 ;patient name
SET NAME=$$GET1^DIQ(2,PAT,.01)
+12 ;last physical movement
SET X=$$PRIORMVT^BDGF1(DATE,ADM,PAT)
+13 ;last ward
IF 'X
QUIT
SET WARD=$$GET1^DIQ(405,X,.06)
+14 ;last service transfers ien
SET X=$$PRIORTXN^BDGF1(DATE,ADM,PAT)
IF 'X
QUIT
+15 ;
+16 ; if newborn
+17 IF $$GET1^DIQ(405,X,.09)="NEWBORN"
Begin DoDot:1
+18 ;
+19 ; and if death
+20 IF $$GET1^DIQ(405,IFN,.04)["DEATH"
Begin DoDot:2
+21 SET ^TMP("BDGCEN31",$JOB,WARD,"NBDT",DATE,NAME,DFN)=""
QUIT
End DoDot:2
QUIT
+22 ;
+23 ; if ward transfer
+24 IF SUB="AMV2"
Begin DoDot:2
+25 ; if all wards selected
+26 IF BDGWD="A"
Begin DoDot:3
+27 ;transfer out
SET ^TMP("BDGCEN31",$JOB,WARD,SUB,DATE,NAME,DFN)=""
+28 ;new ward
SET X=$$GET1^DIQ(405,IFN,.06)
+29 ;transfer in
SET ^TMP("BDGCEN31",$JOB,X,"NBTI",DATE,NAME,DFN)=""
End DoDot:3
QUIT
+30 ;
+31 ; if just one ward selected
+32 IF OLD=BDGWD
SET ^TMP("BDGCEN31",$JOB,WARD,SUB,DATE,NAME,DFN)=""
+33 ;new ward
SET X=$$GET1^DIQ(405,IFN,.06)
+34 IF NEW=BDGWD
SET ^TMP("BDGCEN31",$JOB,X,"NBTI",DATE,NAME,DFN)=""
End DoDot:2
QUIT
+35 ;
+36 ; or other newborn transaction
+37 SET ^TMP("BDGCEN31",$JOB,WARD,"NB"_SUB,DATE,NAME,DFN)=""
+38 ;
End DoDot:1
QUIT
+39 ;
+40 ; else if other service
+41 ; and if death
+42 IF $$GET1^DIQ(405,IFN,.04)["DEATH"
Begin DoDot:1
+43 SET ^TMP("BDGCEN31",$JOB,WARD,"DT"_SUB,DATE,NAME,DFN)=""
QUIT
End DoDot:1
QUIT
+44 ;
+45 ; if ward transfer
+46 IF SUB="AMV2"
Begin DoDot:1
+47 ; if all wards selected
+48 IF BDGWD="A"
Begin DoDot:2
+49 ;transfer out
SET ^TMP("BDGCEN31",$JOB,WARD,SUB,DATE,NAME,DFN)=""
+50 ;new ward
SET X=$$GET1^DIQ(405,IFN,.06)
+51 ;transfer in
SET ^TMP("BDGCEN31",$JOB,X,"TI",DATE,NAME,DFN)=""
End DoDot:2
QUIT
+52 ;
+53 ; if just one ward selected
+54 IF OLD=BDGWD
SET ^TMP("BDGCEN31",$JOB,WARD,SUB,DATE,NAME,DFN)=""
+55 ;new ward
SET X=$$GET1^DIQ(405,IFN,.06)
+56 IF NEW=BDGWD
SET ^TMP("BDGCEN31",$JOB,X,"TI",DATE,NAME,DFN)=""
End DoDot:1
QUIT
+57 ;
+58 ; or other transaction
+59 SET ^TMP("BDGCEN31",$JOB,WARD,SUB,DATE,NAME,DFN)=""
+60 QUIT
+61 ;
+62 ;
+63 ; Subscripts available for print routine:
+64 ; AMV1 = admission
+65 ; NBAMV1 = newborn admission
+66 ; AMV2 = transfer out
+67 ; NBAMV2 = newborn transfer out
+68 ; TI = transfer in
+69 ; NBTI = newborn transfer in
+70 ; AMV3 = discharge
+71 ; NBAMV2 = neborn discharge
+72 ; DT = death
+73 ; NBDT = newborn death
