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 Oct 16, 2024@18:25:25 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
