IBRFN1 ;ALB/CPM - PASS PATIENT STATEMENT DATA TO A/R ; 24-FEB-93
;;2.0;INTEGRATED BILLING;**27,57,52,715**; 21-MAR-94;Build 25
;;Per VA Directive 6402, this routine should not be modified.
;
STMT(TRAN) ; Pass clinical data to AR for the patient statement.
; Input: TRAN -- AR Transaction number (ptr to #433)
; Returns: ^TMP("IBRFN1",$J,n)=1^2^3^4^5^6^7^8 , where
;
; -----------------------------------------------------------
; | | Transaction Type |
; |----------|------------------------------------------------|
; | Piece | Pharmacy | Outpatient | Inpatient |
; |----------|----------------|--------------|----------------|
; | 1 | IB Ref# | IB Ref# | IB Ref# |
; | 2 | Rx# | Visit Date | Adm Date |
; | 3 | Drug | -- | Bill From Date |
; | 4 | Days Supply | -- | Bill To Date |
; | 5 | Physician | -- | Disc Date |
; | 6 | Quantity | -- | -- |
; | 7 |Fill/Refill Date| -- | -- |
; | 8 | Charge Amt | Charge Amt | Charge Amt |
; -----------------------------------------------------------
;
Q:'$G(TRAN) K ^TMP("IBRFN1",$J)
N IBATYP,IBATYPN,IBN,IBJ,IBND,IBBG,IBSL,IBPE,IBCHG
S IBN=0 F IBJ=1:1 S IBN=$O(^IB("AT",TRAN,IBN)) Q:'IBN D
.S IBND=$G(^IB(IBN,0)),IBSL=$P(IBND,U,4),IBCHG=$P(IBND,U,7) Q:'IBND
.I +IBSL=52 D RX Q
.S IBATYP=$P(IBND,U,3),IBATYPN=$$GET1^DIQ(350.1,IBATYP_",",.01) ; get action type (file 350.1 ien) and action type name (350.1/.01) IB*2.0*715
.S IBBG=$P($G(^IBE(350.1,IBATYP,0)),U,11)
.I IBBG=4 S ^TMP("IBRFN1",$J,IBJ)=+IBND_U_$P(IBND,U,14)_"^^^^^^"_IBCHG Q ; outpatient
.I IBBG=7,IBATYPN["OPT"!(IBATYPN["RX") S ^TMP("IBRFN1",$J,IBJ)=+IBND_U_$P(IBND,U,14)_"^^^^^^"_IBCHG Q ; Tricare outpatient / RX IB*2.0*715
.S IBPE=$G(^IB(+$P(IBND,U,16),0))
.I +IBSL'=405,+IBSL'=45 S IBSL=$P(IBPE,U,4)
.I +IBSL=405!(+IBSL=45) D INP Q
.S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^^"_$P(IBND,U,14)_U_$P(IBND,U,15)_"^^^^"_IBCHG
.Q
Q
;
RX ; Build array element for Pharmacy Co-pay charges.
N %DT,I,IBRX,IBFILL,PSOFILL,PSONTALK,PSORX0,PSORX1,PSORXN,PSOTMP,VA,VAERR,X,Y,Z
S IBRX=$P($P(IBSL,";"),":",2),IBFILL=+$P($P(IBSL,";",2),":",2)
S X=IBRX_"^"_IBFILL,PSONTALK="" D EN^PSOCPVW
S Z=+IBND F I=.01,6,8,4,7,22 S Z=Z_"^"_$G(PSOTMP(52,IBRX,I,"E"))
S:IBFILL $P(Z,"^",7)=$G(PSOTMP(52.1,IBFILL,.01,"E"))
S X=$P(Z,"^",7),%DT="" D ^%DT S $P(Z,"^",7)=$S(Y>0:Y,1:"")
S ^TMP("IBRFN1",$J,IBJ)=Z_"^"_IBCHG
Q
;
INP ; Build array element for inpatient charges.
N IBADM,IBDIS,IBFR,IBTO,PM,PM0,X,X1,X2
I +IBSL=405 D
. S PM=+$P(IBSL,":",2),PM0=$G(^DGPM(PM,0))
. S IBADM=$S(PM0:+PM0\1,1:$P(IBPE,"^",17))
. S IBDIS=$S(PM0:$S($D(^DGPM(+$P(PM0,"^",17),0)):+^(0)\1,1:""),1:"")
I +IBSL=45 D
. S PM=+$P(IBSL,":",2),PM0=$G(^DGPT(PM,0))
. S IBADM=$S(PM0:+$P(PM0,"^",2)\1,1:$P(IBPE,"^",17))
. S IBDIS=$S($G(^DGPT(PM,70)):+^(70)\1,1:"")
;
S IBFR=$P(IBND,"^",14),IBTO=$P(IBND,"^",15)
; - check for per diems added through C/E/A which are off by one day
I IBBG=3 S X1=IBTO,X2=IBFR D ^%DTC I X+1'=$P(IBND,"^",6) S X1=IBTO,X2=-1 D C^%DTC S IBTO=X
S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^"_IBADM_"^"_IBFR_"^"_IBTO_"^"_IBDIS_"^^^"_IBCHG
Q
;
;
STMTB(BILL) ; AR Patient Statement Entry point for CHAMPVA Subsistence
; Input: BILL -- AR Bill number (field #.01 value of #430)
; Returns: Same output as described above in the Pharmacy
; and inpatient columns.
;
Q:$G(BILL)="" K ^TMP("IBRFN1",$J)
N IBN,IBJ,IBND,IBBG,IBSL,IBPE,IBCHG,IBAT
S IBN=$O(^IB("ABIL",BILL,0)) Q:'IBN
S IBND=$G(^IB(IBN,0)),IBSL=$P(IBND,"^",4),IBCHG=$P(IBND,"^",7) Q:'IBND
S IBAT=$G(^IBE(350.1,+$P(IBND,"^",3),0)),IBBG=$P(IBAT,"^",11),IBJ=1
I +IBSL=52 D RX Q
I $P(IBAT,"^")["OPT COPAY" S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^"_$P(IBND,"^",14)_"^^^^^^"_IBCHG Q
S IBPE=$G(^IB(+$P(IBND,"^",16),0))
I +IBSL'=405,+IBSL'=45 S IBSL=$P(IBPE,"^",4)
I +IBSL=405!(+IBSL=45) D INP Q
S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^^"_$P(IBND,"^",14)_"^"_$P(IBND,"^",15)_"^^^^"_IBCHG
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRFN1 4342 printed Dec 13, 2024@02:26:53 Page 2
IBRFN1 ;ALB/CPM - PASS PATIENT STATEMENT DATA TO A/R ; 24-FEB-93
+1 ;;2.0;INTEGRATED BILLING;**27,57,52,715**; 21-MAR-94;Build 25
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
STMT(TRAN) ; Pass clinical data to AR for the patient statement.
+1 ; Input: TRAN -- AR Transaction number (ptr to #433)
+2 ; Returns: ^TMP("IBRFN1",$J,n)=1^2^3^4^5^6^7^8 , where
+3 ;
+4 ; -----------------------------------------------------------
+5 ; | | Transaction Type |
+6 ; |----------|------------------------------------------------|
+7 ; | Piece | Pharmacy | Outpatient | Inpatient |
+8 ; |----------|----------------|--------------|----------------|
+9 ; | 1 | IB Ref# | IB Ref# | IB Ref# |
+10 ; | 2 | Rx# | Visit Date | Adm Date |
+11 ; | 3 | Drug | -- | Bill From Date |
+12 ; | 4 | Days Supply | -- | Bill To Date |
+13 ; | 5 | Physician | -- | Disc Date |
+14 ; | 6 | Quantity | -- | -- |
+15 ; | 7 |Fill/Refill Date| -- | -- |
+16 ; | 8 | Charge Amt | Charge Amt | Charge Amt |
+17 ; -----------------------------------------------------------
+18 ;
+19 if '$GET(TRAN)
QUIT
KILL ^TMP("IBRFN1",$JOB)
+20 NEW IBATYP,IBATYPN,IBN,IBJ,IBND,IBBG,IBSL,IBPE,IBCHG
+21 SET IBN=0
FOR IBJ=1:1
SET IBN=$ORDER(^IB("AT",TRAN,IBN))
if 'IBN
QUIT
Begin DoDot:1
+22 SET IBND=$GET(^IB(IBN,0))
SET IBSL=$PIECE(IBND,U,4)
SET IBCHG=$PIECE(IBND,U,7)
if 'IBND
QUIT
+23 IF +IBSL=52
DO RX
QUIT
+24 ; get action type (file 350.1 ien) and action type name (350.1/.01) IB*2.0*715
SET IBATYP=$PIECE(IBND,U,3)
SET IBATYPN=$$GET1^DIQ(350.1,IBATYP_",",.01)
+25 SET IBBG=$PIECE($GET(^IBE(350.1,IBATYP,0)),U,11)
+26 ; outpatient
IF IBBG=4
SET ^TMP("IBRFN1",$JOB,IBJ)=+IBND_U_$PIECE(IBND,U,14)_"^^^^^^"_IBCHG
QUIT
+27 ; Tricare outpatient / RX IB*2.0*715
IF IBBG=7
IF IBATYPN["OPT"!(IBATYPN["RX")
SET ^TMP("IBRFN1",$JOB,IBJ)=+IBND_U_$PIECE(IBND,U,14)_"^^^^^^"_IBCHG
QUIT
+28 SET IBPE=$GET(^IB(+$PIECE(IBND,U,16),0))
+29 IF +IBSL'=405
IF +IBSL'=45
SET IBSL=$PIECE(IBPE,U,4)
+30 IF +IBSL=405!(+IBSL=45)
DO INP
QUIT
+31 SET ^TMP("IBRFN1",$JOB,IBJ)=+IBND_"^^"_$PIECE(IBND,U,14)_U_$PIECE(IBND,U,15)_"^^^^"_IBCHG
+32 QUIT
End DoDot:1
+33 QUIT
+34 ;
RX ; Build array element for Pharmacy Co-pay charges.
+1 NEW %DT,I,IBRX,IBFILL,PSOFILL,PSONTALK,PSORX0,PSORX1,PSORXN,PSOTMP,VA,VAERR,X,Y,Z
+2 SET IBRX=$PIECE($PIECE(IBSL,";"),":",2)
SET IBFILL=+$PIECE($PIECE(IBSL,";",2),":",2)
+3 SET X=IBRX_"^"_IBFILL
SET PSONTALK=""
DO EN^PSOCPVW
+4 SET Z=+IBND
FOR I=.01,6,8,4,7,22
SET Z=Z_"^"_$GET(PSOTMP(52,IBRX,I,"E"))
+5 if IBFILL
SET $PIECE(Z,"^",7)=$GET(PSOTMP(52.1,IBFILL,.01,"E"))
+6 SET X=$PIECE(Z,"^",7)
SET %DT=""
DO ^%DT
SET $PIECE(Z,"^",7)=$SELECT(Y>0:Y,1:"")
+7 SET ^TMP("IBRFN1",$JOB,IBJ)=Z_"^"_IBCHG
+8 QUIT
+9 ;
INP ; Build array element for inpatient charges.
+1 NEW IBADM,IBDIS,IBFR,IBTO,PM,PM0,X,X1,X2
+2 IF +IBSL=405
Begin DoDot:1
+3 SET PM=+$PIECE(IBSL,":",2)
SET PM0=$GET(^DGPM(PM,0))
+4 SET IBADM=$SELECT(PM0:+PM0\1,1:$PIECE(IBPE,"^",17))
+5 SET IBDIS=$SELECT(PM0:$SELECT($DATA(^DGPM(+$PIECE(PM0,"^",17),0)):+^(0)\1,1:""),1:"")
End DoDot:1
+6 IF +IBSL=45
Begin DoDot:1
+7 SET PM=+$PIECE(IBSL,":",2)
SET PM0=$GET(^DGPT(PM,0))
+8 SET IBADM=$SELECT(PM0:+$PIECE(PM0,"^",2)\1,1:$PIECE(IBPE,"^",17))
+9 SET IBDIS=$SELECT($GET(^DGPT(PM,70)):+^(70)\1,1:"")
End DoDot:1
+10 ;
+11 SET IBFR=$PIECE(IBND,"^",14)
SET IBTO=$PIECE(IBND,"^",15)
+12 ; - check for per diems added through C/E/A which are off by one day
+13 IF IBBG=3
SET X1=IBTO
SET X2=IBFR
DO ^%DTC
IF X+1'=$PIECE(IBND,"^",6)
SET X1=IBTO
SET X2=-1
DO C^%DTC
SET IBTO=X
+14 SET ^TMP("IBRFN1",$JOB,IBJ)=+IBND_"^"_IBADM_"^"_IBFR_"^"_IBTO_"^"_IBDIS_"^^^"_IBCHG
+15 QUIT
+16 ;
+17 ;
STMTB(BILL) ; AR Patient Statement Entry point for CHAMPVA Subsistence
+1 ; Input: BILL -- AR Bill number (field #.01 value of #430)
+2 ; Returns: Same output as described above in the Pharmacy
+3 ; and inpatient columns.
+4 ;
+5 if $GET(BILL)=""
QUIT
KILL ^TMP("IBRFN1",$JOB)
+6 NEW IBN,IBJ,IBND,IBBG,IBSL,IBPE,IBCHG,IBAT
+7 SET IBN=$ORDER(^IB("ABIL",BILL,0))
if 'IBN
QUIT
+8 SET IBND=$GET(^IB(IBN,0))
SET IBSL=$PIECE(IBND,"^",4)
SET IBCHG=$PIECE(IBND,"^",7)
if 'IBND
QUIT
+9 SET IBAT=$GET(^IBE(350.1,+$PIECE(IBND,"^",3),0))
SET IBBG=$PIECE(IBAT,"^",11)
SET IBJ=1
+10 IF +IBSL=52
DO RX
QUIT
+11 IF $PIECE(IBAT,"^")["OPT COPAY"
SET ^TMP("IBRFN1",$JOB,IBJ)=+IBND_"^"_$PIECE(IBND,"^",14)_"^^^^^^"_IBCHG
QUIT
+12 SET IBPE=$GET(^IB(+$PIECE(IBND,"^",16),0))
+13 IF +IBSL'=405
IF +IBSL'=45
SET IBSL=$PIECE(IBPE,"^",4)
+14 IF +IBSL=405!(+IBSL=45)
DO INP
QUIT
+15 SET ^TMP("IBRFN1",$JOB,IBJ)=+IBND_"^^"_$PIECE(IBND,"^",14)_"^"_$PIECE(IBND,"^",15)_"^^^^"_IBCHG
+16 QUIT
