BDGIPL7 ; IHS/ANMC/LJF - CURR INPTS W/INSURANCE ;
;;5.3;PIMS;**1007,1009,1010**;FEB 27, 2007
;
;
;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
;cmi/anch/maw 2/22/2007 added code in INIT and INITC to sort by coverage type PATCH 1007 item 1007.40.
;cmi/anch/maw 05/08/2008 PATCH 1009 requirements 22,31,71 for insurance display
;
;
I $E(IOST,1,2)="P-" D INIT,PRINT Q
;
EN ; -- main entry point for BDG IPL INSURANCE
; assumes BDGSRT is set
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IPL INSURANCE")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
S X=$S(BDGSRT="A":"For ALL Ward Locations",1:$P(BDGSRT,U,2))
S VALMHDR(2)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW WD,DFN,BDGCNT,NAME,FIRST
K ^TMP("BDGIPL",$J),^TMP("BDGIPL1",$J)
S VALMCNT=0,BDGCNT=1,FIRST=1
;
I $G(BDGSRT2)="C" D INITC Q ;cmi/anch/maw 2/22/2007 added for Coverage Type
; if only one ward chosen
I BDGSRT D
. S WD=$P(BDGSRT,U,2),DFN=0 F S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN D
.. S ^TMP("BDGIPL1",$J,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; OR for all wards, find current inpatients & sort by ward then name
E S WD=0 F S WD=$O(^DPT("CN",WD)) Q:WD="" D
. S DFN=0 F S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN D
.. S ^TMP("BDGIPL1",$J,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; pull sorted list and create display array
S WD=0 F S WD=$O(^TMP("BDGIPL1",$J,WD)) Q:WD="" D
. ;
. I BDGSRT="A" D ;display ward subheading
.. ;
.. ; if printer, mark stop to add form feed
.. I 'FIRST,$E(IOST,1,2)="P-" D SET("@@@@",.VALMCNT,BDGCNT,"")
.. S FIRST=0
.. ;
.. D SET($G(IORVON)_"WARD: "_WD_$G(IORVOFF),.VALMCNT,BDGCNT,"")
. ;
. S NAME=0 F S NAME=$O(^TMP("BDGIPL1",$J,WD,NAME)) Q:NAME="" D
.. S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,WD,NAME,DFN)) Q:'DFN D
... D LINE
;
K ^TMP("BDGIPL1",$J)
Q
;
INITC ;-- init variables for coverage type and list array
;cmi/anch/maw 2/22/2007 added to sort by coverage type patch 1007 item 1007.40
;cmi/anch/maw 5/08/2008 changed insurance call to new insurance calls in BDGF2
N BDGADM,BDGCOV,BDGMCR,BDGMCD,BDGRR,BDGRAIL
I BDGSRT D
. S WD=$P(BDGSRT,U,2),DFN=0 F S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN D
. S BDGCOV=0 ;used to find patients with no coverage
. S BDGADM=+$$GET1^DIQ(2,DFN,.105,"I") ;admit ien
. S BDGMCD=$$NEWINS^BDGF2(DFN,BDGADM,"MCD") ;medicaid # if any
. I $G(BDGMCD)]"" S BDGCOV="MCD"
. S BDGMCR=$$NEWINS^BDGF2(DFN,BDGADM,"MCR") ;medicare # if any
. I $G(BDGMCR)]"" S BDGCOV="MCR"
. S BDGRAIL=$$NEWINS^BDGF2(DFN,BDGADM,"RR")
. I $G(BDGRAIL)]"" S BDGCOV="RR"
. D NEWINS^BDGF2(DFN,BDGADM,"PI") ;check for pvt ins
. I $D(BDGRR) S BDGCOV="PI"
. I BDGCOV=0 S BDGCOV="ZZ"
. S ^TMP("BDGIPL1",$J,WD,BDGCOV,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; OR for all wards, find current inpatients & sort by ward then name
E S WD=0 F S WD=$O(^DPT("CN",WD)) Q:WD="" D
. S DFN=0 F S DFN=$O(^DPT("CN",WD,DFN)) Q:'DFN D
.. S BDGCOV=0 ;used to find patients with no coverage
.. S BDGADM=+$$GET1^DIQ(2,DFN,.105,"I") ;admit ien
.. ;S BDGMCD=$$MCD^BDGF2(DFN,BDGADM) ;medicaid # if any
.. ;I BDGMCD S BDGCOV="MCD"
.. ;S BDGMCR=$$MCR^BDGF2(DFN,BDGADM) ;medicare # if any
.. ;I BDGMCR S BDGCOV="MCR"
.. ;D INS^BDGF2(DFN,BDGADM,.BDGRR) ;check for pvt ins
.. ;I $D(BDGRR) S BDGCOV="PI"
.. ;cmi/maw 5/8/2008 PATCH 1009 next lines for new insurance display
.. S BDGMCD=$$NEWINS^BDGF2(DFN,BDGADM,"MCD") ;medicaid # if any
.. I $G(BDGMCD)]"" S BDGCOV="MCD"
.. S BDGMCR=$$NEWINS^BDGF2(DFN,BDGADM,"MCR") ;medicare # if any
.. I $G(BDGMCR)]"" S BDGCOV="MCR"
.. S BDGRAIL=$$NEWINS^BDGF2(DFN,BDGADM,"RR")
.. I $G(BDGRAIL)]"" S BDGCOV="RR"
.. D NEWINS^BDGF2(DFN,BDGADM,"PI") ;check for pvt ins
.. I BDGCOV=0 S BDGCOV="ZZ"
.. S ^TMP("BDGIPL1",$J,WD,BDGCOV,$$GET1^DIQ(2,DFN,.01),DFN)=""
;
; pull sorted list and create display array
S WD=0 F S WD=$O(^TMP("BDGIPL1",$J,WD)) Q:WD="" D
. ;
. I BDGSRT="A" D ;display ward subheading
.. ;
.. ; if printer, mark stop to add form feed
.. I 'FIRST,$E(IOST,1,2)="P-" D SET("@@@@",.VALMCNT,BDGCNT,"")
.. S FIRST=0
.. ;
.. D SET($G(IORVON)_"WARD: "_WD_$G(IORVOFF),.VALMCNT,BDGCNT,"")
. ;
. N COV
. S COV=0 F S COV=$O(^TMP("BDGIPL1",$J,WD,COV)) Q:COV="" D
.. S NAME=0 F S NAME=$O(^TMP("BDGIPL1",$J,WD,COV,NAME)) Q:NAME="" D
... S DFN=0 F S DFN=$O(^TMP("BDGIPL1",$J,WD,COV,NAME,DFN)) Q:'DFN D
.... D LINE
;
K ^TMP("BDGIPL1",$J)
Q
;
LINE ; set up dislay line for patient
NEW LINE,BDGCOV,ADM
S LINE=$S($E(IOST,1,2)="P-":$$SP(5),1:$J(BDGCNT,3)_") ")
S LINE=$$PAD(LINE,5)_$E($$GET1^DIQ(2,DFN,.01),1,18) ;name
S LINE=$$PAD(LINE,25)_$$HRCND^BDGF2($$HRCN^BDGF2(DFN,DUZ(2))) ;chart#
S LINE=$$PAD(LINE,35)_$G(^DPT(DFN,.101)) ;room
S LINE=$$PAD(LINE,43)_$$GET1^DIQ(45.7,+$G(^DPT(DFN,.103)),99) ;srv
S LINE=$$PAD(LINE,50)_$E($P($$CURPRV^BDGF1(DFN),"/"),1,15) ;prim prov
S LINE=$$PAD(LINE,67)_$P($$INPT1^BDGF1(DFN,DT),"@") ;admit date
D SET(LINE,.VALMCNT,BDGCNT,DFN)
;
; display diagnosis & M/M info
S LINE=$$SP(5)_"Adx Dx: "_$E($$GET1^DIQ(405,+$G(^DPT(DFN,.105)),.1),1,23)
S BDGCOV=0 ;used to find patients with no coverage
S ADM=+$$GET1^DIQ(2,DFN,.105,"I") ;admit ien
;cmi/anch/maw 5/8/2008 PATCH 1009 next lines for new insurance display
;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,BDGRR
S BDGX=$$NEWINS^BDGF2(DFN,ADM,"MCR"),BDGY=$$NEWINS^BDGF2(DFN,ADM,"MCD") ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31
S BDGW=$$NEWINS^BDGF2(DFN,ADM,"RR"),BDGZ=$$NEWINS^BDGF2(DFN,ADM,"PI") ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 7/30/2009 PATCH 1010 reversed RR and PI calls
;I BDGCOV=0 D SET($$SP(10)_"**No Additional Coverage**",.VALMCNT) Q
I (BDGW]"")!(BDGX]"")!(BDGY]"") S LINE=$$SP(5)_BDGX_$$SP(2)_BDGY_$$SP(2)_BDGW ;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
;S LINE=$$PAD(LINE,38)_$$MCD^BDGF2(DFN,ADM) ;medicaid # if any
;S LINE=$$PAD(LINE,60)_$$MCR^BDGF2(DFN,ADM) ;medicare # if any
;D INS^BDGF2(DFN,ADM,.BDGRR) ;check for pvt ins
I BDGCOV=0 S LINE=$$PAD(LINE,38)_"No Additional Coverage"
D SET(LINE,.VALMCNT,BDGCNT,DFN)
;
; display all current private insurance coverage
S I=0 F S I=$O(BDGRR(I)) Q:'I D
. D SET($$SP(5)_BDGRR(I),.VALMCNT,BDGCNT,DFN)
;
D SET("",.VALMCNT,BDGCNT,"")
;
; increment counter
S BDGCNT=BDGCNT+1
Q
;
SET(LINE,NUM,COUNT,IEN) ; put display line into array
D SET^BDGIPL1(LINE,.NUM,COUNT,IEN)
Q
;
PRINT ; print report to paper
NEW BDGX,BDGLN,BDGPG
U IO D INIT^BDGF,HDG
;
; loop thru display array
S BDGX=0 F S BDGX=$O(^TMP("BDGIPL",$J,BDGX)) Q:'BDGX D
. S BDGLN=^TMP("BDGIPL",$J,BDGX,0)
. ;
. ;marker for form feed between wards
. I $E(BDGLN,1,4)="@@@@" D HDG Q
. ;
. I $Y>(IOSL-4) D HDG
. W !,BDGLN
I '$G(BDGCOP) D ^%ZISC ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39
D PRTKL^BDGF,EXIT
;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
Q ;cmi/anch/maw 7/25/2007 quit missing patch 1007
;
HDG ; heading for paper report
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
W !,BDGUSR,?16,$$CONF^BDGF
W !,BDGDATE,?20,"Insurance Coverage for Current Inpatients"
W ?71,"Page: ",BDGPG
S X=$S(BDGSRT="A":"For ALL Ward Locations",1:$P(BDGSRT,U,2))
W !,BDGTIME,?(80-$L(X)\2),X
W !,$$REPEAT^XLFSTR("-",80)
W !?5,"Patient",?25,"Chart #",?35,"Room",?43,"Srv",?50,"Provider"
W ?67,"Admit Date"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGIPL",$J)
;K BDGSRT cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007
Q
;
EXPND ; -- expand code
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)
BDGIPL7 ; IHS/ANMC/LJF - CURR INPTS W/INSURANCE ;
+1 ;;5.3;PIMS;**1007,1009,1010**;FEB 27, 2007
+2 ;
+3 ;
+4 ;cmi/anch/maw 2/22/2007 added code in PRINT to not close device if multiple copies PATCH 1007 item 1007.39
+5 ;cmi/anch/maw 2/22/2007 added code in INIT and INITC to sort by coverage type PATCH 1007 item 1007.40.
+6 ;cmi/anch/maw 05/08/2008 PATCH 1009 requirements 22,31,71 for insurance display
+7 ;
+8 ;
+9 IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+10 ;
EN ; -- main entry point for BDG IPL INSURANCE
+1 ; assumes BDGSRT is set
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG IPL INSURANCE")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET VALMHDR(1)=$$SP(12)_"** "_$$CONF^BDGF_" **"
+3 SET X=$SELECT(BDGSRT="A":"For ALL Ward Locations",1:$PIECE(BDGSRT,U,2))
+4 SET VALMHDR(2)=$$SP(75-$LENGTH(X)\2)_X
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 NEW WD,DFN,BDGCNT,NAME,FIRST
+2 KILL ^TMP("BDGIPL",$JOB),^TMP("BDGIPL1",$JOB)
+3 SET VALMCNT=0
SET BDGCNT=1
SET FIRST=1
+4 ;
+5 ;cmi/anch/maw 2/22/2007 added for Coverage Type
IF $GET(BDGSRT2)="C"
DO INITC
QUIT
+6 ; if only one ward chosen
+7 IF BDGSRT
Begin DoDot:1
+8 SET WD=$PIECE(BDGSRT,U,2)
SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+9 SET ^TMP("BDGIPL1",$JOB,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+10 ;
+11 ; OR for all wards, find current inpatients & sort by ward then name
+12 IF '$TEST
SET WD=0
FOR
SET WD=$ORDER(^DPT("CN",WD))
IF WD=""
QUIT
Begin DoDot:1
+13 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+14 SET ^TMP("BDGIPL1",$JOB,WD,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+15 ;
+16 ; pull sorted list and create display array
+17 SET WD=0
FOR
SET WD=$ORDER(^TMP("BDGIPL1",$JOB,WD))
IF WD=""
QUIT
Begin DoDot:1
+18 ;
+19 ;display ward subheading
IF BDGSRT="A"
Begin DoDot:2
+20 ;
+21 ; if printer, mark stop to add form feed
+22 IF 'FIRST
IF $EXTRACT(IOST,1,2)="P-"
DO SET("@@@@",.VALMCNT,BDGCNT,"")
+23 SET FIRST=0
+24 ;
+25 DO SET($GET(IORVON)_"WARD: "_WD_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
End DoDot:2
+26 ;
+27 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGIPL1",$JOB,WD,NAME))
IF NAME=""
QUIT
Begin DoDot:2
+28 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,WD,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+29 DO LINE
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;
+31 KILL ^TMP("BDGIPL1",$JOB)
+32 QUIT
+33 ;
INITC ;-- init variables for coverage type and list array
+1 ;cmi/anch/maw 2/22/2007 added to sort by coverage type patch 1007 item 1007.40
+2 ;cmi/anch/maw 5/08/2008 changed insurance call to new insurance calls in BDGF2
+3 NEW BDGADM,BDGCOV,BDGMCR,BDGMCD,BDGRR,BDGRAIL
+4 IF BDGSRT
Begin DoDot:1
+5 SET WD=$PIECE(BDGSRT,U,2)
SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
End DoDot:2
+6 ;used to find patients with no coverage
SET BDGCOV=0
+7 ;admit ien
SET BDGADM=+$$GET1^DIQ(2,DFN,.105,"I")
+8 ;medicaid # if any
SET BDGMCD=$$NEWINS^BDGF2(DFN,BDGADM,"MCD")
+9 IF $GET(BDGMCD)]""
SET BDGCOV="MCD"
+10 ;medicare # if any
SET BDGMCR=$$NEWINS^BDGF2(DFN,BDGADM,"MCR")
+11 IF $GET(BDGMCR)]""
SET BDGCOV="MCR"
+12 SET BDGRAIL=$$NEWINS^BDGF2(DFN,BDGADM,"RR")
+13 IF $GET(BDGRAIL)]""
SET BDGCOV="RR"
+14 ;check for pvt ins
DO NEWINS^BDGF2(DFN,BDGADM,"PI")
+15 IF $DATA(BDGRR)
SET BDGCOV="PI"
+16 IF BDGCOV=0
SET BDGCOV="ZZ"
+17 SET ^TMP("BDGIPL1",$JOB,WD,BDGCOV,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:1
+18 ;
+19 ; OR for all wards, find current inpatients & sort by ward then name
+20 IF '$TEST
SET WD=0
FOR
SET WD=$ORDER(^DPT("CN",WD))
IF WD=""
QUIT
Begin DoDot:1
+21 SET DFN=0
FOR
SET DFN=$ORDER(^DPT("CN",WD,DFN))
IF 'DFN
QUIT
Begin DoDot:2
+22 ;used to find patients with no coverage
SET BDGCOV=0
+23 ;admit ien
SET BDGADM=+$$GET1^DIQ(2,DFN,.105,"I")
+24 ;S BDGMCD=$$MCD^BDGF2(DFN,BDGADM) ;medicaid # if any
+25 ;I BDGMCD S BDGCOV="MCD"
+26 ;S BDGMCR=$$MCR^BDGF2(DFN,BDGADM) ;medicare # if any
+27 ;I BDGMCR S BDGCOV="MCR"
+28 ;D INS^BDGF2(DFN,BDGADM,.BDGRR) ;check for pvt ins
+29 ;I $D(BDGRR) S BDGCOV="PI"
+30 ;cmi/maw 5/8/2008 PATCH 1009 next lines for new insurance display
+31 ;medicaid # if any
SET BDGMCD=$$NEWINS^BDGF2(DFN,BDGADM,"MCD")
+32 IF $GET(BDGMCD)]""
SET BDGCOV="MCD"
+33 ;medicare # if any
SET BDGMCR=$$NEWINS^BDGF2(DFN,BDGADM,"MCR")
+34 IF $GET(BDGMCR)]""
SET BDGCOV="MCR"
+35 SET BDGRAIL=$$NEWINS^BDGF2(DFN,BDGADM,"RR")
+36 IF $GET(BDGRAIL)]""
SET BDGCOV="RR"
+37 ;check for pvt ins
DO NEWINS^BDGF2(DFN,BDGADM,"PI")
+38 IF BDGCOV=0
SET BDGCOV="ZZ"
+39 SET ^TMP("BDGIPL1",$JOB,WD,BDGCOV,$$GET1^DIQ(2,DFN,.01),DFN)=""
End DoDot:2
End DoDot:1
+40 ;
+41 ; pull sorted list and create display array
+42 SET WD=0
FOR
SET WD=$ORDER(^TMP("BDGIPL1",$JOB,WD))
IF WD=""
QUIT
Begin DoDot:1
+43 ;
+44 ;display ward subheading
IF BDGSRT="A"
Begin DoDot:2
+45 ;
+46 ; if printer, mark stop to add form feed
+47 IF 'FIRST
IF $EXTRACT(IOST,1,2)="P-"
DO SET("@@@@",.VALMCNT,BDGCNT,"")
+48 SET FIRST=0
+49 ;
+50 DO SET($GET(IORVON)_"WARD: "_WD_$GET(IORVOFF),.VALMCNT,BDGCNT,"")
End DoDot:2
+51 ;
+52 NEW COV
+53 SET COV=0
FOR
SET COV=$ORDER(^TMP("BDGIPL1",$JOB,WD,COV))
IF COV=""
QUIT
Begin DoDot:2
+54 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGIPL1",$JOB,WD,COV,NAME))
IF NAME=""
QUIT
Begin DoDot:3
+55 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("BDGIPL1",$JOB,WD,COV,NAME,DFN))
IF 'DFN
QUIT
Begin DoDot:4
+56 DO LINE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+57 ;
+58 KILL ^TMP("BDGIPL1",$JOB)
+59 QUIT
+60 ;
LINE ; set up dislay line for patient
+1 NEW LINE,BDGCOV,ADM
+2 SET LINE=$SELECT($EXTRACT(IOST,1,2)="P-":$$SP(5),1:$JUSTIFY(BDGCNT,3)_") ")
+3 ;name
SET LINE=$$PAD(LINE,5)_$EXTRACT($$GET1^DIQ(2,DFN,.01),1,18)
+4 ;chart#
SET LINE=$$PAD(LINE,25)_$$HRCND^BDGF2($$HRCN^BDGF2(DFN,DUZ(2)))
+5 ;room
SET LINE=$$PAD(LINE,35)_$GET(^DPT(DFN,.101))
+6 ;srv
SET LINE=$$PAD(LINE,43)_$$GET1^DIQ(45.7,+$GET(^DPT(DFN,.103)),99)
+7 ;prim prov
SET LINE=$$PAD(LINE,50)_$EXTRACT($PIECE($$CURPRV^BDGF1(DFN),"/"),1,15)
+8 ;admit date
SET LINE=$$PAD(LINE,67)_$PIECE($$INPT1^BDGF1(DFN,DT),"@")
+9 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+10 ;
+11 ; display diagnosis & M/M info
+12 SET LINE=$$SP(5)_"Adx Dx: "_$EXTRACT($$GET1^DIQ(405,+$GET(^DPT(DFN,.105)),.1),1,23)
+13 ;used to find patients with no coverage
SET BDGCOV=0
+14 ;admit ien
SET ADM=+$$GET1^DIQ(2,DFN,.105,"I")
+15 ;cmi/anch/maw 5/8/2008 PATCH 1009 next lines for new insurance display
+16 ;S X=$$MCR^BDGF2(DFN,IEN),Y=$$MCD^BDGF2(DFN,IEN) ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 orig line
+17 ;D INS^BDGF2(DFN,IEN,.BDGRR) ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 orig line
+18 NEW BDGW,BDGX,BDGY,BDGZ,BDGRR
+19 ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31
SET BDGX=$$NEWINS^BDGF2(DFN,ADM,"MCR")
SET BDGY=$$NEWINS^BDGF2(DFN,ADM,"MCD")
+20 ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31 7/30/2009 PATCH 1010 reversed RR and PI calls
SET BDGW=$$NEWINS^BDGF2(DFN,ADM,"RR")
SET BDGZ=$$NEWINS^BDGF2(DFN,ADM,"PI")
+21 ;I BDGCOV=0 D SET($$SP(10)_"**No Additional Coverage**",.VALMCNT) Q
+22 ;cmi/anch/maw 5/2/2008 PATCH 1009 requirements 22,31
IF (BDGW]"")!(BDGX]"")!(BDGY]"")
SET LINE=$$SP(5)_BDGX_$$SP(2)_BDGY_$$SP(2)_BDGW
+23 ;I (X]"")!(Y]"") D SET($$PAD($$SP(10)_X,40)_Y,.VALMCNT) ;cmi/anch/maw 5/2/2008 PATCH 1009 orig line
+24 ;S LINE=$$PAD(LINE,38)_$$MCD^BDGF2(DFN,ADM) ;medicaid # if any
+25 ;S LINE=$$PAD(LINE,60)_$$MCR^BDGF2(DFN,ADM) ;medicare # if any
+26 ;D INS^BDGF2(DFN,ADM,.BDGRR) ;check for pvt ins
+27 IF BDGCOV=0
SET LINE=$$PAD(LINE,38)_"No Additional Coverage"
+28 DO SET(LINE,.VALMCNT,BDGCNT,DFN)
+29 ;
+30 ; display all current private insurance coverage
+31 SET I=0
FOR
SET I=$ORDER(BDGRR(I))
IF 'I
QUIT
Begin DoDot:1
+32 DO SET($$SP(5)_BDGRR(I),.VALMCNT,BDGCNT,DFN)
End DoDot:1
+33 ;
+34 DO SET("",.VALMCNT,BDGCNT,"")
+35 ;
+36 ; increment counter
+37 SET BDGCNT=BDGCNT+1
+38 QUIT
+39 ;
SET(LINE,NUM,COUNT,IEN) ; put display line into array
+1 DO SET^BDGIPL1(LINE,.NUM,COUNT,IEN)
+2 QUIT
+3 ;
PRINT ; print report to paper
+1 NEW BDGX,BDGLN,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 ;
+4 ; loop thru display array
+5 SET BDGX=0
FOR
SET BDGX=$ORDER(^TMP("BDGIPL",$JOB,BDGX))
IF 'BDGX
QUIT
Begin DoDot:1
+6 SET BDGLN=^TMP("BDGIPL",$JOB,BDGX,0)
+7 ;
+8 ;marker for form feed between wards
+9 IF $EXTRACT(BDGLN,1,4)="@@@@"
DO HDG
QUIT
+10 ;
+11 IF $Y>(IOSL-4)
DO HDG
+12 WRITE !,BDGLN
End DoDot:1
+13 ;cmi/anch/maw 2/22/2007 added for no close of device if multiple copies PATCH 1007 item 1007.39
IF '$GET(BDGCOP)
DO ^%ZISC
+14 DO PRTKL^BDGF
DO EXIT
+15 ;D ^%ZISC,PRTKL^BDGF,EXIT cmi/anch/maw 2/22/2007 orig line
+16 ;cmi/anch/maw 7/25/2007 quit missing patch 1007
QUIT
+17 ;
HDG ; heading for paper report
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 WRITE !,BDGUSR,?16,$$CONF^BDGF
+3 WRITE !,BDGDATE,?20,"Insurance Coverage for Current Inpatients"
+4 WRITE ?71,"Page: ",BDGPG
+5 SET X=$SELECT(BDGSRT="A":"For ALL Ward Locations",1:$PIECE(BDGSRT,U,2))
+6 WRITE !,BDGTIME,?(80-$LENGTH(X)\2),X
+7 WRITE !,$$REPEAT^XLFSTR("-",80)
+8 WRITE !?5,"Patient",?25,"Chart #",?35,"Room",?43,"Srv",?50,"Provider"
+9 WRITE ?67,"Admit Date"
+10 WRITE !,$$REPEAT^XLFSTR("=",80)
+11 QUIT
+12 ;
+13 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGIPL",$JOB)
+2 ;K BDGSRT cmi/anch/maw 7/25/2007 is needed for multiple copies patch 1007
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
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)
