BDGILD3 ; IHS/ANMC/LJF - NON-BENE ADMISSIONS ;
;;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 NON-BENE ADMITS
; 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 NON-BENE ADMITS")
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("BDGILD3",$J),^TMP("BDGILD3A",$J)
;
; loop through admissions 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("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
... ;
... Q:$$GET1^DIQ(9000001,DFN,1112)'="INELIGIBLE" ;non-bene only
... Q:'$$OKAY^BDGILD1(BDGTYP,.BDGSRT,IEN,DFN) ;ok to use admission?
... ;
... S SORT=$$SORT^BDGILD1(BDGTYP,IEN) S:SORT="" SORT="??"
... S ^TMP("BDGILD3A",$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("BDGILD3A",$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("BDGILD3A",$J,SORT,DATE)) Q:'DATE D
.. S IEN=0 F S IEN=$O(^TMP("BDGILD3A",$J,SORT,DATE,IEN)) Q:'IEN D
... ;
... ; build display lines
... S DFN=^TMP("BDGILD3A",$J,SORT,DATE,IEN)
... 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
... S X=$$GET1^DIQ(405,IEN,.17,"I") ;discharge ien for date
... I X S LINE=LINE_" - "_$$NUMDATE^BDGF(+$G(^DGPM(X,0))\1) ;dsch date
... S LINE=$$PAD(LINE,57)_$J($$GET1^DIQ(405,IEN,201),3) ;los
... 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)_"(Admitted by "
... S LINE=LINE_$E($$ADMPRV^BDGF1(IEN,DFN,"ADM"),1,18) ;admtg prov
... S LINE=$$PAD(LINE,45)_"Dx: "_$$GET1^DIQ(405,IEN,.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("BDGILD3",$J)) D SET("No data found",.VALMCNT)
;
K ^TMP("BDGILD3A",$J)
Q
;
;
SET(DATA,NUM) ; puts display line into array
S NUM=NUM+1
S ^TMP("BDGILD3",$J,NUM,0)=DATA
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGILD3",$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("BDGILD3",$J,LINE)) Q:'LINE D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGILD3",$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,?11,"***",$$CONF^BDGF,"***"
W !,BDGDATE,?25,"Non-beneficiary Admissions",?70,"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,"Admission Dates",?55,"LOS"
W ?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;;
BDGILD3 ; IHS/ANMC/LJF - NON-BENE ADMISSIONS ;
+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 NON-BENE ADMITS
+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 NON-BENE ADMITS")
+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("BDGILD3",$JOB),^TMP("BDGILD3A",$JOB)
+3 ;
+4 ; loop through admissions 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("AMV1",DATE))
IF 'DATE
QUIT
IF (DATE>END)
QUIT
Begin DoDot:1
+8 SET DFN=0
FOR
SET DFN=$ORDER(^DGPM("AMV1",DATE,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+9 SET IEN=0
FOR
SET IEN=$ORDER(^DGPM("AMV1",DATE,DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+10 ;
+11 ;non-bene only
IF $$GET1^DIQ(9000001,DFN,1112)'="INELIGIBLE"
QUIT
+12 ;ok to use admission?
IF '$$OKAY^BDGILD1(BDGTYP,.BDGSRT,IEN,DFN)
QUIT
+13 ;
+14 SET SORT=$$SORT^BDGILD1(BDGTYP,IEN)
IF SORT=""
SET SORT="??"
+15 SET ^TMP("BDGILD3A",$JOB,SORT,DATE,IEN)=DFN
End DoDot:3
End DoDot:2
End DoDot:1
+16 ;
+17 ;
+18 ; loop thru sorted array and put into display array
+19 NEW SORT,DATE,IEN,LINE,X,BDGCOV,BDGRR,I
+20 SET SORT=0
FOR
SET SORT=$ORDER(^TMP("BDGILD3A",$JOB,SORT))
IF SORT=""
QUIT
Begin DoDot:1
+21 ;
+22 ; display sort heading (unless sorting by date alone)
+23 IF BDGTYP>1
Begin DoDot:2
+24 SET X="*** "_SORT_" ***"
+25 DO SET("",.VALMCNT)
DO SET($$SP(75-$LENGTH(X)\2)_X,.VALMCNT)
End DoDot:2
+26 ;
+27 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("BDGILD3A",$JOB,SORT,DATE))
IF 'DATE
QUIT
Begin DoDot:2
+28 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("BDGILD3A",$JOB,SORT,DATE,IEN))
IF 'IEN
QUIT
Begin DoDot:3
+29 ;
+30 ; build display lines
+31 SET DFN=^TMP("BDGILD3A",$JOB,SORT,DATE,IEN)
+32 ;pat name
SET LINE=$EXTRACT($$GET1^DIQ(2,DFN,.01),1,20)
+33 ;chart #
SET LINE=$$PAD(LINE,23)_$JUSTIFY($$HRCN^BDGF2(DFN,DUZ(2)),6)
+34 ;admit date
SET LINE=$$PAD(LINE,31)_$$NUMDATE^BDGF(DATE\1)
+35 ;discharge ien for date
SET X=$$GET1^DIQ(405,IEN,.17,"I")
+36 ;dsch date
IF X
SET LINE=LINE_" - "_$$NUMDATE^BDGF(+$GET(^DGPM(X,0))\1)
+37 ;los
SET LINE=$$PAD(LINE,57)_$JUSTIFY($$GET1^DIQ(405,IEN,201),3)
+38 ;srv abbrv
SET LINE=$$PAD(LINE,65)_$PIECE($$ADMSRVC^BDGF1(IEN,DFN)," ")
+39 ;ward abbrv
SET LINE=$$PAD(LINE,72)_$$WRDABRV2^BDGF1(IEN)
+40 DO SET(LINE,.VALMCNT)
+41 ;
+42 SET LINE=$$SP(10)_"(Admitted by "
+43 ;admtg prov
SET LINE=LINE_$EXTRACT($$ADMPRV^BDGF1(IEN,DFN,"ADM"),1,18)
+44 ;adm dx
SET LINE=$$PAD(LINE,45)_"Dx: "_$$GET1^DIQ(405,IEN,.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("BDGILD3",$JOB))
DO SET("No data found",.VALMCNT)
+66 ;
+67 KILL ^TMP("BDGILD3A",$JOB)
+68 QUIT
+69 ;
+70 ;
SET(DATA,NUM) ; puts display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGILD3",$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("BDGILD3",$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("BDGILD3",$JOB,LINE))
IF 'LINE
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGILD3",$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 !,BDGUSR,?11,"***",$$CONF^BDGF,"***"
+3 WRITE !,BDGDATE,?25,"Non-beneficiary Admissions",?70,"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,"Admission Dates",?55,"LOS"
+10 WRITE ?65,"Serv",?72,"Ward"
WRITE !,$$REPEAT^XLFSTR("=",80)
+11 QUIT
+12 ;
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;;
