IBOSCDC1 ;ALB/BNT - SERVICE CONNECTED DETERMINATION CHANGE REPORT UTILITIES ;10/04/07
;;2.0;INTEGRATED BILLING;**384,435**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;Patient info for header
;Input:
;IBDFN = Patient DFN
;IBLEN = Length of overall characters for output
;Returns:
;Left Justified patient name with Last 4 SSN
PATINF(IBDFN,IBLEN) ;
N X
S X=$$PATNAME(IBDFN,IBLEN-7)_" "_$$SSN4^IBNCPRR1(IBDFN)
Q $$LJ(X,IBLEN) ;name
;
;Get patient's name
;Input:
;IBDFN = Patient DFN
;IBLEN = Length of characters to return
;Returns:
;patient's name
PATNAME(IBDFN,IBLEN) ;
Q $E($P($G(^DPT(IBDFN,0)),U),1,IBLEN)
;
;left justified, blank padded
;adds spaces on right or truncates to make return string IBLEN characters long
;IBST- original string
;IBLEN - desired length
LJ(IBST,IBLEN) ;
N IBL
S IBL=IBLEN-$L(IBST)
Q $E(IBST_$J("",$S(IBL<0:0,1:IBL)),1,IBLEN)
;
;Get Third Party bill from file 362.4, if one exists
;IBRXN = RX number
;IBDT = RX Fill Date
;Returns the Bill Number
BILL(IBRXN,IBDT) ;Bill IEN (if any) or null
N RES,X,IBZ
S IBDT=$P(IBDT,".")
S RES=""
S X="" F S X=$O(^IBA(362.4,"B",IBRXN,X),-1) Q:X="" D:X Q:RES
. S IBZ=$G(^IBA(362.4,X,0))
. I $P($P(IBZ,U,3),".")=IBDT,$P(IBZ,U,2) S RES=+$P(IBZ,U,2)
Q RES
;
;Check if the status on the first party bill in 350 is CANCELLED?
;IBILL = IEN from file 350
;Returns 1=yes, 0=no
BILLCNCL(IBILL) ;
N IBBILSTS
Q:(IBILL="")!(IBILL=0) 1
Q $S($$BILLSTS(IBILL)["CANCEL":1,1:0)
;
;Returns the PRINT NAME of the STATUS associated with a bill
;IBILL = IEN from file 350
;Returns the PRINT NAME field from file 350.21
BILLSTS(IBILL) ;
N IBBILSTS
Q:(IBILL="")!(IBILL=0) ""
S IBBILSTS=+$P($G(^IB(IBILL,0)),U,5)
Q $P($G(^IBE(350.21,IBBILSTS,0)),U,2)
;
;Get the TOTAL CHARGE for the bill
;IBILL = IEN from file 350
;Returns the TOTAL CHARGE
BILLAMNT(IBILL) ;
N X,X2,X3
Q:(IBILL="")!(IBILL=0) ""
S X=$P($G(^IB(IBILL,0)),U,7),X2="2$",X3=0 D COMMA^%DTC
Q X
;
;Collect the RX related data using Pharmacy API for the report and store in ^TMP($J,"IBRXARR"
;DFN = Patient IEN
;IBBDT = Beginning search date, used to determine if Rx was filled within this date
COLLECT(DFN,IBBDT) ; Collect data for patient
N LIST,IBRX,IBFIL,CNT
S LIST="IBRXARR",(IBRX,CNT,IBFIL)=0
K ^TMP($J,LIST)
D RX^PSO52API(DFN,LIST,,,"2,I,R",,)
F S IBRX=$O(^TMP($J,LIST,DFN,IBRX)) Q:'IBRX D
. Q:'+$P(^TMP($J,LIST,DFN,IBRX,31),U)
. D GETDATA(0,IBRX,DFN,LIST)
. I ^TMP($J,LIST,DFN,IBRX,"RF",0)<0 Q
. F S IBFIL=$O(^TMP($J,LIST,DFN,IBRX,"RF",IBFIL)) Q:IBFIL="" D
. . Q:IBFIL=0
. . D GETDATA(IBFIL,IBRX,DFN,LIST)
. Q
Q
;
;Gets specific data for first and third party bills and store in TMP file
;IBFIL = RX Fill #
;IBRX = IEN to Prescription file - RX ID Placeholder in the TMP file
;DFN = Patient IEN
;LIST = placeholder for data in ^TMP file
GETDATA(IBFIL,IBRX,DFN,LIST) ;
N IBBA,IBBILL,IBRXN,IBFILDT,IBRXINS,IBBILLN,IBECN
I IBFIL=0 D
. S IBFILDT=+$P(^TMP($J,LIST,DFN,IBRX,22),U)
. S IBBA=+$P($G(^TMP($J,LIST,DFN,IBRX,106)),U)
E S IBFILDT=+$P(^TMP($J,LIST,DFN,IBRX,"RF",IBFIL,.01),U) D
. S IBBA=+$P($G(^TMP($J,LIST,DFN,IBRX,"IB",IBFIL,9)),U)
Q:IBFILDT<IBBDT
S IBRXN=^TMP($J,LIST,DFN,IBRX,.01)
; First party copay
I $$BILLCNCL(IBBA) Q
S IBBILL=$P($P($G(^IB(IBBA,0)),U,11),"-",2)
I IBBILL="" S IBBILL=$$BILLSTS(IBBA)
S CNT=CNT+1 D SETREF(CNT,IBRXN,IBFIL,IBFILDT,IBBILL,"Copay","",$$BILLAMNT(IBBA))
; Third party bills
S IBBILL=$$BILL(IBRXN,IBFILDT) Q:IBBILL']""
S IBBILLN=$$GETBILLN(IBBILL)
S IBRXINS=$$GETINS(IBBILL)
S IBECN=$$GETECME(IBBILL)
S CNT=CNT+1 D SETREF(CNT,IBRXN,IBFIL,IBFILDT,IBBILLN,IBRXINS,IBECN,"")
Q
;
;SETREF sets the reference global with report data
;INPUT: DATA = Counter^RxIEN^Rx#^Fill#^FillDate^BillNumber^BillInsurance^ECME#^TotalCharge
SETREF(CNT,IBRXN,IBFIL,IBDT,IBBILLN,IBRXINS,IBECN,IBCHRG) ;
S @REF@(DFN,CNT)=IBRXN_U_IBFIL_U_IBDT_U_IBBILLN_U_IBECN_U_IBRXINS_U_IBCHRG
Q
;
;Get the Bill Number from file 399
;Input:
;IEN of file 399
;Returns:
;BILL NUMBER field
GETBILLN(IBBIL) ;
Q $P($G(^DGCR(399,IBBIL,0)),U)_$$ECME^IBTRE(IBBIL,"")
;
;Get the ECME Number from file 399
;Input:
;IEN of file 399
;Returns:
;ECME NUMBER field
GETECME(IBBIL) ;
Q $P($P($G(^DGCR(399,IBBIL,"M1")),U,8),";")
;
;Get Insurance payer
;Input:
;IEN of file 399
;Returns:
;Insurance company name prefixed with p-, s-, or t-.
GETINS(IBBIL) ;
N IBINS,IBSEQ,IBM
Q:'$D(^DGCR(399,IBBIL,0)) ""
S IBSEQ=$P($G(^DGCR(399,IBBIL,0)),U,21)
;Don't include Patient in CURRENT BILL PAYER SEQUENCE.
Q:IBSEQ["A" ""
S IBM=$G(^DGCR(399,IBBIL,"M"))
Q:'IBM "UNKNOWN"
S IBINS=$S(IBSEQ="P":$P(IBM,U),IBSEQ="S":$P(IBM,U,2),IBSEQ="T":$P(IBM,U,3))
I IBINS']"" Q "UNKNOWN"
Q $$LOW^XLFSTR(IBSEQ)_"-"_$P($G(^DIC(36,IBINS,0)),U)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOSCDC1 4947 printed Sep 23, 2025@20:02:24 Page 2
IBOSCDC1 ;ALB/BNT - SERVICE CONNECTED DETERMINATION CHANGE REPORT UTILITIES ;10/04/07
+1 ;;2.0;INTEGRATED BILLING;**384,435**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Patient info for header
+5 ;Input:
+6 ;IBDFN = Patient DFN
+7 ;IBLEN = Length of overall characters for output
+8 ;Returns:
+9 ;Left Justified patient name with Last 4 SSN
PATINF(IBDFN,IBLEN) ;
+1 NEW X
+2 SET X=$$PATNAME(IBDFN,IBLEN-7)_" "_$$SSN4^IBNCPRR1(IBDFN)
+3 ;name
QUIT $$LJ(X,IBLEN)
+4 ;
+5 ;Get patient's name
+6 ;Input:
+7 ;IBDFN = Patient DFN
+8 ;IBLEN = Length of characters to return
+9 ;Returns:
+10 ;patient's name
PATNAME(IBDFN,IBLEN) ;
+1 QUIT $EXTRACT($PIECE($GET(^DPT(IBDFN,0)),U),1,IBLEN)
+2 ;
+3 ;left justified, blank padded
+4 ;adds spaces on right or truncates to make return string IBLEN characters long
+5 ;IBST- original string
+6 ;IBLEN - desired length
LJ(IBST,IBLEN) ;
+1 NEW IBL
+2 SET IBL=IBLEN-$LENGTH(IBST)
+3 QUIT $EXTRACT(IBST_$JUSTIFY("",$SELECT(IBL<0:0,1:IBL)),1,IBLEN)
+4 ;
+5 ;Get Third Party bill from file 362.4, if one exists
+6 ;IBRXN = RX number
+7 ;IBDT = RX Fill Date
+8 ;Returns the Bill Number
BILL(IBRXN,IBDT) ;Bill IEN (if any) or null
+1 NEW RES,X,IBZ
+2 SET IBDT=$PIECE(IBDT,".")
+3 SET RES=""
+4 SET X=""
FOR
SET X=$ORDER(^IBA(362.4,"B",IBRXN,X),-1)
if X=""
QUIT
if X
Begin DoDot:1
+5 SET IBZ=$GET(^IBA(362.4,X,0))
+6 IF $PIECE($PIECE(IBZ,U,3),".")=IBDT
IF $PIECE(IBZ,U,2)
SET RES=+$PIECE(IBZ,U,2)
End DoDot:1
if RES
QUIT
+7 QUIT RES
+8 ;
+9 ;Check if the status on the first party bill in 350 is CANCELLED?
+10 ;IBILL = IEN from file 350
+11 ;Returns 1=yes, 0=no
BILLCNCL(IBILL) ;
+1 NEW IBBILSTS
+2 if (IBILL="")!(IBILL=0)
QUIT 1
+3 QUIT $SELECT($$BILLSTS(IBILL)["CANCEL":1,1:0)
+4 ;
+5 ;Returns the PRINT NAME of the STATUS associated with a bill
+6 ;IBILL = IEN from file 350
+7 ;Returns the PRINT NAME field from file 350.21
BILLSTS(IBILL) ;
+1 NEW IBBILSTS
+2 if (IBILL="")!(IBILL=0)
QUIT ""
+3 SET IBBILSTS=+$PIECE($GET(^IB(IBILL,0)),U,5)
+4 QUIT $PIECE($GET(^IBE(350.21,IBBILSTS,0)),U,2)
+5 ;
+6 ;Get the TOTAL CHARGE for the bill
+7 ;IBILL = IEN from file 350
+8 ;Returns the TOTAL CHARGE
BILLAMNT(IBILL) ;
+1 NEW X,X2,X3
+2 if (IBILL="")!(IBILL=0)
QUIT ""
+3 SET X=$PIECE($GET(^IB(IBILL,0)),U,7)
SET X2="2$"
SET X3=0
DO COMMA^%DTC
+4 QUIT X
+5 ;
+6 ;Collect the RX related data using Pharmacy API for the report and store in ^TMP($J,"IBRXARR"
+7 ;DFN = Patient IEN
+8 ;IBBDT = Beginning search date, used to determine if Rx was filled within this date
COLLECT(DFN,IBBDT) ; Collect data for patient
+1 NEW LIST,IBRX,IBFIL,CNT
+2 SET LIST="IBRXARR"
SET (IBRX,CNT,IBFIL)=0
+3 KILL ^TMP($JOB,LIST)
+4 DO RX^PSO52API(DFN,LIST,,,"2,I,R",,)
+5 FOR
SET IBRX=$ORDER(^TMP($JOB,LIST,DFN,IBRX))
if 'IBRX
QUIT
Begin DoDot:1
+6 if '+$PIECE(^TMP($JOB,LIST,DFN,IBRX,31),U)
QUIT
+7 DO GETDATA(0,IBRX,DFN,LIST)
+8 IF ^TMP($JOB,LIST,DFN,IBRX,"RF",0)<0
QUIT
+9 FOR
SET IBFIL=$ORDER(^TMP($JOB,LIST,DFN,IBRX,"RF",IBFIL))
if IBFIL=""
QUIT
Begin DoDot:2
+10 if IBFIL=0
QUIT
+11 DO GETDATA(IBFIL,IBRX,DFN,LIST)
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
+15 ;Gets specific data for first and third party bills and store in TMP file
+16 ;IBFIL = RX Fill #
+17 ;IBRX = IEN to Prescription file - RX ID Placeholder in the TMP file
+18 ;DFN = Patient IEN
+19 ;LIST = placeholder for data in ^TMP file
GETDATA(IBFIL,IBRX,DFN,LIST) ;
+1 NEW IBBA,IBBILL,IBRXN,IBFILDT,IBRXINS,IBBILLN,IBECN
+2 IF IBFIL=0
Begin DoDot:1
+3 SET IBFILDT=+$PIECE(^TMP($JOB,LIST,DFN,IBRX,22),U)
+4 SET IBBA=+$PIECE($GET(^TMP($JOB,LIST,DFN,IBRX,106)),U)
End DoDot:1
+5 IF '$TEST
SET IBFILDT=+$PIECE(^TMP($JOB,LIST,DFN,IBRX,"RF",IBFIL,.01),U)
Begin DoDot:1
+6 SET IBBA=+$PIECE($GET(^TMP($JOB,LIST,DFN,IBRX,"IB",IBFIL,9)),U)
End DoDot:1
+7 if IBFILDT<IBBDT
QUIT
+8 SET IBRXN=^TMP($JOB,LIST,DFN,IBRX,.01)
+9 ; First party copay
+10 IF $$BILLCNCL(IBBA)
QUIT
+11 SET IBBILL=$PIECE($PIECE($GET(^IB(IBBA,0)),U,11),"-",2)
+12 IF IBBILL=""
SET IBBILL=$$BILLSTS(IBBA)
+13 SET CNT=CNT+1
DO SETREF(CNT,IBRXN,IBFIL,IBFILDT,IBBILL,"Copay","",$$BILLAMNT(IBBA))
+14 ; Third party bills
+15 SET IBBILL=$$BILL(IBRXN,IBFILDT)
if IBBILL']""
QUIT
+16 SET IBBILLN=$$GETBILLN(IBBILL)
+17 SET IBRXINS=$$GETINS(IBBILL)
+18 SET IBECN=$$GETECME(IBBILL)
+19 SET CNT=CNT+1
DO SETREF(CNT,IBRXN,IBFIL,IBFILDT,IBBILLN,IBRXINS,IBECN,"")
+20 QUIT
+21 ;
+22 ;SETREF sets the reference global with report data
+23 ;INPUT: DATA = Counter^RxIEN^Rx#^Fill#^FillDate^BillNumber^BillInsurance^ECME#^TotalCharge
SETREF(CNT,IBRXN,IBFIL,IBDT,IBBILLN,IBRXINS,IBECN,IBCHRG) ;
+1 SET @REF@(DFN,CNT)=IBRXN_U_IBFIL_U_IBDT_U_IBBILLN_U_IBECN_U_IBRXINS_U_IBCHRG
+2 QUIT
+3 ;
+4 ;Get the Bill Number from file 399
+5 ;Input:
+6 ;IEN of file 399
+7 ;Returns:
+8 ;BILL NUMBER field
GETBILLN(IBBIL) ;
+1 QUIT $PIECE($GET(^DGCR(399,IBBIL,0)),U)_$$ECME^IBTRE(IBBIL,"")
+2 ;
+3 ;Get the ECME Number from file 399
+4 ;Input:
+5 ;IEN of file 399
+6 ;Returns:
+7 ;ECME NUMBER field
GETECME(IBBIL) ;
+1 QUIT $PIECE($PIECE($GET(^DGCR(399,IBBIL,"M1")),U,8),";")
+2 ;
+3 ;Get Insurance payer
+4 ;Input:
+5 ;IEN of file 399
+6 ;Returns:
+7 ;Insurance company name prefixed with p-, s-, or t-.
GETINS(IBBIL) ;
+1 NEW IBINS,IBSEQ,IBM
+2 if '$DATA(^DGCR(399,IBBIL,0))
QUIT ""
+3 SET IBSEQ=$PIECE($GET(^DGCR(399,IBBIL,0)),U,21)
+4 ;Don't include Patient in CURRENT BILL PAYER SEQUENCE.
+5 if IBSEQ["A"
QUIT ""
+6 SET IBM=$GET(^DGCR(399,IBBIL,"M"))
+7 if 'IBM
QUIT "UNKNOWN"
+8 SET IBINS=$SELECT(IBSEQ="P":$PIECE(IBM,U),IBSEQ="S":$PIECE(IBM,U,2),IBSEQ="T":$PIECE(IBM,U,3))
+9 IF IBINS']""
QUIT "UNKNOWN"
+10 QUIT $$LOW^XLFSTR(IBSEQ)_"-"_$PIECE($GET(^DIC(36,IBINS,0)),U)
+11 ;
