BDGIPL6 ; IHS/ANMC/LJF - CHAPLAIN'S 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 CHAPLAIN
; assumes BDGSRT is set
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IPL CHAPLAIN")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
S X=$S(BDGSRT="A":"For ALL Religions",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,FIRST
K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
S VALMCNT=0,BDGCNT=1,FIRST=1
;
; find current inpatients & sort by religion, ward then room
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
.. S REL=$$GET1^DIQ(2,DFN,.08) Q:REL="" ;if no rel, don't display
.. I BDGSRT,REL'=$P(BDGSRT,U,2) Q ;not selected
.. S RM=$G(^DPT(DFN,.101)) I RM="" S RM="UNK"
.. S ^TMP("BDGIPL1",$J,REL,WD,RM,DFN)=""
;
; pull sorted list and create display array
S REL=0 F S REL=$O(^TMP("BDGIPL1",$J,REL)) Q:REL="" D
. ;
. I BDGSRT="A" D ;display religion subheading
.. ; if printer, mark stop to add form feed
.. I FIRST=0,$E(IOST,1,2)="P-" D SET("@@@@",.VALMCNT,BDGCNT,"")
.. S FIRST=0
.. ;
.. D SET($G(IORVON)_REL_$G(IORVOFF),.VALMCNT,BDGCNT,"")
.. ;
. ;
. S WD=0 F S WD=$O(^TMP("BDGIPL1",$J,REL,WD)) Q:WD="" D
.. S RM=0 F S RM=$O(^TMP("BDGIPL1",$J,REL,WD,RM)) Q:RM="" D
... S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,REL,WD,RM,DFN)) Q:'DFN D
.... D LINE
;
K ^TMP("BDGIPL1",$J)
Q
;
LINE ; set up dislay line for patient
NEW LINE,X
S X=$O(^DIC(42,"B",WD,0)) I X S X=$$GET1^DIQ(9009016.5,X,.02)
S LINE=$$PAD(X,7)_RM ;ward abbrv & room
S LINE=$$PAD(LINE,15)_$E($$GET1^DIQ(2,DFN,.01),1,18) ;name
S LINE=$$PAD(LINE,35)_$$AGE(DFN) ;age
S LINE=$$PAD(LINE,45)_$E($$GET1^DIQ(9000001,DFN,1118),1,18) ;community
S LINE=$$PAD(LINE,65)_$P($$INPT1^BDGF1(DFN,DT),"@") ;admit date
D SET(LINE,.VALMCNT,BDGCNT,DFN)
;
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,REL,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
. S BDGLN=^TMP("BDGIPL",$J,BDGX,0)
. ;
. ;marker for form feed between religions
. I $E(BDGLN,1,4)="@@@@" D HDG Q
. ;
. I $Y>(IOSL-4) D HDG
. 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
W !,BDGDATE,?32,"Chaplain's List",?70,"Page: ",BDGPG
S X=$S(BDGSRT="A":"For ALL Religions",1:$P(BDGSRT,U,2))
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !,"Ward",?7,"Room",?15,"Patient Name",?35,"Age",?45,"Community"
W ?65,"Admit Date"
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
BDGIPL6 ; IHS/ANMC/LJF - CHAPLAIN'S 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 CHAPLAIN
+1 ; assumes BDGSRT is set
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG IPL CHAPLAIN")
+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 Religions",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,FIRST
+2 KILL ^TMP("BDGIPL",$JOB),^TMP("BDGIPL1",$JOB)
+3 SET VALMCNT=0
SET BDGCNT=1
SET FIRST=1
+4 ;
+5 ; find current inpatients & sort by religion, ward then room
+6 SET WD=0
FOR
SET WD=$ORDER(^DPT("CN",WD))
IF WD=""
QUIT
Begin DoDot:1
+7 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+8 ;if no rel, don't display
SET REL=$$GET1^DIQ(2,DFN,.08)
IF REL=""
QUIT
+9 ;not selected
IF BDGSRT
IF REL'=$PIECE(BDGSRT,U,2)
QUIT
+10 SET RM=$GET(^DPT(DFN,.101))
IF RM=""
SET RM="UNK"
+11 SET ^TMP("BDGIPL1",$JOB,REL,WD,RM,DFN)=""
End DoDot:2
End DoDot:1
+12 ;
+13 ; pull sorted list and create display array
+14 SET REL=0
FOR
SET REL=$ORDER(^TMP("BDGIPL1",$JOB,REL))
IF REL=""
QUIT
Begin DoDot:1
+15 ;
+16 ;display religion subheading
IF BDGSRT="A"
Begin DoDot:2
+17 ; if printer, mark stop to add form feed
+18 IF FIRST=0
IF $EXTRACT(IOST,1,2)="P-"
DO SET("@@@@",.VALMCNT,BDGCNT,"")
+19 SET FIRST=0
+20 ;
+21 DO SET($GET(IORVON)_REL_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
+22 ;
End DoDot:2
+23 ;
+24 SET WD=0
FOR
SET WD=$ORDER(^TMP("BDGIPL1",$JOB,REL,WD))
IF WD=""
QUIT
Begin DoDot:2
+25 SET RM=0
FOR
SET RM=$ORDER(^TMP("BDGIPL1",$JOB,REL,WD,RM))
IF RM=""
QUIT
Begin DoDot:3
+26 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,REL,WD,RM,DFN))
IF 'DFN
QUIT
Begin DoDot:4
+27 DO LINE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;
+29 KILL ^TMP("BDGIPL1",$JOB)
+30 QUIT
+31 ;
LINE ; set up dislay line for patient
+1 NEW LINE,X
+2 SET X=$ORDER(^DIC(42,"B",WD,0))
IF X
SET X=$$GET1^DIQ(9009016.5,X,.02)
+3 ;ward abbrv & room
SET LINE=$$PAD(X,7)_RM
+4 ;name
SET LINE=$$PAD(LINE,15)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,18)
+5 ;age
SET LINE=$$PAD(LINE,35)_$$AGE(DFN)
+6 ;community
SET LINE=$$PAD(LINE,45)_$EXTRACT($$GET1^DIQ(9000001,DFN,1118),1,18)
+7 ;admit date
SET LINE=$$PAD(LINE,65)_$PIECE($$INPT1^BDGF1(DFN,DT),"@")
+8 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+9 ;
+10 QUIT
+11 ;
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,REL,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 SET BDGLN=^TMP("BDGIPL",$JOB,BDGX,0)
+7 ;
+8 ;marker for form feed between religions
+9 IF $EXTRACT(BDGLN,1,4)="@@@@"
DO HDG
QUIT
+10 ;
+11 IF $Y>(IOSL-4)
DO HDG
+12 WRITE !,BDGLN
End DoDot:1
+13 ;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
+14 DO PRTKL^BDGF
DO EXIT
+15 ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
+16 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
QUIT
+17 ;
HDG ; heading for paper report
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?16,$$CONF^BDGF
+3 WRITE !,BDGDATE,?32,"Chaplain's List",?70,"Page: ",BDGPG
+4 SET X=$SELECT(BDGSRT="A":"For ALL Religions",1:$PIECE(BDGSRT,U,2))
+5 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+6 WRITE !,$$REPEAT^XLFSTR("-",80)
+7 WRITE !,"Ward",?7,"Room",?15,"Patient Name",?35,"Age",?45,"Community"
+8 WRITE ?65,"Admit Date"
+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 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
