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

BDGILD7.m

Go to the documentation of this file. 
  1. BDGILD7 ; IHS/ANMC/LJF - INPT DEATHS BY DATE ; 
  1.  ;;5.3;PIMS;**1009**;APR 26, 2002
  1.  ;
  1.  ;cmi/anch/maw 05/08/2008 PATCH 1009 requirements 22,31,71 for insurance display
  1.  ;
  1. EN ;EP; -- main entry point for BDG ILD DEATHS
  1.  ; Assumes BDGTYP,BDGBD,BDGED,BDGTYP are set
  1.  ;
  1.  I $E(IOST,1,2)="P-" D INIT,PRINT Q    ;if printing to paper
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BDG ILD DEATHS")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  NEW X
  1.  S VALMHDR(1)=$$SP(10)_"*** "_$$CONF^BDGF_" ***"
  1.  S X="Sorted by "_$P($T(TYPE+BDGTYP),";;",2)
  1.  S VALMHDR(2)=$$SP(75-$L(X)\2)_X
  1.  S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
  1.  S VALMHDR(3)=$$SP(75-$L(X)\2)_X
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  S VALMCNT=0
  1.  K ^TMP("BDGILD7",$J),^TMP("BDGILD7A",$J)
  1.  ;
  1.  ; loop through discharges by date range and put into sorted array
  1.  NEW DATE,DFN,IEN,END,SORT
  1.  S DATE=BDGBD-.0001,END=BDGED+.24
  1.  F  S DATE=$O(^DGPM("AMV3",DATE)) Q:'DATE  Q:(DATE>END)  D
  1.  . S DFN=0 F  S DFN=$O(^DGPM("AMV3",DATE,DFN)) Q:'DFN  D
  1.  .. S IEN=0 F  S IEN=$O(^DGPM("AMV3",DATE,DFN,IEN))  Q:'IEN  D
  1.  ... ;
  1.  ... Q:$$GET1^DIQ(405,IEN,.04)'["DEATH"            ;quit if not a death
  1.  ... Q:'$$OKAY^BDGILD5(BDGTYP,.BDGSRT,IEN,DFN)  ;ok to use disch?
  1.  ... ;
  1.  ... S SORT=$$SORT^BDGILD5(BDGTYP,DFN,IEN,$$GET1^DIQ(405,IEN,.14,"I"))
  1.  ... S:SORT="" SORT="??"
  1.  ... S ^TMP("BDGILD7A",$J,SORT,DATE,IEN)=DFN
  1.  ;
  1.  ;
  1.  ; loop thru sorted array and put into display array
  1.  NEW SORT,DATE,IEN,LINE,X,BDGCOV,BDGRR,I
  1.  S SORT=0 F  S SORT=$O(^TMP("BDGILD7A",$J,SORT)) Q:SORT=""  D
  1.  . ;
  1.  . ; display sort heading (unless sorting by date alone)
  1.  . I BDGTYP>1 D
  1.  .. S X="*** "_SORT_" ***"
  1.  .. D SET("",.VALMCNT),SET($$SP(75-$L(X)\2)_X,.VALMCNT)
  1.  . ;
  1.  . S DATE=0 F  S DATE=$O(^TMP("BDGILD7A",$J,SORT,DATE)) Q:'DATE  D
  1.  .. S IEN=0 F  S IEN=$O(^TMP("BDGILD7A",$J,SORT,DATE,IEN)) Q:'IEN  D
  1.  ... ;
  1.  ... ; build display lines
  1.  ... S DFN=^TMP("BDGILD7A",$J,SORT,DATE,IEN)
  1.  ... S ADM=+$$GET1^DIQ(405,IEN,.14,"I")
  1.  ... S LINE=$E($$GET1^DIQ(2,DFN,.01),1,20)                  ;pat name
  1.  ... S LINE=$$PAD(LINE,23)_$J($$HRCN^BDGF2(DFN,DUZ(2)),6)   ;chart #
  1.  ... S LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE)             ;disch date
  1.  ... S LINE=$$PAD(LINE,41)_$J($$GET1^DIQ(405,ADM,201),3)    ;los
  1.  ... S LINE=$$PAD(LINE,51)_$P($$LASTSRVC^BDGF1(ADM,DFN)," ")  ;srv abbrv
  1.  ... S LINE=$$PAD(LINE,61)_$$GET1^DIQ(405,IEN,.04)          ;disch type
  1.  ... D SET(LINE,.VALMCNT)
  1.  ... ;
  1.  ... S LINE=$$SP(10)_"(Attending: "
  1.  ... S LINE=LINE_$E($$LASTPRV^BDGF1(ADM,DFN),1,18)    ;atten prov
  1.  ... S LINE=$$PAD(LINE,45)_"Dx: "_$$GET1^DIQ(405,ADM,.1)_")"     ;adm dx
  1.  ... D SET(LINE,.VALMCNT)
  1.  ... ;
  1.  ... I BDGINS=1 D    ;include insurance coverage
  1.  .... S BDGCOV=0
  1.  .... ;S X=$$MCR^BDGF2(DFN,IEN),Y=$$MCD^BDGF2(DFN,IEN)  ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 orig line
  1.  .... ;D INS^BDGF2(DFN,IEN,.BDGRR)  ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 orig line
  1.  .... N BDGW,BDGX,BDGY,BDGZ
  1.  .... S BDGX=$$NEWINS^BDGF2(DFN,IEN,"MCR"),BDGY=$$NEWINS^BDGF2(DFN,IEN,"MCD")  ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31
  1.  .... S BDGZ=$$NEWINS^BDGF2(DFN,IEN,"PI"),BDGW=$$NEWINS^BDGF2(DFN,IEN,"RR")  ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31
  1.  .... I BDGCOV=0 D SET($$SP(10)_"**No Additional Coverage**",.VALMCNT) Q
  1.  .... I (BDGW]"")!(BDGX]"")!(BDGY]"") D SET($$SP(10)_BDGX_$$SP(2)_BDGY_$$SP(2)_BDGW,.VALMCNT)  ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31
  1.  .... ;I (X]"")!(Y]"") D SET($$PAD($$SP(10)_X,40)_Y,.VALMCNT)  ;cmi/anch/maw 5/2/2008 PATCH 1009 orig line
  1.  .... ; display all current private insurance coverage
  1.  .... S I=0 F  S I=$O(BDGRR(I)) Q:'I  D
  1.  ..... D SET($$SP(3)_BDGRR(I),.VALMCNT)
  1.  ... ;
  1.  ... ; separate patients by blank line
  1.  ...D SET("",.VALMCNT)
  1.  ;
  1.  ;
  1.  I '$D(^TMP("BDGILD7",$J)) D SET("No data found",.VALMCNT)
  1.  ;
  1.  K ^TMP("BDGILD7A",$J)
  1.  Q
  1.  ;
  1.  ;
  1. SET(DATA,NUM) ; puts display line into array
  1.  S NUM=NUM+1
  1.  S ^TMP("BDGILD7",$J,NUM,0)=DATA
  1.  Q
  1.  ;         
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BDGILD7",$J) K BDGBD,BDGED,BDGTYP,BDGSRT
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. PRINT ; print to paper
  1.  NEW LINE,BDGPG
  1.  U IO D INIT^BDGF,HDG
  1.  ;
  1.  S LINE=0 F  S LINE=$O(^TMP("BDGILD7",$J,LINE)) Q:'LINE  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BDGILD7",$J,LINE,0)
  1.  D ^%ZISC,PRTKL^BDGF,EXIT
  1.  Q
  1.  ;
  1. HDG ; heading when printing to paper
  1.  S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
  1.  W !,BDGUSR,?13,"***",$$CONF^BDGF,"***"
  1.  W !,BDGDATE,?28,"Inpatient Deaths by Date",?71,"Page: ",BDGPG
  1.  NEW X S X="Sorted by "_$P($T(TYPE+BDGTYP),";;",2)
  1.  W !,BDGTIME,?(80-$L(X)\2),X
  1.  S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
  1.  W !?(80-$L(X)\2),X
  1.  W !,$$REPEAT^XLFSTR("-",80)
  1.  W !,"Patient Name",?23,"Chart #",?31,"Death Date",?41,"LOS"
  1.  W ?51,"Serv",?61,"Disch Type"
  1.  W !,$$REPEAT^XLFSTR("=",80)
  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)
  1.  ;
  1.  ;
  1. TYPE ;;
  1.  ;;Date;;
  1.  ;;Ward;;
  1.  ;;Treating Specialty;;
  1.  ;;Admitting Provider;;
  1.  ;;Provider's Service;;
  1.  ;;Community;;
  1.  ;;Service Unit;;
  1.  ;;Patient Name;;