- IBNCPDPU ;OAK/ELZ - UTILITIES FOR NCPDP ;Jun 06, 2014@19:13:12
- ;;2.0;INTEGRATED BILLING;**223,276,347,383,405,384,437,435,452,511,534,550,624,711**;21-MAR-94;Build 18
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference to ECMEACT^PSOBPSU1 in ICR #4702
- ; Reference to $$EN^BPSNCPDP in ICR #4415
- ; Reference to $$NABP^BPSBUTL in ICR #4719
- ; Reference to $$CLMECME^BPSUTIL2 in ICR #6028
- ; Reference to $$VALECME^BPSUTIL2 in ICR #6139
- ; Reference to $$RXRLDT^PSOBPSUT in ICR #4701
- ;
- ;
- CT(DFN,IBRXN,IBFIL,IBADT,IBRMARK) ; files in claims tracking
- ; Input:
- ; DFN - Patient IEN
- ; IBRXN - Rx IEN
- ; IBFIL - Fill#
- ; IBADT - Date of Service
- ; IBRMARK - Non-billable Reason (.01 from 356.8)
- ;
- N DIE,DR,DA,IBRXTYP,IBEABD
- ; Check that the Date of Service is current
- I IBTRKRN,$G(IBADT),($G(IBADT)'=$P(^IBT(356,IBTRKRN,0),U,6)) D
- . S DIE="^IBT(356,",DA=IBTRKRN,DR=".06////"_IBADT D ^DIE
- I IBTRKRN D:$D(IBRMARK) Q
- . S DIE="^IBT(356,",DA=IBTRKRN,DR=".19///"_IBRMARK
- . D ^DIE
- ; event type pointer for rx billing
- S IBRXTYP=$O(^IBE(356.6,"AC",4,0))
- ; earliest auto-billing date
- S IBEABD=$$EABD^IBTUTL(IBRXTYP,$$FMADD^XLFDT(IBADT,60))
- ; space out earliest auto bill date
- ;
- ; ROI check. The variable IBSCROI will be set to:
- ; '1' if NOT REQUIRED '2' if OBTAINED
- ; '3' if REQUIRED '4' if REFUSED
- N IBSCROI,IBDRUG,IBDEA,IBRXDATA
- S IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN)
- S IBDRUG=$P(IBRXDATA,U,6)
- ;
- ; $$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
- I $$SENS^IBNCPDR(IBDRUG) D
- . N IBINS,IBFLG,IBINSP
- . D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
- . S IBINSP=$O(IBINS("S",1,99),-1) Q:IBINSP=""
- . ; If the Date of Service (DOS) is on or after to the Mission Act
- . ; implementation date (MAID), skip ROI check.
- . I $$MACHK^IBNCPDR4($G(IBADT)) S (IBFLG,IBSCROI)=1,IBRMARK="" Q
- . S IBFLG=$$ROI^IBNCPDR4(DFN,$G(IBDRUG),+$G(IBINS(IBINSP,"0")),$G(IBADT))
- . I 'IBFLG,$G(IBRMARK)="" S IBRMARK="ROI NOT OBTAINED" ; IB*2*550
- . I 'IBFLG S IBSCROI=3
- . I IBFLG S IBSCROI=2
- ;
- D REFILL^IBTUTL1(DFN,IBRXTYP,IBADT,IBRXN,IBFIL,$G(IBRMARK),IBEABD,$G(IBSCROI))
- Q
- ;
- ;NDC relocated to IBNCPNB
- ;
- FILL(X,LEN) ; Zero-fill, right justified.
- N Y
- S:'$G(LEN) LEN=1
- S Y=$E($G(X),1,LEN)
- F Q:$L(Y)>(LEN-1) S Y="0"_Y
- Q Y
- ;
- PLANN(DFN,IBX,IBADT) ; returns the ien in the insurance multiple for the given plan/patient provided
- ; Output: insurance co ien^2.312 subfile ien
- N IBPOL,IBY,IBR
- S IBR=""
- D ALL^IBCNS1(DFN,"IBPOL",1,IBADT)
- S IBY=0 F S IBY=$O(IBPOL(IBY)) Q:'IBY!IBR I $P($G(IBPOL(IBY,0)),U,18)=IBX S IBR=$P(IBPOL(IBY,0),U,1)_U_IBY Q
- Q IBR
- ;
- PLANEPS(IBPL) ; returns the ePharmacy payer sheets for a group plan
- ; IBPL = IEN to GROUP INSURANCE PLAN file #355.3
- ; Returns: Payer Sheets. (B1,B2,B3,E1) (comma separated string)
- ; Successful: 1^B1,B2,B3,E1
- ; Unsuccessful: 0
- N PIEN,IBR,PLN10,B1,B2,B3,E1
- S IBR=0
- I '$G(IBPL) Q IBR
- ; Get ePharmacy plan IEN
- S PIEN=+$P($G(^IBA(355.3,IBPL,6)),U,1)
- I 'PIEN Q IBR
- S PLN10=$G(^IBCNR(366.03,PIEN,10))
- ; check for test/production sheets
- ; get the test payer sheet first. If nil, then get the regular payer sheet
- S (B1,B2,B3,E1)=""
- S B1=$P(PLN10,U,11),B2=$P(PLN10,U,12),B3=$P(PLN10,U,13),E1=$P(PLN10,U,14)
- I 'B1 S B1=$P(PLN10,U,7) ; billing
- I 'B2 S B2=$P(PLN10,U,8) ; reversal
- I 'B3 S B3=$P(PLN10,U,9) ; rebill (not currently validated)
- I 'E1 S E1=$P(PLN10,U,15) ; eligibility
- S IBR="1^"_B1_","_B2_","_B3_","_E1
- Q IBR
- ;
- RT(DFN,IBDT,IBINS,IBPTYP) ; returns rate type to use for bill
- ; Input:
- ; DFN - patient ien
- ; IBDT - date of service
- ; IBINS - insurance array (pass by reference)
- ;
- ; Output:
- ; 3 piece string in the following format
- ; [1] rate type ien
- ; [2] Rate Type (Tort or Awp or Cost)
- ; [3] Eligibility Basis (V=VETERAN, T=TRICARE, C=CHAMPVA)
- ;
- ; IBPTYP - patient type - optional output parameter (pass by reference)
- ; - this is only used by the PRO option (see IBNCPDP1)
- ; - (V=VETERAN, T=TRICARE, C=CHAMPVA)
- ; - NOT the same thing as [3] of this function
- ;
- N IBPT,IBRT,IBE,IBI,IBRET,IBRS,IBX,VAEL,VAERR
- S IBPTYP=""
- D ELIG^VADPT
- ;
- ; if primary elig is vet type, use reimbursable
- S IBPT=$P($G(^DIC(8,+VAEL(1),0)),U,5) ; = N:NON-VETERAN;Y:VETERAN
- I IBPT="Y" D Q IBRT_U_$S($G(IBRET)="VA COST":"C^V",1:"T^V") ; IB*2*437 modifications
- . S IBRT=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",0))
- . S IBRT=$S(IBRT:IBRT,1:8)
- . I $G(IBDT) S IBRET=$P($$EVNTITM^IBCRU3(IBRT,3,"PRESCRIPTION FILL",IBDT,.IBRS),";",1)
- . Q
- ;
- ; ia #'s 427 & 2516 for references to ^DIC(8 and ^DIC(8.1
- ;
- ; - determine eligibilities - build the IBE array
- S IBE=$P($G(^DIC(8.1,+$P($G(^DIC(8,+VAEL(1),0)),U,9),0)),U,1),IBE($S(IBE="TRICARE"!(IBE="SHARING AGREEMENT"):"T",IBE="CHAMPVA":"C",1:"O"))="" ; primary pt eligibility
- ; IB*2*452 - for CHAMPVA, CHAMPVA must be primary eligibility only - not among secondary eligibilities
- S IBX=0 F S IBX=$O(VAEL(1,IBX)) Q:'IBX S IBE=$P($G(^DIC(8.1,+$P($G(^DIC(8,+VAEL(1,IBX),0)),U,9),0)),U,1) S IBE($S(IBE="TRICARE"!(IBE="SHARING AGREEMENT"):"T",1:"O"))="" ; secondary pt eligibilities
- ;
- ; set patient type parameter
- I $G(VAEL(4)) S IBPTYP="V" ; veteran without any pt. eligibilities defined
- I $D(IBE("T")) S IBPTYP="T" ; TRICARE
- I $D(IBE("C")) S IBPTYP="C" ; CHAMPVA
- ;
- ; - determine insurance policies - build the IBI array
- S IBX=0 F S IBX=$O(IBINS(IBX)) Q:'IBX S IBI=$P($G(^IBE(355.1,+$P($G(IBINS(IBX,355.3)),U,9),0)),U,1) S IBI($S(IBI="TRICARE":"T",IBI="CHAMPVA":"C",1:"O"))=""
- ;
- ; If patient is only TRICARE eligible, and has TRICARE insurance,
- ; set eligibility and rate type to TRICARE.
- ; If patient has another insurance, in addition to TRICARE that is not CHAMPVA,
- ; set eligibility to TRICARE and rate type to TRICARE REIMB. INS.
- I $D(IBE("T")),'$D(IBE("O")),'$D(IBE("C")),$D(IBI("T")) D Q:IBRT IBRT_"^C^T"
- . I $D(IBI("O")) S IBRT=$O(^DGCR(399.3,"B","TRICARE REIMB. INS.",0))
- . E S IBRT=$O(^DGCR(399.3,"B","TRICARE",0))
- ;
- ; IB*2*452 - check for CHAMPVA
- ; If patient is CHAMPVA eligible, and has CHAMPVA insurance,
- ; set eligibility and rate type to CHAMPVA.
- ; If patient has another insurance, in addition to CHAMPVA that is not TRICARAE,
- ; set eligibility to CHAMPVA and rate type to CHAMPVA REIMB. INS.
- I $D(IBE("C")),$D(IBI("C")) D Q:IBRT IBRT_"^C^C"
- . I $D(IBI("O")) S IBRT=$O(^DGCR(399.3,"B","CHAMPVA REIMB. INS.",0))
- . E S IBRT=$O(^DGCR(399.3,"B","CHAMPVA",0))
- ;
- Q "0^unable to determine rate type"
- ;
- ;
- BS() ; returns the mccr utility to use
- N IBX
- S IBX=0 F S IBX=$O(^DGCR(399.1,"B","PRESCRIPTION",IBX)) Q:IBX<1 I $P($G(^DGCR(399.1,+$G(IBX),0)),U,5) Q
- Q IBX
- ;
- RXBIL(IBINP,IBERR) ; Matching NCPDP payments
- ; Find IB Bill by the 7 or 12 digit ECME number and the Rx fill date
- ; This function is called by AR routine $$BILL^RCDPESR1 (DBIA 4435).
- ;Input:
- ; IBINP("ECME") - the 7 or 12 digit ECME number (Reference Number)
- ; IBINP("FILLDT") - the Rx fill date, YYYYMMDD or FileMan format
- ; IBINP("PNM") (optional) - the patient's last name
- ;Returns:
- ; IBERR (by ref) - the error code, or null string if found
- ; RXBIL - IB Bill IEN, or 0 if not matched
- N IBECME,BILLDA,IBDAT,IBPNAME,BPSDAT
- S IBERR=""
- S IBECME=$G(IBINP("ECME"))
- I '$$VALECME^BPSUTIL2(IBECME) S IBERR="Invalid ECME number" Q 0
- S IBDAT=$G(IBINP("FILLDT")) ; Rx fill date
- I IBDAT?8N S IBDAT=($E(IBDAT,1,4)-1700)_$E(IBDAT,5,8) ; conv date to FM format
- I IBDAT'?7N Q $$RXBILND(IBECME) ; date is not correct or null
- S IBPNAME=$G(IBINP("PNM")) ; patient's name (optional)
- S BILLDA=$$ECMEMTCH(IBECME,IBDAT,IBPNAME,.IBERR)
- I 'BILLDA S BPSDAT=$$CLMECME^BPSUTIL2(+IBECME,IBDAT) I $G(BPSDAT)>0,BPSDAT'=IBDAT S BILLDA=$$ECMEMTCH(IBECME,BPSDAT,IBPNAME,.IBERR)
- Q +BILLDA
- ;
- RXBILND(IBECME) ;Match the bill with no date
- N IBKEY,IBBC,BILLDA,IBY,IBCUT,ECMELEN,ECMENUM
- S IBCUT=$$FMADD^XLFDT(DT,-180) ; only 180 days in the past for cut-off date
- ;
- ; Search ECME# 7/12 digits forward looking for PRNT/TX claims (IB*2*435)
- S BILLDA=0
- F ECMELEN=12,7 D Q:BILLDA
- . I $L(+IBECME)>ECMELEN Q ; Quit if too large
- . S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME#
- . S IBKEY=ECMENUM_";"
- . S IBBC=IBKEY_IBCUT
- . F S IBBC=$O(^DGCR(399,"AG",IBBC)) Q:IBBC'[IBKEY D Q:BILLDA
- .. S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY)) Q:'IBY D Q:BILLDA
- ... I $P($G(^DGCR(399,+IBY,0)),U,13)'=4 Q ; not PRNT/TX
- ... S BILLDA=+IBY
- ... Q
- .. Q
- . Q
- ;
- I BILLDA Q BILLDA
- ;
- ; Search ECME# 7/12 digits backwards looking for ANY claims within cut-off date (IB*2*435)
- S BILLDA=0
- F ECMELEN=12,7 D Q:BILLDA
- . I $L(+IBECME)>ECMELEN Q ; Quit if too large
- . S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME#
- . S IBKEY=ECMENUM_";"
- . S IBBC=IBKEY_"8000000"
- . F S IBBC=$O(^DGCR(399,"AG",IBBC),-1) Q:IBBC'[IBKEY Q:$P(IBBC,";",2)<IBCUT D Q:BILLDA
- .. S IBY="" F S IBY=$O(^DGCR(399,"AG",IBBC,IBY),-1) Q:IBY="" D Q:BILLDA
- ... S BILLDA=+IBY
- ... Q
- .. Q
- . Q
- ;
- Q BILLDA
- ;
- ;Check matching of two strings - case insensitive, no spaces etc.
- TXMATCH(IBTXT1,IBTXT2,IBMAX) ;
- N IBTR1,IBTR2,IBT1,IBT2
- ;Checking only first IBMAX characters (long names may be truncated)
- S IBTR1="ABCDEFGHIJKLMNOPQRSTUVWXYZ:;"",'._()<>/\|@#$%&*-=!`~ "
- S IBTR2="abcdefghijklmnopqrstuvwxyz"
- S IBT1=$E($TR(IBTXT1,IBTR1,IBTR2),1,IBMAX)
- S IBT2=$E($TR(IBTXT2,IBTR1,IBTR2),1,IBMAX)
- Q IBT1=IBT2
- ;
- ECMEBIL(DFN,IBADT) ; Is the pat ECME Billable (pharmacy coverage only)
- ; DFN - ptr to the patient
- ; IBADT - the date
- ; IBINS - insurance array returned by ALL^IBCNS1
- N IBANY,IBERMSG,IBX,IBINS,IBT,IBZ,IBRES,IBCAT,IBCOV,IBPCOV
- S IBRES=0 ; Not ECME Billable by default
- S (IBCOV,IBPCOV)=0
- ; -- look up ins with Rx
- D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
- S IBERMSG="" ; Error message
- S IBCAT=$O(^IBE(355.31,"B","PHARMACY",0))
- S IBX=0 F S IBX=$O(IBINS("S",IBX)) Q:'IBX D Q:IBRES
- . S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D Q:IBRES
- . . N IBZ,IBPIEN,IBY,IBPL
- . . S IBZ=$G(IBINS(IBT,0))
- . . S IBPL=+$P(IBZ,U,18) Q:'IBPL
- . . S IBCOV=1 ; covered
- . . I '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q
- . . S IBPCOV=1
- . . S IBPIEN=+$G(^IBA(355.3,IBPL,6))
- . . I 'IBPIEN S IBERMSG="Plan not linked to the Payer" Q ; Not linked
- . . D STCHK^IBCNRU1(IBPIEN,.IBY)
- . . I $E($G(IBY(1)))'="A" S:IBERMSG="" IBERMSG=$$ERMSG^IBNCPNB($P($G(IBY(6)),",")) Q
- . . S IBRES=1
- I 'IBCOV Q "0^Not Insured"
- I 'IBPCOV Q "0^No Pharmacy Coverage"
- I 'IBRES,IBERMSG'="" Q "0^"_IBERMSG
- I 'IBRES Q "0^No Insurance ECME billable"
- ;
- Q IBRES
- ;
- SUBMIT(IBRX,IBFIL,IBDELAY) ; Submit the Rx claim through ECME
- ; IBDELAY - Delay Reason Code, passed as the 18th parameter - IB*2.0*435
- ; IBRX - RX ien in file #52
- ; IBFIL - Fill No (0 for orig fill)
- N IBDT,IBNDC,IBX
- I '$G(IBRX)!('$D(IBFIL)) Q "0^Invalid parameters."
- S IBDT=$$RXRLDT^PSOBPSUT(IBRX,IBFIL)\1 ; release date (DBIA# 4701)
- I 'IBDT!(IBDT>DT) S IBDT=DT ; if not released, use the current date (ePharmacy DOS)
- S IBX=$$EN^BPSNCPDP(+IBRX,+IBFIL,IBDT,"BB",,,,,,,,,,,,,,+$G(IBDELAY))
- I +IBX=0 D ECMEACT^PSOBPSU1(+IBRX,+IBFIL,"Claim submitted to 3rd party payer: IB BACK BILLING")
- Q IBX
- ;
- REASON(IBX,EXACT) ; Close Claim Reasons
- Q $P($G(^IBE(356.8,+IBX,0)),U) ; non-billable reason
- ;
- NABP(IBIFN) ;NABP Number
- N IBY,IBTRKN,IBRX,IBFIL,IBZ,IBNABP
- S IBY=+$O(^IBT(356.399,"C",IBIFN,0)) I 'IBY Q ""
- S IBTRKN=$P($G(^IBT(356.399,IBY,0)),U) I 'IBTRKN Q ""
- S IBZ=$G(^IBT(356,IBTRKN,0)) I IBZ="" Q ""
- S IBRX=$P(IBZ,U,8)
- S IBFIL=$P(IBZ,U,10)
- S IBNABP=$$NABP^BPSBUTL(IBRX,IBFIL)
- Q $S(IBNABP=0:"",1:IBNABP)
- ;
- ; Get the K-bill# from CT
- BILL(IBRX,IBFIL) ;
- N IBTRKN,IBIFN
- S IBTRKN=+$O(^IBT(356,"ARXFL",+$G(IBRX),+$G(IBFIL),""))
- S IBIFN=+$P($G(^IBT(356,IBTRKN,0)),U,11)
- Q $P($G(^DGCR(399,IBIFN,0)),U)
- ;
- REJECT(IBECME,IBDATE) ; Is the e-claim rejected?
- N IBTRKRN,IBY,ECMELEN
- I IBECME'?1.12N Q 0
- S IBTRKRN=0
- F ECMELEN=12,7 D Q:IBTRKRN
- . I $L(+IBECME)>ECMELEN Q
- . S IBECME=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME# with leading zeros
- . S IBTRKRN=+$O(^IBT(356,"AE",IBECME,0))
- . Q
- ;
- I 'IBTRKRN Q 0
- S IBY=$G(^IBT(356,IBTRKRN,1))
- I $P(IBY,U,11)>0 Q 1 ; Rejected or closed
- Q 0
- ;
- RXINS(DFN,IBADT,IBINS) ; Return an array of pharmacy insurance policies by COB order
- ; Input:
- ; DFN - Patient ien (required)
- ; IBADT - Date of Service (fileman format, optional defaults to today)
- ; Output:
- ; IBINS - Name of destination array (pass by reference)
- ;
- N CT,COB,IEN,IBPL
- K IBINS
- S DFN=+$G(DFN)
- S IBADT=+$G(IBADT,DT)
- D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1) ; gather all insurance policies in COB order
- ;
- S CT=0 ; count up Rx policies found
- S COB="" F S COB=$O(IBINS("S",COB)) Q:COB="" S IEN=0 F S IEN=$O(IBINS("S",COB,IEN)) Q:'IEN D
- . S IBPL=+$P($G(IBINS(IEN,0)),U,18) ; plan ien
- . I 'IBPL K IBINS(IEN),IBINS("S",COB,IEN) Q ; no plan
- . I '$$PLCOV^IBCNSU3(IBPL,IBADT,3) K IBINS(IEN),IBINS("S",COB,IEN) Q ; not a pharmacy plan
- . S CT=CT+1
- . Q
- ;
- S IBINS=CT ; store total number found at the top level
- ;
- RXINSX ;
- Q
- ;
- ECMEMTCH(IBECME,IBDAT,IBPNAME,IBERR) ; Attempt ECME# look up with either 7 digit or 12 digit number (IB*2*435)
- N IBFOUND,IBMATCH,ECMELEN,IBKEY,BILLDA
- S IBFOUND=0,IBMATCH=0
- F ECMELEN=12,7 D Q:IBFOUND
- . I $L(+IBECME)>ECMELEN Q ; Quit if too large
- . S ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0) ; build ECME#
- . S IBKEY=ECMENUM_";"_IBDAT ; The ECME Number (BC ID) for the "AG" xref
- . S BILLDA=""
- . ; Search Backward
- . F S BILLDA=$O(^DGCR(399,"AG",IBKEY,BILLDA),-1) Q:BILLDA="" D Q:IBFOUND
- .. I 'BILLDA Q ; IEN must be numeric
- .. I '$D(^DGCR(399,BILLDA,0)) Q ; Corrupted index
- .. S IBMATCH=1
- .. I IBPNAME'="" I '$$TXMATCH($P(IBPNAME,","),$P($G(^DPT(+$P(^DGCR(399,BILLDA,0),U,2),0)),","),8) Q ; Patient name doesn't match
- .. S IBFOUND=1
- I 'BILLDA S IBERR=$S(IBMATCH:"Patient's name does not match",1:"Matching bill not found") ; not matched
- Q +BILLDA
- ;
- ACDUTY(DFN) ;
- ; Check active duty status for the patient
- ; Input:
- ; DFN: Patient (#2) IEN
- ; Output:
- ; 0: Does not have an Active Duty Status
- ; 1: Has an active Duty Status
- ;
- I '$G(DFN) Q 0
- ; Check if Patient TYPE is ACTIVE DUTY
- N VAEL
- D ELIG^VADPT
- I $P($G(VAEL(6)),"^",2)'="ACTIVE DUTY" Q 0
- ; If the PERIOD OF SERVICE has '-ACTIVE DUTY', quit with true
- I $F($P($G(VAEL(2)),"^",2),"-ACTIVE DUTY") Q 1
- Q 0
- ;
- ;IBNCPDPU
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDPU 14671 printed Feb 18, 2025@23:51:18 Page 2
- IBNCPDPU ;OAK/ELZ - UTILITIES FOR NCPDP ;Jun 06, 2014@19:13:12
- +1 ;;2.0;INTEGRATED BILLING;**223,276,347,383,405,384,437,435,452,511,534,550,624,711**;21-MAR-94;Build 18
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference to ECMEACT^PSOBPSU1 in ICR #4702
- +5 ; Reference to $$EN^BPSNCPDP in ICR #4415
- +6 ; Reference to $$NABP^BPSBUTL in ICR #4719
- +7 ; Reference to $$CLMECME^BPSUTIL2 in ICR #6028
- +8 ; Reference to $$VALECME^BPSUTIL2 in ICR #6139
- +9 ; Reference to $$RXRLDT^PSOBPSUT in ICR #4701
- +10 ;
- +11 ;
- CT(DFN,IBRXN,IBFIL,IBADT,IBRMARK) ; files in claims tracking
- +1 ; Input:
- +2 ; DFN - Patient IEN
- +3 ; IBRXN - Rx IEN
- +4 ; IBFIL - Fill#
- +5 ; IBADT - Date of Service
- +6 ; IBRMARK - Non-billable Reason (.01 from 356.8)
- +7 ;
- +8 NEW DIE,DR,DA,IBRXTYP,IBEABD
- +9 ; Check that the Date of Service is current
- +10 IF IBTRKRN
- IF $GET(IBADT)
- IF ($GET(IBADT)'=$PIECE(^IBT(356,IBTRKRN,0),U,6))
- Begin DoDot:1
- +11 SET DIE="^IBT(356,"
- SET DA=IBTRKRN
- SET DR=".06////"_IBADT
- DO ^DIE
- End DoDot:1
- +12 IF IBTRKRN
- if $DATA(IBRMARK)
- Begin DoDot:1
- +13 SET DIE="^IBT(356,"
- SET DA=IBTRKRN
- SET DR=".19///"_IBRMARK
- +14 DO ^DIE
- End DoDot:1
- QUIT
- +15 ; event type pointer for rx billing
- +16 SET IBRXTYP=$ORDER(^IBE(356.6,"AC",4,0))
- +17 ; earliest auto-billing date
- +18 SET IBEABD=$$EABD^IBTUTL(IBRXTYP,$$FMADD^XLFDT(IBADT,60))
- +19 ; space out earliest auto bill date
- +20 ;
- +21 ; ROI check. The variable IBSCROI will be set to:
- +22 ; '1' if NOT REQUIRED '2' if OBTAINED
- +23 ; '3' if REQUIRED '4' if REFUSED
- +24 NEW IBSCROI,IBDRUG,IBDEA,IBRXDATA
- +25 SET IBRXDATA=$$RXZERO^IBRXUTL(DFN,IBRXN)
- +26 SET IBDRUG=$PIECE(IBRXDATA,U,6)
- +27 ;
- +28 ; $$SENS^IBNCPDR returns 1 if the drug is sensitive diagnosis drug
- +29 IF $$SENS^IBNCPDR(IBDRUG)
- Begin DoDot:1
- +30 NEW IBINS,IBFLG,IBINSP
- +31 DO ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
- +32 SET IBINSP=$ORDER(IBINS("S",1,99),-1)
- if IBINSP=""
- QUIT
- +33 ; If the Date of Service (DOS) is on or after to the Mission Act
- +34 ; implementation date (MAID), skip ROI check.
- +35 IF $$MACHK^IBNCPDR4($GET(IBADT))
- SET (IBFLG,IBSCROI)=1
- SET IBRMARK=""
- QUIT
- +36 SET IBFLG=$$ROI^IBNCPDR4(DFN,$GET(IBDRUG),+$GET(IBINS(IBINSP,"0")),$GET(IBADT))
- +37 ; IB*2*550
- IF 'IBFLG
- IF $GET(IBRMARK)=""
- SET IBRMARK="ROI NOT OBTAINED"
- +38 IF 'IBFLG
- SET IBSCROI=3
- +39 IF IBFLG
- SET IBSCROI=2
- End DoDot:1
- +40 ;
- +41 DO REFILL^IBTUTL1(DFN,IBRXTYP,IBADT,IBRXN,IBFIL,$GET(IBRMARK),IBEABD,$GET(IBSCROI))
- +42 QUIT
- +43 ;
- +44 ;NDC relocated to IBNCPNB
- +45 ;
- FILL(X,LEN) ; Zero-fill, right justified.
- +1 NEW Y
- +2 if '$GET(LEN)
- SET LEN=1
- +3 SET Y=$EXTRACT($GET(X),1,LEN)
- +4 FOR
- if $LENGTH(Y)>(LEN-1)
- QUIT
- SET Y="0"_Y
- +5 QUIT Y
- +6 ;
- PLANN(DFN,IBX,IBADT) ; returns the ien in the insurance multiple for the given plan/patient provided
- +1 ; Output: insurance co ien^2.312 subfile ien
- +2 NEW IBPOL,IBY,IBR
- +3 SET IBR=""
- +4 DO ALL^IBCNS1(DFN,"IBPOL",1,IBADT)
- +5 SET IBY=0
- FOR
- SET IBY=$ORDER(IBPOL(IBY))
- if 'IBY!IBR
- QUIT
- IF $PIECE($GET(IBPOL(IBY,0)),U,18)=IBX
- SET IBR=$PIECE(IBPOL(IBY,0),U,1)_U_IBY
- QUIT
- +6 QUIT IBR
- +7 ;
- PLANEPS(IBPL) ; returns the ePharmacy payer sheets for a group plan
- +1 ; IBPL = IEN to GROUP INSURANCE PLAN file #355.3
- +2 ; Returns: Payer Sheets. (B1,B2,B3,E1) (comma separated string)
- +3 ; Successful: 1^B1,B2,B3,E1
- +4 ; Unsuccessful: 0
- +5 NEW PIEN,IBR,PLN10,B1,B2,B3,E1
- +6 SET IBR=0
- +7 IF '$GET(IBPL)
- QUIT IBR
- +8 ; Get ePharmacy plan IEN
- +9 SET PIEN=+$PIECE($GET(^IBA(355.3,IBPL,6)),U,1)
- +10 IF 'PIEN
- QUIT IBR
- +11 SET PLN10=$GET(^IBCNR(366.03,PIEN,10))
- +12 ; check for test/production sheets
- +13 ; get the test payer sheet first. If nil, then get the regular payer sheet
- +14 SET (B1,B2,B3,E1)=""
- +15 SET B1=$PIECE(PLN10,U,11)
- SET B2=$PIECE(PLN10,U,12)
- SET B3=$PIECE(PLN10,U,13)
- SET E1=$PIECE(PLN10,U,14)
- +16 ; billing
- IF 'B1
- SET B1=$PIECE(PLN10,U,7)
- +17 ; reversal
- IF 'B2
- SET B2=$PIECE(PLN10,U,8)
- +18 ; rebill (not currently validated)
- IF 'B3
- SET B3=$PIECE(PLN10,U,9)
- +19 ; eligibility
- IF 'E1
- SET E1=$PIECE(PLN10,U,15)
- +20 SET IBR="1^"_B1_","_B2_","_B3_","_E1
- +21 QUIT IBR
- +22 ;
- RT(DFN,IBDT,IBINS,IBPTYP) ; returns rate type to use for bill
- +1 ; Input:
- +2 ; DFN - patient ien
- +3 ; IBDT - date of service
- +4 ; IBINS - insurance array (pass by reference)
- +5 ;
- +6 ; Output:
- +7 ; 3 piece string in the following format
- +8 ; [1] rate type ien
- +9 ; [2] Rate Type (Tort or Awp or Cost)
- +10 ; [3] Eligibility Basis (V=VETERAN, T=TRICARE, C=CHAMPVA)
- +11 ;
- +12 ; IBPTYP - patient type - optional output parameter (pass by reference)
- +13 ; - this is only used by the PRO option (see IBNCPDP1)
- +14 ; - (V=VETERAN, T=TRICARE, C=CHAMPVA)
- +15 ; - NOT the same thing as [3] of this function
- +16 ;
- +17 NEW IBPT,IBRT,IBE,IBI,IBRET,IBRS,IBX,VAEL,VAERR
- +18 SET IBPTYP=""
- +19 DO ELIG^VADPT
- +20 ;
- +21 ; if primary elig is vet type, use reimbursable
- +22 ; = N:NON-VETERAN;Y:VETERAN
- SET IBPT=$PIECE($GET(^DIC(8,+VAEL(1),0)),U,5)
- +23 ; IB*2*437 modifications
- IF IBPT="Y"
- Begin DoDot:1
- +24 SET IBRT=$ORDER(^DGCR(399.3,"B","REIMBURSABLE INS.",0))
- +25 SET IBRT=$SELECT(IBRT:IBRT,1:8)
- +26 IF $GET(IBDT)
- SET IBRET=$PIECE($$EVNTITM^IBCRU3(IBRT,3,"PRESCRIPTION FILL",IBDT,.IBRS),";",1)
- +27 QUIT
- End DoDot:1
- QUIT IBRT_U_$SELECT($GET(IBRET)="VA COST":"C^V",1:"T^V")
- +28 ;
- +29 ; ia #'s 427 & 2516 for references to ^DIC(8 and ^DIC(8.1
- +30 ;
- +31 ; - determine eligibilities - build the IBE array
- +32 ; primary pt eligibility
- SET IBE=$PIECE($GET(^DIC(8.1,+$PIECE($GET(^DIC(8,+VAEL(1),0)),U,9),0)),U,1)
- SET IBE($SELECT(IBE="TRICARE"!(IBE="SHARING AGREEMENT"):"T",IBE="CHAMPVA":"C",1:"O"))=""
- +33 ; IB*2*452 - for CHAMPVA, CHAMPVA must be primary eligibility only - not among secondary eligibilities
- +34 ; secondary pt eligibilities
- SET IBX=0
- FOR
- SET IBX=$ORDER(VAEL(1,IBX))
- if 'IBX
- QUIT
- SET IBE=$PIECE($GET(^DIC(8.1,+$PIECE($GET(^DIC(8,+VAEL(1,IBX),0)),U,9),0)),U,1)
- SET IBE($SELECT(IBE="TRICARE"!(IBE="SHARING AGREEMENT"):"T",1:"O"))=""
- +35 ;
- +36 ; set patient type parameter
- +37 ; veteran without any pt. eligibilities defined
- IF $GET(VAEL(4))
- SET IBPTYP="V"
- +38 ; TRICARE
- IF $DATA(IBE("T"))
- SET IBPTYP="T"
- +39 ; CHAMPVA
- IF $DATA(IBE("C"))
- SET IBPTYP="C"
- +40 ;
- +41 ; - determine insurance policies - build the IBI array
- +42 SET IBX=0
- FOR
- SET IBX=$ORDER(IBINS(IBX))
- if 'IBX
- QUIT
- SET IBI=$PIECE($GET(^IBE(355.1,+$PIECE($GET(IBINS(IBX,355.3)),U,9),0)),U,1)
- SET IBI($SELECT(IBI="TRICARE":"T",IBI="CHAMPVA":"C",1:"O"))=""
- +43 ;
- +44 ; If patient is only TRICARE eligible, and has TRICARE insurance,
- +45 ; set eligibility and rate type to TRICARE.
- +46 ; If patient has another insurance, in addition to TRICARE that is not CHAMPVA,
- +47 ; set eligibility to TRICARE and rate type to TRICARE REIMB. INS.
- +48 IF $DATA(IBE("T"))
- IF '$DATA(IBE("O"))
- IF '$DATA(IBE("C"))
- IF $DATA(IBI("T"))
- Begin DoDot:1
- +49 IF $DATA(IBI("O"))
- SET IBRT=$ORDER(^DGCR(399.3,"B","TRICARE REIMB. INS.",0))
- +50 IF '$TEST
- SET IBRT=$ORDER(^DGCR(399.3,"B","TRICARE",0))
- End DoDot:1
- if IBRT
- QUIT IBRT_"^C^T"
- +51 ;
- +52 ; IB*2*452 - check for CHAMPVA
- +53 ; If patient is CHAMPVA eligible, and has CHAMPVA insurance,
- +54 ; set eligibility and rate type to CHAMPVA.
- +55 ; If patient has another insurance, in addition to CHAMPVA that is not TRICARAE,
- +56 ; set eligibility to CHAMPVA and rate type to CHAMPVA REIMB. INS.
- +57 IF $DATA(IBE("C"))
- IF $DATA(IBI("C"))
- Begin DoDot:1
- +58 IF $DATA(IBI("O"))
- SET IBRT=$ORDER(^DGCR(399.3,"B","CHAMPVA REIMB. INS.",0))
- +59 IF '$TEST
- SET IBRT=$ORDER(^DGCR(399.3,"B","CHAMPVA",0))
- End DoDot:1
- if IBRT
- QUIT IBRT_"^C^C"
- +60 ;
- +61 QUIT "0^unable to determine rate type"
- +62 ;
- +63 ;
- BS() ; returns the mccr utility to use
- +1 NEW IBX
- +2 SET IBX=0
- FOR
- SET IBX=$ORDER(^DGCR(399.1,"B","PRESCRIPTION",IBX))
- if IBX<1
- QUIT
- IF $PIECE($GET(^DGCR(399.1,+$GET(IBX),0)),U,5)
- QUIT
- +3 QUIT IBX
- +4 ;
- RXBIL(IBINP,IBERR) ; Matching NCPDP payments
- +1 ; Find IB Bill by the 7 or 12 digit ECME number and the Rx fill date
- +2 ; This function is called by AR routine $$BILL^RCDPESR1 (DBIA 4435).
- +3 ;Input:
- +4 ; IBINP("ECME") - the 7 or 12 digit ECME number (Reference Number)
- +5 ; IBINP("FILLDT") - the Rx fill date, YYYYMMDD or FileMan format
- +6 ; IBINP("PNM") (optional) - the patient's last name
- +7 ;Returns:
- +8 ; IBERR (by ref) - the error code, or null string if found
- +9 ; RXBIL - IB Bill IEN, or 0 if not matched
- +10 NEW IBECME,BILLDA,IBDAT,IBPNAME,BPSDAT
- +11 SET IBERR=""
- +12 SET IBECME=$GET(IBINP("ECME"))
- +13 IF '$$VALECME^BPSUTIL2(IBECME)
- SET IBERR="Invalid ECME number"
- QUIT 0
- +14 ; Rx fill date
- SET IBDAT=$GET(IBINP("FILLDT"))
- +15 ; conv date to FM format
- IF IBDAT?8N
- SET IBDAT=($EXTRACT(IBDAT,1,4)-1700)_$EXTRACT(IBDAT,5,8)
- +16 ; date is not correct or null
- IF IBDAT'?7N
- QUIT $$RXBILND(IBECME)
- +17 ; patient's name (optional)
- SET IBPNAME=$GET(IBINP("PNM"))
- +18 SET BILLDA=$$ECMEMTCH(IBECME,IBDAT,IBPNAME,.IBERR)
- +19 IF 'BILLDA
- SET BPSDAT=$$CLMECME^BPSUTIL2(+IBECME,IBDAT)
- IF $GET(BPSDAT)>0
- IF BPSDAT'=IBDAT
- SET BILLDA=$$ECMEMTCH(IBECME,BPSDAT,IBPNAME,.IBERR)
- +20 QUIT +BILLDA
- +21 ;
- RXBILND(IBECME) ;Match the bill with no date
- +1 NEW IBKEY,IBBC,BILLDA,IBY,IBCUT,ECMELEN,ECMENUM
- +2 ; only 180 days in the past for cut-off date
- SET IBCUT=$$FMADD^XLFDT(DT,-180)
- +3 ;
- +4 ; Search ECME# 7/12 digits forward looking for PRNT/TX claims (IB*2*435)
- +5 SET BILLDA=0
- +6 FOR ECMELEN=12,7
- Begin DoDot:1
- +7 ; Quit if too large
- IF $LENGTH(+IBECME)>ECMELEN
- QUIT
- +8 ; build ECME#
- SET ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0)
- +9 SET IBKEY=ECMENUM_";"
- +10 SET IBBC=IBKEY_IBCUT
- +11 FOR
- SET IBBC=$ORDER(^DGCR(399,"AG",IBBC))
- if IBBC'[IBKEY
- QUIT
- Begin DoDot:2
- +12 SET IBY=""
- FOR
- SET IBY=$ORDER(^DGCR(399,"AG",IBBC,IBY))
- if 'IBY
- QUIT
- Begin DoDot:3
- +13 ; not PRNT/TX
- IF $PIECE($GET(^DGCR(399,+IBY,0)),U,13)'=4
- QUIT
- +14 SET BILLDA=+IBY
- +15 QUIT
- End DoDot:3
- if BILLDA
- QUIT
- +16 QUIT
- End DoDot:2
- if BILLDA
- QUIT
- +17 QUIT
- End DoDot:1
- if BILLDA
- QUIT
- +18 ;
- +19 IF BILLDA
- QUIT BILLDA
- +20 ;
- +21 ; Search ECME# 7/12 digits backwards looking for ANY claims within cut-off date (IB*2*435)
- +22 SET BILLDA=0
- +23 FOR ECMELEN=12,7
- Begin DoDot:1
- +24 ; Quit if too large
- IF $LENGTH(+IBECME)>ECMELEN
- QUIT
- +25 ; build ECME#
- SET ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0)
- +26 SET IBKEY=ECMENUM_";"
- +27 SET IBBC=IBKEY_"8000000"
- +28 FOR
- SET IBBC=$ORDER(^DGCR(399,"AG",IBBC),-1)
- if IBBC'[IBKEY
- QUIT
- if $PIECE(IBBC,";",2)<IBCUT
- QUIT
- Begin DoDot:2
- +29 SET IBY=""
- FOR
- SET IBY=$ORDER(^DGCR(399,"AG",IBBC,IBY),-1)
- if IBY=""
- QUIT
- Begin DoDot:3
- +30 SET BILLDA=+IBY
- +31 QUIT
- End DoDot:3
- if BILLDA
- QUIT
- +32 QUIT
- End DoDot:2
- if BILLDA
- QUIT
- +33 QUIT
- End DoDot:1
- if BILLDA
- QUIT
- +34 ;
- +35 QUIT BILLDA
- +36 ;
- +37 ;Check matching of two strings - case insensitive, no spaces etc.
- TXMATCH(IBTXT1,IBTXT2,IBMAX) ;
- +1 NEW IBTR1,IBTR2,IBT1,IBT2
- +2 ;Checking only first IBMAX characters (long names may be truncated)
- +3 SET IBTR1="ABCDEFGHIJKLMNOPQRSTUVWXYZ:;"",'._()<>/\|@#$%&*-=!`~ "
- +4 SET IBTR2="abcdefghijklmnopqrstuvwxyz"
- +5 SET IBT1=$EXTRACT($TRANSLATE(IBTXT1,IBTR1,IBTR2),1,IBMAX)
- +6 SET IBT2=$EXTRACT($TRANSLATE(IBTXT2,IBTR1,IBTR2),1,IBMAX)
- +7 QUIT IBT1=IBT2
- +8 ;
- ECMEBIL(DFN,IBADT) ; Is the pat ECME Billable (pharmacy coverage only)
- +1 ; DFN - ptr to the patient
- +2 ; IBADT - the date
- +3 ; IBINS - insurance array returned by ALL^IBCNS1
- +4 NEW IBANY,IBERMSG,IBX,IBINS,IBT,IBZ,IBRES,IBCAT,IBCOV,IBPCOV
- +5 ; Not ECME Billable by default
- SET IBRES=0
- +6 SET (IBCOV,IBPCOV)=0
- +7 ; -- look up ins with Rx
- +8 DO ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
- +9 ; Error message
- SET IBERMSG=""
- +10 SET IBCAT=$ORDER(^IBE(355.31,"B","PHARMACY",0))
- +11 SET IBX=0
- FOR
- SET IBX=$ORDER(IBINS("S",IBX))
- if 'IBX
- QUIT
- Begin DoDot:1
- +12 SET IBT=0
- FOR
- SET IBT=$ORDER(IBINS("S",IBX,IBT))
- if 'IBT
- QUIT
- Begin DoDot:2
- +13 NEW IBZ,IBPIEN,IBY,IBPL
- +14 SET IBZ=$GET(IBINS(IBT,0))
- +15 SET IBPL=+$PIECE(IBZ,U,18)
- if 'IBPL
- QUIT
- +16 ; covered
- SET IBCOV=1
- +17 IF '$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT)
- QUIT
- +18 SET IBPCOV=1
- +19 SET IBPIEN=+$GET(^IBA(355.3,IBPL,6))
- +20 ; Not linked
- IF 'IBPIEN
- SET IBERMSG="Plan not linked to the Payer"
- QUIT
- +21 DO STCHK^IBCNRU1(IBPIEN,.IBY)
- +22 IF $EXTRACT($GET(IBY(1)))'="A"
- if IBERMSG=""
- SET IBERMSG=$$ERMSG^IBNCPNB($PIECE($GET(IBY(6)),","))
- QUIT
- +23 SET IBRES=1
- End DoDot:2
- if IBRES
- QUIT
- End DoDot:1
- if IBRES
- QUIT
- +24 IF 'IBCOV
- QUIT "0^Not Insured"
- +25 IF 'IBPCOV
- QUIT "0^No Pharmacy Coverage"
- +26 IF 'IBRES
- IF IBERMSG'=""
- QUIT "0^"_IBERMSG
- +27 IF 'IBRES
- QUIT "0^No Insurance ECME billable"
- +28 ;
- +29 QUIT IBRES
- +30 ;
- SUBMIT(IBRX,IBFIL,IBDELAY) ; Submit the Rx claim through ECME
- +1 ; IBDELAY - Delay Reason Code, passed as the 18th parameter - IB*2.0*435
- +2 ; IBRX - RX ien in file #52
- +3 ; IBFIL - Fill No (0 for orig fill)
- +4 NEW IBDT,IBNDC,IBX
- +5 IF '$GET(IBRX)!('$DATA(IBFIL))
- QUIT "0^Invalid parameters."
- +6 ; release date (DBIA# 4701)
- SET IBDT=$$RXRLDT^PSOBPSUT(IBRX,IBFIL)\1
- +7 ; if not released, use the current date (ePharmacy DOS)
- IF 'IBDT!(IBDT>DT)
- SET IBDT=DT
- +8 SET IBX=$$EN^BPSNCPDP(+IBRX,+IBFIL,IBDT,"BB",,,,,,,,,,,,,,+$GET(IBDELAY))
- +9 IF +IBX=0
- DO ECMEACT^PSOBPSU1(+IBRX,+IBFIL,"Claim submitted to 3rd party payer: IB BACK BILLING")
- +10 QUIT IBX
- +11 ;
- REASON(IBX,EXACT) ; Close Claim Reasons
- +1 ; non-billable reason
- QUIT $PIECE($GET(^IBE(356.8,+IBX,0)),U)
- +2 ;
- NABP(IBIFN) ;NABP Number
- +1 NEW IBY,IBTRKN,IBRX,IBFIL,IBZ,IBNABP
- +2 SET IBY=+$ORDER(^IBT(356.399,"C",IBIFN,0))
- IF 'IBY
- QUIT ""
- +3 SET IBTRKN=$PIECE($GET(^IBT(356.399,IBY,0)),U)
- IF 'IBTRKN
- QUIT ""
- +4 SET IBZ=$GET(^IBT(356,IBTRKN,0))
- IF IBZ=""
- QUIT ""
- +5 SET IBRX=$PIECE(IBZ,U,8)
- +6 SET IBFIL=$PIECE(IBZ,U,10)
- +7 SET IBNABP=$$NABP^BPSBUTL(IBRX,IBFIL)
- +8 QUIT $SELECT(IBNABP=0:"",1:IBNABP)
- +9 ;
- +10 ; Get the K-bill# from CT
- BILL(IBRX,IBFIL) ;
- +1 NEW IBTRKN,IBIFN
- +2 SET IBTRKN=+$ORDER(^IBT(356,"ARXFL",+$GET(IBRX),+$GET(IBFIL),""))
- +3 SET IBIFN=+$PIECE($GET(^IBT(356,IBTRKN,0)),U,11)
- +4 QUIT $PIECE($GET(^DGCR(399,IBIFN,0)),U)
- +5 ;
- REJECT(IBECME,IBDATE) ; Is the e-claim rejected?
- +1 NEW IBTRKRN,IBY,ECMELEN
- +2 IF IBECME'?1.12N
- QUIT 0
- +3 SET IBTRKRN=0
- +4 FOR ECMELEN=12,7
- Begin DoDot:1
- +5 IF $LENGTH(+IBECME)>ECMELEN
- QUIT
- +6 ; build ECME# with leading zeros
- SET IBECME=$$RJ^XLFSTR(+IBECME,ECMELEN,0)
- +7 SET IBTRKRN=+$ORDER(^IBT(356,"AE",IBECME,0))
- +8 QUIT
- End DoDot:1
- if IBTRKRN
- QUIT
- +9 ;
- +10 IF 'IBTRKRN
- QUIT 0
- +11 SET IBY=$GET(^IBT(356,IBTRKRN,1))
- +12 ; Rejected or closed
- IF $PIECE(IBY,U,11)>0
- QUIT 1
- +13 QUIT 0
- +14 ;
- RXINS(DFN,IBADT,IBINS) ; Return an array of pharmacy insurance policies by COB order
- +1 ; Input:
- +2 ; DFN - Patient ien (required)
- +3 ; IBADT - Date of Service (fileman format, optional defaults to today)
- +4 ; Output:
- +5 ; IBINS - Name of destination array (pass by reference)
- +6 ;
- +7 NEW CT,COB,IEN,IBPL
- +8 KILL IBINS
- +9 SET DFN=+$GET(DFN)
- +10 SET IBADT=+$GET(IBADT,DT)
- +11 ; gather all insurance policies in COB order
- DO ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
- +12 ;
- +13 ; count up Rx policies found
- SET CT=0
- +14 SET COB=""
- FOR
- SET COB=$ORDER(IBINS("S",COB))
- if COB=""
- QUIT
- SET IEN=0
- FOR
- SET IEN=$ORDER(IBINS("S",COB,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +15 ; plan ien
- SET IBPL=+$PIECE($GET(IBINS(IEN,0)),U,18)
- +16 ; no plan
- IF 'IBPL
- KILL IBINS(IEN),IBINS("S",COB,IEN)
- QUIT
- +17 ; not a pharmacy plan
- IF '$$PLCOV^IBCNSU3(IBPL,IBADT,3)
- KILL IBINS(IEN),IBINS("S",COB,IEN)
- QUIT
- +18 SET CT=CT+1
- +19 QUIT
- End DoDot:1
- +20 ;
- +21 ; store total number found at the top level
- SET IBINS=CT
- +22 ;
- RXINSX ;
- +1 QUIT
- +2 ;
- ECMEMTCH(IBECME,IBDAT,IBPNAME,IBERR) ; Attempt ECME# look up with either 7 digit or 12 digit number (IB*2*435)
- +1 NEW IBFOUND,IBMATCH,ECMELEN,IBKEY,BILLDA
- +2 SET IBFOUND=0
- SET IBMATCH=0
- +3 FOR ECMELEN=12,7
- Begin DoDot:1
- +4 ; Quit if too large
- IF $LENGTH(+IBECME)>ECMELEN
- QUIT
- +5 ; build ECME#
- SET ECMENUM=$$RJ^XLFSTR(+IBECME,ECMELEN,0)
- +6 ; The ECME Number (BC ID) for the "AG" xref
- SET IBKEY=ECMENUM_";"_IBDAT
- +7 SET BILLDA=""
- +8 ; Search Backward
- +9 FOR
- SET BILLDA=$ORDER(^DGCR(399,"AG",IBKEY,BILLDA),-1)
- if BILLDA=""
- QUIT
- Begin DoDot:2
- +10 ; IEN must be numeric
- IF 'BILLDA
- QUIT
- +11 ; Corrupted index
- IF '$DATA(^DGCR(399,BILLDA,0))
- QUIT
- +12 SET IBMATCH=1
- +13 ; Patient name doesn't match
- IF IBPNAME'=""
- IF '$$TXMATCH($PIECE(IBPNAME,","),$PIECE($GET(^DPT(+$PIECE(^DGCR(399,BILLDA,0),U,2),0)),","),8)
- QUIT
- +14 SET IBFOUND=1
- End DoDot:2
- if IBFOUND
- QUIT
- End DoDot:1
- if IBFOUND
- QUIT
- +15 ; not matched
- IF 'BILLDA
- SET IBERR=$SELECT(IBMATCH:"Patient's name does not match",1:"Matching bill not found")
- +16 QUIT +BILLDA
- +17 ;
- ACDUTY(DFN) ;
- +1 ; Check active duty status for the patient
- +2 ; Input:
- +3 ; DFN: Patient (#2) IEN
- +4 ; Output:
- +5 ; 0: Does not have an Active Duty Status
- +6 ; 1: Has an active Duty Status
- +7 ;
- +8 IF '$GET(DFN)
- QUIT 0
- +9 ; Check if Patient TYPE is ACTIVE DUTY
- +10 NEW VAEL
- +11 DO ELIG^VADPT
- +12 IF $PIECE($GET(VAEL(6)),"^",2)'="ACTIVE DUTY"
- QUIT 0
- +13 ; If the PERIOD OF SERVICE has '-ACTIVE DUTY', quit with true
- +14 IF $FIND($PIECE($GET(VAEL(2)),"^",2),"-ACTIVE DUTY")
- QUIT 1
- +15 QUIT 0
- +16 ;
- +17 ;IBNCPDPU