IBCONS1 ;ALB/AAS - NSC PATIENTS W/ INS BACKGROUND PRINTS ;7 JUN 90
;;2.0;INTEGRATED BILLING;**66,80,137,516,528**;21-MAR-94;Build 163
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRONS1
;
EN ; Inpatient Discharge entry to que background once weekly
S IBINPT=2,IBSUB="AMV3" G QUEUE
;
EN1 ; Inpatient Admission entry to que background once weekly
S IBINPT=1,IBSUB="AMV1" G QUEUE
;
EN2 ; Outpatient entry to que background once weekly
S IBINPT=0,IBSUB=""
;
QUEUE ; Set up the background job to run for the previous week
; o For All Divisions
; o For Insured veterans with unbilled episodes of care
; o With the output sorted by Terminal Digit
;
K ^TMP($J)
S X="T",%DT="" D ^%DT S IBEND=+Y
S X="T-7",%DT="" D ^%DT S IBBEG=+Y K %DT
S (VAUTD,IBSELUBL,IBSELTRM,IBSELRNB)=1
U IO G BEGIN^IBCONSC
;
;
LOOP25 ; Print all NSC w/Insurance reports.
I "^R^E^"'[(U_$G(IBOUT)_U) S IBOUT="R"
S IBQUIT=0,IBFL=1,IBHDRDV="",IBSUM=0,IBPTINFO="" I +$G(IBSELCDV),IBOUT="R" D HDRDV^IBCONSC
I IBOUT="E" D PHDL
S IBDV="" F S IBDV=$O(^TMP($J,IBDV)) Q:IBDV="" I IBDV'="TOTAL" D LOOP3 Q:IBQUIT
;
G:IBQUIT Q S IBSUM=1,IBPAGE=0 D:IBOUT="R" HEAD Q:IBQUIT
S IBDV="" F S IBDV=$O(^TMP($J,"TOTAL",IBDV)) Q:IBDV="" D PRNSUM
D PAUSE
;
Q K %,%DT,B,I,J,K,L,M,X,X1,X2,Y,DFN,IBCNT,IBIFN,IBBILL,IBDATE,IBFLAG,IBI,IBDT,IBPAGE,IBL,IBHD,IBBEG1,IBHDRDV,IBSUM
K IBBEG,IBEND,IBOUT,IBINPT,IBFLAG,IBNAME,IBAPPT,IBDC,IBDAT,IBDFN,POP,IBNEWPT,IBPTINFO,^TMP($J)
Q
;
;
LOOP3 ; Loop through billed, unbilled, or both types of episodes of care.
I +$G(IBSELUBL) S IBBILL=1,IBNAME="",IBPAGE=0 K IBFLAG D:IBOUT="R" HEAD Q:IBQUIT D LOOP31 Q:IBQUIT
I +$G(IBSELBNA)!+$G(IBSELBIL) S IBBILL=2,IBNAME="",IBPAGE=0 K IBFLAG D:IBOUT="R" HEAD Q:IBQUIT D LOOP31 Q:IBQUIT
Q
;
LOOP31 ; Loop through each name or terminal digit (and associated DFN).
F S IBNAME=$O(^TMP($J,IBDV,IBBILL,IBNAME)) D Q:IBNAME=""!(IBQUIT)
. I IBNAME="",'$D(IBFLAG) W !!,"No matches found.",!
. Q:IBNAME=""
. S DFN=0 F S DFN=$O(^TMP($J,IBDV,IBBILL,IBNAME,DFN)) Q:'DFN S IBNEWPT=1 D LOOP4 Q:IBQUIT
Q
;
LOOP4 ; Loop through each episode of care for a patient.
S IBDAT="" F I=0:0 S IBDAT=$O(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT)) Q:IBDAT=""!(IBQUIT) D PRINT I $Y>$S($D(IOSL):(IOSL-6),1:6),IBOUT="R" W ! D HEAD Q:IBQUIT
Q
;
PRINT ; Print each detail line.
I '$G(IBSELRNB),$D(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,2)) Q ; exclude episodes with reason not billable
I +$G(IBSELRNB)=2,'$D(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,2)) Q ; exclude episode w/o RNB ** PATCH 66
I IBBILL=2,'$G(IBSELBNA),+$G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT))=1 Q ; non-auth episodes ** PATCH 66
I IBBILL=2,'$G(IBSELBIL),+$G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT))=2 Q ; auth episodes ** PATCH 66
;
D SUMTOT S IBFLAG=1 D PID^VADPT6
I IBOUT="E" S IBPTINFO=$P($G(^DG(40.8,+IBDV,0)),"^")_U_VA("BID")_U_$P(^DPT(DFN,0),"^")_U_VA("PID")_U_$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),"^",6)
;
I +$G(IBNEWPT) W:IBOUT="R" ! D PTPRNT S IBNEWPT=0
W:IBOUT="R" !,VA("BID"),?6,$E($P(^DPT(DFN,0),"^"),1,20),?28,VA("PID"),?42,$E($P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),"^",6),1,16) K VA,VAERR
S Y=IBDAT X ^DD("DD") W:IBOUT="R" ?60 W:IBOUT="E" U W Y
;
; -- print insurance, use ibcns1 calls
S X=$$INSP(DFN,IBDAT) W:IBOUT="R" ?82 W:IBOUT="E" U W X
;
; -- print reason not billable
I $G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))]"" W:IBOUT="R" ?115,$E(^(2),1,16) W:IBOUT="E" U_^(2)
;
I IBOUT="E",'IBINPT W U
S X=$G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,1))
I X]"" W:IBOUT="R" !?10 W $P(X,"^") I $P(X,"^",2)]"" W " with " F IBDC=2:1 Q:$P(X,"^",IBDC)="" W $P(X,"^",IBDC),", "
S X=^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT) Q:'$L(X) F K=2:1 S IBIFN=$P(X,"^",K) Q:IBIFN="" D PRINT1
Q
;
PRINT1 ; If an episode of care has been billed, display billing information.
D GVAR^IBCBB
I IBOUT="E" D
. I K>2 D XLCOLS(4,"")
. W U_$P(^DGCR(399,IBIFN,0),"^")_U_$P($G(^DGCR(399.3,+IBAT,0)),"^",4),"-",$S(IBCL<3:"INPT",IBCL>2:"OUTP",1:"")
. W U_$S(IBST=1:"Entered",IBST=2:"Request MRA",IBST=3:"Authorized",IBST=4:"Prnt/Trans",IBST=7:"Cancelled",IBST=0:"Closed",1:"")
. W U_$E(IBFDT,4,5)_"/"_$E(IBFDT,6,7)_"/"_$E(IBFDT,2,3)_U_$E(IBTDT,4,5)_"/"_$E(IBTDT,6,7)_"/"_$E(IBTDT,2,3)
. W U_$S($P(IBND0,U,21)="S":"s",$P(IBND0,U,21)="T":"t",1:"")_U
I IBOUT="R" D
. W !?10,$P(^DGCR(399,IBIFN,0),"^"),?20,$P($G(^DGCR(399.3,+IBAT,0)),"^",4),"-",$S(IBCL<3:"INPT",IBCL>2:"OUTP",1:"")
. W ?37,$S(IBST=1:"Entered",IBST=2:"Request MRA",IBST=3:"Authorized",IBST=4:"Prnt/Trans",IBST=7:"Cancelled",IBST=0:"Closed",1:"")
. W ?50,"From: ",$E(IBFDT,4,5)_"/"_$E(IBFDT,6,7)_"/"_$E(IBFDT,2,3)
. W ?68,"To: ",$E(IBTDT,4,5)_"/"_$E(IBTDT,6,7)_"/"_$E(IBTDT,2,3)
. W ?88,$S($P(IBND0,U,21)="S":"s",$P(IBND0,U,21)="T":"t",1:"")
. W ?91,"Debtor: "
I IBWHO="i",$D(^DIC(36,+IBNDMP,0)) W $P(^(0),"^")
I IBWHO="o",$D(^DIC(4,+$P(IBNDM,"^",11),0)) W $P(^(0),"^")
I IBWHO="p" W $P(^DPT(DFN,0),"^")
D END^IBCBB1 Q
;
HEAD ; Print header; don't pause on first pass through.
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,IBQUIT)=1 Q
D:'IBFL PAUSE Q:IBQUIT S IBFL=0 N IBI
S IBPAGE=IBPAGE+1
; -- ibformfd = skip only intial form feed, need ffs for each div.
I $E(IOST,1,2)["C-"!(IBPAGE>1)!($G(IBFORMFD)) W @IOF
S IBFORMFD=1
S IBI=$S(IBBILL=2:"PREVIOUSLY ",1:"UN")_"BILLED PATIENTS"
I '$G(IBSELCDV) S IBI=IBI_" for Division "_$P($G(^DG(40.8,+IBDV,0)),"^")
I +$G(IBSELCDV) S IBI=IBI_IBHDRDV
I +$G(IBSUM) S IBI="Summary"
W IBHD,!,IBI W:$L(IBI)>78 ! W ?80,"Printed: ",IBDATE,?118,"Page: ",IBPAGE
I +$G(IBSUM) W !,?40,"Unbilled",?53,"Unbilled w/RNB",?70,"Billed/Not Auth",?88,"Billed/Auth",?103,"# Visits",?117,"# Patients",!,IBL Q
W !,"PT ID PATIENT",?28,"SSN",?42,"ELIGIBILITY",?60,"DATE OF ",$S(IBINPT=2:"DISCHARGE",1:"CARE"),?82,"INSURANCE COMPANIES"
W:+$G(IBSELRNB) ?115,"NOT BILLABLE"
W !,IBL
Q
;
INSP(DFN,IBDAT) ; -- print ins. company on report logic
N X,IBDD,IBDDINS,IBCNT
S IBCNT=0,IBDDINS=""
I '$G(DFN)!('$G(IBDAT)) G INSPQ
S IBDD="" D ALL^IBCNS1(DFN,"IBDD",4,IBDAT)
S X=0 F S X=$O(IBDD(X)) Q:'X!(IBCNT>2) D
.S IBCNT=IBCNT+1
.I IBCNT>1 S IBDDINS=IBDDINS_","
.S IBDDINS=IBDDINS_$E($P($G(^DIC(36,+$G(IBDD(X,0)),0)),"^"),1,10)
S IBDDINS=$E(IBDDINS,1,30)
I $G(IBDD(0))>3 S IBDDINS=IBDDINS_"*"
INSPQ Q IBDDINS
;
PAUSE Q:$E(IOST,1,2)'="C-"
F J=$Y:1:(IOSL-5) W !
S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
Q
PRNSUM ; print 1 line of the summary
N IBSUM S IBSUM=$G(^TMP($J,"TOTAL",IBDV)) Q:IBSUM=""
W:IBOUT="R" !
I IBOUT="E" D XLCOLS(5,"")
W $S(IBDV="TOTAL":IBDV,1:$P($G(^DG(40.8,+IBDV,0)),U,1))
I IBOUT="E" W U_$P(IBSUM,U,2,5)_U_$P(IBSUM,U,1)_U_$P(IBSUM,U,6) Q
W ?40,$P(IBSUM,U,2),?58,$P(IBSUM,U,3),?75,$P(IBSUM,U,4),?91,$P(IBSUM,U,5),?105,$P(IBSUM,U,1),?120,$P(IBSUM,U,6)
Q
DATE(X) ;
N Y S Y="" I +$G(X) S Y=$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
Q Y
;
SUMTOT ; total cnt of visits ^ cnt unbilled ^ cnt unbilled w/RNB ^ cnt billed/not auth ^ cnt billed/auth ^ cnt of pats
N IBSUM,IBTOT,IBBILLED,IBRMARK
S IBBILLED=$G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT)),IBRMARK=$G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))
S IBSUM=$G(^TMP($J,"TOTAL",+IBDV)),IBTOT=$G(^TMP($J,"TOTAL","TOTAL"))
S $P(IBSUM,U,1)=+$P(IBSUM,U,1)+1,$P(IBTOT,U,1)=+$P(IBTOT,U,1)+1
I 'IBBILLED,IBRMARK="" S $P(IBSUM,U,2)=$P(IBSUM,U,2)+1,$P(IBTOT,U,2)=$P(IBTOT,U,2)+1
I 'IBBILLED,IBRMARK'="" S $P(IBSUM,U,3)=$P(IBSUM,U,3)+1,$P(IBTOT,U,3)=$P(IBTOT,U,3)+1
I +IBBILLED=1 S $P(IBSUM,U,4)=$P(IBSUM,U,4)+1,$P(IBTOT,U,4)=$P(IBTOT,U,4)+1
I +IBBILLED=2 S $P(IBSUM,U,5)=$P(IBSUM,U,5)+1,$P(IBTOT,U,5)=$P(IBTOT,U,5)+1
I '$D(^TMP($J,"TOTAL",+IBDV,DFN)) S $P(IBSUM,U,6)=$P(IBSUM,U,6)+1
I '$D(^TMP($J,"TOTAL","TOTAL",DFN)) S $P(IBTOT,U,6)=$P(IBTOT,U,6)+1
I +IBDV S ^TMP($J,"TOTAL",+IBDV)=IBSUM,^TMP($J,"TOTAL",+IBDV,DFN)=""
S ^TMP($J,"TOTAL","TOTAL")=IBTOT,^TMP($J,"TOTAL","TOTAL",DFN)=""
Q
;
PTPRNT ; print patient specific data is requested: Rate Disabilities and expanded insurance Info
;
N IBLN1,IBI,IBX,IBY,IBD,IBLN2,IBLN3,IBY1,IBJ,IBY3,IBRIDE,IBPLAN,IBCVG,IBGC1,IBCR1,IBCOMFL
S IBLN1=$P($G(^DPT(+DFN,0)),U,1) I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
;
I '$G(IBPRTRDS),IBOUT="E" W !,IBPTINFO
I +$G(IBPRTRDS) S IBLN2="Rated Disabilities:" D Q:+$G(IBQUIT) K IBX,IBY
. I '$O(^DPT(DFN,.372,0)) W:IBOUT="R" !,IBLN1,?33,IBLN2," None" W:IBOUT="E" !,IBPTINFO_"^None" S (IBLN1,IBLN2)="" Q
. S IBI=0 F S IBI=$O(^DPT(DFN,.372,IBI)) Q:'IBI D I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
.. S IBX=$G(^DPT(DFN,.372,IBI,0)),IBY=$G(^DIC(31,+IBX,0))
.. S IBD=$S($P(IBY,U,4)="":$P(IBY,U,1),1:$P(IBY,U,4))_" ("_$P(IBX,U,2)_"%-"_$S(+$P(IBX,U,3):"SC",1:"NSC")_")"
.. W:IBOUT="R" !,IBLN1,?33,IBLN2,?57,IBD W:IBOUT="E" !,IBPTINFO_U_IBD S (IBLN1,IBLN2)=""
;
I '$G(IBPRTIEX),'$G(IBPRTIPC),'$G(IBPRTIGC),'$G(IBPRTICR),IBOUT="R" Q
;
I IBOUT="R" W:IBLN1'="" !,IBLN1
D ALL^IBCNS1(DFN,"IBX",4,IBBEG),ALL^IBCNS1(DFN,"IBX",4,IBEND)
;
I IBOUT="E",'$O(IBX(0)) D XLCOLS(0,"")
S IBI=0 F S IBI=$O(IBX(IBI)) Q:'IBI D Q:+$G(IBQUIT) I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
. S IBY=IBX(IBI,0),IBY1=IBX(IBI,1)
. S IBLN1=$P($G(^DIC(36,+IBY,0)),U,1),IBPLAN=+$P(IBY,U,18) S:IBOUT="R" IBLN1=$E(IBLN1,1,25)
. ;
. ;IB*2.0*516/DRF - Retrieve HIPAA compliant Group #
. ;I +$G(IBPRTIEX) W !,?5,IBLN1,?33,"Group #: ",$P($G(^IBA(355.3,+IBPLAN,0)),U,4),?65,"Effective: ",$$DATE(+$P(IBY,U,8))," - ",$$DATE(+$P(IBY,U,4)),?100,"Last Ver: ",$$DATE($P(IBY1,U,3)) S IBLN1=""
. I +$G(IBPRTIEX) D
.. I IBOUT="E" W U_IBLN1_U_$P(IBY,U,3)_U_$$DATE(+$P(IBY,U,8))_U_$$DATE(+$P(IBY,U,4))_U_$$DATE($P(IBY1,U,3)) Q
.. W !,?5,IBLN1,?33,"Group #: ",$P(IBY,U,3)
.. W !,?33,"Effective: ",$$DATE(+$P(IBY,U,8))," - ",$$DATE(+$P(IBY,U,4)),?68,"Last Ver: ",$$DATE($P(IBY1,U,3)) S IBLN1=""
. ;
. I +$G(IBPRTIPC) S IBLN2="Policy Comment: " D I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
.. I IBOUT="E" W U_$P(IBY1,U,8) Q
.. I $P(IBY1,U,8)'="" W !,?5,IBLN1,?33,IBLN2,?51,$P(IBY1,U,8) S (IBLN1,IBLN2)=""
. ;
. I +$G(IBPRTIGC) S IBLN2="Group Comments: " D I IBOUT="E",+$G(IBGC1) W U
.. S IBJ=0,IBGC1=1 F S IBJ=$O(^IBA(355.3,+IBPLAN,11,IBJ)) Q:'IBJ D I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
... S IBY3=$G(^IBA(355.3,+IBPLAN,11,IBJ,0)) D
.... I IBOUT="E" D:'IBGC1 XLCOLS(1,IBLN1) W U_IBY3 S IBGC1=0 Q
.... W !,?5,IBLN1,?33,IBLN2,?51,IBY3 S (IBLN1,IBLN2)=""
. ;
. I +$G(IBPRTICR) S IBLN2="Coverage Limits:" D I IBOUT="E",+$G(IBCR1) W "^^"
.. S IBCVG=0,IBCR1=1 F S IBCVG=$O(^IBA(355.32,"B",IBPLAN,IBCVG)) Q:'IBCVG D I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
... S IBY3=$G(^IBA(355.32,IBCVG,0)) Q:IBY3=""
... S IBLN3=$P($G(^IBE(355.31,+$P(IBY3,U,2),0)),U,1) I IBOUT="R" S IBLN3=$E(IBLN3,1,20)
... S IBLN3=IBLN3_" "_$$DDSET(355.32,.04,+$P(IBY3,U,4))_" "_$$DATE(+$P(IBY3,U,3))
... S (IBJ,IBCOMFL)=0 F S IBJ=$O(^IBA(355.32,IBCVG,2,IBJ)) Q:'IBJ D I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
.... I IBOUT="E" D:'IBCR1 XLCOLS(2,IBLN1) W U_IBLN3_U_$G(^IBA(355.32,IBCVG,2,IBJ,0)) S IBCR1=0,IBCOMFL=1 Q
.... W !,?5,IBLN1,?33,IBLN2,?51,IBLN3,?104,$G(^IBA(355.32,IBCVG,2,IBJ,0)) S (IBLN1,IBLN2,IBLN3)=""
... I IBLN3'="",IBOUT="R" W !,?5,IBLN1,?33,IBLN2,?51,IBLN3 S (IBLN1,IBLN2,IBLN3)=""
... I 'IBCOMFL,IBOUT="E" D:'IBCR1 XLCOLS(2,IBLN1) W U_IBLN3_U S IBCR1=0
. ;
. I +$G(IBPRTICR) S IBLN2="Riders: " D I IBOUT="E",+$G(IBCR1) W U
.. S IBRIDE=0,IBCR1=1 F S IBRIDE=$O(^IBA(355.7,"APP",DFN,IBI,IBRIDE)) Q:'IBRIDE D I $Y>(IOSL-6),IBOUT="R" W ! D HEAD Q:IBQUIT
... I IBOUT="E" D:'IBCR1 XLCOLS(3,IBLN1) W U_$P($G(^IBE(355.6,+IBRIDE,0)),U,1) S IBCR1=0 Q
... W !,?5,IBLN1,?33,IBLN2,?51,$P($G(^IBE(355.6,+IBRIDE,0)),U,1) S (IBLN1,IBLN2)=""
;
I IBOUT="R" W !
Q
;
DDSET(FILE,FLD,X) ; returns external value for a set
N Y,Z,T S Z="",Y=$G(^DD(+$G(FILE),+$G(FLD),0)) S T=$G(X)_":",Z=$P($P(Y,T,2),";",1)
Q Z
;
PHDL ; Print header for Excel format
W "DIV^PT ID^PATIENT^SSN^ELIGIBILITY"
I +$G(IBPRTRDS) W "^Rated Disabilities"
I +$G(IBPRTIEX) W "^Insurance^Group #^Effective Begin Date^Effective End Date^Last Ver"
I +$G(IBPRTIPC) W "^Policy Comment"
I +$G(IBPRTIGC) W "^Group Comments"
I +$G(IBPRTICR) W "^Coverage Limits^Limitation Comments^Riders"
;
W "^DATE OF "_$S(IBINPT=2:"DISCHARGE",1:"CARE")_"^INSURANCE COMPANIES"
I +$G(IBSELRNB) W "^NOT BILLABLE"
I 'IBINPT W "^Encounter Add/Edits"
;
W "^BILL NUMBER^LOCATION OF CARE^STATUS^From^To^Current Bill Payer Sequence^Debtor"
W "^DIV TOTALS^Unbilled^Unbilled w/RNB^Billed/Not Auth^Billed/Auth^# Visits^# Patients"
Q
;
XLCOLS(PLACE,INS) ; Print spacers for Excel columns
I +PLACE W !,IBPTINFO
I +$G(IBPRTRDS),+PLACE W U
I +$G(IBPRTIEX) W U_INS_"^^^^"
I +$G(IBPRTIPC) W U Q:PLACE=1
I +$G(IBPRTIGC) W U Q:PLACE=2
I +$G(IBPRTICR) W "^^" Q:PLACE=3
I +$G(IBPRTICR) W U
Q:'PLACE
;
W "^^"
I +$G(IBSELRNB) W U
I 'IBINPT W U Q:PLACE=4
W "^^^^^^^^"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCONS1 13011 printed Oct 16, 2024@18:19:06 Page 2
IBCONS1 ;ALB/AAS - NSC PATIENTS W/ INS BACKGROUND PRINTS ;7 JUN 90
+1 ;;2.0;INTEGRATED BILLING;**66,80,137,516,528**;21-MAR-94;Build 163
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRONS1
+5 ;
EN ; Inpatient Discharge entry to que background once weekly
+1 SET IBINPT=2
SET IBSUB="AMV3"
GOTO QUEUE
+2 ;
EN1 ; Inpatient Admission entry to que background once weekly
+1 SET IBINPT=1
SET IBSUB="AMV1"
GOTO QUEUE
+2 ;
EN2 ; Outpatient entry to que background once weekly
+1 SET IBINPT=0
SET IBSUB=""
+2 ;
QUEUE ; Set up the background job to run for the previous week
+1 ; o For All Divisions
+2 ; o For Insured veterans with unbilled episodes of care
+3 ; o With the output sorted by Terminal Digit
+4 ;
+5 KILL ^TMP($JOB)
+6 SET X="T"
SET %DT=""
DO ^%DT
SET IBEND=+Y
+7 SET X="T-7"
SET %DT=""
DO ^%DT
SET IBBEG=+Y
KILL %DT
+8 SET (VAUTD,IBSELUBL,IBSELTRM,IBSELRNB)=1
+9 USE IO
GOTO BEGIN^IBCONSC
+10 ;
+11 ;
LOOP25 ; Print all NSC w/Insurance reports.
+1 IF "^R^E^"'[(U_$GET(IBOUT)_U)
SET IBOUT="R"
+2 SET IBQUIT=0
SET IBFL=1
SET IBHDRDV=""
SET IBSUM=0
SET IBPTINFO=""
IF +$GET(IBSELCDV)
IF IBOUT="R"
DO HDRDV^IBCONSC
+3 IF IBOUT="E"
DO PHDL
+4 SET IBDV=""
FOR
SET IBDV=$ORDER(^TMP($JOB,IBDV))
if IBDV=""
QUIT
IF IBDV'="TOTAL"
DO LOOP3
if IBQUIT
QUIT
+5 ;
+6 if IBQUIT
GOTO Q
SET IBSUM=1
SET IBPAGE=0
if IBOUT="R"
DO HEAD
if IBQUIT
QUIT
+7 SET IBDV=""
FOR
SET IBDV=$ORDER(^TMP($JOB,"TOTAL",IBDV))
if IBDV=""
QUIT
DO PRNSUM
+8 DO PAUSE
+9 ;
Q KILL %,%DT,B,I,J,K,L,M,X,X1,X2,Y,DFN,IBCNT,IBIFN,IBBILL,IBDATE,IBFLAG,IBI,IBDT,IBPAGE,IBL,IBHD,IBBEG1,IBHDRDV,IBSUM
+1 KILL IBBEG,IBEND,IBOUT,IBINPT,IBFLAG,IBNAME,IBAPPT,IBDC,IBDAT,IBDFN,POP,IBNEWPT,IBPTINFO,^TMP($JOB)
+2 QUIT
+3 ;
+4 ;
LOOP3 ; Loop through billed, unbilled, or both types of episodes of care.
+1 IF +$GET(IBSELUBL)
SET IBBILL=1
SET IBNAME=""
SET IBPAGE=0
KILL IBFLAG
if IBOUT="R"
DO HEAD
if IBQUIT
QUIT
DO LOOP31
if IBQUIT
QUIT
+2 IF +$GET(IBSELBNA)!+$GET(IBSELBIL)
SET IBBILL=2
SET IBNAME=""
SET IBPAGE=0
KILL IBFLAG
if IBOUT="R"
DO HEAD
if IBQUIT
QUIT
DO LOOP31
if IBQUIT
QUIT
+3 QUIT
+4 ;
LOOP31 ; Loop through each name or terminal digit (and associated DFN).
+1 FOR
SET IBNAME=$ORDER(^TMP($JOB,IBDV,IBBILL,IBNAME))
Begin DoDot:1
+2 IF IBNAME=""
IF '$DATA(IBFLAG)
WRITE !!,"No matches found.",!
+3 if IBNAME=""
QUIT
+4 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN))
if 'DFN
QUIT
SET IBNEWPT=1
DO LOOP4
if IBQUIT
QUIT
End DoDot:1
if IBNAME=""!(IBQUIT)
QUIT
+5 QUIT
+6 ;
LOOP4 ; Loop through each episode of care for a patient.
+1 SET IBDAT=""
FOR I=0:0
SET IBDAT=$ORDER(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT))
if IBDAT=""!(IBQUIT)
QUIT
DO PRINT
IF $Y>$SELECT($DATA(IOSL):(IOSL-6),1:6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
+2 QUIT
+3 ;
PRINT ; Print each detail line.
+1 ; exclude episodes with reason not billable
IF '$GET(IBSELRNB)
IF $DATA(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))
QUIT
+2 ; exclude episode w/o RNB ** PATCH 66
IF +$GET(IBSELRNB)=2
IF '$DATA(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))
QUIT
+3 ; non-auth episodes ** PATCH 66
IF IBBILL=2
IF '$GET(IBSELBNA)
IF +$GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT))=1
QUIT
+4 ; auth episodes ** PATCH 66
IF IBBILL=2
IF '$GET(IBSELBIL)
IF +$GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT))=2
QUIT
+5 ;
+6 DO SUMTOT
SET IBFLAG=1
DO PID^VADPT6
+7 IF IBOUT="E"
SET IBPTINFO=$PIECE($GET(^DG(40.8,+IBDV,0)),"^")_U_VA("BID")_U_$PIECE(^DPT(DFN,0),"^")_U_VA("PID")_U_$PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),"^",6)
+8 ;
+9 IF +$GET(IBNEWPT)
if IBOUT="R"
WRITE !
DO PTPRNT
SET IBNEWPT=0
+10 if IBOUT="R"
WRITE !,VA("BID"),?6,$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20),?28,VA("PID"),?42,$EXTRACT($PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),"^",6),1,16)
KILL VA,VAERR
+11 SET Y=IBDAT
XECUTE ^DD("DD")
if IBOUT="R"
WRITE ?60
if IBOUT="E"
WRITE U
WRITE Y
+12 ;
+13 ; -- print insurance, use ibcns1 calls
+14 SET X=$$INSP(DFN,IBDAT)
if IBOUT="R"
WRITE ?82
if IBOUT="E"
WRITE U
WRITE X
+15 ;
+16 ; -- print reason not billable
+17 IF $GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))]""
if IBOUT="R"
WRITE ?115,$EXTRACT(^(2),1,16)
if IBOUT="E"
WRITE U_^(2)
+18 ;
+19 IF IBOUT="E"
IF 'IBINPT
WRITE U
+20 SET X=$GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,1))
+21 IF X]""
if IBOUT="R"
WRITE !?10
WRITE $PIECE(X,"^")
IF $PIECE(X,"^",2)]""
WRITE " with "
FOR IBDC=2:1
if $PIECE(X,"^",IBDC)=""
QUIT
WRITE $PIECE(X,"^",IBDC),", "
+22 SET X=^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT)
if '$LENGTH(X)
QUIT
FOR K=2:1
SET IBIFN=$PIECE(X,"^",K)
if IBIFN=""
QUIT
DO PRINT1
+23 QUIT
+24 ;
PRINT1 ; If an episode of care has been billed, display billing information.
+1 DO GVAR^IBCBB
+2 IF IBOUT="E"
Begin DoDot:1
+3 IF K>2
DO XLCOLS(4,"")
+4 WRITE U_$PIECE(^DGCR(399,IBIFN,0),"^")_U_$PIECE($GET(^DGCR(399.3,+IBAT,0)),"^",4),"-",$SELECT(IBCL<3:"INPT",IBCL>2:"OUTP",1:"")
+5 WRITE U_$SELECT(IBST=1:"Entered",IBST=2:"Request MRA",IBST=3:"Authorized",IBST=4:"Prnt/Trans",IBST=7:"Cancelled",IBST=0:"Closed",1:"")
+6 WRITE U_$EXTRACT(IBFDT,4,5)_"/"_$EXTRACT(IBFDT,6,7)_"/"_$EXTRACT(IBFDT,2,3)_U_$EXTRACT(IBTDT,4,5)_"/"_$EXTRACT(IBTDT,6,7)_"/"_$EXTRACT(IBTDT,2,3)
+7 WRITE U_$SELECT($PIECE(IBND0,U,21)="S":"s",$PIECE(IBND0,U,21)="T":"t",1:"")_U
End DoDot:1
+8 IF IBOUT="R"
Begin DoDot:1
+9 WRITE !?10,$PIECE(^DGCR(399,IBIFN,0),"^"),?20,$PIECE($GET(^DGCR(399.3,+IBAT,0)),"^",4),"-",$SELECT(IBCL<3:"INPT",IBCL>2:"OUTP",1:"")
+10 WRITE ?37,$SELECT(IBST=1:"Entered",IBST=2:"Request MRA",IBST=3:"Authorized",IBST=4:"Prnt/Trans",IBST=7:"Cancelled",IBST=0:"Closed",1:"")
+11 WRITE ?50,"From: ",$EXTRACT(IBFDT,4,5)_"/"_$EXTRACT(IBFDT,6,7)_"/"_$EXTRACT(IBFDT,2,3)
+12 WRITE ?68,"To: ",$EXTRACT(IBTDT,4,5)_"/"_$EXTRACT(IBTDT,6,7)_"/"_$EXTRACT(IBTDT,2,3)
+13 WRITE ?88,$SELECT($PIECE(IBND0,U,21)="S":"s",$PIECE(IBND0,U,21)="T":"t",1:"")
+14 WRITE ?91,"Debtor: "
End DoDot:1
+15 IF IBWHO="i"
IF $DATA(^DIC(36,+IBNDMP,0))
WRITE $PIECE(^(0),"^")
+16 IF IBWHO="o"
IF $DATA(^DIC(4,+$PIECE(IBNDM,"^",11),0))
WRITE $PIECE(^(0),"^")
+17 IF IBWHO="p"
WRITE $PIECE(^DPT(DFN,0),"^")
+18 DO END^IBCBB1
QUIT
+19 ;
HEAD ; Print header; don't pause on first pass through.
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,IBQUIT)=1
QUIT
+2 if 'IBFL
DO PAUSE
if IBQUIT
QUIT
SET IBFL=0
NEW IBI
+3 SET IBPAGE=IBPAGE+1
+4 ; -- ibformfd = skip only intial form feed, need ffs for each div.
+5 IF $EXTRACT(IOST,1,2)["C-"!(IBPAGE>1)!($GET(IBFORMFD))
WRITE @IOF
+6 SET IBFORMFD=1
+7 SET IBI=$SELECT(IBBILL=2:"PREVIOUSLY ",1:"UN")_"BILLED PATIENTS"
+8 IF '$GET(IBSELCDV)
SET IBI=IBI_" for Division "_$PIECE($GET(^DG(40.8,+IBDV,0)),"^")
+9 IF +$GET(IBSELCDV)
SET IBI=IBI_IBHDRDV
+10 IF +$GET(IBSUM)
SET IBI="Summary"
+11 WRITE IBHD,!,IBI
if $LENGTH(IBI)>78
WRITE !
WRITE ?80,"Printed: ",IBDATE,?118,"Page: ",IBPAGE
+12 IF +$GET(IBSUM)
WRITE !,?40,"Unbilled",?53,"Unbilled w/RNB",?70,"Billed/Not Auth",?88,"Billed/Auth",?103,"# Visits",?117,"# Patients",!,IBL
QUIT
+13 WRITE !,"PT ID PATIENT",?28,"SSN",?42,"ELIGIBILITY",?60,"DATE OF ",$SELECT(IBINPT=2:"DISCHARGE",1:"CARE"),?82,"INSURANCE COMPANIES"
+14 if +$GET(IBSELRNB)
WRITE ?115,"NOT BILLABLE"
+15 WRITE !,IBL
+16 QUIT
+17 ;
INSP(DFN,IBDAT) ; -- print ins. company on report logic
+1 NEW X,IBDD,IBDDINS,IBCNT
+2 SET IBCNT=0
SET IBDDINS=""
+3 IF '$GET(DFN)!('$GET(IBDAT))
GOTO INSPQ
+4 SET IBDD=""
DO ALL^IBCNS1(DFN,"IBDD",4,IBDAT)
+5 SET X=0
FOR
SET X=$ORDER(IBDD(X))
if 'X!(IBCNT>2)
QUIT
Begin DoDot:1
+6 SET IBCNT=IBCNT+1
+7 IF IBCNT>1
SET IBDDINS=IBDDINS_","
+8 SET IBDDINS=IBDDINS_$EXTRACT($PIECE($GET(^DIC(36,+$GET(IBDD(X,0)),0)),"^"),1,10)
End DoDot:1
+9 SET IBDDINS=$EXTRACT(IBDDINS,1,30)
+10 IF $GET(IBDD(0))>3
SET IBDDINS=IBDDINS_"*"
INSPQ QUIT IBDDINS
+1 ;
PAUSE if $EXTRACT(IOST,1,2)'="C-"
QUIT
+1 FOR J=$Y:1:(IOSL-5)
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!($DATA(DUOUT))
SET IBQUIT=1
KILL DIRUT,DTOUT,DUOUT
+3 QUIT
PRNSUM ; print 1 line of the summary
+1 NEW IBSUM
SET IBSUM=$GET(^TMP($JOB,"TOTAL",IBDV))
if IBSUM=""
QUIT
+2 if IBOUT="R"
WRITE !
+3 IF IBOUT="E"
DO XLCOLS(5,"")
+4 WRITE $SELECT(IBDV="TOTAL":IBDV,1:$PIECE($GET(^DG(40.8,+IBDV,0)),U,1))
+5 IF IBOUT="E"
WRITE U_$PIECE(IBSUM,U,2,5)_U_$PIECE(IBSUM,U,1)_U_$PIECE(IBSUM,U,6)
QUIT
+6 WRITE ?40,$PIECE(IBSUM,U,2),?58,$PIECE(IBSUM,U,3),?75,$PIECE(IBSUM,U,4),?91,$PIECE(IBSUM,U,5),?105,$PIECE(IBSUM,U,1),?120,$PIECE(IBSUM,U,6)
+7 QUIT
DATE(X) ;
+1 NEW Y
SET Y=""
IF +$GET(X)
SET Y=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+2 QUIT Y
+3 ;
SUMTOT ; total cnt of visits ^ cnt unbilled ^ cnt unbilled w/RNB ^ cnt billed/not auth ^ cnt billed/auth ^ cnt of pats
+1 NEW IBSUM,IBTOT,IBBILLED,IBRMARK
+2 SET IBBILLED=$GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT))
SET IBRMARK=$GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))
+3 SET IBSUM=$GET(^TMP($JOB,"TOTAL",+IBDV))
SET IBTOT=$GET(^TMP($JOB,"TOTAL","TOTAL"))
+4 SET $PIECE(IBSUM,U,1)=+$PIECE(IBSUM,U,1)+1
SET $PIECE(IBTOT,U,1)=+$PIECE(IBTOT,U,1)+1
+5 IF 'IBBILLED
IF IBRMARK=""
SET $PIECE(IBSUM,U,2)=$PIECE(IBSUM,U,2)+1
SET $PIECE(IBTOT,U,2)=$PIECE(IBTOT,U,2)+1
+6 IF 'IBBILLED
IF IBRMARK'=""
SET $PIECE(IBSUM,U,3)=$PIECE(IBSUM,U,3)+1
SET $PIECE(IBTOT,U,3)=$PIECE(IBTOT,U,3)+1
+7 IF +IBBILLED=1
SET $PIECE(IBSUM,U,4)=$PIECE(IBSUM,U,4)+1
SET $PIECE(IBTOT,U,4)=$PIECE(IBTOT,U,4)+1
+8 IF +IBBILLED=2
SET $PIECE(IBSUM,U,5)=$PIECE(IBSUM,U,5)+1
SET $PIECE(IBTOT,U,5)=$PIECE(IBTOT,U,5)+1
+9 IF '$DATA(^TMP($JOB,"TOTAL",+IBDV,DFN))
SET $PIECE(IBSUM,U,6)=$PIECE(IBSUM,U,6)+1
+10 IF '$DATA(^TMP($JOB,"TOTAL","TOTAL",DFN))
SET $PIECE(IBTOT,U,6)=$PIECE(IBTOT,U,6)+1
+11 IF +IBDV
SET ^TMP($JOB,"TOTAL",+IBDV)=IBSUM
SET ^TMP($JOB,"TOTAL",+IBDV,DFN)=""
+12 SET ^TMP($JOB,"TOTAL","TOTAL")=IBTOT
SET ^TMP($JOB,"TOTAL","TOTAL",DFN)=""
+13 QUIT
+14 ;
PTPRNT ; print patient specific data is requested: Rate Disabilities and expanded insurance Info
+1 ;
+2 NEW IBLN1,IBI,IBX,IBY,IBD,IBLN2,IBLN3,IBY1,IBJ,IBY3,IBRIDE,IBPLAN,IBCVG,IBGC1,IBCR1,IBCOMFL
+3 SET IBLN1=$PIECE($GET(^DPT(+DFN,0)),U,1)
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
+4 ;
+5 IF '$GET(IBPRTRDS)
IF IBOUT="E"
WRITE !,IBPTINFO
+6 IF +$GET(IBPRTRDS)
SET IBLN2="Rated Disabilities:"
Begin DoDot:1
+7 IF '$ORDER(^DPT(DFN,.372,0))
if IBOUT="R"
WRITE !,IBLN1,?33,IBLN2," None"
if IBOUT="E"
WRITE !,IBPTINFO_"^None"
SET (IBLN1,IBLN2)=""
QUIT
+8 SET IBI=0
FOR
SET IBI=$ORDER(^DPT(DFN,.372,IBI))
if 'IBI
QUIT
Begin DoDot:2
+9 SET IBX=$GET(^DPT(DFN,.372,IBI,0))
SET IBY=$GET(^DIC(31,+IBX,0))
+10 SET IBD=$SELECT($PIECE(IBY,U,4)="":$PIECE(IBY,U,1),1:$PIECE(IBY,U,4))_" ("_$PIECE(IBX,U,2)_"%-"_$SELECT(+$PIECE(IBX,U,3):"SC",1:"NSC")_")"
+11 if IBOUT="R"
WRITE !,IBLN1,?33,IBLN2,?57,IBD
if IBOUT="E"
WRITE !,IBPTINFO_U_IBD
SET (IBLN1,IBLN2)=""
End DoDot:2
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
End DoDot:1
if +$GET(IBQUIT)
QUIT
KILL IBX,IBY
+12 ;
+13 IF '$GET(IBPRTIEX)
IF '$GET(IBPRTIPC)
IF '$GET(IBPRTIGC)
IF '$GET(IBPRTICR)
IF IBOUT="R"
QUIT
+14 ;
+15 IF IBOUT="R"
if IBLN1'=""
WRITE !,IBLN1
+16 DO ALL^IBCNS1(DFN,"IBX",4,IBBEG)
DO ALL^IBCNS1(DFN,"IBX",4,IBEND)
+17 ;
+18 IF IBOUT="E"
IF '$ORDER(IBX(0))
DO XLCOLS(0,"")
+19 SET IBI=0
FOR
SET IBI=$ORDER(IBX(IBI))
if 'IBI
QUIT
Begin DoDot:1
+20 SET IBY=IBX(IBI,0)
SET IBY1=IBX(IBI,1)
+21 SET IBLN1=$PIECE($GET(^DIC(36,+IBY,0)),U,1)
SET IBPLAN=+$PIECE(IBY,U,18)
if IBOUT="R"
SET IBLN1=$EXTRACT(IBLN1,1,25)
+22 ;
+23 ;IB*2.0*516/DRF - Retrieve HIPAA compliant Group #
+24 ;I +$G(IBPRTIEX) W !,?5,IBLN1,?33,"Group #: ",$P($G(^IBA(355.3,+IBPLAN,0)),U,4),?65,"Effective: ",$$DATE(+$P(IBY,U,8))," - ",$$DATE(+$P(IBY,U,4)),?100,"Last Ver: ",$$DATE($P(IBY1,U,3)) S IBLN1=""
+25 IF +$GET(IBPRTIEX)
Begin DoDot:2
+26 IF IBOUT="E"
WRITE U_IBLN1_U_$PIECE(IBY,U,3)_U_$$DATE(+$PIECE(IBY,U,8))_U_$$DATE(+$PIECE(IBY,U,4))_U_$$DATE($PIECE(IBY1,U,3))
QUIT
+27 WRITE !,?5,IBLN1,?33,"Group #: ",$PIECE(IBY,U,3)
+28 WRITE !,?33,"Effective: ",$$DATE(+$PIECE(IBY,U,8))," - ",$$DATE(+$PIECE(IBY,U,4)),?68,"Last Ver: ",$$DATE($PIECE(IBY1,U,3))
SET IBLN1=""
End DoDot:2
+29 ;
+30 IF +$GET(IBPRTIPC)
SET IBLN2="Policy Comment: "
Begin DoDot:2
+31 IF IBOUT="E"
WRITE U_$PIECE(IBY1,U,8)
QUIT
+32 IF $PIECE(IBY1,U,8)'=""
WRITE !,?5,IBLN1,?33,IBLN2,?51,$PIECE(IBY1,U,8)
SET (IBLN1,IBLN2)=""
End DoDot:2
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
+33 ;
+34 IF +$GET(IBPRTIGC)
SET IBLN2="Group Comments: "
Begin DoDot:2
+35 SET IBJ=0
SET IBGC1=1
FOR
SET IBJ=$ORDER(^IBA(355.3,+IBPLAN,11,IBJ))
if 'IBJ
QUIT
Begin DoDot:3
+36 SET IBY3=$GET(^IBA(355.3,+IBPLAN,11,IBJ,0))
Begin DoDot:4
+37 IF IBOUT="E"
if 'IBGC1
DO XLCOLS(1,IBLN1)
WRITE U_IBY3
SET IBGC1=0
QUIT
+38 WRITE !,?5,IBLN1,?33,IBLN2,?51,IBY3
SET (IBLN1,IBLN2)=""
End DoDot:4
End DoDot:3
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
End DoDot:2
IF IBOUT="E"
IF +$GET(IBGC1)
WRITE U
+39 ;
+40 IF +$GET(IBPRTICR)
SET IBLN2="Coverage Limits:"
Begin DoDot:2
+41 SET IBCVG=0
SET IBCR1=1
FOR
SET IBCVG=$ORDER(^IBA(355.32,"B",IBPLAN,IBCVG))
if 'IBCVG
QUIT
Begin DoDot:3
+42 SET IBY3=$GET(^IBA(355.32,IBCVG,0))
if IBY3=""
QUIT
+43 SET IBLN3=$PIECE($GET(^IBE(355.31,+$PIECE(IBY3,U,2),0)),U,1)
IF IBOUT="R"
SET IBLN3=$EXTRACT(IBLN3,1,20)
+44 SET IBLN3=IBLN3_" "_$$DDSET(355.32,.04,+$PIECE(IBY3,U,4))_" "_$$DATE(+$PIECE(IBY3,U,3))
+45 SET (IBJ,IBCOMFL)=0
FOR
SET IBJ=$ORDER(^IBA(355.32,IBCVG,2,IBJ))
if 'IBJ
QUIT
Begin DoDot:4
+46 IF IBOUT="E"
if 'IBCR1
DO XLCOLS(2,IBLN1)
WRITE U_IBLN3_U_$GET(^IBA(355.32,IBCVG,2,IBJ,0))
SET IBCR1=0
SET IBCOMFL=1
QUIT
+47 WRITE !,?5,IBLN1,?33,IBLN2,?51,IBLN3,?104,$GET(^IBA(355.32,IBCVG,2,IBJ,0))
SET (IBLN1,IBLN2,IBLN3)=""
End DoDot:4
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
+48 IF IBLN3'=""
IF IBOUT="R"
WRITE !,?5,IBLN1,?33,IBLN2,?51,IBLN3
SET (IBLN1,IBLN2,IBLN3)=""
+49 IF 'IBCOMFL
IF IBOUT="E"
if 'IBCR1
DO XLCOLS(2,IBLN1)
WRITE U_IBLN3_U
SET IBCR1=0
End DoDot:3
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
End DoDot:2
IF IBOUT="E"
IF +$GET(IBCR1)
WRITE "^^"
+50 ;
+51 IF +$GET(IBPRTICR)
SET IBLN2="Riders: "
Begin DoDot:2
+52 SET IBRIDE=0
SET IBCR1=1
FOR
SET IBRIDE=$ORDER(^IBA(355.7,"APP",DFN,IBI,IBRIDE))
if 'IBRIDE
QUIT
Begin DoDot:3
+53 IF IBOUT="E"
if 'IBCR1
DO XLCOLS(3,IBLN1)
WRITE U_$PIECE($GET(^IBE(355.6,+IBRIDE,0)),U,1)
SET IBCR1=0
QUIT
+54 WRITE !,?5,IBLN1,?33,IBLN2,?51,$PIECE($GET(^IBE(355.6,+IBRIDE,0)),U,1)
SET (IBLN1,IBLN2)=""
End DoDot:3
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
End DoDot:2
IF IBOUT="E"
IF +$GET(IBCR1)
WRITE U
End DoDot:1
if +$GET(IBQUIT)
QUIT
IF $Y>(IOSL-6)
IF IBOUT="R"
WRITE !
DO HEAD
if IBQUIT
QUIT
+55 ;
+56 IF IBOUT="R"
WRITE !
+57 QUIT
+58 ;
DDSET(FILE,FLD,X) ; returns external value for a set
+1 NEW Y,Z,T
SET Z=""
SET Y=$GET(^DD(+$GET(FILE),+$GET(FLD),0))
SET T=$GET(X)_":"
SET Z=$PIECE($PIECE(Y,T,2),";",1)
+2 QUIT Z
+3 ;
PHDL ; Print header for Excel format
+1 WRITE "DIV^PT ID^PATIENT^SSN^ELIGIBILITY"
+2 IF +$GET(IBPRTRDS)
WRITE "^Rated Disabilities"
+3 IF +$GET(IBPRTIEX)
WRITE "^Insurance^Group #^Effective Begin Date^Effective End Date^Last Ver"
+4 IF +$GET(IBPRTIPC)
WRITE "^Policy Comment"
+5 IF +$GET(IBPRTIGC)
WRITE "^Group Comments"
+6 IF +$GET(IBPRTICR)
WRITE "^Coverage Limits^Limitation Comments^Riders"
+7 ;
+8 WRITE "^DATE OF "_$SELECT(IBINPT=2:"DISCHARGE",1:"CARE")_"^INSURANCE COMPANIES"
+9 IF +$GET(IBSELRNB)
WRITE "^NOT BILLABLE"
+10 IF 'IBINPT
WRITE "^Encounter Add/Edits"
+11 ;
+12 WRITE "^BILL NUMBER^LOCATION OF CARE^STATUS^From^To^Current Bill Payer Sequence^Debtor"
+13 WRITE "^DIV TOTALS^Unbilled^Unbilled w/RNB^Billed/Not Auth^Billed/Auth^# Visits^# Patients"
+14 QUIT
+15 ;
XLCOLS(PLACE,INS) ; Print spacers for Excel columns
+1 IF +PLACE
WRITE !,IBPTINFO
+2 IF +$GET(IBPRTRDS)
IF +PLACE
WRITE U
+3 IF +$GET(IBPRTIEX)
WRITE U_INS_"^^^^"
+4 IF +$GET(IBPRTIPC)
WRITE U
if PLACE=1
QUIT
+5 IF +$GET(IBPRTIGC)
WRITE U
if PLACE=2
QUIT
+6 IF +$GET(IBPRTICR)
WRITE "^^"
if PLACE=3
QUIT
+7 IF +$GET(IBPRTICR)
WRITE U
+8 if 'PLACE
QUIT
+9 ;
+10 WRITE "^^"
+11 IF +$GET(IBSELRNB)
WRITE U
+12 IF 'IBINPT
WRITE U
if PLACE=4
QUIT
+13 WRITE "^^^^^^^^"
+14 QUIT
