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