IB20P247 ;WOIFO/SS - POST INIT ROUTINE FOR IB*2*247 ;6-OCT-03
;;2.0;INTEGRATED BILLING;**247**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
POST ; adding charge removal reason entries if not there
N IBX,IBT,IBY,X,Y,DIC,DO
D ADDCRR
D ADDNBR
Q
;
ADDCRR ; need to add charge removal reasons
N IBX,IBT,IBY,DIC,Y,X
F IBX=1:1 S IBY=$P($T(CRR+IBX),";",3,99) Q:IBY="" S IBT=$P(IBY,";") I '$O(^IBE(350.3,"B",IBT,0)) K DO D
. S DIC="^IBE(350.3,",DIC(0)="",X=IBT,DIC("DR")=$P(IBY,";",2,3)
. D FILE^DICN I Y>0 D BMES^XPDUTL(" --> Added Charge Removal Reasons: "_IBT)
Q
;
ADDNBR ; need to add non billable reasons
F IBX=1:1 S IBT=$P($T(NBR+IBX),";",3) Q:IBT="" I '$O(^IBE(356.8,"B",IBT,0)) K DO D
. S DIC="^IBE(356.8,",DIC(0)="",X=IBT
. D FILE^DICN I Y>0 D BMES^XPDUTL(" --> Added Reason Not Billable: "_IBT)
Q
;
CRR ; charge removal reasons to add in #350.3
;;COMBAT VETERAN;.02///CV;.03///GENERIC
;;
NBR ; non-billable reasons to add in #356.8 if not there
;;HEAD/NECK CANCER
;;COMBAT VETERAN
;;
;
;-------- report for CV expiration date problem
RPT ;
I '$$PATCH^XPDUTL("DG*5.3*576") W !,"The patch DG*5.3*576 needs to be installed to run the report." Q
K ^TMP("DGCVEX",$J),^TMP("IBCVEX",$J)
D EN^DGCVEXP
N IBDFN,IBDT,IBNNN
S IBNNN=0
S IBDFN=0 F S IBDFN=$O(^TMP("DGCVEX",$J,IBDFN)) Q:+IBDFN=0 D
. S IBDT=0 F S IBDT=$O(^TMP("DGCVEX",$J,IBDFN,IBDT)) Q:+IBDT=0 D COUNTIN(IBDFN,IBDT,.IBNNN)
D PRINTREP(IBNNN)
K ^TMP("DGCVEX",$J),^TMP("IBCVEX",$J)
Q
;--------
;IBDF - patient's DFN
;IBD - the last date of CV
COUNTIN(IBDF,IBD,IBNN) ;
;3rd party claims
N IBIEN,IBRVDT,IB1,IBTO,IBFR,IBI,IBK
S IBIEN=0 F S IBIEN=$O(^DGCR(399,"C",IBDF,IBIEN)) Q:+IBIEN=0 D
. S IB1=$G(^DGCR(399,IBIEN,0))
. Q:+$P(IB1,"^",5)=0 ;no care type
. S IBTO=+$P($G(^DGCR(399,IBIEN,"U")),"^",2),IBFR=+$G(^DGCR(399,IBIEN,"U"))
. ;outpatients
. I $P(IB1,"^",5)>2 D:IBD=IBFR SETTMP(IBDF,IBD,IBIEN,1,.IBNN) Q
. ;inpatients
. I (IBD'<IBFR) I IBTO=0!(IBD'>IBTO) D SETTMP(IBDF,IBD,IBIEN,2,.IBNN)
;1st party copays
S IBIEN=0 F S IBIEN=$O(^IB("C",IBDF,IBIEN)) Q:+IBIEN=0 D
. S IB1=$G(^IB(IBIEN,0)),IBFR=+$P(IB1,"^",14),IBTO=+$P(IB1,"^",15)
. I (IBD'<IBFR),(IBD'>IBTO) D SETTMP(IBDF,IBD,IBIEN,3,.IBNN)
Q
;--------
; print report
PRINTREP(IBNN) ;
N IBDFN,IBDT,IB1,IBN
D HEADER
S IBDFN=0 F S IBDFN=$O(^TMP("IBCVEX",$J,IBDFN)) Q:+IBDFN=0 D
. S IBDT=0 F S IBDT=$O(^TMP("IBCVEX",$J,IBDFN,IBDT)) Q:+IBDT=0 D
.. S IBN=0 F S IBN=$O(^TMP("IBCVEX",$J,IBDFN,IBDT,IBN)) Q:+IBN=0 D OUTP(IBDFN,IBDT,$G(^TMP("IBCVEX",$J,IBDFN,IBDT,IBN)))
D FOOTER(IBNN)
Q
;--------
;set ^TMP
SETTMP(IBDFN,IBDT,IBIEN1,IBTYP,IBNUM) ;
S IBNUM=IBNUM+1,^TMP("IBCVEX",$J,IBDFN,IBDT,IBNUM)=IBTYP_"^"_IBIEN1
Q
OUTP(IBDFN,IBDT,IBDATA) ;
Q:$G(IBDATA)=""
N Y S Y=$$PATINFO(IBDFN)
W !,$P(Y,"^"),?30,$P(Y,"^",2),?43,$$STRDATE(IBDT),?55,$E($$BILLINFO(IBDATA),1,18)
Q
;--------
;billing info
BILLINFO(IBDATA) ;
I +IBDATA=3 Q $P($P($G(^IB(+$P(IBDATA,"^",2),0)),"^",11),"-",2)_" PATIENT"
Q $P($G(^DGCR(399,+$P(IBDATA,"^",2),0)),"^")_" INSURANCE"
;--------
;Fileman date to String format
;Y - fileman date
STRDATE(Y) ;
I Y>0 X ^DD("DD") Q Y
Q ""
;--------
;patient info
PATINFO(DFN) ;
I +$G(DFN)=0 Q "??"
N VADM,VA,VAERR
D DEM^VADPT
Q $E($G(VADM(1)),1,28)_"^"_$P($G(VADM(2)),"^",2)
;
;--------
W !,"...Please wait..."
W !,?15,">> CV Billing Verification Report <<"
D LINE
W !,"Name",?30,"SSN",?43,"Date",?55,"Bill #"
D LINE
Q
;--------
D LINE
W !,"Total: "_IBNNN_" bills/copays"
Q
;--------
LINE ;line
W !,"-----------------------------",?30,"------------",?43,"-----------",?55,"------------------"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P247 3812 printed Dec 13, 2024@02:02 Page 2
IB20P247 ;WOIFO/SS - POST INIT ROUTINE FOR IB*2*247 ;6-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**247**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
POST ; adding charge removal reason entries if not there
+1 NEW IBX,IBT,IBY,X,Y,DIC,DO
+2 DO ADDCRR
+3 DO ADDNBR
+4 QUIT
+5 ;
ADDCRR ; need to add charge removal reasons
+1 NEW IBX,IBT,IBY,DIC,Y,X
+2 FOR IBX=1:1
SET IBY=$PIECE($TEXT(CRR+IBX),";",3,99)
if IBY=""
QUIT
SET IBT=$PIECE(IBY,";")
IF '$ORDER(^IBE(350.3,"B",IBT,0))
KILL DO
Begin DoDot:1
+3 SET DIC="^IBE(350.3,"
SET DIC(0)=""
SET X=IBT
SET DIC("DR")=$PIECE(IBY,";",2,3)
+4 DO FILE^DICN
IF Y>0
DO BMES^XPDUTL(" --> Added Charge Removal Reasons: "_IBT)
End DoDot:1
+5 QUIT
+6 ;
ADDNBR ; need to add non billable reasons
+1 FOR IBX=1:1
SET IBT=$PIECE($TEXT(NBR+IBX),";",3)
if IBT=""
QUIT
IF '$ORDER(^IBE(356.8,"B",IBT,0))
KILL DO
Begin DoDot:1
+2 SET DIC="^IBE(356.8,"
SET DIC(0)=""
SET X=IBT
+3 DO FILE^DICN
IF Y>0
DO BMES^XPDUTL(" --> Added Reason Not Billable: "_IBT)
End DoDot:1
+4 QUIT
+5 ;
CRR ; charge removal reasons to add in #350.3
+1 ;;COMBAT VETERAN;.02///CV;.03///GENERIC
+2 ;;
NBR ; non-billable reasons to add in #356.8 if not there
+1 ;;HEAD/NECK CANCER
+2 ;;COMBAT VETERAN
+3 ;;
+4 ;
+5 ;-------- report for CV expiration date problem
RPT ;
+1 IF '$$PATCH^XPDUTL("DG*5.3*576")
WRITE !,"The patch DG*5.3*576 needs to be installed to run the report."
QUIT
+2 KILL ^TMP("DGCVEX",$JOB),^TMP("IBCVEX",$JOB)
+3 DO EN^DGCVEXP
+4 NEW IBDFN,IBDT,IBNNN
+5 SET IBNNN=0
+6 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^TMP("DGCVEX",$JOB,IBDFN))
if +IBDFN=0
QUIT
Begin DoDot:1
+7 SET IBDT=0
FOR
SET IBDT=$ORDER(^TMP("DGCVEX",$JOB,IBDFN,IBDT))
if +IBDT=0
QUIT
DO COUNTIN(IBDFN,IBDT,.IBNNN)
End DoDot:1
+8 DO PRINTREP(IBNNN)
+9 KILL ^TMP("DGCVEX",$JOB),^TMP("IBCVEX",$JOB)
+10 QUIT
+11 ;--------
+12 ;IBDF - patient's DFN
+13 ;IBD - the last date of CV
COUNTIN(IBDF,IBD,IBNN) ;
+1 ;3rd party claims
+2 NEW IBIEN,IBRVDT,IB1,IBTO,IBFR,IBI,IBK
+3 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^DGCR(399,"C",IBDF,IBIEN))
if +IBIEN=0
QUIT
Begin DoDot:1
+4 SET IB1=$GET(^DGCR(399,IBIEN,0))
+5 ;no care type
if +$PIECE(IB1,"^",5)=0
QUIT
+6 SET IBTO=+$PIECE($GET(^DGCR(399,IBIEN,"U")),"^",2)
SET IBFR=+$GET(^DGCR(399,IBIEN,"U"))
+7 ;outpatients
+8 IF $PIECE(IB1,"^",5)>2
if IBD=IBFR
DO SETTMP(IBDF,IBD,IBIEN,1,.IBNN)
QUIT
+9 ;inpatients
+10 IF (IBD'<IBFR)
IF IBTO=0!(IBD'>IBTO)
DO SETTMP(IBDF,IBD,IBIEN,2,.IBNN)
End DoDot:1
+11 ;1st party copays
+12 SET IBIEN=0
FOR
SET IBIEN=$ORDER(^IB("C",IBDF,IBIEN))
if +IBIEN=0
QUIT
Begin DoDot:1
+13 SET IB1=$GET(^IB(IBIEN,0))
SET IBFR=+$PIECE(IB1,"^",14)
SET IBTO=+$PIECE(IB1,"^",15)
+14 IF (IBD'<IBFR)
IF (IBD'>IBTO)
DO SETTMP(IBDF,IBD,IBIEN,3,.IBNN)
End DoDot:1
+15 QUIT
+16 ;--------
+17 ; print report
PRINTREP(IBNN) ;
+1 NEW IBDFN,IBDT,IB1,IBN
+2 DO HEADER
+3 SET IBDFN=0
FOR
SET IBDFN=$ORDER(^TMP("IBCVEX",$JOB,IBDFN))
if +IBDFN=0
QUIT
Begin DoDot:1
+4 SET IBDT=0
FOR
SET IBDT=$ORDER(^TMP("IBCVEX",$JOB,IBDFN,IBDT))
if +IBDT=0
QUIT
Begin DoDot:2
+5 SET IBN=0
FOR
SET IBN=$ORDER(^TMP("IBCVEX",$JOB,IBDFN,IBDT,IBN))
if +IBN=0
QUIT
DO OUTP(IBDFN,IBDT,$GET(^TMP("IBCVEX",$JOB,IBDFN,IBDT,IBN)))
End DoDot:2
End DoDot:1
+6 DO FOOTER(IBNN)
+7 QUIT
+8 ;--------
+9 ;set ^TMP
SETTMP(IBDFN,IBDT,IBIEN1,IBTYP,IBNUM) ;
+1 SET IBNUM=IBNUM+1
SET ^TMP("IBCVEX",$JOB,IBDFN,IBDT,IBNUM)=IBTYP_"^"_IBIEN1
+2 QUIT
OUTP(IBDFN,IBDT,IBDATA) ;
+1 if $GET(IBDATA)=""
QUIT
+2 NEW Y
SET Y=$$PATINFO(IBDFN)
+3 WRITE !,$PIECE(Y,"^"),?30,$PIECE(Y,"^",2),?43,$$STRDATE(IBDT),?55,$EXTRACT($$BILLINFO(IBDATA),1,18)
+4 QUIT
+5 ;--------
+6 ;billing info
BILLINFO(IBDATA) ;
+1 IF +IBDATA=3
QUIT $PIECE($PIECE($GET(^IB(+$PIECE(IBDATA,"^",2),0)),"^",11),"-",2)_" PATIENT"
+2 QUIT $PIECE($GET(^DGCR(399,+$PIECE(IBDATA,"^",2),0)),"^")_" INSURANCE"
+3 ;--------
+4 ;Fileman date to String format
+5 ;Y - fileman date
STRDATE(Y) ;
+1 IF Y>0
XECUTE ^DD("DD")
QUIT Y
+2 QUIT ""
+3 ;--------
+4 ;patient info
PATINFO(DFN) ;
+1 IF +$GET(DFN)=0
QUIT "??"
+2 NEW VADM,VA,VAERR
+3 DO DEM^VADPT
+4 QUIT $EXTRACT($GET(VADM(1)),1,28)_"^"_$PIECE($GET(VADM(2)),"^",2)
+5 ;
+6 ;--------
+1 WRITE !,"...Please wait..."
+2 WRITE !,?15,">> CV Billing Verification Report <<"
+3 DO LINE
+4 WRITE !,"Name",?30,"SSN",?43,"Date",?55,"Bill #"
+5 DO LINE
+6 QUIT
+7 ;--------
+1 DO LINE
+2 WRITE !,"Total: "_IBNNN_" bills/copays"
+3 QUIT
+4 ;--------
LINE ;line
+1 WRITE !,"-----------------------------",?30,"------------",?43,"-----------",?55,"------------------"
+2 QUIT
+3 ;
