BDGILD2 ; IHS/ANMC/LJF - READMISSIONS 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 READMISSIONS
; 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 READMISSIONS")
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("BDGILD2",$J),^TMP("BDGILD2A",$J)
;
D SET("Maximum days between inpatient stays: "_BDGMAX,.VALMCNT)
;
; loop through admissions by date range and put into sorted array
NEW DATE,DFN,IEN,END,SORT,LAST
S DATE=BDGBD-.0001,END=BDGED+.24
F S DATE=$O(^DGPM("AMV1",DATE)) Q:'DATE Q:(DATE>END) D
. S DFN=0 F S DFN=$O(^DGPM("AMV1",DATE,DFN)) Q:'DFN D
.. S IEN=0 F S IEN=$O(^DGPM("AMV1",DATE,DFN,IEN)) Q:'IEN D
... ;
... ; is this a readmission?
... S LAST=$$READM^BDGF1(IEN,DFN,BDGMAX) Q:'LAST
... ;
... ; okay to use this admission based on sort criteria?
... Q:'$$OKAY^BDGILD1(BDGTYP,.BDGSRT,IEN,DFN)
... ;
... S SORT=$$SORT^BDGILD1(BDGTYP,IEN) S:SORT="" SORT="??"
... S ^TMP("BDGILD2A",$J,SORT,DATE,IEN)=DFN_U_$P(LAST,U,2)
;
;
; loop thru sorted array and put into display array
NEW SORT,DATE,IEN,LINE,X,BDGCOV,BDGRR,I,DFN,LAST
S SORT=0 F S SORT=$O(^TMP("BDGILD2A",$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("BDGILD2A",$J,SORT,DATE)) Q:'DATE D
.. S IEN=0 F S IEN=$O(^TMP("BDGILD2A",$J,SORT,DATE,IEN)) Q:'IEN D
... ;
... ; build display lines
... S DFN=+^TMP("BDGILD2A",$J,SORT,DATE,IEN)
... S LAST=$P(^TMP("BDGILD2A",$J,SORT,DATE,IEN),U,2)
... 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\1) ;admit date
... I LAST S LINE=$$PAD(LINE,45)_$$NUMDATE^BDGF(LAST\1) ;dsch date
... S LINE=$$PAD(LINE,57)_$J($$FMDIFF^XLFDT(DATE,LAST),3) ;days diff
... S LINE=$$PAD(LINE,65)_$P($$ADMSRVC^BDGF1(IEN,DFN)," ") ;srv abbrv
... S LINE=$$PAD(LINE,72)_$$WRDABRV2^BDGF1(IEN) ;ward abbrv
... D SET(LINE,.VALMCNT)
... ;
... S LINE=$$SP(10)_"New Dx: "_$E($$GET1^DIQ(405,IEN,.1),1,25) ;adm dx
... ; find admission ien for last discharge date
... S LASTCA=$P($G(^DGPM(+$O(^DGPM("APTT3",DFN,LAST,0)),0)),U,14)
... S LINE=$$PAD(LINE,45)_"Last Dx: "_$$GET1^DIQ(405,+LASTCA,.1)
... 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 VALMCNT=1 D SET("No data found",.VALMCNT)
;
K ^TMP("BDGILD2A",$J)
Q
;
;
SET(DATA,NUM) ; puts display line into array
S NUM=NUM+1
S ^TMP("BDGILD2",$J,NUM,0)=DATA
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGILD2",$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("BDGILD2",$J,LINE)) Q:'LINE D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGILD2",$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 !?13,"***",$$CONF^BDGF,"***"
W !,BDGUSR,?30,"Readmissions by Date",?71,"Page: ",BDGPG
NEW X S X="Sorted by "_$P($T(TYPE+BDGTYP),";;",2)
W !,BDGDATE,?(80-$L(X)\2),X
S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !,"Patient Name",?23,"Chart #",?31,"Admit Date",?45,"Last Dsch"
W ?55,"Diff",?65,"Serv",?72,"Ward"
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;;
BDGILD2 ; IHS/ANMC/LJF - READMISSIONS 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 READMISSIONS
+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 READMISSIONS")
+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("BDGILD2",$JOB),^TMP("BDGILD2A",$JOB)
+3 ;
+4 DO SET("Maximum days between inpatient stays: "_BDGMAX,.VALMCNT)
+5 ;
+6 ; loop through admissions by date range and put into sorted array
+7 NEW DATE,DFN,IEN,END,SORT,LAST
+8 SET DATE=BDGBD-.0001
SET END=BDGED+.24
+9 FOR
SET DATE=$ORDER(^DGPM("AMV1",DATE))
IF 'DATE
QUIT
IF (DATE>END)
QUIT
Begin DoDot:1
+10 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",DATE,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+11 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("AMV1",DATE,DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+12 ;
+13 ; is this a readmission?
+14 SET LAST=$$READM^BDGF1(IEN,DFN,BDGMAX)
IF 'LAST
QUIT
+15 ;
+16 ; okay to use this admission based on sort criteria?
+17 IF '$$OKAY^BDGILD1(BDGTYP,.BDGSRT,IEN,DFN)
QUIT
+18 ;
+19 SET SORT=$$SORT^BDGILD1(BDGTYP,IEN)
IF SORT=""
SET SORT="??"
+20 SET ^TMP("BDGILD2A",$JOB,SORT,DATE,IEN)=DFN_U_$PIECE(LAST,U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;
+22 ;
+23 ; loop thru sorted array and put into display array
+24 NEW SORT,DATE,IEN,LINE,X,BDGCOV,BDGRR,I,DFN,LAST
+25 SET SORT=0
FOR
SET SORT=$ORDER(^TMP("BDGILD2A",$JOB,SORT))
IF SORT=""
QUIT
Begin DoDot:1
+26 ;
+27 ; display sort heading (unless sorting by date alone)
+28 IF BDGTYP>1
Begin DoDot:2
+29 SET X="*** "_SORT_" ***"
+30 DO SET("",.VALMCNT)
DO SET($$SP(75-$LENGTH(X)\2)_X,.VALMCNT)
End DoDot:2
+31 ;
+32 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGILD2A",$JOB,SORT,DATE))
IF 'DATE
QUIT
Begin DoDot:2
+33 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGILD2A",$JOB,SORT,DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+34 ;
+35 ; build display lines
+36 SET DFN=+^TMP("BDGILD2A",$JOB,SORT,DATE,IEN)
+37 SET LAST=$PIECE(^TMP("BDGILD2A",$JOB,SORT,DATE,IEN),U,2)
+38 ;pat name
SET LINE=$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+39 ;chart #
SET LINE=$$PAD(LINE,23)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+40 ;admit date
SET LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE\1)
+41 ;dsch date
IF LAST
SET LINE=$$PAD(LINE,45)_$$NUMDATE^BDGF(LAST\1)
+42 ;days diff
SET LINE=$$PAD(LINE,57)_$JUSTIFY($$FMDIFF^XLFDT(DATE,LAST),3)
+43 ;srv abbrv
SET LINE=$$PAD(LINE,65)_$PIECE($$ADMSRVC^BDGF1(IEN,DFN)," ")
+44 ;ward abbrv
SET LINE=$$PAD(LINE,72)_$$WRDABRV2^BDGF1(IEN)
+45 DO SET(LINE,.VALMCNT)
+46 ;
+47 ;adm dx
SET LINE=$$SP(10)_"New Dx: "_$EXTRACT($$GET1^DIQ(405,IEN,.1),1,25)
+48 ; find admission ien for last discharge date
+49 SET LASTCA=$PIECE($GET(^DGPM(+$ORDER(^DGPM("APTT3",DFN,LAST,0)),0)),U,14)
+50 SET LINE=$$PAD(LINE,45)_"Last Dx: "_$$GET1^DIQ(405,+LASTCA,.1)
+51 DO SET(LINE,.VALMCNT)
+52 ;
+53 ;include insurance coverage
IF BDGINS=1
Begin DoDot:4
+54 SET BDGCOV=0
+55 ;S X=$$MCR^BDGF2(DFN,IEN),Y=$$MCD^BDGF2(DFN,IEN) ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 orig line
+56 ;D INS^BDGF2(DFN,IEN,.BDGRR) ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 orig line
+57 NEW BDGW,BDGX,BDGY,BDGZ
+58 ;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")
+59 ;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")
+60 IF BDGCOV=0
DO SET($$SP(10)_"**No Additional Coverage**",.VALMCNT)
QUIT
+61 ;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)
+62 ;I (X]"")!(Y]"") D SET($$PAD($$SP(10)_X,40)_Y,.VALMCNT) ;cmi/anch/maw 5/2/2008 PATCH 1009 orig line
+63 ; display all current private insurance coverage
+64 SET I=0
FOR
SET I=$ORDER(BDGRR(I))
IF 'I
QUIT
Begin DoDot:5
+65 DO SET($$SP(3)_BDGRR(I),.VALMCNT)
End DoDot:5
End DoDot:4
+66 ;
+67 ; separate patients by blank line
+68 DO SET("",.VALMCNT)
End DoDot:3
End DoDot:2
End DoDot:1
+69 ;
+70 ;
+71 IF VALMCNT=1
DO SET("No data found",.VALMCNT)
+72 ;
+73 KILL ^TMP("BDGILD2A",$JOB)
+74 QUIT
+75 ;
+76 ;
SET(DATA,NUM) ; puts display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGILD2",$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("BDGILD2",$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("BDGILD2",$JOB,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGILD2",$JOB,LINE,0)
End DoDot:1
+7 ;
+8 DO ^%ZISC
DO PRTKL^BDGF
DO EXIT
+9 QUIT
+10 ;
HDG ; heading when printing to paper
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !?13,"***",$$CONF^BDGF,"***"
+3 WRITE !,BDGUSR,?30,"Readmissions by Date",?71,"Page: ",BDGPG
+4 NEW X
SET X="Sorted by "_$PIECE($TEXT(TYPE+BDGTYP),";;",2)
+5 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X
+6 SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+7 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+8 WRITE !,$$REPEAT^XLFSTR("-",80)
+9 WRITE !,"Patient Name",?23,"Chart #",?31,"Admit Date",?45,"Last Dsch"
+10 WRITE ?55,"Diff",?65,"Serv",?72,"Ward"
+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;;
