BDGAD2 ; IHS/ANMC/LJF - A&D WARD TRANSFERS ; [ 02/10/2005 4:05 PM ]
;;5.3;PIMS;**1001,1002,1012,1019**;APR 26, 2002;Build 3
;
LOOP ;--loop ward transfers
NEW DGDT,DFN,IFN
S DGDT=DGBEG
F S DGDT=$O(^DGPM("AMV2",DGDT)) Q:'DGDT!(DGDT>DGEND) D
. S DFN=0 F S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV2",DGDT,DFN,IFN)) Q:'IFN D GATHER
Q
;
GATHER ; gather info on ward transfers and put counts into arrays
NEW ADM,ADULT,NEWWD,OLDWD,OLDSV,OLDSVN,NEWSV,NEWSVN,X,NAME,LOS
S ADM=$P(^DGPM(IFN,0),U,14) ;admit ien
S ADULT=$S($$AGE<$$ADULT^BDGPAR:0,1:1) ;1=adult, 0=peds
;
;S NEWWD=$P($G(^DGPM(IFN,0)),U,6) I 'NEWWD S NEWWD="??" ;new ward cmi/maw 4/23/2010 orig line
S NEWWD=$P($G(^DGPM(IFN,0)),U,6) Q:'NEWWD ;new ward cmi/maw 4/23/2010 new ling
S OLDWD=$P($G(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)),U,6) ;old ward
Q:'$G(OLDWD) ;cmi/maw 4/23/2010 if old ward is blank patch 1012
;
S OLDSV=$P(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9) ;old srv
Q:'$G(OLDSV) ;cmi/maw 4/23/2010 if old service is blank PATCH 1012
S X=$O(^DGPM("AMV6",DGDT,DFN,0))
S NEWSV=$S('X:OLDSV,X:$P($G(^DGPM(X,0)),U,9),1:OLDSV) ;new srv
;IHS/ITSC/WAR 1/21/2005 PATCH #1002 Added next line, defensive code for Pc9 being NULL (only a bed change on transfer record)
; Interward change - has no ward change, nor srv change
I 'NEWSV S NEWSV=OLDSV
S OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)
S NEWSVN=$$GET1^DIQ(45.7,NEWSV,.01)
;
S LOS=$$FMDIFF^XLFDT(DGDT,+$G(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)))
;
; collect patient data for report
S NAME=$$GET1^DIQ(2,DFN,.01)
Q:$$DEMO^APCLUTL(DFN,"E") ;ihs/cmi/maw patch 1019
S ^TMP("BDGAD",$J,"WARD",NAME,DFN,IFN)=OLDWD_U_NEWWD
I OLDSV'=NEWSV S ^TMP("BDGAD",$J,"SERV",NAME,DFN,IFN)=OLDSV_U_NEWSV ;IHS/ITSC/LJF 7/7/2004 PATCH #1001
Q:$G(BDGREP) ;reprint, not recalculating
;
; -- increment counts in ADT Census files
; --- transfer in to new ward
S $P(^BDGCWD(NEWWD,1,BDGT,0),U,5)=$P($G(^BDGCWD(NEWWD,1,BDGT,0)),U,5)+1
;
; --- transfer in for service within ward by age
; ---- set zero node if needed
I '$D(^BDGCWD(NEWWD,1,BDGT,1,NEWSV)) D
. S ^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)=NEWSV
. S $P(^BDGCWD(NEWWD,1,BDGT,1,0),U,3,4)=NEWSV_U_($P(^BDGCWD(NEWWD,1,BDGT,1,0),U,4)+1)
;
I '$D(^BDGCTX(NEWSV,1,BDGT,0)) D
. S ^BDGCTX(NEWSV,1,BDGT,0)=BDGT
I ADULT D
. S $P(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,5)=$P($G(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,5)+1
. I NEWSV'=OLDSV S $P(^BDGCTX(NEWSV,1,BDGT,0),U,5)=$P($G(^BDGCTX(NEWSV,1,BDGT,0)),U,5)+1
I 'ADULT D
. S $P(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,15)=$P($G(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,15)+1
. I NEWSV'=OLDSV S $P(^BDGCTX(NEWSV,1,BDGT,0),U,15)=$P($G(^BDGCTX(NEWSV,1,BDGT,0)),U,15)+1
;
;
; --- transfer out of old ward
S $P(^BDGCWD(OLDWD,1,BDGT,0),U,6)=$P($G(^BDGCWD(OLDWD,1,BDGT,0)),U,6)+1
; ---- increment LOS for old ward
S $P(^BDGCWD(OLDWD,1,BDGT,0),U,9)=$P($G(^BDGCWD(OLDWD,1,BDGT,0)),U,9)+LOS
;
; --- increment transfer out for service with in ward by age
; ---- set zero node if needed
I '$D(^BDGCWD(OLDWD,1,BDGT,1,OLDSV)) D
. S ^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)=OLDSV
. S $P(^BDGCWD(OLDWD,1,BDGT,1,0),U,3,4)=OLDSV_U_($P(^BDGCWD(OLDWD,1,BDGT,1,0),U,4)+1)
;
I ADULT D
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,6)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,6)+1
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,9)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,9)+LOS
. I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,6)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,6)+1
. I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,9)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,9)+LOS
;
I 'ADULT D
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,16)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,16)+1
. S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,19)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,19)+LOS
. I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,16)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,16)+1
. I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,19)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,19)+LOS
;
Q
;
AGE() ;--age at admit
NEW X,X1,X2
S X1=+$G(^DGPM(ADM,0)) ;admit date
S X2=$P($G(^DPT(DFN,0)),U,3) D ^%DTC ;date of birth
Q:'X "" Q X\365.25
;
BDGAD2 ; IHS/ANMC/LJF - A&D WARD TRANSFERS ; [ 02/10/2005 4:05 PM ]
+1 ;;5.3;PIMS;**1001,1002,1012,1019**;APR 26, 2002;Build 3
+2 ;
LOOP ;--loop ward transfers
+1 NEW DGDT,DFN,IFN
+2 SET DGDT=DGBEG
+3 FOR
SET DGDT=$ORDER(^DGPM("AMV2",DGDT))
IF 'DGDT!(DGDT>DGEND)
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV2",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+5 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV2",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO GATHER
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
GATHER ; gather info on ward transfers and put counts into arrays
+1 NEW ADM,ADULT,NEWWD,OLDWD,OLDSV,OLDSVN,NEWSV,NEWSVN,X,NAME,LOS
+2 ;admit ien
SET ADM=$PIECE(^DGPM(IFN,0),U,14)
+3 ;1=adult, 0=peds
SET ADULT=$SELECT($$AGE<$$ADULT^BDGPAR:0,1:1)
+4 ;
+5 ;S NEWWD=$P($G(^DGPM(IFN,0)),U,6) I 'NEWWD S NEWWD="??" ;new ward cmi/maw 4/23/2010 orig line
+6 ;new ward cmi/maw 4/23/2010 new ling
SET NEWWD=$PIECE($GET(^DGPM(IFN,0)),U,6)
IF 'NEWWD
QUIT
+7 ;old ward
SET OLDWD=$PIECE($GET(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)),U,6)
+8 ;cmi/maw 4/23/2010 if old ward is blank patch 1012
IF '$GET(OLDWD)
QUIT
+9 ;
+10 ;old srv
SET OLDSV=$PIECE(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9)
+11 ;cmi/maw 4/23/2010 if old service is blank PATCH 1012
IF '$GET(OLDSV)
QUIT
+12 SET X=$ORDER(^DGPM("AMV6",DGDT,DFN,0))
+13 ;new srv
SET NEWSV=$SELECT('X:OLDSV,X:$PIECE($GET(^DGPM(X,0)),U,9),1:OLDSV)
+14 ;IHS/ITSC/WAR 1/21/2005 PATCH #1002 Added next line, defensive code for Pc9 being NULL (only a bed change on transfer record)
+15 ; Interward change - has no ward change, nor srv change
+16 IF 'NEWSV
SET NEWSV=OLDSV
+17 SET OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)
+18 SET NEWSVN=$$GET1^DIQ(45.7,NEWSV,.01)
+19 ;
+20 SET LOS=$$FMDIFF^XLFDT(DGDT,+$GET(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)))
+21 ;
+22 ; collect patient data for report
+23 SET NAME=$$GET1^DIQ(2,DFN,.01)
+24 ;ihs/cmi/maw patch 1019
IF $$DEMO^APCLUTL(DFN,"E")
QUIT
+25 SET ^TMP("BDGAD",$JOB,"WARD",NAME,DFN,IFN)=OLDWD_U_NEWWD
+26 ;IHS/ITSC/LJF 7/7/2004 PATCH #1001
IF OLDSV'=NEWSV
SET ^TMP("BDGAD",$JOB,"SERV",NAME,DFN,IFN)=OLDSV_U_NEWSV
+27 ;reprint, not recalculating
IF $GET(BDGREP)
QUIT
+28 ;
+29 ; -- increment counts in ADT Census files
+30 ; --- transfer in to new ward
+31 SET $PIECE(^BDGCWD(NEWWD,1,BDGT,0),U,5)=$PIECE($GET(^BDGCWD(NEWWD,1,BDGT,0)),U,5)+1
+32 ;
+33 ; --- transfer in for service within ward by age
+34 ; ---- set zero node if needed
+35 IF '$DATA(^BDGCWD(NEWWD,1,BDGT,1,NEWSV))
Begin DoDot:1
+36 SET ^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)=NEWSV
+37 SET $PIECE(^BDGCWD(NEWWD,1,BDGT,1,0),U,3,4)=NEWSV_U_($PIECE(^BDGCWD(NEWWD,1,BDGT,1,0),U,4)+1)
End DoDot:1
+38 ;
+39 IF '$DATA(^BDGCTX(NEWSV,1,BDGT,0))
Begin DoDot:1
+40 SET ^BDGCTX(NEWSV,1,BDGT,0)=BDGT
End DoDot:1
+41 IF ADULT
Begin DoDot:1
+42 SET $PIECE(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,5)=$PIECE($GET(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,5)+1
+43 IF NEWSV'=OLDSV
SET $PIECE(^BDGCTX(NEWSV,1,BDGT,0),U,5)=$PIECE($GET(^BDGCTX(NEWSV,1,BDGT,0)),U,5)+1
End DoDot:1
+44 IF 'ADULT
Begin DoDot:1
+45 SET $PIECE(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,15)=$PIECE($GET(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,15)+1
+46 IF NEWSV'=OLDSV
SET $PIECE(^BDGCTX(NEWSV,1,BDGT,0),U,15)=$PIECE($GET(^BDGCTX(NEWSV,1,BDGT,0)),U,15)+1
End DoDot:1
+47 ;
+48 ;
+49 ; --- transfer out of old ward
+50 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,6)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,0)),U,6)+1
+51 ; ---- increment LOS for old ward
+52 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,9)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,0)),U,9)+LOS
+53 ;
+54 ; --- increment transfer out for service with in ward by age
+55 ; ---- set zero node if needed
+56 IF '$DATA(^BDGCWD(OLDWD,1,BDGT,1,OLDSV))
Begin DoDot:1
+57 SET ^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)=OLDSV
+58 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,0),U,3,4)=OLDSV_U_($PIECE(^BDGCWD(OLDWD,1,BDGT,1,0),U,4)+1)
End DoDot:1
+59 ;
+60 IF ADULT
Begin DoDot:1
+61 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,6)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,6)+1
+62 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,9)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,9)+LOS
+63 IF OLDSV'=NEWSV
SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,6)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,6)+1
+64 IF OLDSV'=NEWSV
SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,9)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,9)+LOS
End DoDot:1
+65 ;
+66 IF 'ADULT
Begin DoDot:1
+67 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,16)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,16)+1
+68 SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,19)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,19)+LOS
+69 IF OLDSV'=NEWSV
SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,16)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,16)+1
+70 IF OLDSV'=NEWSV
SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,19)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,19)+LOS
End DoDot:1
+71 ;
+72 QUIT
+73 ;
AGE() ;--age at admit
+1 NEW X,X1,X2
+2 ;admit date
SET X1=+$GET(^DGPM(ADM,0))
+3 ;date of birth
SET X2=$PIECE($GET(^DPT(DFN,0)),U,3)
DO ^%DTC
+4 IF 'X
QUIT ""
QUIT X\365.25
+5 ;
