- 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 Jan 18, 2025@03:03:13 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 ;