- IBCBB11 ;ALB/AAS/OIFO-BP/PIJ - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006 3:45 PM
- ;;2.0;INTEGRATED BILLING;**51,343,363,371,395,392,401,384,400,436,432,516,550,577,568,591,592**;21-MAR-94;Build 58
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- WARN(IBDISP) ; Set warning in global
- ; DISP = warning text to display
- ;
- N Z
- S Z=+$O(^TMP($J,"BILL-WARN",""),-1)
- I Z=0 S ^TMP($J,"BILL-WARN",1)=$J("",5)_"**Warnings**:",Z=1
- S Z=Z+1,^TMP($J,"BILL-WARN",Z)=$J("",5)_IBDISP
- Q
- ;
- MULTDIV(IBIFN,IBND0) ; Check for multiple divisions on a bill ien IBIFN
- ; IBND0 = 0-node of bill
- ;
- ; Function returns 1 if more than 1 division found on bill
- N Z,Z0,Z1,MULT
- S MULT=0,Z1=$P(IBND0,U,22)
- I Z1 D
- . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$P(^(Z,0),U,7) I Z0,Z0'=Z1 S MULT=1 Q
- . S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z S Z0=$P(^(Z,0),U,6) I Z0,Z0'=Z1 S MULT=2 Q
- I 'Z1 S MULT=3
- Q MULT
- ;
- ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
- ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
- ;
- NPICHK ; Check for required NPIs
- N IBNPIS,IBNONPI,IBNPIREQ,Z,IBNFI,IBTF,IBWC,IBXSAVE,IBPRV,IBLINE,IBPRVNT1,IBPRVNT2
- ;*** pij start IB*20*436 ***
- N IBRATYPE,IBLEGAL
- S (IBRATYPE,IBLEGAL)=""
- S IBRATYPE=$P($G(^DGCR(399,IBIFN,0)),U,7)
- ; Legal types for this use.
- ; 7=NO FAULT INS.
- ; 10=TORT FEASOR
- ; 11=WORKERS' COMP.
- S IBNFI=$O(^DGCR(399.3,"B","NO FAULT INS.",0)) S:'IBNFI IBNFI=7
- S IBTF=$O(^DGCR(399.3,"B","TORT FEASOR",0)) S:'IBTF IBTF=10
- S IBWC=$O(^DGCR(399.3,"B","WORKERS' COMP.",0)) S:'IBWC IBWC=11
- ;
- I IBRATYPE=IBNFI!(IBRATYPE=IBTF)!(IBRATYPE=IBWC) D
- . ; One of the legal types - force local print
- . S IBLEGAL=1
- ;*** pij end ***
- S IBNPIREQ=$$NPIREQ^IBCEP81(DT) ; Check if NPI is required
- ; Check providers
- ; IB*2.0*432 changed the NPI check to the new Provider Array
- ;S IBNPIS=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI)
- D ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
- S IBPRV=""
- F S IBPRV=$O(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV)) Q:'IBPRV D
- . I $P($G(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV,0)),U,4)="" S IBNONPI(IBPRV)=""
- S IBLINE=""
- F S IBLINE=$O(IBXSAVE("L-PROV",IBIFN,IBLINE)) Q:'IBLINE D
- . S IBPRV=""
- . F S IBPRV=$O(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV)) Q:IBPRV="" D
- .. I $P($G(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV,0)),U,4)="" S IBNONPI(IBPRV)=""
- I $D(IBNONPI) S IBPRV="" F S IBPRV=$O(IBNONPI(IBPRV)) Q:'IBPRV D
- . ;JWS;IB*2.0*592;Assistant Surgeon for dental
- . I IBPRV=6 S IBER=IBER_"IB358;" Q
- . S IBER=IBER_"IB"_(140+IBPRV)_";" Q ; If required, set error IB*2*516
- ; Check organizations
- S IBNONPI=""
- S IBNPIS=$$ORGNPI^IBCEF73A(IBIFN,.IBNONPI)
- I $L(IBNONPI) F Z=1:1:$L(IBNONPI,U) D
- . S IBER=IBER_$P("IB339;^IB340;^IB341;",U,$P(IBNONPI,U,Z)) ; DEM;432 Added NPI errors.
- Q
- ;
- TAXCHK ; Check for required taxonomies
- N IBDT,IBLINE,IBNOTAX,IBNOTAX1,IBNOTAX2,IBPRV,IBTAXS,IBXSAVE,Z
- ;
- ; MRD;IB*2.0*516 - This check is now moot; 'today' is always on or
- ; after May 23, 2008, so taxonomy codes are always required
- ; for certain providers.
- ;S IBTAXREQ=$$TAXREQ^IBCEP81(DT) ; Check if taxonomy is required
- ;
- ; Check providers
- ; IB*2.0*432 changed the Taxonomy check to the new Provider Array
- ;S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
- D ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
- ;JWS;IB*2.0*592; prevent having both RENDERING and ASSISTANT SURGEON providers at the claim level
- ; ;performing check here after providers are 'merged' into the claim level, if only at line level
- ; ;done in ALLIDS^IBCEFP
- I $$FT^IBCEF(IBIFN)=7 D
- . I $D(IBXSAVE("PROVINF",IBIFN,"C",1,3)),$D(IBXSAVE("PROVINF",IBIFN,"C",1,6)) D
- .. I '$F(IBER,"IB363;") S IBER=IBER_"IB363;"
- .. Q
- . ;JWS;IB*2.0*592 - US1108 start
- . I '$D(IBXSAVE("PROVINF",IBIFN,"C",1,3)),'$D(IBXSAVE("PROVINF",IBIFN,"C",1,6)) D
- .. N IBX,OK S OK=0,IBX=""
- .. F S IBX=$O(IBXSAVE("L-PROV",IBX)) Q:IBX="" D Q:OK
- ... I $D(IBXSAVE("L-PROV",IBX,"C",1,3)) S OK=1 Q
- ... I $D(IBXSAVE("L-PROV",IBX,"C",1,6)) S OK=1 Q
- .. I 'OK S IBER=IBER_"IB357;"
- .. Q
- . Q
- ;JWS;IB*2.0*592 - US1108 end
- S IBPRV=""
- F S IBPRV=$O(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV)) Q:'IBPRV D
- . I $G(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV,"TAXONOMY"))="" D
- .. S IBNOTAX(IBPRV)=""
- .. S IBNOTAX1=$P(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV),";",1) ; New variables IBNOTAX1 and IBNOTAX2 for IB*2.0*568 - Deactivated Provider
- .. S IBNOTAX2(IBPRV,IBNOTAX1)=""
- .. Q
- . Q
- ;
- S IBLINE=""
- F S IBLINE=$O(IBXSAVE("L-PROV",IBIFN,IBLINE)) Q:'IBLINE D
- . S IBPRV=""
- . F S IBPRV=$O(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV)) Q:IBPRV="" D
- .. I $G(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV,"TAXONOMY"))="" D
- ... S IBNOTAX(IBPRV)=""
- ... S IBNOTAX1=$P(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV),";",1) ; New variables IBNOTAX1 and IBNOTAX2 for IB*2.0*568 - Deactivated Provider
- ... S IBNOTAX2(IBPRV,IBNOTAX1)=""
- ... Q
- .. Q
- . Q
- ;
- ; IB251 = Referring provider taxonomy missing.
- ; IB253 = Rendering provider taxonomy missing.
- ; IB254 = Attending provider taxonomy missing.
- ; IB256 = Assistant Surgeon taxonomy missing. ;JWS;IB*2.0*592
- ;JWS;IB*2.0*592;dental start
- I $D(IBNOTAX) S IBPRV="" F S IBPRV=$O(IBNOTAX(IBPRV)) Q:'IBPRV D
- . ; Only Referring, Rendering and Attending are currently sent to the payer
- . ;I IBTAXREQ,"134"[IBPRV S IBER=IBER_"IB"_(250+IBPRV)_";" Q ; MRD;IB*2.0*516 - Always required.
- . I "134"[IBPRV D Q
- .. S IBER=IBER_"IB"_(250+IBPRV)_";" ; If required, set error
- .. S IBPRVNT1=$O(IBNOTAX2(IBPRV,"")) ; New check for Deactivated Provider IB*2.0*568 next three lines
- .. S IBPRVNT2=$$SPEC^IBCEU(IBPRVNT1,IBEVDT)
- .. I '$G(IBPRVNT2) D WARN($P("Referring^Operating^Rendering^Attending^Supervising^^^^Other",U,IBPRV)_" Provider PERSON CLASS/taxonomy was not active at DOS.") ; set warning
- . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,IBPRV)_" provider has no value") ; Else, set warning
- . Q
- ;JWS;IB*2.0*592;end
- ;
- ; Check organizations. The function ORGTAX will set IBNOTAX to be a
- ; list of entities missing taxonomy codes, if any (n, n^m, n^m^p,
- ; where each 1 is service facility, 2 is non-VA service facility and
- ; 3 is billing provider.
- ;
- S IBNOTAX=""
- S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX)
- I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
- . ; IB167 = Billing Provider taxonomy missing.
- . ;I IBTAXREQ,$P(IBNOTAX,U,Z)=3 S IBER=IBER_"IB167;" Q ; MRD;IB*2.0*516 - Always required.
- . I $P(IBNOTAX,U,Z)=3 S IBER=IBER_"IB167;" Q
- . ; MRD;IB*2.0*516 - Remove warning message for missing taxonomy code for lab or facility.
- . ; D WARN("Taxonomy for the "_$P("Service Facility^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value") ; Else, set warning
- . Q
- ;
- Q
- ;
- VALNDC(IBIFN,IBDFN) ; Moving pharmacy checks to reduce likelihood of patch collision
- D VALNDC^IBCBB14(IBIFN,IBDFN)
- Q
- ;
- PRIIDCHK ; Check for required Pimarary ID (SSN/EIN)
- ; If the provider is on the claim, he must have one
- ;
- N IBI,IBZ
- I $$TXMT^IBCEF4(IBIFN) D
- . D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
- . S IBI="" F S IBI=$O(^DGCR(399,IBIFN,"PRV","B",IBI)) Q:IBI="" D
- .. I $P(IBZ,U,IBI)="" S IBER=IBER_$S(IBI=1:"IB151;",IBI=2:"IB152;",IBI=3!(IBI=4):"IB321;",IBI=5:"IB153;",IBI=9:"IB154;",1:"")
- Q
- ;
- RXNPI(IBIFN) ; Moving pharmacy checks to reduce likelihood of patch collision
- D RXNPI^IBCBB14(IBIFN)
- Q
- ;
- ROICHK(IBIFN,IBDFN,IBINS) ; Moving pharmacy checks to reduce likelihood of patch collision
- Q $$ROICHK^IBCBB14(IBIFN,IBDFN,IBINS)
- ;
- AMBCK(IBIFN) ; IB*2.0*432 - if ambulance location defined, address must be defined
- ; if there is anything entered in any of the address fields (either p/up or drop/off fields), than there needs to be:
- ; Address 1, State and ZIP unless the State is not a US state or possession, then zip code is not needed (CMS1500 only)
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - 0 = no error
- ; 1 = Error
- ;
- N IBPAMB,IBDAMB,IBAMBR,IBCK
- S IBAMBR=0
- Q:$$INSPRF^IBCEF(IBIFN)'=0 IBAMBR
- S IBPAMB=$G(^DGCR(399,IBIFN,"U5")),IBDAMB=$G(^DGCR(399,IBIFN,"U6"))
- S IBCK(5)=$$NOPUNCT^IBCEF($P(IBPAMB,U,2,6),1),IBCK(6)=$$NOPUNCT^IBCEF($P(IBDAMB,U,1,6),1)
- I IBCK(5)="",IBCK(6)="" Q IBAMBR
- ; at this point we know that at least one ambulance field has data, so check to see if all have data
- I IBCK(5)'="" F I=2,4,5 I $P(IBPAMB,U,I)="" S IBAMBR=1
- I IBCK(6)'="" F I=1,2,4,5 I $P(IBDAMB,U,I)="" S IBAMBR=1
- Q:IBAMBR=1 IBAMBR
- ; now check zip code. OK to be null if state is not a US Posession
- F I="IBPAMB","IBDAMB" I $P(I,U,5)'="",$P($G(^DIC(5,$P(I,U,5),0)),U,6)=1,$P(I,U,6)="" S IBAMBR=1
- Q IBAMBR
- ;
- COBAMT(IBIFN) ; IB*2.0*432 - IF there is a COB amt. it must equal the Total Claim Charge Amount
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - 0 = no error
- ; 1 = Error
- ;
- Q:IBIFN="" 0
- Q:$P($G(^DGCR(399,IBIFN,"U4")),U)="" 0
- Q:+$P($G(^DGCR(399,IBIFN,"U1")),U)'=+$P($G(^DGCR(399,IBIFN,"U4")),U) 1
- Q 0
- ;
- COBMRA(IBIFN) ; IB*2.0*432 - If there is a 'COB total non-covered amount' (File#399, Field#260),
- ; Primary Insurance must be Medicare that never went to Medicare, and this must be a 2ndary or tertiary claim
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - 0 = no error
- ; 1 = Error
- ;
- N IBP
- Q:IBIFN="" 0
- Q:$P($G(^DGCR(399,IBIFN,"U4")),U)="" 0
- S IBP=$P($G(^DGCR(399,IBIFN,"M1")),U,5) S:IBP="" IBP=IBIFN
- I $$WNRBILL^IBEFUNC(IBIFN,1),$P($G(^DGCR(399,IBP,"S")),U,7)="",$$COBN^IBCEF(IBIFN)>1 Q 0
- Q 1
- ;
- COBSEC(IBIFN) ; IB*2.0*432 - If there is NOT a 'COB total non-covered amount' (File#399, Field#260),
- ; and Primary Insurance is Medicare that never went to Medicare, 2ndary or tertiary claim cannot be set to transmit
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - 0 = no error
- ; 1 = Error
- ;
- N IBP
- Q:IBIFN="" 0
- Q:$P($G(^DGCR(399,IBIFN,"U4")),U)'="" 0
- Q:$$COBN^IBCEF(IBIFN)<2 0
- S IBP=$P($G(^DGCR(399,IBIFN,"M1")),U,5) S:IBP="" IBP=IBIFN
- I $$WNRBILL^IBEFUNC(IBIFN,1),$P($G(^DGCR(399,IBP,"S")),U,7)="",$P($G(^DGCR(399,IBIFN,"TX")),U,8)'=1 Q 1
- Q 0
- ;
- TMCK(IBIFN) ; IB*2.0*432 - Attachment Control Number - REQUIRED when Transmission Method = BM, EL, EM, or FT
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - 0 = no error
- ; 1 = Error
- ;
- N IBAC
- Q:IBIFN="" 0
- F I=1,3 S IBAC(I)=$P($G(^DGCR(399,IBIFN,"U8")),U,I)
- Q:IBAC(3)="" 0
- Q:IBAC(1)'="" 0
- Q:IBAC(3)="AA" 0
- Q 1
- ;
- ACCK(IBIFN) ; IB*2.0*432 If any of the loop info is present, then Report Type & Transmission Method req'd
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - 0 = no error
- ; 1 = Error
- ;
- N IBAC
- Q:IBIFN="" 0
- F I=1:1:3 S IBAC(I)=$P($G(^DGCR(399,IBIFN,"U8")),U,I)
- ; All fields null, no error
- I IBAC(1)="",IBAC(2)="",IBAC(3)="" Q 0
- ; Both required fields complete, no error
- I IBAC(2)'="",IBAC(3)'="" Q 0
- ; At this point, one of the 2 required fields has data and one does not, so error
- Q 1
- ;
- LNTMCK(IBIFN) ; DEM;IB*2.0*432 - (Line Level) Attachment Control Number - REQUIRED when Transmission Method = BM, EL, EM, or FT
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - IBLNERR = 0 = no error
- ; IBLNERR = 1 = Error
- ;
- N IBAC,IBPROCP,I,IBLNERR
- S IBLNERR=0 ; DEM;432 - Initialize error flag IBLNERR to '0' for no errors.
- Q:IBIFN="" IBLNERR
- S IBPROCP=0 F S IBPROCP=$O(^DGCR(399,IBIFN,"CP",IBPROCP)) Q:'IBPROCP D Q:IBLNERR
- . Q:'($D(^DGCR(399,IBIFN,"CP",IBPROCP,0))#10) ; DEM;432 - Node '0' is procedure node.
- . Q:'($D(^DGCR(399,IBIFN,"CP",IBPROCP,1))#10) ; DEM;432 - Node '1' is line level Attachment Control fields.
- . F I=1,3 S IBAC(I)=$P(^DGCR(399,IBIFN,"CP",IBPROCP,1),U,I)
- . I IBAC(3)="" S IBLNERR=0 Q
- . I IBAC(1)'="" S IBLNERR=0 Q
- . I (IBAC(3)="AA") S IBLNERR=0 Q
- . S IBLNERR=1
- . Q
- ;
- Q IBLNERR
- ;
- LNACCK(IBIFN) ; DEM;IB*2.0*432 (Line Level) If any of the loop info is present, then Report Type & Transmission Method req'd
- ; input - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - IBLNERR = 0 = no error
- ; IBLNERR = 1 = Error
- ;
- N IBAC,IBPROCP,I,IBLNERR
- S IBLNERR=0 ; DEM;432 - Initialize error flag IBLNERR to '0' for no errors.
- Q:IBIFN="" IBLNERR
- S IBPROCP=0 F S IBPROCP=$O(^DGCR(399,IBIFN,"CP",IBPROCP)) Q:'IBPROCP D Q:IBLNERR
- . Q:'($D(^DGCR(399,IBIFN,"CP",IBPROCP,0))#10) ; DEM;432 - Node '0' is procedure node.
- . Q:'($D(^DGCR(399,IBIFN,"CP",IBPROCP,1))#10) ; DEM;432 - Node '1' is line level Attachment Control fields.
- . F I=1:1:3 S IBAC(I)=$P(^DGCR(399,IBIFN,"CP",IBPROCP,1),U,I)
- . ; All fields null, no error
- . I IBAC(1)="",IBAC(2)="",IBAC(3)="" S IBLNERR=0 Q
- . ; Both required fields complete, no error
- . I IBAC(2)'="",IBAC(3)'="" S IBLNERR=0 Q
- . ; At this point, one of the 2 required fields has data and one does not, so error
- . S IBLNERR=1
- . Q
- ;
- Q IBLNERR
- ;
- ;vd/Beginning of IB*2*577 - Validate Line Level for NDC
- LNNDCCK(IBIFN) ;IB*2*577 (Line Level) The Units and Units/Basis of Measurement fields are required if the NDC field is populated.
- ; INPUT - IBIFN = IEN of the Bill/Claims file (#399)
- ; OUTPUT - IBLNERR = 0 = no error
- ; IBLNERR = 1 = Error
- ;
- N IBAC,IBPROCP,I,IBLNERR
- S IBLNERR=0 ; IB*2*577 - Initialize error flag IBLNERR to '0' for no errors.
- Q:IBIFN="" IBLNERR
- S IBPROCP=0 F S IBPROCP=$O(^DGCR(399,IBIFN,"CP",IBPROCP)) Q:'IBPROCP D Q:IBLNERR
- . Q:($$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",","NDC","I")="") ; IB*2*577 - No NDC Code
- . ; If there is an NDC Code, then the UNITS and UNITS/BASIS OF MEASUREMENT are Required.
- . I $$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",","UNITS/BASIS OF MEASUREMENT","I")="" S IBLNERR=1 Q
- . I $$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",","UNITS","I")="" S IBLNERR=1 Q ;Units (Quantity) is required if there is an NDC Code.
- . Q
- ;
- Q IBLNERR
- ;vd/End of IB*2*577
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCBB11 14114 printed Feb 18, 2025@23:35:11 Page 2
- IBCBB11 ;ALB/AAS/OIFO-BP/PIJ - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006 3:45 PM
- +1 ;;2.0;INTEGRATED BILLING;**51,343,363,371,395,392,401,384,400,436,432,516,550,577,568,591,592**;21-MAR-94;Build 58
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- WARN(IBDISP) ; Set warning in global
- +1 ; DISP = warning text to display
- +2 ;
- +3 NEW Z
- +4 SET Z=+$ORDER(^TMP($JOB,"BILL-WARN",""),-1)
- +5 IF Z=0
- SET ^TMP($JOB,"BILL-WARN",1)=$JUSTIFY("",5)_"**Warnings**:"
- SET Z=1
- +6 SET Z=Z+1
- SET ^TMP($JOB,"BILL-WARN",Z)=$JUSTIFY("",5)_IBDISP
- +7 QUIT
- +8 ;
- MULTDIV(IBIFN,IBND0) ; Check for multiple divisions on a bill ien IBIFN
- +1 ; IBND0 = 0-node of bill
- +2 ;
- +3 ; Function returns 1 if more than 1 division found on bill
- +4 NEW Z,Z0,Z1,MULT
- +5 SET MULT=0
- SET Z1=$PIECE(IBND0,U,22)
- +6 IF Z1
- Begin DoDot:1
- +7 SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399,IBIFN,"RC",Z))
- if 'Z
- QUIT
- SET Z0=$PIECE(^(Z,0),U,7)
- IF Z0
- IF Z0'=Z1
- SET MULT=1
- QUIT
- +8 SET Z=0
- FOR
- SET Z=$ORDER(^DGCR(399,IBIFN,"CP",Z))
- if 'Z
- QUIT
- SET Z0=$PIECE(^(Z,0),U,6)
- IF Z0
- IF Z0'=Z1
- SET MULT=2
- QUIT
- End DoDot:1
- +9 IF 'Z1
- SET MULT=3
- +10 QUIT MULT
- +11 ;
- +12 ;; PREGNANCY DX CODES: V22**-V24**, V27**-V28**, 630**-677**
- +13 ;; FLU SHOTS PROCEDURE CODES: 90724, G0008, 90732, G0009
- +14 ;
- NPICHK ; Check for required NPIs
- +1 NEW IBNPIS,IBNONPI,IBNPIREQ,Z,IBNFI,IBTF,IBWC,IBXSAVE,IBPRV,IBLINE,IBPRVNT1,IBPRVNT2
- +2 ;*** pij start IB*20*436 ***
- +3 NEW IBRATYPE,IBLEGAL
- +4 SET (IBRATYPE,IBLEGAL)=""
- +5 SET IBRATYPE=$PIECE($GET(^DGCR(399,IBIFN,0)),U,7)
- +6 ; Legal types for this use.
- +7 ; 7=NO FAULT INS.
- +8 ; 10=TORT FEASOR
- +9 ; 11=WORKERS' COMP.
- +10 SET IBNFI=$ORDER(^DGCR(399.3,"B","NO FAULT INS.",0))
- if 'IBNFI
- SET IBNFI=7
- +11 SET IBTF=$ORDER(^DGCR(399.3,"B","TORT FEASOR",0))
- if 'IBTF
- SET IBTF=10
- +12 SET IBWC=$ORDER(^DGCR(399.3,"B","WORKERS' COMP.",0))
- if 'IBWC
- SET IBWC=11
- +13 ;
- +14 IF IBRATYPE=IBNFI!(IBRATYPE=IBTF)!(IBRATYPE=IBWC)
- Begin DoDot:1
- +15 ; One of the legal types - force local print
- +16 SET IBLEGAL=1
- End DoDot:1
- +17 ;*** pij end ***
- +18 ; Check if NPI is required
- SET IBNPIREQ=$$NPIREQ^IBCEP81(DT)
- +19 ; Check providers
- +20 ; IB*2.0*432 changed the NPI check to the new Provider Array
- +21 ;S IBNPIS=$$PROVNPI^IBCEF73A(IBIFN,.IBNONPI)
- +22 DO ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
- +23 SET IBPRV=""
- +24 FOR
- SET IBPRV=$ORDER(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV))
- if 'IBPRV
- QUIT
- Begin DoDot:1
- +25 IF $PIECE($GET(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV,0)),U,4)=""
- SET IBNONPI(IBPRV)=""
- End DoDot:1
- +26 SET IBLINE=""
- +27 FOR
- SET IBLINE=$ORDER(IBXSAVE("L-PROV",IBIFN,IBLINE))
- if 'IBLINE
- QUIT
- Begin DoDot:1
- +28 SET IBPRV=""
- +29 FOR
- SET IBPRV=$ORDER(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV))
- if IBPRV=""
- QUIT
- Begin DoDot:2
- +30 IF $PIECE($GET(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV,0)),U,4)=""
- SET IBNONPI(IBPRV)=""
- End DoDot:2
- End DoDot:1
- +31 IF $DATA(IBNONPI)
- SET IBPRV=""
- FOR
- SET IBPRV=$ORDER(IBNONPI(IBPRV))
- if 'IBPRV
- QUIT
- Begin DoDot:1
- +32 ;JWS;IB*2.0*592;Assistant Surgeon for dental
- +33 IF IBPRV=6
- SET IBER=IBER_"IB358;"
- QUIT
- +34 ; If required, set error IB*2*516
- SET IBER=IBER_"IB"_(140+IBPRV)_";"
- QUIT
- End DoDot:1
- +35 ; Check organizations
- +36 SET IBNONPI=""
- +37 SET IBNPIS=$$ORGNPI^IBCEF73A(IBIFN,.IBNONPI)
- +38 IF $LENGTH(IBNONPI)
- FOR Z=1:1:$LENGTH(IBNONPI,U)
- Begin DoDot:1
- +39 ; DEM;432 Added NPI errors.
- SET IBER=IBER_$PIECE("IB339;^IB340;^IB341;",U,$PIECE(IBNONPI,U,Z))
- End DoDot:1
- +40 QUIT
- +41 ;
- TAXCHK ; Check for required taxonomies
- +1 NEW IBDT,IBLINE,IBNOTAX,IBNOTAX1,IBNOTAX2,IBPRV,IBTAXS,IBXSAVE,Z
- +2 ;
- +3 ; MRD;IB*2.0*516 - This check is now moot; 'today' is always on or
- +4 ; after May 23, 2008, so taxonomy codes are always required
- +5 ; for certain providers.
- +6 ;S IBTAXREQ=$$TAXREQ^IBCEP81(DT) ; Check if taxonomy is required
- +7 ;
- +8 ; Check providers
- +9 ; IB*2.0*432 changed the Taxonomy check to the new Provider Array
- +10 ;S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
- +11 DO ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
- +12 ;JWS;IB*2.0*592; prevent having both RENDERING and ASSISTANT SURGEON providers at the claim level
- +13 ; ;performing check here after providers are 'merged' into the claim level, if only at line level
- +14 ; ;done in ALLIDS^IBCEFP
- +15 IF $$FT^IBCEF(IBIFN)=7
- Begin DoDot:1
- +16 IF $DATA(IBXSAVE("PROVINF",IBIFN,"C",1,3))
- IF $DATA(IBXSAVE("PROVINF",IBIFN,"C",1,6))
- Begin DoDot:2
- +17 IF '$FIND(IBER,"IB363;")
- SET IBER=IBER_"IB363;"
- +18 QUIT
- End DoDot:2
- +19 ;JWS;IB*2.0*592 - US1108 start
- +20 IF '$DATA(IBXSAVE("PROVINF",IBIFN,"C",1,3))
- IF '$DATA(IBXSAVE("PROVINF",IBIFN,"C",1,6))
- Begin DoDot:2
- +21 NEW IBX,OK
- SET OK=0
- SET IBX=""
- +22 FOR
- SET IBX=$ORDER(IBXSAVE("L-PROV",IBX))
- if IBX=""
- QUIT
- Begin DoDot:3
- +23 IF $DATA(IBXSAVE("L-PROV",IBX,"C",1,3))
- SET OK=1
- QUIT
- +24 IF $DATA(IBXSAVE("L-PROV",IBX,"C",1,6))
- SET OK=1
- QUIT
- End DoDot:3
- if OK
- QUIT
- +25 IF 'OK
- SET IBER=IBER_"IB357;"
- +26 QUIT
- End DoDot:2
- +27 QUIT
- End DoDot:1
- +28 ;JWS;IB*2.0*592 - US1108 end
- +29 SET IBPRV=""
- +30 FOR
- SET IBPRV=$ORDER(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV))
- if 'IBPRV
- QUIT
- Begin DoDot:1
- +31 IF $GET(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV,"TAXONOMY"))=""
- Begin DoDot:2
- +32 SET IBNOTAX(IBPRV)=""
- +33 ; New variables IBNOTAX1 and IBNOTAX2 for IB*2.0*568 - Deactivated Provider
- SET IBNOTAX1=$PIECE(IBXSAVE("PROVINF",IBIFN,"C",1,IBPRV),";",1)
- +34 SET IBNOTAX2(IBPRV,IBNOTAX1)=""
- +35 QUIT
- End DoDot:2
- +36 QUIT
- End DoDot:1
- +37 ;
- +38 SET IBLINE=""
- +39 FOR
- SET IBLINE=$ORDER(IBXSAVE("L-PROV",IBIFN,IBLINE))
- if 'IBLINE
- QUIT
- Begin DoDot:1
- +40 SET IBPRV=""
- +41 FOR
- SET IBPRV=$ORDER(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV))
- if IBPRV=""
- QUIT
- Begin DoDot:2
- +42 IF $GET(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV,"TAXONOMY"))=""
- Begin DoDot:3
- +43 SET IBNOTAX(IBPRV)=""
- +44 ; New variables IBNOTAX1 and IBNOTAX2 for IB*2.0*568 - Deactivated Provider
- SET IBNOTAX1=$PIECE(IBXSAVE("L-PROV",IBIFN,IBLINE,"C",1,IBPRV),";",1)
- +45 SET IBNOTAX2(IBPRV,IBNOTAX1)=""
- +46 QUIT
- End DoDot:3
- +47 QUIT
- End DoDot:2
- +48 QUIT
- End DoDot:1
- +49 ;
- +50 ; IB251 = Referring provider taxonomy missing.
- +51 ; IB253 = Rendering provider taxonomy missing.
- +52 ; IB254 = Attending provider taxonomy missing.
- +53 ; IB256 = Assistant Surgeon taxonomy missing. ;JWS;IB*2.0*592
- +54 ;JWS;IB*2.0*592;dental start
- +55 IF $DATA(IBNOTAX)
- SET IBPRV=""
- FOR
- SET IBPRV=$ORDER(IBNOTAX(IBPRV))
- if 'IBPRV
- QUIT
- Begin DoDot:1
- +56 ; Only Referring, Rendering and Attending are currently sent to the payer
- +57 ;I IBTAXREQ,"134"[IBPRV S IBER=IBER_"IB"_(250+IBPRV)_";" Q ; MRD;IB*2.0*516 - Always required.
- +58 IF "134"[IBPRV
- Begin DoDot:2
- +59 ; If required, set error
- SET IBER=IBER_"IB"_(250+IBPRV)_";"
- +60 ; New check for Deactivated Provider IB*2.0*568 next three lines
- SET IBPRVNT1=$ORDER(IBNOTAX2(IBPRV,""))
- +61 SET IBPRVNT2=$$SPEC^IBCEU(IBPRVNT1,IBEVDT)
- +62 ; set warning
- IF '$GET(IBPRVNT2)
- DO WARN($PIECE("Referring^Operating^Rendering^Attending^Supervising^^^^Other",U,IBPRV)_" Provider PERSON CLASS/taxonomy was not active at DOS.")
- End DoDot:2
- QUIT
- +63 ; Else, set warning
- DO WARN("Taxonomy for the "_$PIECE("referring^operating^rendering^attending^supervising^^^^other",U,IBPRV)_" provider has no value")
- +64 QUIT
- End DoDot:1
- +65 ;JWS;IB*2.0*592;end
- +66 ;
- +67 ; Check organizations. The function ORGTAX will set IBNOTAX to be a
- +68 ; list of entities missing taxonomy codes, if any (n, n^m, n^m^p,
- +69 ; where each 1 is service facility, 2 is non-VA service facility and
- +70 ; 3 is billing provider.
- +71 ;
- +72 SET IBNOTAX=""
- +73 SET IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX)
- +74 IF $LENGTH(IBNOTAX)
- FOR Z=1:1:$LENGTH(IBNOTAX,U)
- Begin DoDot:1
- +75 ; IB167 = Billing Provider taxonomy missing.
- +76 ;I IBTAXREQ,$P(IBNOTAX,U,Z)=3 S IBER=IBER_"IB167;" Q ; MRD;IB*2.0*516 - Always required.
- +77 IF $PIECE(IBNOTAX,U,Z)=3
- SET IBER=IBER_"IB167;"
- QUIT
- +78 ; MRD;IB*2.0*516 - Remove warning message for missing taxonomy code for lab or facility.
- +79 ; D WARN("Taxonomy for the "_$P("Service Facility^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value") ; Else, set warning
- +80 QUIT
- End DoDot:1
- +81 ;
- +82 QUIT
- +83 ;
- VALNDC(IBIFN,IBDFN) ; Moving pharmacy checks to reduce likelihood of patch collision
- +1 DO VALNDC^IBCBB14(IBIFN,IBDFN)
- +2 QUIT
- +3 ;
- PRIIDCHK ; Check for required Pimarary ID (SSN/EIN)
- +1 ; If the provider is on the claim, he must have one
- +2 ;
- +3 NEW IBI,IBZ
- +4 IF $$TXMT^IBCEF4(IBIFN)
- Begin DoDot:1
- +5 DO F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
- +6 SET IBI=""
- FOR
- SET IBI=$ORDER(^DGCR(399,IBIFN,"PRV","B",IBI))
- if IBI=""
- QUIT
- Begin DoDot:2
- +7 IF $PIECE(IBZ,U,IBI)=""
- SET IBER=IBER_$SELECT(IBI=1:"IB151;",IBI=2:"IB152;",IBI=3!(IBI=4):"IB321;",IBI=5:"IB153;",IBI=9:"IB154;",1:"")
- End DoDot:2
- End DoDot:1
- +8 QUIT
- +9 ;
- RXNPI(IBIFN) ; Moving pharmacy checks to reduce likelihood of patch collision
- +1 DO RXNPI^IBCBB14(IBIFN)
- +2 QUIT
- +3 ;
- ROICHK(IBIFN,IBDFN,IBINS) ; Moving pharmacy checks to reduce likelihood of patch collision
- +1 QUIT $$ROICHK^IBCBB14(IBIFN,IBDFN,IBINS)
- +2 ;
- AMBCK(IBIFN) ; IB*2.0*432 - if ambulance location defined, address must be defined
- +1 ; if there is anything entered in any of the address fields (either p/up or drop/off fields), than there needs to be:
- +2 ; Address 1, State and ZIP unless the State is not a US state or possession, then zip code is not needed (CMS1500 only)
- +3 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +4 ; OUTPUT - 0 = no error
- +5 ; 1 = Error
- +6 ;
- +7 NEW IBPAMB,IBDAMB,IBAMBR,IBCK
- +8 SET IBAMBR=0
- +9 if $$INSPRF^IBCEF(IBIFN)'=0
- QUIT IBAMBR
- +10 SET IBPAMB=$GET(^DGCR(399,IBIFN,"U5"))
- SET IBDAMB=$GET(^DGCR(399,IBIFN,"U6"))
- +11 SET IBCK(5)=$$NOPUNCT^IBCEF($PIECE(IBPAMB,U,2,6),1)
- SET IBCK(6)=$$NOPUNCT^IBCEF($PIECE(IBDAMB,U,1,6),1)
- +12 IF IBCK(5)=""
- IF IBCK(6)=""
- QUIT IBAMBR
- +13 ; at this point we know that at least one ambulance field has data, so check to see if all have data
- +14 IF IBCK(5)'=""
- FOR I=2,4,5
- IF $PIECE(IBPAMB,U,I)=""
- SET IBAMBR=1
- +15 IF IBCK(6)'=""
- FOR I=1,2,4,5
- IF $PIECE(IBDAMB,U,I)=""
- SET IBAMBR=1
- +16 if IBAMBR=1
- QUIT IBAMBR
- +17 ; now check zip code. OK to be null if state is not a US Posession
- +18 FOR I="IBPAMB","IBDAMB"
- IF $PIECE(I,U,5)'=""
- IF $PIECE($GET(^DIC(5,$PIECE(I,U,5),0)),U,6)=1
- IF $PIECE(I,U,6)=""
- SET IBAMBR=1
- +19 QUIT IBAMBR
- +20 ;
- COBAMT(IBIFN) ; IB*2.0*432 - IF there is a COB amt. it must equal the Total Claim Charge Amount
- +1 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +2 ; OUTPUT - 0 = no error
- +3 ; 1 = Error
- +4 ;
- +5 if IBIFN=""
- QUIT 0
- +6 if $PIECE($GET(^DGCR(399,IBIFN,"U4")),U)=""
- QUIT 0
- +7 if +$PIECE($GET(^DGCR(399,IBIFN,"U1")),U)'=+$PIECE($GET(^DGCR(399,IBIFN,"U4")),U)
- QUIT 1
- +8 QUIT 0
- +9 ;
- COBMRA(IBIFN) ; IB*2.0*432 - If there is a 'COB total non-covered amount' (File#399, Field#260),
- +1 ; Primary Insurance must be Medicare that never went to Medicare, and this must be a 2ndary or tertiary claim
- +2 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +3 ; OUTPUT - 0 = no error
- +4 ; 1 = Error
- +5 ;
- +6 NEW IBP
- +7 if IBIFN=""
- QUIT 0
- +8 if $PIECE($GET(^DGCR(399,IBIFN,"U4")),U)=""
- QUIT 0
- +9 SET IBP=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5)
- if IBP=""
- SET IBP=IBIFN
- +10 IF $$WNRBILL^IBEFUNC(IBIFN,1)
- IF $PIECE($GET(^DGCR(399,IBP,"S")),U,7)=""
- IF $$COBN^IBCEF(IBIFN)>1
- QUIT 0
- +11 QUIT 1
- +12 ;
- COBSEC(IBIFN) ; IB*2.0*432 - If there is NOT a 'COB total non-covered amount' (File#399, Field#260),
- +1 ; and Primary Insurance is Medicare that never went to Medicare, 2ndary or tertiary claim cannot be set to transmit
- +2 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +3 ; OUTPUT - 0 = no error
- +4 ; 1 = Error
- +5 ;
- +6 NEW IBP
- +7 if IBIFN=""
- QUIT 0
- +8 if $PIECE($GET(^DGCR(399,IBIFN,"U4")),U)'=""
- QUIT 0
- +9 if $$COBN^IBCEF(IBIFN)<2
- QUIT 0
- +10 SET IBP=$PIECE($GET(^DGCR(399,IBIFN,"M1")),U,5)
- if IBP=""
- SET IBP=IBIFN
- +11 IF $$WNRBILL^IBEFUNC(IBIFN,1)
- IF $PIECE($GET(^DGCR(399,IBP,"S")),U,7)=""
- IF $PIECE($GET(^DGCR(399,IBIFN,"TX")),U,8)'=1
- QUIT 1
- +12 QUIT 0
- +13 ;
- TMCK(IBIFN) ; IB*2.0*432 - Attachment Control Number - REQUIRED when Transmission Method = BM, EL, EM, or FT
- +1 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +2 ; OUTPUT - 0 = no error
- +3 ; 1 = Error
- +4 ;
- +5 NEW IBAC
- +6 if IBIFN=""
- QUIT 0
- +7 FOR I=1,3
- SET IBAC(I)=$PIECE($GET(^DGCR(399,IBIFN,"U8")),U,I)
- +8 if IBAC(3)=""
- QUIT 0
- +9 if IBAC(1)'=""
- QUIT 0
- +10 if IBAC(3)="AA"
- QUIT 0
- +11 QUIT 1
- +12 ;
- ACCK(IBIFN) ; IB*2.0*432 If any of the loop info is present, then Report Type & Transmission Method req'd
- +1 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +2 ; OUTPUT - 0 = no error
- +3 ; 1 = Error
- +4 ;
- +5 NEW IBAC
- +6 if IBIFN=""
- QUIT 0
- +7 FOR I=1:1:3
- SET IBAC(I)=$PIECE($GET(^DGCR(399,IBIFN,"U8")),U,I)
- +8 ; All fields null, no error
- +9 IF IBAC(1)=""
- IF IBAC(2)=""
- IF IBAC(3)=""
- QUIT 0
- +10 ; Both required fields complete, no error
- +11 IF IBAC(2)'=""
- IF IBAC(3)'=""
- QUIT 0
- +12 ; At this point, one of the 2 required fields has data and one does not, so error
- +13 QUIT 1
- +14 ;
- LNTMCK(IBIFN) ; DEM;IB*2.0*432 - (Line Level) Attachment Control Number - REQUIRED when Transmission Method = BM, EL, EM, or FT
- +1 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +2 ; OUTPUT - IBLNERR = 0 = no error
- +3 ; IBLNERR = 1 = Error
- +4 ;
- +5 NEW IBAC,IBPROCP,I,IBLNERR
- +6 ; DEM;432 - Initialize error flag IBLNERR to '0' for no errors.
- SET IBLNERR=0
- +7 if IBIFN=""
- QUIT IBLNERR
- +8 SET IBPROCP=0
- FOR
- SET IBPROCP=$ORDER(^DGCR(399,IBIFN,"CP",IBPROCP))
- if 'IBPROCP
- QUIT
- Begin DoDot:1
- +9 ; DEM;432 - Node '0' is procedure node.
- if '($DATA(^DGCR(399,IBIFN,"CP",IBPROCP,0))#10)
- QUIT
- +10 ; DEM;432 - Node '1' is line level Attachment Control fields.
- if '($DATA(^DGCR(399,IBIFN,"CP",IBPROCP,1))#10)
- QUIT
- +11 FOR I=1,3
- SET IBAC(I)=$PIECE(^DGCR(399,IBIFN,"CP",IBPROCP,1),U,I)
- +12 IF IBAC(3)=""
- SET IBLNERR=0
- QUIT
- +13 IF IBAC(1)'=""
- SET IBLNERR=0
- QUIT
- +14 IF (IBAC(3)="AA")
- SET IBLNERR=0
- QUIT
- +15 SET IBLNERR=1
- +16 QUIT
- End DoDot:1
- if IBLNERR
- QUIT
- +17 ;
- +18 QUIT IBLNERR
- +19 ;
- LNACCK(IBIFN) ; DEM;IB*2.0*432 (Line Level) If any of the loop info is present, then Report Type & Transmission Method req'd
- +1 ; input - IBIFN = IEN of the Bill/Claims file (#399)
- +2 ; OUTPUT - IBLNERR = 0 = no error
- +3 ; IBLNERR = 1 = Error
- +4 ;
- +5 NEW IBAC,IBPROCP,I,IBLNERR
- +6 ; DEM;432 - Initialize error flag IBLNERR to '0' for no errors.
- SET IBLNERR=0
- +7 if IBIFN=""
- QUIT IBLNERR
- +8 SET IBPROCP=0
- FOR
- SET IBPROCP=$ORDER(^DGCR(399,IBIFN,"CP",IBPROCP))
- if 'IBPROCP
- QUIT
- Begin DoDot:1
- +9 ; DEM;432 - Node '0' is procedure node.
- if '($DATA(^DGCR(399,IBIFN,"CP",IBPROCP,0))#10)
- QUIT
- +10 ; DEM;432 - Node '1' is line level Attachment Control fields.
- if '($DATA(^DGCR(399,IBIFN,"CP",IBPROCP,1))#10)
- QUIT
- +11 FOR I=1:1:3
- SET IBAC(I)=$PIECE(^DGCR(399,IBIFN,"CP",IBPROCP,1),U,I)
- +12 ; All fields null, no error
- +13 IF IBAC(1)=""
- IF IBAC(2)=""
- IF IBAC(3)=""
- SET IBLNERR=0
- QUIT
- +14 ; Both required fields complete, no error
- +15 IF IBAC(2)'=""
- IF IBAC(3)'=""
- SET IBLNERR=0
- QUIT
- +16 ; At this point, one of the 2 required fields has data and one does not, so error
- +17 SET IBLNERR=1
- +18 QUIT
- End DoDot:1
- if IBLNERR
- QUIT
- +19 ;
- +20 QUIT IBLNERR
- +21 ;
- +22 ;vd/Beginning of IB*2*577 - Validate Line Level for NDC
- LNNDCCK(IBIFN) ;IB*2*577 (Line Level) The Units and Units/Basis of Measurement fields are required if the NDC field is populated.
- +1 ; INPUT - IBIFN = IEN of the Bill/Claims file (#399)
- +2 ; OUTPUT - IBLNERR = 0 = no error
- +3 ; IBLNERR = 1 = Error
- +4 ;
- +5 NEW IBAC,IBPROCP,I,IBLNERR
- +6 ; IB*2*577 - Initialize error flag IBLNERR to '0' for no errors.
- SET IBLNERR=0
- +7 if IBIFN=""
- QUIT IBLNERR
- +8 SET IBPROCP=0
- FOR
- SET IBPROCP=$ORDER(^DGCR(399,IBIFN,"CP",IBPROCP))
- if 'IBPROCP
- QUIT
- Begin DoDot:1
- +9 ; IB*2*577 - No NDC Code
- if ($$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",","NDC","I")="")
- QUIT
- +10 ; If there is an NDC Code, then the UNITS and UNITS/BASIS OF MEASUREMENT are Required.
- +11 IF $$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",","UNITS/BASIS OF MEASUREMENT","I")=""
- SET IBLNERR=1
- QUIT
- +12 ;Units (Quantity) is required if there is an NDC Code.
- IF $$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",","UNITS","I")=""
- SET IBLNERR=1
- QUIT
- +13 QUIT
- End DoDot:1
- if IBLNERR
- QUIT
- +14 ;
- +15 QUIT IBLNERR
- +16 ;vd/End of IB*2*577