Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBRFN1

IBRFN1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. STMT(TRAN) ; Pass clinical data to AR for the patient statement.
  1. ; Input: TRAN -- AR Transaction number (ptr to #433)
  1. ; Returns: ^TMP("IBRFN1",$J,n)=1^2^3^4^5^6^7^8 , where
  1. ;
  1. ; -----------------------------------------------------------
  1. ; | | Transaction Type |
  1. ; |----------|------------------------------------------------|
  1. ; | Piece | Pharmacy | Outpatient | Inpatient |
  1. ; |----------|----------------|--------------|----------------|
  1. ; | 1 | IB Ref# | IB Ref# | IB Ref# |
  1. ; | 2 | Rx# | Visit Date | Adm Date |
  1. ; | 3 | Drug | -- | Bill From Date |
  1. ; | 4 | Days Supply | -- | Bill To Date |
  1. ; | 5 | Physician | -- | Disc Date |
  1. ; | 6 | Quantity | -- | -- |
  1. ; | 7 |Fill/Refill Date| -- | -- |
  1. ; | 8 | Charge Amt | Charge Amt | Charge Amt |
  1. ; -----------------------------------------------------------
  1. ;
  1. Q:'$G(TRAN) K ^TMP("IBRFN1",$J)
  1. N IBATYP,IBATYPN,IBN,IBJ,IBND,IBBG,IBSL,IBPE,IBCHG
  1. S IBN=0 F IBJ=1:1 S IBN=$O(^IB("AT",TRAN,IBN)) Q:'IBN D
  1. .S IBND=$G(^IB(IBN,0)),IBSL=$P(IBND,U,4),IBCHG=$P(IBND,U,7) Q:'IBND
  1. .I +IBSL=52 D RX Q
  1. .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
  1. .S IBBG=$P($G(^IBE(350.1,IBATYP,0)),U,11)
  1. .I IBBG=4 S ^TMP("IBRFN1",$J,IBJ)=+IBND_U_$P(IBND,U,14)_"^^^^^^"_IBCHG Q ; outpatient
  1. .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
  1. .S IBPE=$G(^IB(+$P(IBND,U,16),0))
  1. .I +IBSL'=405,+IBSL'=45 S IBSL=$P(IBPE,U,4)
  1. .I +IBSL=405!(+IBSL=45) D INP Q
  1. .S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^^"_$P(IBND,U,14)_U_$P(IBND,U,15)_"^^^^"_IBCHG
  1. .Q
  1. Q
  1. ;
  1. RX ; Build array element for Pharmacy Co-pay charges.
  1. N %DT,I,IBRX,IBFILL,PSOFILL,PSONTALK,PSORX0,PSORX1,PSORXN,PSOTMP,VA,VAERR,X,Y,Z
  1. S IBRX=$P($P(IBSL,";"),":",2),IBFILL=+$P($P(IBSL,";",2),":",2)
  1. S X=IBRX_"^"_IBFILL,PSONTALK="" D EN^PSOCPVW
  1. S Z=+IBND F I=.01,6,8,4,7,22 S Z=Z_"^"_$G(PSOTMP(52,IBRX,I,"E"))
  1. S:IBFILL $P(Z,"^",7)=$G(PSOTMP(52.1,IBFILL,.01,"E"))
  1. S X=$P(Z,"^",7),%DT="" D ^%DT S $P(Z,"^",7)=$S(Y>0:Y,1:"")
  1. S ^TMP("IBRFN1",$J,IBJ)=Z_"^"_IBCHG
  1. Q
  1. ;
  1. INP ; Build array element for inpatient charges.
  1. N IBADM,IBDIS,IBFR,IBTO,PM,PM0,X,X1,X2
  1. I +IBSL=405 D
  1. . S PM=+$P(IBSL,":",2),PM0=$G(^DGPM(PM,0))
  1. . S IBADM=$S(PM0:+PM0\1,1:$P(IBPE,"^",17))
  1. . S IBDIS=$S(PM0:$S($D(^DGPM(+$P(PM0,"^",17),0)):+^(0)\1,1:""),1:"")
  1. I +IBSL=45 D
  1. . S PM=+$P(IBSL,":",2),PM0=$G(^DGPT(PM,0))
  1. . S IBADM=$S(PM0:+$P(PM0,"^",2)\1,1:$P(IBPE,"^",17))
  1. . S IBDIS=$S($G(^DGPT(PM,70)):+^(70)\1,1:"")
  1. ;
  1. S IBFR=$P(IBND,"^",14),IBTO=$P(IBND,"^",15)
  1. ; - check for per diems added through C/E/A which are off by one day
  1. 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
  1. S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^"_IBADM_"^"_IBFR_"^"_IBTO_"^"_IBDIS_"^^^"_IBCHG
  1. Q
  1. ;
  1. ;
  1. STMTB(BILL) ; AR Patient Statement Entry point for CHAMPVA Subsistence
  1. ; Input: BILL -- AR Bill number (field #.01 value of #430)
  1. ; Returns: Same output as described above in the Pharmacy
  1. ; and inpatient columns.
  1. ;
  1. Q:$G(BILL)="" K ^TMP("IBRFN1",$J)
  1. N IBN,IBJ,IBND,IBBG,IBSL,IBPE,IBCHG,IBAT
  1. S IBN=$O(^IB("ABIL",BILL,0)) Q:'IBN
  1. S IBND=$G(^IB(IBN,0)),IBSL=$P(IBND,"^",4),IBCHG=$P(IBND,"^",7) Q:'IBND
  1. S IBAT=$G(^IBE(350.1,+$P(IBND,"^",3),0)),IBBG=$P(IBAT,"^",11),IBJ=1
  1. I +IBSL=52 D RX Q
  1. I $P(IBAT,"^")["OPT COPAY" S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^"_$P(IBND,"^",14)_"^^^^^^"_IBCHG Q
  1. S IBPE=$G(^IB(+$P(IBND,"^",16),0))
  1. I +IBSL'=405,+IBSL'=45 S IBSL=$P(IBPE,"^",4)
  1. I +IBSL=405!(+IBSL=45) D INP Q
  1. S ^TMP("IBRFN1",$J,IBJ)=+IBND_"^^"_$P(IBND,"^",14)_"^"_$P(IBND,"^",15)_"^^^^"_IBCHG
  1. Q