- 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 ;
