- 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 Apr 23, 2025@18:32:59 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
