- IBCONS1 ;ALB/AAS - NSC PATIENTS W/ INS BACKGROUND PRINTS ; 7 JUN 90
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;
- ;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,IBSORT,IBTERM,IBRNB)=1
- U IO G BEGIN^IBCONSC
- ;
- ;
- LOOP25 ; Print all NSC w/Insurance reports.
- S IBQUIT=0,IBFL=1,IBDV=""
- F S IBDV=$O(^TMP($J,IBDV)) Q:IBDV="" D LOOP3 Q:IBQUIT
- D:'IBQUIT 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
- K IBBEG,IBEND,IBINPT,IBFLAG,IBNAME,IBAPPT,IBDC,IBDAT,IBDFN,POP,^TMP($J)
- ;I '$D(ZTQUEUED) D ^%ZISC
- Q
- ;
- ;
- LOOP3 ; Loop through billed, unbilled, or both types of episodes of care.
- F IBBILL=$S(IBSORT<3:IBSORT,1:1):1:$S(IBSORT<3:IBSORT,1:2) S IBNAME="",IBPAGE=0 K IBFLAG D 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 D LOOP4 Q:IBQUIT W !
- 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) W ! D HEAD Q:IBQUIT
- Q
- ;
- PRINT ; Print each detail line.
- I '$G(IBRNB),$D(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,2)) Q ; if reason not billable, and don't print if not billable quit
- S IBFLAG=1 D PID^VADPT6
- W !,VA("BID"),?6,$E($P(^DPT(DFN,0),"^"),1,20),?28,VA("PID"),?42,$E($P($G(^DIC(8,+$G(^(.36)),0)),"^",6),1,16) K VA,VAERR
- S Y=IBDAT X ^DD("DD") W ?60,Y
- ;
- ; -- print insurance, use ibcns1 calls
- S X=$$INSP(DFN,IBDAT) W ?82,X
- ;
- ;S IBCNT=0 F II=0:0 S II=$O(^DPT(DFN,.312,II)) Q:'II S IBCNT=IBCNT+1,X=+^(II,0) D
- ;. I $D(^DIC(36,X,0)) W:IBCNT=2!(IBCNT=3) ", " W:IBCNT<4 $E($P(^(0),"^"),1,14) W:IBCNT=4 " " W:IBCNT>3 "*"
- ;
- ; -- print reason not billable
- I $G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))]"" W ?115,$E(^(2),1,16)
- ;
- S X=$G(^TMP($J,IBDV,IBBILL,IBNAME,DFN,IBDAT,1))
- I X]"" W !?10,$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=1: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
- 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,"From: ",$E(IBFDT,4,5)_"/"_$E(IBFDT,6,7)_"/"_$E(IBFDT,2,3)
- W ?55,"To: ",$E(IBTDT,4,5)_"/"_$E(IBTDT,6,7)_"/"_$E(IBTDT,2,3)
- W ?78,"Debtor: "
- I IBWHO="i",$D(^DIC(36,+IBNDM,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
- 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
- W IBHD,!,$S(IBBILL=2:"PREVIOUSLY ",1:"UN"),"BILLED PATIENTS for Division ",$P($G(^DG(40.8,IBDV,0)),"^"),?80,"Printed: ",IBDATE,?118,"Page: ",IBPAGE
- W !,"PT ID PATIENT",?28,"SSN",?42,"ELIGIBILITY",?60,"DATE OF ",$S(IBINPT=2:"DISCHARGE",1:"CARE"),?82,"INSURANCE COMPANIES"
- W:IBRNB ?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",1,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
- IBCONS1 ;ALB/AAS - NSC PATIENTS W/ INS BACKGROUND PRINTS ; 7 JUN 90
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;
- +3 ;MAP TO DGCRONS1
- +4 ;
- 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,IBSORT,IBTERM,IBRNB)=1
- +9 USE IO
- GOTO BEGIN^IBCONSC
- +10 ;
- +11 ;
- LOOP25 ; Print all NSC w/Insurance reports.
- +1 SET IBQUIT=0
- SET IBFL=1
- SET IBDV=""
- +2 FOR
- SET IBDV=$ORDER(^TMP($JOB,IBDV))
- IF IBDV=""
- QUIT
- DO LOOP3
- IF IBQUIT
- QUIT
- +3 IF 'IBQUIT
- DO PAUSE
- +4 ;
- 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
- +1 KILL IBBEG,IBEND,IBINPT,IBFLAG,IBNAME,IBAPPT,IBDC,IBDAT,IBDFN,POP,^TMP($JOB)
- +2 ;I '$D(ZTQUEUED) D ^%ZISC
- +3 QUIT
- +4 ;
- +5 ;
- LOOP3 ; Loop through billed, unbilled, or both types of episodes of care.
- +1 FOR IBBILL=$SELECT(IBSORT<3:IBSORT,1:1):1:$SELECT(IBSORT<3:IBSORT,1:2)
- SET IBNAME=""
- SET IBPAGE=0
- KILL IBFLAG
- DO HEAD
- IF IBQUIT
- QUIT
- DO LOOP31
- IF IBQUIT
- QUIT
- +2 QUIT
- +3 ;
- 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
- DO LOOP4
- IF IBQUIT
- QUIT
- WRITE !
- 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)
- WRITE !
- DO HEAD
- IF IBQUIT
- QUIT
- +2 QUIT
- +3 ;
- PRINT ; Print each detail line.
- +1 ; if reason not billable, and don't print if not billable quit
- IF '$GET(IBRNB)
- IF $DATA(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))
- QUIT
- +2 SET IBFLAG=1
- DO PID^VADPT6
- +3 WRITE !,VA("BID"),?6,$EXTRACT($PIECE(^DPT(DFN,0),"^"),1,20),?28,VA("PID"),?42,$EXTRACT($PIECE($GET(^DIC(8,+$GET(^(.36)),0)),"^",6),1,16)
- KILL VA,VAERR
- +4 SET Y=IBDAT
- XECUTE ^DD("DD")
- WRITE ?60,Y
- +5 ;
- +6 ; -- print insurance, use ibcns1 calls
- +7 SET X=$$INSP(DFN,IBDAT)
- WRITE ?82,X
- +8 ;
- +9 ;S IBCNT=0 F II=0:0 S II=$O(^DPT(DFN,.312,II)) Q:'II S IBCNT=IBCNT+1,X=+^(II,0) D
- +10 ;. I $D(^DIC(36,X,0)) W:IBCNT=2!(IBCNT=3) ", " W:IBCNT<4 $E($P(^(0),"^"),1,14) W:IBCNT=4 " " W:IBCNT>3 "*"
- +11 ;
- +12 ; -- print reason not billable
- +13 IF $GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,2))]""
- WRITE ?115,$EXTRACT(^(2),1,16)
- +14 ;
- +15 SET X=$GET(^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT,1))
- +16 IF X]""
- WRITE !?10,$PIECE(X,"^")
- IF $PIECE(X,"^",2)]""
- WRITE " with "
- FOR IBDC=2:1
- IF $PIECE(X,"^",IBDC)=""
- QUIT
- WRITE $PIECE(X,"^",IBDC),", "
- +17 SET X=^TMP($JOB,IBDV,IBBILL,IBNAME,DFN,IBDAT)
- IF '$LENGTH(X)
- QUIT
- FOR K=1:1
- SET IBIFN=$PIECE(X,"^",K)
- IF IBIFN=""
- QUIT
- DO PRINT1
- +18 QUIT
- +19 ;
- PRINT1 ; If an episode of care has been billed, display billing information.
- +1 DO GVAR^IBCBB
- +2 WRITE !?10,$PIECE(^DGCR(399,IBIFN,0),"^"),?20,$PIECE($GET(^DGCR(399.3,+IBAT,0)),"^",4),"-",$SELECT(IBCL<3:"INPT",IBCL>2:"OUTP",1:"")
- +3 WRITE ?37,"From: ",$EXTRACT(IBFDT,4,5)_"/"_$EXTRACT(IBFDT,6,7)_"/"_$EXTRACT(IBFDT,2,3)
- +4 WRITE ?55,"To: ",$EXTRACT(IBTDT,4,5)_"/"_$EXTRACT(IBTDT,6,7)_"/"_$EXTRACT(IBTDT,2,3)
- +5 WRITE ?78,"Debtor: "
- +6 IF IBWHO="i"
- IF $DATA(^DIC(36,+IBNDM,0))
- WRITE $PIECE(^(0),"^")
- +7 IF IBWHO="o"
- IF $DATA(^DIC(4,+$PIECE(IBNDM,"^",11),0))
- WRITE $PIECE(^(0),"^")
- +8 IF IBWHO="p"
- WRITE $PIECE(^DPT(DFN,0),"^")
- +9 DO END^IBCBB1
- QUIT
- +10 ;
- 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
- +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 WRITE IBHD,!,$SELECT(IBBILL=2:"PREVIOUSLY ",1:"UN"),"BILLED PATIENTS for Division ",$PIECE($GET(^DG(40.8,IBDV,0)),"^"),?80,"Printed: ",IBDATE,?118,"Page: ",IBPAGE
- +8 WRITE !,"PT ID PATIENT",?28,"SSN",?42,"ELIGIBILITY",?60,"DATE OF ",$SELECT(IBINPT=2:"DISCHARGE",1:"CARE"),?82,"INSURANCE COMPANIES"
- +9 IF IBRNB
- WRITE ?115,"NOT BILLABLE"
- +10 WRITE !,IBL
- +11 QUIT
- +12 ;
- 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",1,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
