BDGIPL8 ; IHS/ANMC/LJF - CURR INPTS BY LOS ;
;;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 LOS
; assumes BDGSRT and BDGSRT2 are set
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IPL BY LOS")
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
S X="With LOS of "_BDGSRT2_" Days or Greater"
S VALMHDR(3)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW WD,DFN,BDGCNT,NAME
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
.. ;
.. ; check patient length of stay against user's request
.. S D0=+$G(^DPT(DFN,.105)),X="" Q:'$D(^DGPM(D0,0))
.. D EN^DGPMLOS I +X<BDGSRT2 Q
.. ;
.. S ^TMP("BDGIPL1",$J,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
.. ;
.. ; check patient length of stay against user's request
.. S D0=+$G(^DPT(DFN,.105)),X="" Q:'$D(^DGPM(D0,0))
.. D EN^DGPMLOS I +X<BDGSRT2 Q
.. ;
.. S ^TMP("BDGIPL1",$J,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; pull sorted list and create display array
S WD=0 F S WD=$O(^TMP("BDGIPL1",$J,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,WD,NAME)) Q:NAME="" D
.. S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,WD,NAME,DFN)) Q:'DFN D
... D LINE
. ;
. D SET("",.VALMCNT,BDGCNT-1,"")
;
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)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;hrcn
S LINE=$$PAD(LINE,33)_$$AGE(DFN) ;age
S LINE=$$PAD(LINE,41)_$P($$GET1^DIQ(2,DFN,.105),",") ;admit
S LINE=$$PAD(LINE,50)_$J($P($$CURLOS^BDGF1(DFN)," "),3) ;los
S LINE=$$PAD(LINE,57)_$$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99) ;srv
S LINE=$$PAD(LINE,63)_$$GET1^DIQ(9000001,DFN,1118) ;comm
D SET(LINE,.VALMCNT,BDGCNT,DFN)
;
; 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 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
;
HDG ; heading for paper report
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?16,$$CONF^BDGF
S X="Inpatients With LOS of "_BDGSRT2_" Days or Greater"
W !,BDGDATE,?(80-$L(X)\2),X,?70,"Page: ",BDGPG
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 #",?35,"Age",?41,"Admit",?50,"LOS"
W ?57,"Srv",?63,"Community"
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 patch 1007
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
BDGIPL8 ; IHS/ANMC/LJF - CURR INPTS BY LOS ;
+1 ;;5.3;PIMS;**1007**;FEB 27, 2007
+2 ;
+3 ;
+4 ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
+5 ;
+6 ;
+7 IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+8 ;
EN ; -- main entry point for BDG IPL BY LOS
+1 ; assumes BDGSRT and BDGSRT2 are set
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG IPL BY LOS")
+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 SET X="With LOS of "_BDGSRT2_" Days or Greater"
+6 SET VALMHDR(3)=$$SP(75-$LENGTH(X)\2)_X
+7 QUIT
+8 ;
INIT ; -- init variables and list array
+1 NEW WD,DFN,BDGCNT,NAME
+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 ;
+9 ; check patient length of stay against user's request
+10 SET D0=+$GET(^DPT(DFN,.105))
SET X=""
IF '$DATA(^DGPM(D0,0))
QUIT
+11 DO EN^DGPMLOS
IF +X<BDGSRT2
QUIT
+12 ;
+13 SET ^TMP("BDGIPL1",$JOB,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+14 ;
+15 ; OR for all wards, find current inpatients & sort by ward then name
+16 IF '$TEST
SET WD=0
FOR
SET WD=$ORDER(^DPT("CN",WD))
IF WD=""
QUIT
Begin DoDot:1
+17 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+18 ;
+19 ; check patient length of stay against user's request
+20 SET D0=+$GET(^DPT(DFN,.105))
SET X=""
IF '$DATA(^DGPM(D0,0))
QUIT
+21 DO EN^DGPMLOS
IF +X<BDGSRT2
QUIT
+22 ;
+23 SET ^TMP("BDGIPL1",$JOB,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+24 ;
+25 ; pull sorted list and create display array
+26 SET WD=0
FOR
SET WD=$ORDER(^TMP("BDGIPL1",$JOB,WD))
IF WD=""
QUIT
Begin DoDot:1
+27 ;
+28 ;display ward subheading
IF BDGSRT="A"
Begin DoDot:2
+29 DO SET($GET(IORVON)_"WARD: "_WD_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
End DoDot:2
+30 ;
+31 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGIPL1",$JOB,WD,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+32 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,WD,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+33 DO LINE
End DoDot:3
End DoDot:2
+34 ;
+35 DO SET("",.VALMCNT,BDGCNT-1,"")
End DoDot:1
+36 ;
+37 KILL ^TMP("BDGIPL1",$JOB)
+38 QUIT
+39 ;
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 ;hrcn
SET LINE=$$PAD(LINE,25)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+5 ;age
SET LINE=$$PAD(LINE,33)_$$AGE(DFN)
+6 ;admit
SET LINE=$$PAD(LINE,41)_$PIECE($$GET1^DIQ(2,DFN,.105),",")
+7 ;los
SET LINE=$$PAD(LINE,50)_$JUSTIFY($PIECE($$CURLOS^BDGF1(DFN)," "),3)
+8 ;srv
SET LINE=$$PAD(LINE,57)_$$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)
+9 ;comm
SET LINE=$$PAD(LINE,63)_$$GET1^DIQ(9000001,DFN,1118)
+10 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+11 ;
+12 ; increment counter
+13 SET BDGCNT=BDGCNT+1
+14 QUIT
+15 ;
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 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
QUIT
+13 ;
HDG ; heading for paper report
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?16,$$CONF^BDGF
+3 SET X="Inpatients With LOS of "_BDGSRT2_" Days or Greater"
+4 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?70,"Page: ",BDGPG
+5 SET X=$SELECT(BDGSRT="A":"For ALL Ward Locations",1:$PIECE(BDGSRT,U,2))
+6 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+7 WRITE !,$$REPEAT^XLFSTR("-",80)
+8 WRITE !?5,"Patient",?25,"Chart #",?35,"Age",?41,"Admit",?50,"LOS"
+9 WRITE ?57,"Srv",?63,"Community"
+10 WRITE !,$$REPEAT^XLFSTR("=",80)
+11 QUIT
+12 ;
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 patch 1007
+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
