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