BDGILD4 ; IHS/ANMC/LJF - ICU TRANSFERS ;
;;5.3;PIMS;;APR 26, 2002
;
EN ;EP; -- main entry point for BDG ILD ICU TRANSFERS
; Assumes BDGTYP,BDGBD,BDGED,BDGTYP are set
;
I $E(IOST,1,2)="P-" D INIT,PRINT Q ;if printing to paper
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
S X=$S(BDGTYP=1:"BDG ILD ICU TRANSFERS",1:"BDG ILD RETURNS TO ICU")
D EN^VALM(X)
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(10)_"*** "_$$CONF^BDGF_" ***"
S X=$S(BDGTYP=1:"Transfers",1:"Returns")_" to ICU"
I BDGTYP=2 S X=X_" within "_BDGMAX_" days"
S VALMHDR(2)=$$SP(75-$L(X)\2)_X
S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
S VALMHDR(3)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
S VALMCNT=0
K ^TMP("BDGILD4",$J),^TMP("BDGILD4A",$J)
;
; loop through ward transfers by date range and put into sorted array
NEW DATE,DFN,IEN,END,DIFF
S DATE=BDGBD-.0001,END=BDGED+.24
F S DATE=$O(^DGPM("AMV2",DATE)) Q:'DATE Q:(DATE>END) D
. S DFN=0 F S DFN=$O(^DGPM("AMV2",DATE,DFN)) Q:'DFN D
.. S IEN=0 F S IEN=$O(^DGPM("AMV2",DATE,DFN,IEN)) Q:'IEN D
... ;
... Q:'$$ICU^BDGPAR(IEN) ;quit if not ICU
... ;
... ; is it a return to ICU and within time limit?
... I BDGTYP=2 S DIFF=$$OKAY(DATE,DFN,IEN) Q:'DIFF
... ;
... S ^TMP("BDGILD4A",$J,DATE,IEN)=DFN_U_$G(DIFF)
;
;
; loop thru sorted array and put into display array
NEW DATE,IEN,LINE,X,BDGCOV,BDGRR,I
S DATE=0 F S DATE=$O(^TMP("BDGILD4A",$J,DATE)) Q:'DATE D
. S IEN=0 F S IEN=$O(^TMP("BDGILD4A",$J,DATE,IEN)) Q:'IEN D
.. ;
.. ; build display lines
.. S DFN=+^TMP("BDGILD4A",$J,DATE,IEN)
.. S LINE=$E($$GET1^DIQ(2,DFN,.01),1,20) ;pat name
.. S LINE=$$PAD(LINE,23)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart #
.. ;
.. I BDGTYP=1 D ; transfers
... S LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE) ;trans date
... S X=$$PRIORTXN^BDGF1((DATE+.0001),+$P(^DGPM(IEN,0),U,14),DFN)
... S X=$$GET1^DIQ(405,X,.09,"I") ;last serv
... S LINE=$$PAD($$PAD(LINE,49)_$$GET1^DIQ(45.7,+X,99),56) ;serv abbrv
.. ;
.. I BDGTYP=2 D ; returns
... S LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE) ;trans date
... S X=$P(^TMP("BDGILD4A",$J,DATE,IEN),U,2) ;diff
... S LINE=$$PAD($$PAD(LINE,49)_X_$S(X=1:" day",1:" days"),61)
.. ;
.. ; admitting dx
.. S LINE=LINE_$E($$GET1^DIQ(405,+$$GET1^DIQ(405,IEN,.14,"I"),.1),1,23)
.. D SET(LINE,.VALMCNT)
;
I '$D(^TMP("BDGILD4",$J)) D SET("No data found",.VALMCNT)
;
K ^TMP("BDGILD4A",$J)
Q
;
OKAY(DATE,PAT,IEN) ; is transfer a return and within the time limit?
NEW TO,LAST,ADM,FOUND,N
S ADM=$$GET1^DIQ(405,IEN,.14,"I") I 'ADM Q 0
S (TO,LAST)=DATE,FOUND=0
; look for last ICU transfer, then use date of next transfer
; as discharge from ICU
F S TO=$O(^DGPM("APCA",PAT,ADM,TO),-1) Q:'TO Q:FOUND D
. S N=$O(^DGPM("APCA",PAT,ADM,TO,0)) Q:'N ;ien for movement
. I $$ICU^BDGPAR(N) S FOUND=1 Q ;if ICU stop looking
. S LAST=TO ;save last date
I 'FOUND Q 0 ;not a return to ICU
;
S X=$$FMDIFF^XLFDT(DATE,LAST) ;difference
I X'>BDGMAX Q X ;if w/in limit, return diff
Q 0
;
;
SET(DATA,NUM) ; puts display line into array
S NUM=NUM+1
S ^TMP("BDGILD4",$J,NUM,0)=DATA
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGILD4",$J) K BDGBD,BDGED,BDGTYP,BDGSRT
Q
;
EXPND ; -- expand code
Q
;
PRINT ; print to paper
NEW LINE,BDGPG
U IO D INIT^BDGF,HDG
;
S LINE=0 F S LINE=$O(^TMP("BDGILD4",$J,LINE)) Q:'LINE D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGILD4",$J,LINE,0)
;
D ^%ZISC,PRTKL^BDGF,EXIT
Q
;
HDG ; heading when printing to paper
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?13,"***",$$CONF^BDGF,"***"
NEW X S X=$S(BDGTYP=1:"Transfers",1:"Returns")_" to ICU"
I BDGTYP=2 S X=X_" within "_BDGMAX_" days"
W !,BDGDATE,?(80-$L(X)\2),X,?71,"Page: ",BDGPG
S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !,"Patient Name",?23,"Chart #"
I BDGTYP=1 W ?31,"Admit Date",?46,"Transferred"
I BDGTYP=2 W ?31,"Transferred",?46,"Returned w/in"
W ?61,"Admitting Dx"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
;
BDGILD4 ; IHS/ANMC/LJF - ICU TRANSFERS ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
EN ;EP; -- main entry point for BDG ILD ICU TRANSFERS
+1 ; Assumes BDGTYP,BDGBD,BDGED,BDGTYP are set
+2 ;
+3 ;if printing to paper
IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+4 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+5 SET X=$SELECT(BDGTYP=1:"BDG ILD ICU TRANSFERS",1:"BDG ILD RETURNS TO ICU")
+6 DO EN^VALM(X)
+7 DO CLEAR^VALM1
+8 QUIT
+9 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(10)_"*** "_$$CONF^BDGF_" ***"
+3 SET X=$SELECT(BDGTYP=1:"Transfers",1:"Returns")_" to ICU"
+4 IF BDGTYP=2
SET X=X_" within "_BDGMAX_" days"
+5 SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X
+6 SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+7 SET VALMHDR(3)=$$SP(75-$LENGTH(X)\2)_X
+8 QUIT
+9 ;
INIT ; -- init variables and list array
+1 SET VALMCNT=0
+2 KILL ^TMP("BDGILD4",$JOB),^TMP("BDGILD4A",$JOB)
+3 ;
+4 ; loop through ward transfers by date range and put into sorted array
+5 NEW DATE,DFN,IEN,END,DIFF
+6 SET DATE=BDGBD-.0001
SET END=BDGED+.24
+7 FOR
SET DATE=$ORDER(^DGPM("AMV2",DATE))
IF 'DATE
QUIT
IF (DATE>END)
QUIT
Begin DoDot:1
+8 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV2",DATE,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+9 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("AMV2",DATE,DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+10 ;
+11 ;quit if not ICU
IF '$$ICU^BDGPAR(IEN)
QUIT
+12 ;
+13 ; is it a return to ICU and within time limit?
+14 IF BDGTYP=2
SET DIFF=$$OKAY(DATE,DFN,IEN)
IF 'DIFF
QUIT
+15 ;
+16 SET ^TMP("BDGILD4A",$JOB,DATE,IEN)=DFN_U_$GET(DIFF)
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;
+18 ;
+19 ; loop thru sorted array and put into display array
+20 NEW DATE,IEN,LINE,X,BDGCOV,BDGRR,I
+21 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGILD4A",$JOB,DATE))
IF 'DATE
QUIT
Begin DoDot:1
+22 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGILD4A",$JOB,DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+23 ;
+24 ; build display lines
+25 SET DFN=+^TMP("BDGILD4A",$JOB,DATE,IEN)
+26 ;pat name
SET LINE=$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+27 ;chart #
SET LINE=$$PAD(LINE,23)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+28 ;
+29 ; transfers
IF BDGTYP=1
Begin DoDot:3
+30 ;trans date
SET LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE)
+31 SET X=$$PRIORTXN^BDGF1((DATE+.0001),+$PIECE(^DGPM(IEN,0),U,14),DFN)
+32 ;last serv
SET X=$$GET1^DIQ(405,X,.09,"I")
+33 ;serv abbrv
SET LINE=$$PAD($$PAD(LINE,49)_$$GET1^DIQ(45.7,+X,99),56)
End DoDot:3
+34 ;
+35 ; returns
IF BDGTYP=2
Begin DoDot:3
+36 ;trans date
SET LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE)
+37 ;diff
SET X=$PIECE(^TMP("BDGILD4A",$JOB,DATE,IEN),U,2)
+38 SET LINE=$$PAD($$PAD(LINE,49)_X_$SELECT(X=1:" day",1:" days"),61)
End DoDot:3
+39 ;
+40 ; admitting dx
+41 SET LINE=LINE_$EXTRACT($$GET1^DIQ(405,+$$GET1^DIQ(405,IEN,.14,"I"),.1),1,23)
+42 DO SET(LINE,.VALMCNT)
End DoDot:2
End DoDot:1
+43 ;
+44 IF '$DATA(^TMP("BDGILD4",$JOB))
DO SET("No data found",.VALMCNT)
+45 ;
+46 KILL ^TMP("BDGILD4A",$JOB)
+47 QUIT
+48 ;
OKAY(DATE,PAT,IEN) ; is transfer a return and within the time limit?
+1 NEW TO,LAST,ADM,FOUND,N
+2 SET ADM=$$GET1^DIQ(405,IEN,.14,"I")
IF 'ADM
QUIT 0
+3 SET (TO,LAST)=DATE
SET FOUND=0
+4 ; look for last ICU transfer, then use date of next transfer
+5 ; as discharge from ICU
+6 FOR
SET TO=$ORDER(^DGPM("APCA",PAT,ADM,TO),-1)
IF 'TO
QUIT
IF FOUND
QUIT
Begin DoDot:1
+7 ;ien for movement
SET N=$ORDER(^DGPM("APCA",PAT,ADM,TO,0))
IF 'N
QUIT
+8 ;if ICU stop looking
IF $$ICU^BDGPAR(N)
SET FOUND=1
QUIT
+9 ;save last date
SET LAST=TO
End DoDot:1
+10 ;not a return to ICU
IF 'FOUND
QUIT 0
+11 ;
+12 ;difference
SET X=$$FMDIFF^XLFDT(DATE,LAST)
+13 ;if w/in limit, return diff
IF X'>BDGMAX
QUIT X
+14 QUIT 0
+15 ;
+16 ;
SET(DATA,NUM) ; puts display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGILD4",$JOB,NUM,0)=DATA
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGILD4",$JOB)
KILL BDGBD,BDGED,BDGTYP,BDGSRT
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PRINT ; print to paper
+1 NEW LINE,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 ;
+4 SET LINE=0
FOR
SET LINE=$ORDER(^TMP("BDGILD4",$JOB,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGILD4",$JOB,LINE,0)
End DoDot:1
+7 ;
+8 DO ^%ZISC
DO PRTKL^BDGF
DO EXIT
+9 QUIT
+10 ;
HDG ; heading when printing to paper
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?13,"***",$$CONF^BDGF,"***"
+3 NEW X
SET X=$SELECT(BDGTYP=1:"Transfers",1:"Returns")_" to ICU"
+4 IF BDGTYP=2
SET X=X_" within "_BDGMAX_" days"
+5 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?71,"Page: ",BDGPG
+6 SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+7 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+8 WRITE !,$$REPEAT^XLFSTR("-",80)
+9 WRITE !,"Patient Name",?23,"Chart #"
+10 IF BDGTYP=1
WRITE ?31,"Admit Date",?46,"Transferred"
+11 IF BDGTYP=2
WRITE ?31,"Transferred",?46,"Returned w/in"
+12 WRITE ?61,"Admitting Dx"
+13 WRITE !,$$REPEAT^XLFSTR("=",80)
+14 QUIT
+15 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
+3 ;
