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

IBNCPDPU.m

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