BDGIPL4 ; IHS/ANMC/LJF - CURR INPTS BY SERVICE ;
;;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 SERVICE
; assumes BDGSRT is set
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IPL BY SERVICE")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
;11/1/2002 WAR per LJF30, P37
;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2)) ;IHS/ANMC/LJF 10/31/2002
S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS) ;IHS/ANMC/LJF 10/31/2002
S VALMHDR(2)=$$SP(75-$L(X)\2)_X
I $G(BDGSRT2) D
. S X=$S(BDGSRT2=1:"Inpatients Only",BDGSRT2=2:"Observations Only",1:"")
. I X]"" S VALMHDR(3)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW BDGSRV,BDGSVN,BDGCNT,SRV,NAME,LINE,DFN
K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
S VALMCNT=0,BDGCNT=1
;11/1/2002 WAR per LJF30, P37
;IHS/ANMC/LJF 10/31/2002 add ability to print >1 service
;S BDGSRV=$S(BDGSRT="A":0,1:+BDGSRT)
;I BDGSRV S BDGSVN=$P(BDGSRT,U,2) D PATLOOP,TRANSFER I 1 ;one service
;
; if user asked for all services
;E F S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV D
I '$D(BDGSRT2) S BDGSRT2=""
S BDGSRV=0 F S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV D
. I BDGSRT=0,'$D(BDGSRT(BDGSRV)) Q ;not in list of selected services
. ;IHS/ANMC/LJF 10/31/2002 end of mods
. S BDGSVN=$$GET1^DIQ(45.7,BDGSRV,.01) ;service name
. I BDGSRT2=1,BDGSVN["OBSERVATION" Q ;inpt only
. I BDGSRT2=2,BDGSVN'["OBSERVATION" Q ;observation only
. D PATLOOP,TRANSFER
;
; pull sorted list and create display array
S SRV=0 F S SRV=$O(^TMP("BDGIPL1",$J,SRV)) Q:SRV="" D
. ;
. ; if SRV contains "**" means list of transfers out of service
. I SRV["**" D
.. D SET("Admitted to "_$P(SRV,"**")_" then tranferred:",.VALMCNT,BDGCNT,"")
. ;
. ; set up service name subheading
. E D SET($G(IORVON)_SRV_$G(IORVOFF),.VALMCNT,BDGCNT,"")
. ;
. S NAME=0 F S NAME=$O(^TMP("BDGIPL1",$J,SRV,NAME)) Q:NAME="" D
.. S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,SRV,NAME,DFN)) Q:'DFN D
... ;
... S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")
... S LINE=LINE_$E(NAME,1,20) ;patient
... S LINE=$$PAD(LINE,27)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6) ;chart#
... S LINE=$$PAD(LINE,36)_$$WRDABRV^BDGF1(DFN) ;ward
... S LINE=$$PAD(LINE,43)_$G(^DPT(DFN,.101)) ;room-bed
... S LINE=$$PAD(LINE,55)_$$CURPRV^BDGF1(DFN,25) ;providers
... D SET(LINE,.VALMCNT,BDGCNT,DFN)
... ;
... ; if transferred, display date and new service
... S X=^TMP("BDGIPL1",$J,SRV,NAME,DFN) I X]"" D
.... S LINE=$$SP(12)_"To "_$$GET1^DIQ(2,DFN,.103)
.... S LINE=LINE_" on "_$P(X,":",1,2)
.... D SET(LINE,.VALMCNT,BDGCNT,DFN)
... ;
... ; increment counter
... S BDGCNT=BDGCNT+1
.. ;
.. ; skip line between services
.. I $O(^TMP("BDGIPL1",$J,SRV,NAME))="" D SET("",.VALMCNT,BDGCNT-1,"")
;
I '$D(^TMP("BDGIPL",$J)) D
. S VALMCNT=1 D SET("No Current Inpatients Found",.VALMCNT,BDGCNT,"")
;
K ^TMP("BDGIPL1",$J)
Q
;
PATLOOP ; loop by dfn then sort results by name
NEW DFN
Q:BDGSVN="" ;in case of incomplete admissions in file
S DFN=0 F S DFN=$O(^DPT("ATR",BDGSRV,DFN)) Q:'DFN D
. S ^TMP("BDGIPL1",$J,BDGSVN,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
Q
;
TRANSFER ; returns new service and date if transferred from admtg service
NEW CA,SRV,DATE
S WARD=0 F S WARD=$O(^DPT("CN",WARD)) Q:WARD="" D
. S DFN=0 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN D
.. S CA=$G(^DPT(DFN,.105)) ;admission ien
.. S SRV=$$ADMSRV^BDGF1(CA,DFN) ;admission service
.. ;
.. ; if adm service not equal current service, continue
.. I SRV'=$$GET1^DIQ(2,DFN,.103) D
... ;11/1/2002 WAR per LJF30, P37
... ;IHS/ANMC/LJF 10/31/2002 check array of sevices
... ;I BDGSRT'="A" Q:SRV'=BDGSVN ;not looking for this service
... I BDGSRT'="A" NEW X S X=$O(^DIC(45.7,"B",SRV,0)) Q:'X I '$D(BDGSRT(X)) Q
... ;IHS/ANMC/LJF 10/31/2002 end of mods
... I BDGSRT="A",$G(BDGSRT2)=2 Q:SRV'["OBSERVATION"
... S DATE=$$GET1^DIQ(405,+$$LASTTXN^BDGF1(CA,DFN),.01) ;transf date
... ;
... ; subscript is adm service
... S ^TMP("BDGIPL1",$J,SRV_"**",$$GET1^DIQ(2,DFN,.01),DFN)=DATE
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,BDGPG
U IO D INIT^BDGF,HDG
;
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
NEW X,Y
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?11,"***",$$CONF^BDGF,"***"
W !,BDGDATE,?24,"Current Inpatients by Service",?70,"Page: ",BDGPG
;11/1/2002 WAR per LJF30, P37
;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2)) ;IHS/ANMC/LJF 10/31/2002
S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS) ;IHS/ANMC/LJF 10/31/2002
I $G(BDGSRT2) D
. S Y=$S(BDGSRT2=1:"Inpatients",BDGSRT2=2:"Observations",1:"")
. I Y]"" S X=X_" ("_Y_" Only)"
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !?5,"Patient Name",?27,"Chart #",?36,"Ward",?43,"Room-Bed"
W ?55,"Primary/Attending"
W !,$$REPEAT^XLFSTR("=",80)
Q
;11/1/2002 WAR per LJF30, P37
SERVS() ; returns service name or "selected services";IHS/ANMC/LJF 10/31/2002
NEW X
S X=$O(BDGSRT(0)) I $O(BDGSRT(X)) Q "Selected Services"
Q BDGSRT(X)
;11/1/2002 WAR - end of new 'tag' being added per Linda
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGIPL",$J)
;K BDGSRT,BDGSRT2 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)
BDGIPL4 ; IHS/ANMC/LJF - CURR INPTS BY SERVICE ;
+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 IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+7 ;
EN ; -- main entry point for BDG IPL BY SERVICE
+1 ; assumes BDGSRT is set
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG IPL BY SERVICE")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
+3 ;11/1/2002 WAR per LJF30, P37
+4 ;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2)) ;IHS/ANMC/LJF 10/31/2002
+5 ;IHS/ANMC/LJF 10/31/2002
SET X=$SELECT(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS)
+6 SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X
+7 IF $GET(BDGSRT2)
Begin DoDot:1
+8 SET X=$SELECT(BDGSRT2=1:"Inpatients Only",BDGSRT2=2:"Observations Only",1:"")
+9 IF X]""
SET VALMHDR(3)=$$SP(75-$LENGTH(X)\2)_X
End DoDot:1
+10 QUIT
+11 ;
INIT ; -- init variables and list array
+1 NEW BDGSRV,BDGSVN,BDGCNT,SRV,NAME,LINE,DFN
+2 KILL ^TMP("BDGIPL",$JOB),^TMP("BDGIPL1",$JOB)
+3 SET VALMCNT=0
SET BDGCNT=1
+4 ;11/1/2002 WAR per LJF30, P37
+5 ;IHS/ANMC/LJF 10/31/2002 add ability to print >1 service
+6 ;S BDGSRV=$S(BDGSRT="A":0,1:+BDGSRT)
+7 ;I BDGSRV S BDGSVN=$P(BDGSRT,U,2) D PATLOOP,TRANSFER I 1 ;one service
+8 ;
+9 ; if user asked for all services
+10 ;E F S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV D
+11 IF '$DATA(BDGSRT2)
SET BDGSRT2=""
+12 SET BDGSRV=0
FOR
SET BDGSRV=$ORDER(^DPT("ATR",BDGSRV))
IF 'BDGSRV
QUIT
Begin DoDot:1
+13 ;not in list of selected services
IF BDGSRT=0
IF '$DATA(BDGSRT(BDGSRV))
QUIT
+14 ;IHS/ANMC/LJF 10/31/2002 end of mods
+15 ;service name
SET BDGSVN=$$GET1^DIQ(45.7,BDGSRV,.01)
+16 ;inpt only
IF BDGSRT2=1
IF BDGSVN["OBSERVATION"
QUIT
+17 ;observation only
IF BDGSRT2=2
IF BDGSVN'["OBSERVATION"
QUIT
+18 DO PATLOOP
DO TRANSFER
End DoDot:1
+19 ;
+20 ; pull sorted list and create display array
+21 SET SRV=0
FOR
SET SRV=$ORDER(^TMP("BDGIPL1",$JOB,SRV))
IF SRV=""
QUIT
Begin DoDot:1
+22 ;
+23 ; if SRV contains "**" means list of transfers out of service
+24 IF SRV["**"
Begin DoDot:2
+25 DO SET("Admitted to "_$PIECE(SRV,"**")_" then tranferred:",.VALMCNT,BDGCNT,"")
End DoDot:2
+26 ;
+27 ; set up service name subheading
+28 IF '$TEST
DO SET($GET(IORVON)_SRV_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
+29 ;
+30 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGIPL1",$JOB,SRV,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+31 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,SRV,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+32 ;
+33 SET LINE=$SELECT($EXTRACT(IOST,1,2)="P-":$$SP(5),1:$JUSTIFY(BDGCNT,3)_") ")
+34 ;patient
SET LINE=LINE_$EXTRACT(NAME,1,20)
+35 ;chart#
SET LINE=$$PAD(LINE,27)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+36 ;ward
SET LINE=$$PAD(LINE,36)_$$WRDABRV^BDGF1(DFN)
+37 ;room-bed
SET LINE=$$PAD(LINE,43)_$GET(^DPT(DFN,.101))
+38 ;providers
SET LINE=$$PAD(LINE,55)_$$CURPRV^BDGF1(DFN,25)
+39 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+40 ;
+41 ; if transferred, display date and new service
+42 SET X=^TMP("BDGIPL1",$JOB,SRV,NAME,DFN)
IF X]""
Begin DoDot:4
+43 SET LINE=$$SP(12)_"To "_$$GET1^DIQ(2,DFN,.103)
+44 SET LINE=LINE_" on "_$PIECE(X,":",1,2)
+45 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
End DoDot:4
+46 ;
+47 ; increment counter
+48 SET BDGCNT=BDGCNT+1
End DoDot:3
+49 ;
+50 ; skip line between services
+51 IF $ORDER(^TMP("BDGIPL1",$JOB,SRV,NAME))=""
DO SET("",.VALMCNT,BDGCNT-1,"")
End DoDot:2
End DoDot:1
+52 ;
+53 IF '$DATA(^TMP("BDGIPL",$JOB))
Begin DoDot:1
+54 SET VALMCNT=1
DO SET("No Current Inpatients Found",.VALMCNT,BDGCNT,"")
End DoDot:1
+55 ;
+56 KILL ^TMP("BDGIPL1",$JOB)
+57 QUIT
+58 ;
PATLOOP ; loop by dfn then sort results by name
+1 NEW DFN
+2 ;in case of incomplete admissions in file
IF BDGSVN=""
QUIT
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("ATR",BDGSRV,DFN))
IF 'DFN
QUIT
Begin DoDot:1
+4 SET ^TMP("BDGIPL1",$JOB,BDGSVN,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:1
+5 ;
+6 QUIT
+7 ;
TRANSFER ; returns new service and date if transferred from admtg service
+1 NEW CA,SRV,DATE
+2 SET WARD=0
FOR
SET WARD=$ORDER(^DPT("CN",WARD))
IF WARD=""
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+4 ;admission ien
SET CA=$GET(^DPT(DFN,.105))
+5 ;admission service
SET SRV=$$ADMSRV^BDGF1(CA,DFN)
+6 ;
+7 ; if adm service not equal current service, continue
+8 IF SRV'=$$GET1^DIQ(2,DFN,.103)
Begin DoDot:3
+9 ;11/1/2002 WAR per LJF30, P37
+10 ;IHS/ANMC/LJF 10/31/2002 check array of sevices
+11 ;I BDGSRT'="A" Q:SRV'=BDGSVN ;not looking for this service
+12 IF BDGSRT'="A"
NEW X
SET X=$ORDER(^DIC(45.7,"B",SRV,0))
IF 'X
QUIT
IF '$DATA(BDGSRT(X))
QUIT
+13 ;IHS/ANMC/LJF 10/31/2002 end of mods
+14 IF BDGSRT="A"
IF $GET(BDGSRT2)=2
IF SRV'["OBSERVATION"
QUIT
+15 ;transf date
SET DATE=$$GET1^DIQ(405,+$$LASTTXN^BDGF1(CA,DFN),.01)
+16 ;
+17 ; subscript is adm service
+18 SET ^TMP("BDGIPL1",$JOB,SRV_"**",$$GET1^DIQ(2,DFN,.01),DFN)=DATE
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
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,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 ;
+4 SET BDGX=0
FOR
SET BDGX=$ORDER(^TMP("BDGIPL",$JOB,BDGX))
IF 'BDGX
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGIPL",$JOB,BDGX,0)
End DoDot:1
+7 ;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
+8 DO PRTKL^BDGF
DO EXIT
+9 ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
+10 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
QUIT
+11 ;
HDG ; heading for paper report
+1 NEW X,Y
+2 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+3 WRITE !,BDGUSR,?11,"***",$$CONF^BDGF,"***"
+4 WRITE !,BDGDATE,?24,"Current Inpatients by Service",?70,"Page: ",BDGPG
+5 ;11/1/2002 WAR per LJF30, P37
+6 ;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2)) ;IHS/ANMC/LJF 10/31/2002
+7 ;IHS/ANMC/LJF 10/31/2002
SET X=$SELECT(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS)
+8 IF $GET(BDGSRT2)
Begin DoDot:1
+9 SET Y=$SELECT(BDGSRT2=1:"Inpatients",BDGSRT2=2:"Observations",1:"")
+10 IF Y]""
SET X=X_" ("_Y_" Only)"
End DoDot:1
+11 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+12 WRITE !,$$REPEAT^XLFSTR("-",80)
+13 WRITE !?5,"Patient Name",?27,"Chart #",?36,"Ward",?43,"Room-Bed"
+14 WRITE ?55,"Primary/Attending"
+15 WRITE !,$$REPEAT^XLFSTR("=",80)
+16 QUIT
+17 ;11/1/2002 WAR per LJF30, P37
SERVS() ; returns service name or "selected services";IHS/ANMC/LJF 10/31/2002
+1 NEW X
+2 SET X=$ORDER(BDGSRT(0))
IF $ORDER(BDGSRT(X))
QUIT "Selected Services"
+3 QUIT BDGSRT(X)
+4 ;11/1/2002 WAR - end of new 'tag' being added per Linda
+5 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGIPL",$JOB)
+2 ;K BDGSRT,BDGSRT2 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)
