BDGIPL9 ; IHS/ANMC/LJF - CURR INPTS ON SI/DNR LIST ;
;;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 SI/DNR
; assumes BDGSRT and BDGSRT2 are set
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IPL BY SI/DNR")
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
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
.. ;
.. ; quit if patient not on SI or DNR lists
.. S X=$P($G(^DPT(DFN,"DAC")),U) Q:X=""
.. ;
.. I (X'="D") S ^TMP("BDGIPL1",$J,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
.. I (X'="S") S ^TMP("BDGIPL1",$J,"D",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
.. ;
.. ; quit if patient not on SI or DNR lists
.. S X=$P($G(^DPT(DFN,"DAC")),U) Q:X=""
.. ;
.. I (X'="D") S ^TMP("BDGIPL1",$J,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
.. I (X'="S") S ^TMP("BDGIPL1",$J,"D",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; pull sorted list and create display array
F BDGI="S","D" D
. ;
. ; display subheading
. I BDGSRT2=1 D ;include DNR patients on list
.. S X=$S(BDGI="S":"Seriously Ill List",1:"Do Not Resuscitate List")
.. D SET($G(IORVON)_X_$G(IORVOFF),.VALMCNT,BDGCNT,"")
. ;
. S WD=0 F S WD=$O(^TMP("BDGIPL1",$J,BDGI,WD)) Q:WD="" D
.. ;
.. I BDGSRT="A" D ;display ward subheading
... D SET($$SP(2)_$G(IOUON)_"WARD: "_WD_$G(IOUOFF),.VALMCNT,BDGCNT,"")
.. ;
.. S NAME=0 F S NAME=$O(^TMP("BDGIPL1",$J,BDGI,WD,NAME)) Q:NAME="" D
... S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,BDGI,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,16) ;name
S LINE=$$PAD(LINE,23)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)
S LINE=$$PAD(LINE,31)_$$AGE(DFN) ;age
S LINE=$$PAD(LINE,39)_$G(^DPT(DFN,.101)) ;room
S LINE=$$PAD(LINE,47)_$$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99) ;srv
S LINE=$$PAD(LINE,53)_$$CURPRV^BDGF1(DFN,15) ;prov
; put date added to SI/DNR list in last column
S LINE=$$PAD(LINE,69)_$$NUMDATE^BDGF($P(^DPT(DFN,"DAC"),U,2))
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
. W !,^TMP("BDGIPL",$J,BDGX,0)
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,?13,"***",$$CONF^BDGF,"***"
NEW X S X="Seriously Ill"_$S(BDGSRT2=1:"/DNR ",1:"")_" List"
W !,BDGDATE,?(80-$L(X)\2),X,?71,"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",?23,"Chart #",?31,"Age",?39,"Room",?47,"Srv"
W ?53,"Provider",?69,"Added"
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
BDGIPL9 ; IHS/ANMC/LJF - CURR INPTS ON SI/DNR LIST ;
+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 SI/DNR
+1 ; assumes BDGSRT and BDGSRT2 are set
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG IPL BY SI/DNR")
+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
+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 ; quit if patient not on SI or DNR lists
+10 SET X=$PIECE($GET(^DPT(DFN,"DAC")),U)
IF X=""
QUIT
+11 ;
+12 IF (X'="D")
SET ^TMP("BDGIPL1",$JOB,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
+13 IF (X'="S")
SET ^TMP("BDGIPL1",$JOB,"D",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 ; quit if patient not on SI or DNR lists
+20 SET X=$PIECE($GET(^DPT(DFN,"DAC")),U)
IF X=""
QUIT
+21 ;
+22 IF (X'="D")
SET ^TMP("BDGIPL1",$JOB,"S",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
+23 IF (X'="S")
SET ^TMP("BDGIPL1",$JOB,"D",WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+24 ;
+25 ; pull sorted list and create display array
+26 FOR BDGI="S","D"
Begin DoDot:1
+27 ;
+28 ; display subheading
+29 ;include DNR patients on list
IF BDGSRT2=1
Begin DoDot:2
+30 SET X=$SELECT(BDGI="S":"Seriously Ill List",1:"Do Not Resuscitate List")
+31 DO SET($GET(IORVON)_X_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
End DoDot:2
+32 ;
+33 SET WD=0
FOR
SET WD=$ORDER(^TMP("BDGIPL1",$JOB,BDGI,WD))
IF WD=""
QUIT
Begin DoDot:2
+34 ;
+35 ;display ward subheading
IF BDGSRT="A"
Begin DoDot:3
+36 DO SET($$SP(2)_$GET(IOUON)_"WARD: "_WD_$GET(IOUOFF),.VALMCNT,BDGCNT,"")
End DoDot:3
+37 ;
+38 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGIPL1",$JOB,BDGI,WD,NAME))
IF NAME=""
QUIT
Begin DoDot:3
+39 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,BDGI,WD,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:4
+40 DO LINE
End DoDot:4
End DoDot:3
End DoDot:2
+41 ;
+42 DO SET("",.VALMCNT,BDGCNT-1,"")
End DoDot:1
+43 ;
+44 KILL ^TMP("BDGIPL1",$JOB)
+45 QUIT
+46 ;
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,16)
+4 SET LINE=$$PAD(LINE,23)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+5 ;age
SET LINE=$$PAD(LINE,31)_$$AGE(DFN)
+6 ;room
SET LINE=$$PAD(LINE,39)_$GET(^DPT(DFN,.101))
+7 ;srv
SET LINE=$$PAD(LINE,47)_$$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)
+8 ;prov
SET LINE=$$PAD(LINE,53)_$$CURPRV^BDGF1(DFN,15)
+9 ; put date added to SI/DNR list in last column
+10 SET LINE=$$PAD(LINE,69)_$$NUMDATE^BDGF($PIECE(^DPT(DFN,"DAC"),U,2))
+11 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+12 ;
+13 ; increment counter
+14 SET BDGCNT=BDGCNT+1
+15 QUIT
+16 ;
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 WRITE !,^TMP("BDGIPL",$JOB,BDGX,0)
End DoDot:1
+8 ;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
+9 DO PRTKL^BDGF
DO EXIT
+10 ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
+11 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
QUIT
+12 ;
HDG ; heading for paper report
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?13,"***",$$CONF^BDGF,"***"
+3 NEW X
SET X="Seriously Ill"_$SELECT(BDGSRT2=1:"/DNR ",1:"")_" List"
+4 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?71,"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",?23,"Chart #",?31,"Age",?39,"Room",?47,"Srv"
+9 WRITE ?53,"Provider",?69,"Added"
+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
