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

BDGILD5.m

Go to the documentation of this file. 
  1. BDGILD5 ; IHS/ANMC/LJF - DISCHARGES 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 DISCHARGES
  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 DISCHARGES")
  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("BDGILD5",$J),^TMP("BDGILD5A",$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:'$$OKAY(BDGTYP,.BDGSRT,IEN,DFN)    ;okay to use discharge?
  1.  ... ;
  1.  ... S SORT=$$SORT(BDGTYP,DFN,IEN,$$GET1^DIQ(405,IEN,.14,"I"))
  1.  ... S:SORT="" SORT="??"
  1.  ... S ^TMP("BDGILD5A",$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,TLOS,COUNT
  1.  S SORT=0 F  S SORT=$O(^TMP("BDGILD5A",$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("BDGILD5A",$J,SORT,DATE)) Q:'DATE  D
  1.  .. S IEN=0 F  S IEN=$O(^TMP("BDGILD5A",$J,SORT,DATE,IEN)) Q:'IEN  D
  1.  ... ;
  1.  ... ; build display lines
  1.  ... S DFN=^TMP("BDGILD5A",$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(+$G(^DGPM(ADM,0))\1)
  1.  ... S LINE=LINE_" - "_$$NUMDATE^BDGF(DATE\1)               ;dsch date
  1.  ... S LINE=$$PAD(LINE,57)_$J($$GET1^DIQ(405,ADM,201),3)     ;los
  1.  ... S LINE=$$PAD(LINE,65)_$P($$LASTSRVC^BDGF1(ADM,DFN)," ")  ;srv abbrv
  1.  ... ; ward abbrev for last ward transfer
  1.  ... S LINE=$$PAD(LINE,72)_$$WRDABRV2^BDGF1(+$$PRIORMVT^BDGF1(DATE,ADM,DFN))
  1.  ... D SET(LINE,.VALMCNT)
  1.  ... ;
  1.  ... S LINE=$$SP(10)_"(Attending: "
  1.  ... S LINE=LINE_$E($$LASTPRV^BDGF1(ADM,DFN),1,18)            ;att 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.  ... ; increment total los count and # of discharges
  1.  ... S TLOS=$G(TLOS)+$$GET1^DIQ(405,ADM,201)  ;increment los
  1.  ... S COUNT=$G(COUNT)+1                      ;increment # ofdischarges
  1.  ;
  1.  I $G(COUNT) D
  1.  . D SET("",.VALMCNT),SET($$SP(45)_"Total LOS: "_$J(TLOS,4),.VALMCNT)
  1.  . D SET($$SP(43)_"Average LOS: "_$J(TLOS/COUNT,4,0),.VALMCNT)
  1.  ;
  1.  I '$D(^TMP("BDGILD5",$J)) D SET("No data found",.VALMCNT)
  1.  ;
  1.  K ^TMP("BDGILD5A",$J)
  1.  Q
  1.  ;
  1. OKAY(TYPE,SORT,IEN,DFN) ; does discharge fall within parameters
  1.  NEW ADM
  1.  I (TYPE=1)!(TYPE=8) Q 1        ;by date or patient
  1.  I $P($G(SORT),U)="A" Q 1             ;all of whatever selected for type
  1.  I TYPE=2 Q $S($D(SORT(+$O(^DIC(42,"B",$$GET1^DIQ(405,IEN,200),0)))):1,1:0)   ;ward at discharge
  1.  S ADM=$$GET1^DIQ(405,IEN,.14,"I")                       ;admission ien
  1.  I TYPE=3 Q $S($D(SORT(+$P($$LASTTXN^BDGF1(ADM,DFN),U,2))):1,1:0)  ;srv
  1.  I TYPE=4 Q $S($D(SORT(+$$LASTPRV^BDGF1(ADM,DFN,"I"))):1,1:0)
  1.  I TYPE=6 Q $S($D(SORT(+$$GET1^DIQ(9000001,DFN,1117,"I"))):1,1:0)  ;com
  1.  I TYPE=7 Q $S($D(SORT(+$$GET1^DIQ(9999999.05,+$$GET1^DIQ(9000001,DFN,1117,"I"),.05,"I"))):1,1:0)   ;serv unit
  1.  Q $S($D(SORT(+$$LASTPRVS^BDGF1(IEN,DFN,"I"))):1,1:0)  ;psrv
  1.  ;
  1.  ;
  1. SORT(TYPE,DFN,N,ADM) ; returns external format of sort for this report
  1.  ; ADM= admission ien
  1.  NEW X
  1.  I TYPE=1 Q +$G(^DGPM(N,0))                      ;date sort
  1.  I TYPE=2 Q $$GET1^DIQ(405,N,200)                ;ward sort
  1.  I TYPE=3 Q $P($$LASTSRVC^BDGF1(ADM,DFN)," ")    ;service sort
  1.  I TYPE=4 Q $$LASTPRV^BDGF1(ADM,DFN)             ;provider sort
  1.  I TYPE=5 Q $$LASTPRVS^BDGF1(ADM,DFN)            ;prov's service sort
  1.  I TYPE=6 Q $$GET1^DIQ(9000001,DFN,1117)         ;current community
  1.  ;                                               ;service unit
  1.  I TYPE=7 Q $$GET1^DIQ(9999999.05,+$$GET1^DIQ(9000001,DFN,1117,"I"),.05)
  1.  Q $$GET1^DIQ(2,DFN,.01)                         ;patient name sort
  1.  ;
  1.  ;
  1. SET(DATA,NUM) ; puts display line into array
  1.  S NUM=NUM+1
  1.  S ^TMP("BDGILD5",$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("BDGILD5",$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("BDGILD5",$J,LINE)) Q:'LINE  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BDGILD5",$J,LINE,0)
  1.  ;
  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,?30,"Discharges 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,"Admission Dates",?57,"LOS"
  1.  W ?65,"Serv",?72,"Ward" 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;;