BDGOPL ; IHS/ANMC/LJF - OPERATORS' LIST OF INPATIENTS ; [ 08/12/2003 3:58 PM ]
;;5.3;PIMS;;APR 26, 2002
;
I $$BROWSE^BDGF="B" D EN Q
D ZIS^BDGF("QP","EN^BDGOPL","OPERATORS' LIST","")
Q
;
EN ; -- main entry point for BDG OPERATORS' LIST
I $E(IOST,1,2)="P-" D INIT,PRINT Q
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG OPERATORS' LIST")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
Q
;
INIT ; -- init variables and list array
NEW WD,DFN,BDGCNT,NAME
K ^TMP("BDGOPL",$J),^TMP("BDGOPL1",$J)
S VALMCNT=0,BDGCNT=1
;
; loop thru inpatients and put in alphabetical order
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 ^TMP("BDGOPL1",$J,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; pull sorted list and create display array
S NM=0 F S NM=$O(^TMP("BDGOPL1",$J,NM)) Q:NM="" D
. S DFN=0 F S DFN=$O(^TMP("BDGOPL1",$J,NM,DFN)) Q:'DFN D
.. D LINE
;
K ^TMP("BDGOPL1",$J)
Q
;
LINE ; set up dislay line for patient
NEW LINE,X
;
S LINE=$E($$GET1^DIQ(2,DFN,.01),1,23) ;name
I $$OPTOUT^BDGF1(DFN) S LINE=$$REPEAT^XLFSTR("*",20) ;if patient opted out of directory;IHS/ITSC/LJF 10/03/2003
;
S LINE=$$PAD(LINE,25)_$$PHONE ;rm phone
S LINE=$$PAD(LINE,33)_$G(^DPT(DFN,.101)) ;room
S LINE=$$PAD(LINE,42)_$$WRDABRV^BDGF1(DFN) ;ward
S LINE=$$PAD(LINE,50)_$$GET1^DIQ(2,DFN,.02,"I") ;sex
S LINE=$$PAD(LINE,55)_$J($$GET1^DIQ(9000001,DFN,1102.98),7) ;age
S LINE=$$PAD(LINE,65)_$E($$GET1^DIQ(9000001,DFN,1118),1,15) ;commun
D SET(LINE,.VALMCNT)
Q
;
SET(LINE,NUM) ; put display line into array
S NUM=NUM+1
S ^TMP("BDGOPL",$J,NUM,0)=LINE
Q
;
PRINT ; print report to paper
NEW BDGX,BDGLN,BDGPG
U IO D HDG
;
; loop thru display array
S BDGX=0 F S BDGX=$O(^TMP("BDGOPL",$J,BDGX)) Q:'BDGX D
. I $Y>(IOSL-4) D HDG
. S BDGLN=^TMP("BDGOPL",$J,BDGX,0)
. W !,BDGLN
;
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF ;page #
W !?16,$$CONF^BDGF,?67,$$FMTE^XLFDT(DT)
W !?28,"Operators' Inpatient List",?70,$J($$TIME^BDGF($$NOW^XLFDT),9)
W !,$$REPEAT^XLFSTR("-",80)
W !,"Patient",?25,"Phone",?33,"Room",?42,"Ward",?49,"Sex"
W ?57,"Age",?65,"Community"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
PHONE() ; returns room phone number if asked for
NEW X,ROOM
S ROOM=$G(^DPT(DFN,.101)) I ROOM="" Q ""
S X=$O(^DG(405.4,"B",ROOM,0)) I 'X Q ""
S X=$$GET1^DIQ(405.4,X,9999999.01)
Q $S(X]"":"x"_X,1:"")
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGOPL",$J)
K BDGSRT
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)
BDGOPL ; IHS/ANMC/LJF - OPERATORS' LIST OF INPATIENTS ; [ 08/12/2003 3:58 PM ]
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 IF $$BROWSE^BDGF="B"
DO EN
QUIT
+4 DO ZIS^BDGF("QP","EN^BDGOPL","OPERATORS' LIST","")
+5 QUIT
+6 ;
EN ; -- main entry point for BDG OPERATORS' LIST
+1 IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG OPERATORS' LIST")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 NEW WD,DFN,BDGCNT,NAME
+2 KILL ^TMP("BDGOPL",$JOB),^TMP("BDGOPL1",$JOB)
+3 SET VALMCNT=0
SET BDGCNT=1
+4 ;
+5 ; loop thru inpatients and put in alphabetical order
+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 SET ^TMP("BDGOPL1",$JOB,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+9 ;
+10 ; pull sorted list and create display array
+11 SET NM=0
FOR
SET NM=$ORDER(^TMP("BDGOPL1",$JOB,NM))
IF NM=""
QUIT
Begin DoDot:1
+12 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGOPL1",$JOB,NM,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+13 DO LINE
End DoDot:2
End DoDot:1
+14 ;
+15 KILL ^TMP("BDGOPL1",$JOB)
+16 QUIT
+17 ;
LINE ; set up dislay line for patient
+1 NEW LINE,X
+2 ;
+3 ;name
SET LINE=$EXTRACT($$GET1^DIQ(2,DFN,.01),1,23)
+4 ;if patient opted out of directory;IHS/ITSC/LJF 10/03/2003
IF $$OPTOUT^BDGF1(DFN)
SET LINE=$$REPEAT^XLFSTR("*",20)
+5 ;
+6 ;rm phone
SET LINE=$$PAD(LINE,25)_$$PHONE
+7 ;room
SET LINE=$$PAD(LINE,33)_$GET(^DPT(DFN,.101))
+8 ;ward
SET LINE=$$PAD(LINE,42)_$$WRDABRV^BDGF1(DFN)
+9 ;sex
SET LINE=$$PAD(LINE,50)_$$GET1^DIQ(2,DFN,.02,"I")
+10 ;age
SET LINE=$$PAD(LINE,55)_$JUSTIFY($$GET1^DIQ(9000001,DFN,1102.98),7)
+11 ;commun
SET LINE=$$PAD(LINE,65)_$EXTRACT($$GET1^DIQ(9000001,DFN,1118),1,15)
+12 DO SET(LINE,.VALMCNT)
+13 QUIT
+14 ;
SET(LINE,NUM) ; put display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGOPL",$JOB,NUM,0)=LINE
+3 QUIT
+4 ;
PRINT ; print report to paper
+1 NEW BDGX,BDGLN,BDGPG
+2 USE IO
DO HDG
+3 ;
+4 ; loop thru display array
+5 SET BDGX=0
FOR
SET BDGX=$ORDER(^TMP("BDGOPL",$JOB,BDGX))
IF 'BDGX
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-4)
DO HDG
+7 SET BDGLN=^TMP("BDGOPL",$JOB,BDGX,0)
+8 WRITE !,BDGLN
End DoDot:1
+9 ;
+10 DO ^%ZISC
DO EXIT
+11 QUIT
+12 ;
HDG ; heading for paper report
+1 ;page #
SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !?16,$$CONF^BDGF,?67,$$FMTE^XLFDT(DT)
+3 WRITE !?28,"Operators' Inpatient List",?70,$JUSTIFY($$TIME^BDGF($$NOW^XLFDT),9)
+4 WRITE !,$$REPEAT^XLFSTR("-",80)
+5 WRITE !,"Patient",?25,"Phone",?33,"Room",?42,"Ward",?49,"Sex"
+6 WRITE ?57,"Age",?65,"Community"
+7 WRITE !,$$REPEAT^XLFSTR("=",80)
+8 QUIT
+9 ;
PHONE() ; returns room phone number if asked for
+1 NEW X,ROOM
+2 SET ROOM=$GET(^DPT(DFN,.101))
IF ROOM=""
QUIT ""
+3 SET X=$ORDER(^DG(405.4,"B",ROOM,0))
IF 'X
QUIT ""
+4 SET X=$$GET1^DIQ(405.4,X,9999999.01)
+5 QUIT $SELECT(X]"":"x"_X,1:"")
+6 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGOPL",$JOB)
+2 KILL BDGSRT
+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)
