BDGAD3 ; IHS/ANMC/LJF - A&D SERV TRANSFERS ; [ 04/16/2004 4:39 PM ]
;;5.3;PIMS;**1013,1019**;APR 26, 2002;Build 3
;
LOOP ;--loop service transfers
NEW DGDT,DFN,IFN
S DGDT=DGBEG
F S DGDT=$O(^DGPM("AMV6",DGDT)) Q:'DGDT!(DGDT>DGEND) D
. S DFN=0 F S DFN=$O(^DGPM("AMV6",DGDT,DFN)) Q:'DFN D
.. S IFN=0 F S IFN=$O(^DGPM("AMV6",DGDT,DFN,IFN)) Q:'IFN D GATHER
Q
;
GATHER ; gather info on service transfers and put counts into arrays
NEW ADULT,ADM,OLDSV,NEWSV,OLDSVN,NEWSVN,X,NAME,LOS,WARD
I $D(^DGPM("AMV2",DGDT,DFN)) Q ;also ward transfer-already counted
S LJF=DGDT_U_DFN_U_IFN
S ADM=$P(^DGPM(IFN,0),U,14) ;admit ien
I IFN=$$ADMTXN^BDGF1(ADM,DFN) Q ;don't use admit service
S ADULT=$S($$AGE<$$ADULT^BDGPAR:0,1:1) ;1=adult, 0=peds
;
Q:'+$$PRIORTXN^BDGF1(DGDT,ADM,DFN) ;ihs/cmi/maw 10/29/2010 patch 1014
S OLDSV=$P(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9) ;old srv
I +OLDSV=0 W !,DFN_" "_ADM
S X=$O(^DGPM("AMV6",DGDT,DFN,0)) Q:'X
S NEWSV=$P($G(^DGPM(X,0)),U,9) Q:'NEWSV Q:(OLDSV=NEWSV)
S OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)
S NEWSVN=$$GET1^DIQ(45.7,NEWSV,.01)
S X=$$PRIORMVT^BDGF1(DGDT,ADM,DFN) Q:'X ;prior physical mvmt
S WARD=$$GET1^DIQ(405,X,.06,"I")
;
S LOS=$$FMDIFF^XLFDT(DGDT,+$G(^DGPM(+$$PRIORTXN^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,"SERV",NAME,DFN,IFN)=OLDSV_U_NEWSV
Q:$G(BDGREP) ;reprint, not recalculating
;
; -- increment counts in ADT Census files
; -- set up services within wards if not already there
I '$D(^BDGCWD(WARD,1,BDGT,1,NEWSV)) D
. S ^BDGCWD(WARD,1,BDGT,1,NEWSV,0)=NEWSV
. S $P(^BDGCWD(WARD,1,BDGT,1,0),U,3,4)=NEWSV_U_($P(^BDGCWD(WARD,1,BDGT,1,0),U,4)+1)
I '$D(^BDGCWD(WARD,1,BDGT,1,OLDSV)) D
. S ^BDGCWD(WARD,1,BDGT,1,OLDSV,0)=OLDSV
. S $P(^BDGCWD(WARD,1,BDGT,1,0),U,3,4)=OLDSV_U_($P(^BDGCWD(WARD,1,BDGT,1,0),U,4)+1)
;
I ADULT D
. ; --- transfer in to new service
. S $P(^BDGCTX(NEWSV,1,BDGT,0),U,5)=$P($G(^BDGCTX(NEWSV,1,BDGT,0)),U,5)+1
. S $P(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,5)=$P(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,5)+1
. ;
. ; transfer out of old service
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,6)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,6)+1
. S $P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,6)=$P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,6)+1
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,9)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,9)+LOS
. S $P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,9)=$P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,9)+LOS
. ;
I 'ADULT D
. ; --- transfer in to new service
. S $P(^BDGCTX(NEWSV,1,BDGT,0),U,15)=$P($G(^BDGCTX(NEWSV,1,BDGT,0)),U,15)+1
. S $P(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,15)=$P(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,15)+1
. ; transfer out of old service
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,16)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,16)+1
. S $P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,16)=$P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,16)+1
. S $P(^BDGCTX(OLDSV,1,BDGT,0),U,19)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,19)+LOS
. S $P(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,19)=$P(^BDGCWD(WARD,1,BDGT,1,OLDSV,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
;
BDGAD3 ; IHS/ANMC/LJF - A&D SERV TRANSFERS ; [ 04/16/2004 4:39 PM ]
+1 ;;5.3;PIMS;**1013,1019**;APR 26, 2002;Build 3
+2 ;
LOOP ;--loop service transfers
+1 NEW DGDT,DFN,IFN
+2 SET DGDT=DGBEG
+3 FOR
SET DGDT=$ORDER(^DGPM("AMV6",DGDT))
IF 'DGDT!(DGDT>DGEND)
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV6",DGDT,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+5 SET IFN=0
FOR
SET IFN=$ORDER(^DGPM("AMV6",DGDT,DFN,IFN))
IF 'IFN
QUIT
DO GATHER
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
GATHER ; gather info on service transfers and put counts into arrays
+1 NEW ADULT,ADM,OLDSV,NEWSV,OLDSVN,NEWSVN,X,NAME,LOS,WARD
+2 ;also ward transfer-already counted
IF $DATA(^DGPM("AMV2",DGDT,DFN))
QUIT
+3 SET LJF=DGDT_U_DFN_U_IFN
+4 ;admit ien
SET ADM=$PIECE(^DGPM(IFN,0),U,14)
+5 ;don't use admit service
IF IFN=$$ADMTXN^BDGF1(ADM,DFN)
QUIT
+6 ;1=adult, 0=peds
SET ADULT=$SELECT($$AGE<$$ADULT^BDGPAR:0,1:1)
+7 ;
+8 ;ihs/cmi/maw 10/29/2010 patch 1014
IF '+$$PRIORTXN^BDGF1(DGDT,ADM,DFN)
QUIT
+9 ;old srv
SET OLDSV=$PIECE(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9)
+10 IF +OLDSV=0
WRITE !,DFN_" "_ADM
+11 SET X=$ORDER(^DGPM("AMV6",DGDT,DFN,0))
IF 'X
QUIT
+12 SET NEWSV=$PIECE($GET(^DGPM(X,0)),U,9)
IF 'NEWSV
QUIT
IF (OLDSV=NEWSV)
QUIT
+13 SET OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)
+14 SET NEWSVN=$$GET1^DIQ(45.7,NEWSV,.01)
+15 ;prior physical mvmt
SET X=$$PRIORMVT^BDGF1(DGDT,ADM,DFN)
IF 'X
QUIT
+16 SET WARD=$$GET1^DIQ(405,X,.06,"I")
+17 ;
+18 SET LOS=$$FMDIFF^XLFDT(DGDT,+$GET(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0)))
+19 ; collect patient data for report
+20 SET NAME=$$GET1^DIQ(2,DFN,.01)
+21 ;ihs/cmi/maw patch 1019
IF $$DEMO^APCLUTL(DFN,"E")
QUIT
+22 SET ^TMP("BDGAD",$JOB,"SERV",NAME,DFN,IFN)=OLDSV_U_NEWSV
+23 ;reprint, not recalculating
IF $GET(BDGREP)
QUIT
+24 ;
+25 ; -- increment counts in ADT Census files
+26 ; -- set up services within wards if not already there
+27 IF '$DATA(^BDGCWD(WARD,1,BDGT,1,NEWSV))
Begin DoDot:1
+28 SET ^BDGCWD(WARD,1,BDGT,1,NEWSV,0)=NEWSV
+29 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,0),U,3,4)=NEWSV_U_($PIECE(^BDGCWD(WARD,1,BDGT,1,0),U,4)+1)
End DoDot:1
+30 IF '$DATA(^BDGCWD(WARD,1,BDGT,1,OLDSV))
Begin DoDot:1
+31 SET ^BDGCWD(WARD,1,BDGT,1,OLDSV,0)=OLDSV
+32 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,0),U,3,4)=OLDSV_U_($PIECE(^BDGCWD(WARD,1,BDGT,1,0),U,4)+1)
End DoDot:1
+33 ;
+34 IF ADULT
Begin DoDot:1
+35 ; --- transfer in to new service
+36 SET $PIECE(^BDGCTX(NEWSV,1,BDGT,0),U,5)=$PIECE($GET(^BDGCTX(NEWSV,1,BDGT,0)),U,5)+1
+37 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,5)=$PIECE(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,5)+1
+38 ;
+39 ; transfer out of old service
+40 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,6)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,6)+1
+41 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,6)=$PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,6)+1
+42 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,9)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,9)+LOS
+43 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,9)=$PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,9)+LOS
+44 ;
End DoDot:1
+45 IF 'ADULT
Begin DoDot:1
+46 ; --- transfer in to new service
+47 SET $PIECE(^BDGCTX(NEWSV,1,BDGT,0),U,15)=$PIECE($GET(^BDGCTX(NEWSV,1,BDGT,0)),U,15)+1
+48 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,15)=$PIECE(^BDGCWD(WARD,1,BDGT,1,NEWSV,0),U,15)+1
+49 ; transfer out of old service
+50 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,16)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,16)+1
+51 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,16)=$PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,16)+1
+52 SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,19)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,19)+LOS
+53 SET $PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,19)=$PIECE(^BDGCWD(WARD,1,BDGT,1,OLDSV,0),U,19)+LOS
End DoDot:1
+54 ;
+55 QUIT
+56 ;
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 ;
