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

BDGIPL2.m

Go to the documentation of this file. 
  1. BDGIPL2 ; IHS/ANMC/LJF - CURR INPTS BY WARD/NAME ; 
  1.  ;;5.3;PIMS;**1007**;FEB 27, 2007
  1.  ;
  1.  ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
  1.  ;
  1.  I $E(IOST,1,2)="P-" D INIT,PRINT Q
  1.  ;
  1. EN ; -- main entry point for BDG IPL BY WARD/NAME
  1.  ; assumes BDGSRT and BDGSRT2 are set
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG IPL BY WARD/NAME")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X
  1.  S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
  1.  S X=$S(BDGSRT="A":"For ALL Ward Locations",1:$P(BDGSRT,U,2))
  1.  S VALMHDR(2)=$$SP(75-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  NEW WD,DFN,BDGCNT,NAME,ORDER,X
  1.  K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
  1.  S VALMCNT=0,BDGCNT=1
  1.  ;
  1.  ; if only one ward chosen
  1.  I BDGSRT D
  1.  . S WD=$P(BDGSRT,U,2),DFN=0 F  S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN  D
  1.  .. S ^TMP("BDGIPL1",$J,1,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
  1.  ;
  1.  ; OR for all wards, find current inpatients & sort by ward then name
  1.  E  S WD=0 F  S WD=$O(^DPT("CN",WD)) Q:WD=""  D
  1.  . S DFN=0 F  S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN  D
  1.  .. ; print in print order
  1.  .. S X=$O(^DIC(42,"B",WD,0)) S ORDER=$$GET1^DIQ(42,+X,400) Q:'ORDER
  1.  .. S ^TMP("BDGIPL1",$J,ORDER,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
  1.  ;
  1.  ; pull sorted list and create display array
  1.  S ORDER=0 F  S ORDER=$O(^TMP("BDGIPL1",$J,ORDER)) Q:'ORDER  D
  1.  . S WD=0 F  S WD=$O(^TMP("BDGIPL1",$J,ORDER,WD)) Q:WD=""  D
  1.  .. ;
  1.  .. I BDGSRT="A" D  ;display ward subheading
  1.  ... D SET($G(IORVON)_"WARD: "_WD_$G(IORVOFF),.VALMCNT,BDGCNT,"")
  1.  .. ;
  1.  .. S NAME=0
  1.  .. F  S NAME=$O(^TMP("BDGIPL1",$J,ORDER,WD,NAME)) Q:NAME=""  D
  1.  ... S DFN=0
  1.  ... F  S DFN=$O(^TMP("BDGIPL1",$J,ORDER,WD,NAME,DFN)) Q:'DFN  D
  1.  .... D LINE
  1.  ;
  1.  K ^TMP("BDGIPL1",$J)
  1.  Q
  1.  ;
  1. LINE ; set up dislay line for patient
  1.  NEW LINE
  1.  S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")
  1.  S LINE=$$PAD(LINE,5)_$E($$GET1^DIQ(2,DFN,.01),1,18)   ;name
  1.  S LINE=$$PAD(LINE,25)_$$HRCND^BDGF2($$HRCN^BDGF2(DFN,DUZ(2)))
  1.  S LINE=$$PAD(LINE,34)_$$AGE(DFN)                          ;age
  1.  S LINE=$$PAD(LINE,42)_$P($$INPT1^BDGF1(DFN,DT),"@")       ;admit date
  1.  S LINE=$$PAD(LINE,53)_$J($P($$CURLOS^BDGF1(DFN)," "),3)   ;los
  1.  S LINE=$$PAD(LINE,58)_$G(^DPT(DFN,.101))                  ;room
  1.  S LINE=$$PAD(LINE,65)_$E($$CURPRV^BDGF1(DFN),1,15)        ;atten prv
  1.  D SET(LINE,.VALMCNT,BDGCNT,DFN)
  1.  ;
  1.  ; if user asked for double spacing
  1.  I BDGSRT2 D SET("",.VALMCNT,BDGCNT,"")
  1.  ;
  1.  ; increment counter
  1.  S BDGCNT=BDGCNT+1
  1.  Q
  1.  ;
  1. SET(LINE,NUM,COUNT,IEN) ; put display line into array
  1.  D SET^BDGIPL1(LINE,.NUM,COUNT,IEN)
  1.  Q
  1.  ;
  1. PRINT ; print report to paper
  1.  NEW BDGX,BDGLN,BDGPG
  1.  U IO D INIT^BDGF,HDG
  1.  ;
  1.  ; loop thru display array
  1.  S BDGX=0 F  S BDGX=$O(^TMP("BDGIPL",$J,BDGX)) Q:'BDGX  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . S BDGLN=^TMP("BDGIPL",$J,BDGX,0)
  1.  . W !,BDGLN
  1.  I '$G(BDGCOP) D ^%ZISC  ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39
  1.  D PRTKL^BDGF,EXIT
  1.  ;D ^%ZISC,PRTKL^BDGF,EXIT  cmi/anch/maw 2/22/2007 orig line
  1.  Q
  1.  ;
  1. HDG ; heading for paper report
  1.  S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
  1.  W !,BDGUSR,?16,$$CONF^BDGF,?71,"Page: ",BDGPG
  1.  W !,BDGDATE,?24,"Current Inpatients by Ward"
  1.  S X=$S(BDGSRT="A":"For ALL Ward Locations",1:$P(BDGSRT,U,2))
  1.  W !,BDGTIME,?(80-$L(X)\2),X
  1.  W !,$$REPEAT^XLFSTR("-",80)
  1.  W !?5,"Patient",?25,"Chart #",?34,"Age",?42,"Admitted",?53,"LOS"
  1.  W ?58,"Room",?65,"Provider"
  1.  W !,$$REPEAT^XLFSTR("=",80)
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGIPL",$J)
  1.  ;K BDGSRT cmi/anch/maw 7/25/2007 is needed for multiple copies
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  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. AGE(P) ; return formatted age
  1.  NEW X S X=$$GET1^DIQ(9000001,DFN,1102.98)
  1.  S X=$J($P(X," "),3)_" "_$E($P(X," ",2),1,2)
  1.  Q X
  1.  ;