Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGILD4

BDGILD4.m

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