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

BDGIPL3.m

Go to the documentation of this file. 
  1. BDGIPL3 ; IHS/ANMC/LJF - CURR INPTS BY WARD/ROOM ; 
  1.  ;;5.3;PIMS;**1007**;FEB 27, 2007
  1.  ;
  1.  ;cmi/anch/maw 2/21/2007 added code to INIT to not print a page break if BDGONE is there from user questions PATCH 1007 item 1007.38
  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.  ;
  1.  NEW BDGIOM S BDGIOM=IOM
  1.  I $E(IOST,1,2)="P-" D INIT,PRINT Q
  1.  ;
  1. EN ; -- main entry point for BDG IPL BY WARD/ROOM
  1.  ; assumes BDGSRT and BDGSRT2 are set
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG IPL BY WARD/ROOM")
  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.  I BDGSRT2=4 S VALMCAP=$$PAD($$PAD($$PAD($$PAD($$PAD($$SP(5)_"Room",14)_"Patient Name",34)_"Chart #",44)_"Diagnosis",64)_"Attending",80)
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  NEW BDGWD,BDGWDN,BDGCNT,SRV,NAME,LINE,DFN,ORD,WD,RM
  1.  K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
  1.  S VALMCNT=0,BDGCNT=1
  1.  D ^BDGIPL31   ;collect wards, rooms and patients
  1.  ;
  1.  ; pull sorted list and create display array
  1.  S ORD=0 F  S ORD=$O(^TMP("BDGIPL1",$J,"BED",ORD)) Q:'ORD  D
  1.  . S WD=0 F  S WD=$O(^TMP("BDGIPL1",$J,"BED",ORD,WD)) Q:WD=""  D
  1.  .. ;
  1.  .. I BDGSRT="A" D  ;display ward subheading
  1.  ... D SET($G(IORVON)_WD_$G(IORVOFF),.VALMCNT,BDGCNT,"")
  1.  ... ;
  1.  ... ; if printer, mark stop to add form feed
  1.  ... ;I $E(IOST,1,2)="P-" D SET("@@@@"_WD,.VALMCNT,BDGCNT,"")  ;cmi/anch/maw 2/21/2007 orig line PATCH 1007 item 1007.38
  1.  ... D SET("@@@@"_WD,.VALMCNT,BDGCNT,"")  ;cmi/anch/maw 2/21/2007 new line to not have a page break for each ward PATCH 1007 item 1007.38
  1.  ... ;I $E(IOST,1,2)="P-",$G(BDGONE) D SET("@@@@"_WD,.VALMCNT,BDGCNT,"")  ;cmi/anch/maw 2/21/2007 new line to not have a page break for each ward PATCH 1007 item 1007.38
  1.  .. ;
  1.  .. S RM=0 F  S RM=$O(^TMP("BDGIPL1",$J,"BED",ORD,WD,RM)) Q:RM=""  D
  1.  ... ;
  1.  ... ; if no patient in room, just print room number
  1.  ... I '$D(^TMP("BDGIPL1",$J,"PAT",WD_";"_RM)) D  Q
  1.  .... D SET($$SP(5)_RM,.VALMCNT,BDGCNT,"")
  1.  .... I BDGSRT2'=4 D SET("",.VALMCNT,BDGCNT,""),DASHES
  1.  ... ;
  1.  ... ; set up patient info lines
  1.  ... S DFN=^TMP("BDGIPL1",$J,"PAT",WD_";"_RM) Q:'DFN
  1.  ... D LINES S BDGCNT=BDGCNT+1
  1.  ... ;
  1.  .. ; if end of ward, print patients without rooms
  1.  .. S DFN=0 F  S DFN=$O(^TMP("BDGIPL1",$J,"PAT",WD_";",DFN)) Q:DFN=""  D
  1.  ... I DFN["P" D PEND Q     ;pending DSO/SDA patients
  1.  ... D LINES S BDGCNT=BDGCNT+1               ;else inpts without rooms
  1.  ;
  1.  K ^TMP("BDGIPL1",$J)
  1.  Q
  1.  ;
  1. LINES ; set up dislay lines for patient
  1.  NEW LINE
  1.  ;
  1.  ; set up line 1
  1.  S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")_RM
  1.  S LINE=$$PAD(LINE,14)_$E($$GET1^DIQ(2,DFN,.01),1,18)   ;name
  1.  S LINE=$$PAD(LINE,34)_$$HRCND^BDGF2($$HRCN^BDGF2(DFN,DUZ(2)))
  1.  ;
  1.  I BDGSRT2=4 D  Q   ;only one line in brief listing
  1.  . S LINE=$$PAD(LINE,44)_$E($$CURDX^BDGF1(DFN),1,18)          ;dx
  1.  . S LINE=$$PAD(LINE,64)_$E($$CURPRV^BDGF1(DFN,30),1,15)      ;prov
  1.  . D SET(LINE,.VALMCNT,BDGCNT,DFN)
  1.  ;
  1.  S LINE=$$PAD(LINE,44)_$$GET1^DIQ(9000001,DFN,1102.98)     ;age
  1.  S LINE=$$PAD(LINE,52)_$J($P($$CURLOS^BDGF1(DFN)," "),3)   ;los
  1.  S LINE=$$PAD(LINE,58)_$$LASTCOL(BDGSRT2,DFN)     ;last column data
  1.  D SET(LINE,.VALMCNT,BDGCNT,DFN)
  1.  ;
  1.  Q:BDGSRT2=4    ;only one line if brief listing
  1.  ;
  1.  ; set up line 2
  1.  S LINE=$$SP(6)_$$OBSERV(DFN)   ;obs if observation
  1.  S LINE=$$PAD(LINE,15)_"("_$$CURPRV^BDGF1(DFN,30)_")"         ;provs
  1.  S LINE=$$PAD(LINE,50)_"("_$$GET1^DIQ(9000001,DFN,1118)_")"   ;commun
  1.  I BDGSRT2=3 S LINE=$$PAD(LINE,15)_"("_$$CURDX^BDGF1(DFN)_")"  ;or dx
  1.  D SET(LINE,.VALMCNT,BDGCNT,DFN)
  1.  D DASHES
  1.  Q
  1.  ;
  1. PEND ; display line for pending DSO/SDA patients for ward
  1.  NEW LINE,NODE,PAT
  1.  S PAT=$P(DFN,";",2)                     ;dfn="P"_time_;_dfn
  1.  S NODE=^TMP("BDGIPL1",$J,"PAT",WD_";",DFN)    ;stored data
  1.  S LINE="Schd "_$P(NODE,U,3)                        ;ds status
  1.  S LINE=$$PAD(LINE,14)_$E($P(NODE,U,2),1,18)             ;name
  1.  S LINE=$$PAD(LINE,34)_$$HRCND^BDGF2($$HRCN^BDGF2(PAT,DUZ(2)))
  1.  S LINE=$$PAD(LINE,44)_$$GET1^DIQ(9000001,PAT,1102.98)   ;age
  1.  S LINE=$$PAD(LINE,58)_$P(NODE,U,4)                      ;service
  1.  D SET(LINE,.VALMCNT,BDGCNT-1,DFN)
  1.  ;
  1.  ; set up line 2
  1.  S LINE="  Surg at "_$$TIME^BDGF($P(NODE,U,7))          ;surgery time
  1.  S LINE=$$PAD(LINE,19)_"("_$E($P(NODE,U,6),1,25)_")"     ;surgeon
  1.  S LINE=$$PAD(LINE,46)_$P(NODE,U,5)                      ;procedure
  1.  D SET(LINE,.VALMCNT,BDGCNT-1,DFN)
  1.  D DASHES
  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. LASTCOL(X,P) ; returns last column data based on request from user
  1.  I X=3 Q ""                      ;notes column to be left blank
  1.  I X=1 Q $$CURDX^BDGF1(DFN)      ;adm dx for current inpt
  1.  I X=2 Q $$GET1^DIQ(2,DFN,.103)  ;current service
  1.  Q ""
  1.  ;
  1. OBSERV(P) ; obs if observatrion service
  1.  Q $S($$GET1^DIQ(2,P,.103)["OBSERVATION":"OBS",1:"")
  1.  ;
  1. PRINT ; print report to paper
  1.  NEW BDGX,BDGLN,BDGWD,BDGPG
  1.  U IO D INIT^BDGF      ;initialize hdg variables
  1.  ;
  1.  ; if only one ward chosen, set ward and print header
  1.  I BDGSRT S BDGWD=$P(BDGSRT,U,2) D HDG
  1.  ;
  1.  ; loop thru display array
  1.  S BDGX=0 F  S BDGX=$O(^TMP("BDGIPL",$J,BDGX)) Q:'BDGX  D
  1.  . S BDGLN=^TMP("BDGIPL",$J,BDGX,0)
  1.  . ;
  1.  . ;marker for form feed between wards
  1.  . I $E(BDGLN,1,4)="@@@@" S BDGWD=$P(BDGLN,"@@@@",2) D HDG Q
  1.  . ;
  1.  . ;try to keep patient data together
  1.  . I $E(BDGLN,1,5)="-----",($Y>(IOSL-7)) D HDG
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,$E(BDGLN,1,80)
  1.  ;
  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  ;7/6/2007 cmi/anch/maw patch 1007
  1.  ;
  1. HDG ; heading for paper report
  1.  S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
  1.  W !?16,$$CONF^BDGF
  1.  W !,BDGUSR,?(80-$L(BDGFAC)\2),BDGFAC
  1.  W !,BDGTIME,?27,"Current Inpatients by Ward",?71,"Page: ",BDGPG
  1.  NEW X S X="*** "_BDGWD_"***" W !,BDGDATE,?(80-$L(X)\2),X
  1.  W !,$$REPEAT^XLFSTR("=",80)
  1.  I BDGSRT2=4 W !?5,"Room",?14,"Patient",?34,"Chart #",?44,"Diagnosis",?64,"Attending",!,$$REPEAT^XLFSTR("-",80) Q
  1.  W !?5,"Room",?14,"Patient",?34,"Chart #",?44,"Age",?52,"LOS"
  1.  W ?58,$S(BDGSRT2=1:"Admitting Diagnosis",BDGSRT2=2:"Service",1:"Nursing Notes")
  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/10/2007 patch 1007
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. DASHES ; adds line of dashes
  1.  D SET($$REPEAT^XLFSTR("-",BDGIOM),.VALMCNT,BDGCNT,"")
  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)