Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGIPL4

BDGIPL4.m

Go to the documentation of this file. 
  1. BDGIPL4 ; IHS/ANMC/LJF - CURR INPTS BY SERVICE ;  
  1.  ;;5.3;PIMS;**1007**;FEB 27, 2007
  1.  ;
  1.  ;
  1.  ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
  1.  ;
  1.  I $E(IOST,1,2)="P-" D INIT,PRINT Q
  1.  ;
  1. EN ; -- main entry point for BDG IPL BY SERVICE
  1.  ; assumes BDGSRT is set
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG IPL BY SERVICE")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X
  1.  S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
  1.  ;11/1/2002 WAR per LJF30, P37
  1.  ;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2))  ;IHS/ANMC/LJF 10/31/2002
  1.  S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS)          ;IHS/ANMC/LJF 10/31/2002
  1.  S VALMHDR(2)=$$SP(75-$L(X)\2)_X
  1.  I $G(BDGSRT2) D
  1.  . S X=$S(BDGSRT2=1:"Inpatients Only",BDGSRT2=2:"Observations Only",1:"")
  1.  . I X]"" S VALMHDR(3)=$$SP(75-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  NEW BDGSRV,BDGSVN,BDGCNT,SRV,NAME,LINE,DFN
  1.  K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
  1.  S VALMCNT=0,BDGCNT=1
  1.  ;11/1/2002 WAR per LJF30, P37
  1.  ;IHS/ANMC/LJF 10/31/2002 add ability to print >1 service
  1.  ;S BDGSRV=$S(BDGSRT="A":0,1:+BDGSRT)
  1.  ;I BDGSRV S BDGSVN=$P(BDGSRT,U,2) D PATLOOP,TRANSFER I 1  ;one service
  1.  ;
  1.  ; if user asked for all services
  1.  ;E  F  S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV  D
  1.  I '$D(BDGSRT2) S BDGSRT2=""
  1.  S BDGSRV=0 F  S BDGSRV=$O(^DPT("ATR",BDGSRV)) Q:'BDGSRV  D
  1.  . I BDGSRT=0,'$D(BDGSRT(BDGSRV)) Q       ;not in list of selected services
  1.  . ;IHS/ANMC/LJF 10/31/2002 end of mods
  1.  . S BDGSVN=$$GET1^DIQ(45.7,BDGSRV,.01)   ;service name
  1.  . I BDGSRT2=1,BDGSVN["OBSERVATION" Q     ;inpt only
  1.  . I BDGSRT2=2,BDGSVN'["OBSERVATION" Q    ;observation only
  1.  . D PATLOOP,TRANSFER
  1.  ;
  1.  ; pull sorted list and create display array
  1.  S SRV=0 F  S SRV=$O(^TMP("BDGIPL1",$J,SRV)) Q:SRV=""  D
  1.  . ;
  1.  . ; if SRV contains "**" means list of transfers out of service
  1.  . I SRV["**" D
  1.  .. D SET("Admitted to "_$P(SRV,"**")_" then tranferred:",.VALMCNT,BDGCNT,"")
  1.  . ;
  1.  . ; set up service name subheading
  1.  . E  D SET($G(IORVON)_SRV_$G(IORVOFF),.VALMCNT,BDGCNT,"")
  1.  . ;
  1.  . S NAME=0 F  S NAME=$O(^TMP("BDGIPL1",$J,SRV,NAME)) Q:NAME=""  D
  1.  .. S DFN=0 F  S DFN=$O(^TMP("BDGIPL1",$J,SRV,NAME,DFN)) Q:'DFN  D
  1.  ... ;
  1.  ... S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")
  1.  ... S LINE=LINE_$E(NAME,1,20)                   ;patient
  1.  ... S LINE=$$PAD(LINE,27)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)  ;chart#
  1.  ... S LINE=$$PAD(LINE,36)_$$WRDABRV^BDGF1(DFN)                ;ward
  1.  ... S LINE=$$PAD(LINE,43)_$G(^DPT(DFN,.101))                 ;room-bed
  1.  ... S LINE=$$PAD(LINE,55)_$$CURPRV^BDGF1(DFN,25)             ;providers
  1.  ... D SET(LINE,.VALMCNT,BDGCNT,DFN)
  1.  ... ;
  1.  ... ; if transferred, display date and new service
  1.  ... S X=^TMP("BDGIPL1",$J,SRV,NAME,DFN) I X]"" D
  1.  .... S LINE=$$SP(12)_"To "_$$GET1^DIQ(2,DFN,.103)
  1.  .... S LINE=LINE_" on "_$P(X,":",1,2)
  1.  .... D SET(LINE,.VALMCNT,BDGCNT,DFN)
  1.  ... ;
  1.  ... ; increment counter
  1.  ... S BDGCNT=BDGCNT+1
  1.  .. ;
  1.  .. ; skip line between services
  1.  .. I $O(^TMP("BDGIPL1",$J,SRV,NAME))="" D SET("",.VALMCNT,BDGCNT-1,"")
  1.  ;
  1.  I '$D(^TMP("BDGIPL",$J)) D
  1.  . S VALMCNT=1 D SET("No Current Inpatients Found",.VALMCNT,BDGCNT,"")
  1.  ;
  1.  K ^TMP("BDGIPL1",$J)
  1.  Q
  1.  ;
  1. PATLOOP ; loop by dfn then sort results by name
  1.  NEW DFN
  1.  Q:BDGSVN=""   ;in case of incomplete admissions in file
  1.  S DFN=0 F  S DFN=$O(^DPT("ATR",BDGSRV,DFN)) Q:'DFN  D
  1.  . S ^TMP("BDGIPL1",$J,BDGSVN,$$GET1^DIQ(2,DFN,.01),DFN)=""
  1.  ;
  1.  Q
  1.  ;
  1. TRANSFER ; returns new service and date if transferred from admtg service
  1.  NEW CA,SRV,DATE
  1.  S WARD=0 F  S WARD=$O(^DPT("CN",WARD)) Q:WARD=""  D
  1.  . S DFN=0 F  S DFN=$O(^DPT("CN",WARD,DFN)) Q:'DFN  D
  1.  .. S CA=$G(^DPT(DFN,.105))                          ;admission ien
  1.  .. S SRV=$$ADMSRV^BDGF1(CA,DFN)                     ;admission service
  1.  .. ;
  1.  .. ; if adm service not equal current service, continue
  1.  .. I SRV'=$$GET1^DIQ(2,DFN,.103) D
  1.  ... ;11/1/2002 WAR per LJF30, P37
  1.  ... ;IHS/ANMC/LJF 10/31/2002 check array of sevices
  1.  ... ;I BDGSRT'="A" Q:SRV'=BDGSVN  ;not looking for this service
  1.  ... I BDGSRT'="A" NEW X S X=$O(^DIC(45.7,"B",SRV,0)) Q:'X  I '$D(BDGSRT(X)) Q
  1.  ... ;IHS/ANMC/LJF 10/31/2002 end of mods
  1.  ... I BDGSRT="A",$G(BDGSRT2)=2 Q:SRV'["OBSERVATION"
  1.  ... S DATE=$$GET1^DIQ(405,+$$LASTTXN^BDGF1(CA,DFN),.01)   ;transf date
  1.  ... ;
  1.  ... ; subscript is adm service
  1.  ... S ^TMP("BDGIPL1",$J,SRV_"**",$$GET1^DIQ(2,DFN,.01),DFN)=DATE
  1.  Q
  1.  ;
  1. SET(LINE,NUM,COUNT,IEN) ; put display line into array
  1.  D SET^BDGIPL1(LINE,.NUM,COUNT,IEN)
  1.  Q
  1.  ;
  1. PRINT ; print report to paper
  1.  NEW BDGX,BDGPG
  1.  U IO D INIT^BDGF,HDG
  1.  ;
  1.  S BDGX=0 F  S BDGX=$O(^TMP("BDGIPL",$J,BDGX)) Q:'BDGX  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BDGIPL",$J,BDGX,0)
  1.  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
  1.  D PRTKL^BDGF,EXIT
  1.  ;D ^%ZISC,PRTKL^BDGF,EXIT  cmi/anch/maw 2/22/2007 orig line
  1.  Q  ;cmi/anch/maw 7/25/2007 quit missing patch 1007
  1.  ;
  1. HDG ; heading for paper report
  1.  NEW X,Y
  1.  S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
  1.  W !,BDGUSR,?11,"***",$$CONF^BDGF,"***"
  1.  W !,BDGDATE,?24,"Current Inpatients by Service",?70,"Page: ",BDGPG
  1.  ;11/1/2002 WAR per LJF30, P37
  1.  ;S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$P(BDGSRT,U,2))  ;IHS/ANMC/LJF 10/31/2002
  1.  S X=$S(BDGSRT="A":"For ALL Treating Specialties",1:$$SERVS)          ;IHS/ANMC/LJF 10/31/2002
  1.  I $G(BDGSRT2) D
  1.  . S Y=$S(BDGSRT2=1:"Inpatients",BDGSRT2=2:"Observations",1:"")
  1.  . I Y]"" S X=X_"  ("_Y_" Only)"
  1.  W !,BDGTIME,?(80-$L(X)\2),X
  1.  W !,$$REPEAT^XLFSTR("-",80)
  1.  W !?5,"Patient Name",?27,"Chart #",?36,"Ward",?43,"Room-Bed"
  1.  W ?55,"Primary/Attending"
  1.  W !,$$REPEAT^XLFSTR("=",80)
  1.  Q
  1.  ;11/1/2002 WAR per LJF30, P37
  1. SERVS() ; returns service name or "selected services";IHS/ANMC/LJF 10/31/2002
  1.  NEW X
  1.  S X=$O(BDGSRT(0)) I $O(BDGSRT(X)) Q "Selected Services"
  1.  Q BDGSRT(X)
  1.  ;11/1/2002 WAR - end of new 'tag' being added per Linda
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGIPL",$J)
  1.  ;K BDGSRT,BDGSRT2  cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)