- 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 Feb 18, 2025@23:53:23 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