- IBJPS4 ;BP/YMG - IB Site Parameters, Pay-To Provider Associations ;06-Nov-2008
- ;;2.0;INTEGRATED BILLING;**400,516,608**;21-MAR-94;Build 90
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; MRD;IB*2.0*516 - Added logic pertaining to TRICARE-Specific Pay-To
- ; Providers, which entailed adding the parameter IBTCFLAG to many
- ; procedures here and in ^IBJPS3.
- ;
- EN(IBTCFLAG) ; -- main entry point for IBJP IB PAY-TO ASSOCIATIONS
- ; select pay-to provider
- D EN^VALM("IBJP IB "_$S(IBTCFLAG:"TRICARE PAY-TO ASSOCS",1:"PAY-TO ASSOCIATIONS"))
- S VALMBCK="R"
- Q
- ;
- HDR ; -- header code
- S VALMHDR(1)=""
- Q
- ;
- INIT(IBTCFLAG) ; -- init variables and list array
- N DFLT,HASDIVS,IBCNT,IBLN,IBSTR,IEN4,PIEN,PROVS
- S DFLT=$$GETDFLT^IBJPS3(IBTCFLAG) D BLD(DFLT,.PROVS,IBTCFLAG)
- I $D(PROVS) D
- .; create listman array
- .S (IBCNT,IBLN)=0 S PIEN="" F S PIEN=$O(PROVS(PIEN)) Q:PIEN="" D
- ..S IBLN=IBLN+1
- ..S IBSTR=$$SETSTR^VALM1(PROVS(PIEN)_$S($$ISDFLT^IBJPS3(PIEN,IBTCFLAG):" (Default)",1:""),"",2,75)
- ..D SET^VALM10(IBLN,IBSTR)
- ..S HASDIVS=0,IEN4="" F S IEN4=$O(PROVS(PIEN,IEN4)) Q:IEN4="" D
- ...S IBLN=IBLN+1,IBCNT=IBCNT+1 S:'HASDIVS HASDIVS=1
- ...S IBSTR=$$SETSTR^VALM1(IBCNT,"",8,4)
- ...S IBSTR=$$SETSTR^VALM1($P(PROVS(PIEN,IEN4),U,2),IBSTR,14,8)
- ...S IBSTR=$$SETSTR^VALM1($P(PROVS(PIEN,IEN4),U),IBSTR,24,55)
- ...D SET^VALM10(IBLN,IBSTR)
- ...S @VALMAR@("ZIDX",IBCNT,IEN4)=""
- ...Q
- ..I 'HASDIVS S IBSTR=$$SETSTR^VALM1("No Divisions found.","",8,45) S IBLN=IBLN+1 D SET^VALM10(IBLN,IBSTR)
- ..S IBLN=IBLN+1 D SET^VALM10(IBLN,"")
- ..Q
- .Q
- I 'DFLT S IBLN=$$SET^IBJPS3(0,$$SETSTR^VALM1("No Default "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider found.","",11,42))
- I DFLT,'$D(PROVS) S IBLN=$$SET^IBJPS3(0,$$SETSTR^VALM1("No "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Providers found.","",15,35))
- S VALMCNT=IBLN,VALMBG=1
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- D CLEAR^VALM1,CLEAN^VALM10
- Q
- ;
- BLD(DFLT,PROVS,IBTCFLAG) ; build array of pay-to providers and divisions
- N ALLDIVS,DIEN,DIVDATA,I,IB0,IEN4,PIEN,IBNODE
- I DFLT'>0 Q
- S IBNODE=$$NODE(IBTCFLAG)
- ;
- ; create list of all pay-to providers
- S I=0 F S I=$O(^IBE(350.9,1,IBNODE,I)) Q:'I D
- .S IB0=$G(^IBE(350.9,1,IBNODE,I,0)) I 'IB0 Q
- .I $P(IB0,U,5)="" S PROVS(I)=$P(IB0,U,2)
- .Q
- I $D(PROVS) D
- .; add divisions to the list
- .D LIST^DIC(40.8,,"@;.01;.07I","PQ",,,,,,,"ALLDIVS")
- .I $D(ALLDIVS) S I=0 F S I=$O(ALLDIVS("DILIST",I)) Q:I="" D
- ..; make sure that we have a file 4 ien to work with
- ..S DIVDATA=$G(ALLDIVS("DILIST",I,0)),IEN4=$P(DIVDATA,U,3) I IEN4="" Q
- ..S DIEN=$O(^IBE(350.9,1,IBNODE,"B",IEN4,""))
- ..; if there is an entry in 350.9 for this division, get corresponding pay-to provider
- ..; otherwise, use default pay-to provider
- ..S PIEN=$S(DIEN:$$GETPROV(DIEN,IBTCFLAG),1:DFLT)
- ..; add this division to the list as division name ^ station number
- ..S PROVS(PIEN,IEN4)=$P(DIVDATA,U,2)_U_$$GET1^DIQ(4,IEN4,99)
- ..Q
- .Q
- D CLEAN^DILF
- Q
- ;
- SEL() ; select division
- ; returns ien of selected division, or 0 if nothing is selected
- N DIR,IEN,MAX,X,Y
- S IEN=0,MAX=+$O(@VALMAR@("ZIDX",""),-1)
- I MAX>0 D
- .S:MAX=1 Y=1 I MAX>1 S DIR("A")="Select Division (1-"_MAX_"): ",DIR(0)="NA^"_1_":"_MAX_":0" D ^DIR
- .S:+Y>0 IEN=$O(@VALMAR@("ZIDX",Y,""))
- .Q
- Q +IEN
- ;
- DIVADD(IBTCFLAG) ; associate division with a pay-to provider
- N DA,DFLT,DIC,DIE,DIEN,DIR,DNAME,DR,IEN4,IEN19,Y,IBNODE
- S IBNODE=$$NODE(IBTCFLAG)
- ;
- D FULL^VALM1
- S VALMBCK="R"
- S IEN4=$$SEL I IEN4>0 D
- .S IEN19=$O(^IBE(350.9,1,IBNODE,"B",IEN4,"")) I IEN19="" D
- ..; create a new entry in 350.9
- ..S DIEN=$$FIND1^DIC(40.8,,"QX",IEN4,"AD") I 'DIEN Q
- ..S DNAME=$$GET1^DIQ(40.8,DIEN,.01),DFLT=$$GETDFLT^IBJPS3(IBTCFLAG) I 'DFLT Q
- ..I IEN4=+$G(^IBE(350.9,1,IBNODE,DFLT,0)) D ERR Q
- ..S DIC="^IBE(350.9,1,"_IBNODE_",",DIC(0)="L",DIC("DR")=".02////"_DNAME_";.05////"_DFLT,X=IEN4,DLAYGO=350.9,DA(1)=1
- ..K DD,DO D FILE^DICN I +Y>0 S IEN19=+Y
- ..K DIC,DD,DO,DLAYGO
- ..Q
- .I +IEN19>0 D
- ..I $P($G(^IBE(350.9,1,IBNODE,IEN19,0)),U,5)="" D ERR Q
- ..S DIR(0)="P^IBE(350.9,1,"_IBNODE_",:M",DIR("S")="I $P(^(0),U,5)="""""
- ..S DA(1)=1,DIR("A")="Select "_$S(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider"
- ..D ^DIR
- ..I +Y>0 S DIE="^IBE(350.9,1,"_IBNODE_",",DA=IEN19,DA(1)=1,DR=".05////"_+Y D ^DIE
- .Q
- D CLEAN^VALM10,CLEAN^DILF,INIT(IBTCFLAG)
- Q
- ;
- ERR ;
- N DIR
- S DIR("A",1)="A division used as a Pay-to Provider cannot be associated"
- S DIR("A",2)="with another Pay-to Provider."
- S DIR("A")="Press RETURN to continue: "
- S DIR(0)="EA" D ^DIR
- Q
- ;
- GETPROV(PIEN,IBTCFLAG) ; return pay-to provider ien for a given division, or 0 if provider can't be found
- ; PIEN has to be a valid ien in pay-to providers sub-file
- ;
- N PRVZ,NXTPIEN,OUT,IBNODE
- S PRVZ(PIEN)="" ; this array holds ien's to prevent infinite chain
- S IBNODE=$$NODE(IBTCFLAG)
- S OUT=0 F S NXTPIEN=+$P($G(^IBE(350.9,1,IBNODE,PIEN,0)),U,5) D Q:OUT ;
- .I 'NXTPIEN S OUT=1 Q ; no parent - this is pay-to provider
- .I $D(PRVZ(NXTPIEN)) S PIEN=0,OUT=1 Q ; we are in an infinite loop, so get out
- .S PIEN=NXTPIEN,PRVZ(NXTPIEN)="" ; parent exists, so continue the loop
- .Q
- Q PIEN
- ;
- GETDIVS(PIEN,DIVS,IBTCFLAG) ; return array of divisions associated with pay-to provider PIEN
- N I,DIV,PPROV,IBNODE
- S IBNODE=$$NODE(IBTCFLAG)
- S I="" F S I=$O(^IBE(350.9,1,IBNODE,"B",I)) Q:I="" D
- .S DIV=$O(^IBE(350.9,1,IBNODE,"B",I,""))
- .Q:+DIV'>0 S PPROV=$$GETPROV(DIV,IBTCFLAG)
- .I PPROV=PIEN,DIV'=PIEN S DIVS(DIV)=$P($G(^IBE(350.9,1,IBNODE,DIV,0)),U,2)
- .Q
- Q
- ;
- NODE(IBTCFLAG) ; Determine appropriate pay-to provide node within ^IBE(350.9).
- ; '29' for TRICARE, otherwise '19'.
- Q $S(IBTCFLAG:29,1:19)
- ;
- SCRN4(IEN) ; Screen for INSTITUTION(#4) file
- N DIERR,IENS,FIELDS,Z,ZERR
- S IENS=+IEN_",",FIELDS="11;13;101"
- D GETS^DIQ(4,IENS,FIELDS,"IE","Z","ZERR")
- I $D(DIERR) Q 0
- ;Check to see if National
- I Z(4,IENS,11,"I")'="N" Q 0
- ;Check to see if Inactive
- I Z(4,IENS,101,"I") Q 0
- ;Check to see if Pharmacy
- I "^PHARM^CMOP^MSN^"[(U_Z(4,IENS,13,"E")_U) Q 0
- ;Default
- Q 1
- ;
- TRICARE(IBIFN) ; Determine whether this bill/claim is TRICARE or not.
- ; Return '1' if TRICARE, '0' if not. There are two rate types that
- ; should return '1': TRICARE and TRICARE REIMB. INS.
- ;
- ; This has been modified to reflect Non-MCCF Claims and not just TRICARE. - IB*2.0*608 - vd (US2599)
- ;
- I '$G(IBIFN) Q 0
- N IBRATE
- S IBRATE=$P(^DGCR(399,IBIFN,0),U,7)
- I 'IBRATE Q 0
- ;
- ;/Begin IB*2.0*608 - vd (US2599) - Replaced the following lines
- ; I $P($G(^DGCR(399.3,IBRATE,0)),U)'["TRICARE" Q 0
- I '$D(^IBE(350.9,1,28,"B",IBRATE)) Q 0 ; Not a Non-MCCF Pay-to Provider Rate Type.
- ;/End IB*2.0*608 - vd
- ;
- ; At this point, the claim has a Non-MCCF rate type However,
- ; quit with a '1' only if a default Non-MCCF-specific pay-to
- ; provider is defined. Otherwise, quit with a '0'.
- ;
- I $$GETDFLT^IBJPS3(1) Q 1
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJPS4 7012 printed Jan 18, 2025@03:24:51 Page 2
- IBJPS4 ;BP/YMG - IB Site Parameters, Pay-To Provider Associations ;06-Nov-2008
- +1 ;;2.0;INTEGRATED BILLING;**400,516,608**;21-MAR-94;Build 90
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; MRD;IB*2.0*516 - Added logic pertaining to TRICARE-Specific Pay-To
- +5 ; Providers, which entailed adding the parameter IBTCFLAG to many
- +6 ; procedures here and in ^IBJPS3.
- +7 ;
- EN(IBTCFLAG) ; -- main entry point for IBJP IB PAY-TO ASSOCIATIONS
- +1 ; select pay-to provider
- +2 DO EN^VALM("IBJP IB "_$SELECT(IBTCFLAG:"TRICARE PAY-TO ASSOCS",1:"PAY-TO ASSOCIATIONS"))
- +3 SET VALMBCK="R"
- +4 QUIT
- +5 ;
- HDR ; -- header code
- +1 SET VALMHDR(1)=""
- +2 QUIT
- +3 ;
- INIT(IBTCFLAG) ; -- init variables and list array
- +1 NEW DFLT,HASDIVS,IBCNT,IBLN,IBSTR,IEN4,PIEN,PROVS
- +2 SET DFLT=$$GETDFLT^IBJPS3(IBTCFLAG)
- DO BLD(DFLT,.PROVS,IBTCFLAG)
- +3 IF $DATA(PROVS)
- Begin DoDot:1
- +4 ; create listman array
- +5 SET (IBCNT,IBLN)=0
- SET PIEN=""
- FOR
- SET PIEN=$ORDER(PROVS(PIEN))
- if PIEN=""
- QUIT
- Begin DoDot:2
- +6 SET IBLN=IBLN+1
- +7 SET IBSTR=$$SETSTR^VALM1(PROVS(PIEN)_$SELECT($$ISDFLT^IBJPS3(PIEN,IBTCFLAG):" (Default)",1:""),"",2,75)
- +8 DO SET^VALM10(IBLN,IBSTR)
- +9 SET HASDIVS=0
- SET IEN4=""
- FOR
- SET IEN4=$ORDER(PROVS(PIEN,IEN4))
- if IEN4=""
- QUIT
- Begin DoDot:3
- +10 SET IBLN=IBLN+1
- SET IBCNT=IBCNT+1
- if 'HASDIVS
- SET HASDIVS=1
- +11 SET IBSTR=$$SETSTR^VALM1(IBCNT,"",8,4)
- +12 SET IBSTR=$$SETSTR^VALM1($PIECE(PROVS(PIEN,IEN4),U,2),IBSTR,14,8)
- +13 SET IBSTR=$$SETSTR^VALM1($PIECE(PROVS(PIEN,IEN4),U),IBSTR,24,55)
- +14 DO SET^VALM10(IBLN,IBSTR)
- +15 SET @VALMAR@("ZIDX",IBCNT,IEN4)=""
- +16 QUIT
- End DoDot:3
- +17 IF 'HASDIVS
- SET IBSTR=$$SETSTR^VALM1("No Divisions found.","",8,45)
- SET IBLN=IBLN+1
- DO SET^VALM10(IBLN,IBSTR)
- +18 SET IBLN=IBLN+1
- DO SET^VALM10(IBLN,"")
- +19 QUIT
- End DoDot:2
- +20 QUIT
- End DoDot:1
- +21 IF 'DFLT
- SET IBLN=$$SET^IBJPS3(0,$$SETSTR^VALM1("No Default "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider found.","",11,42))
- +22 IF DFLT
- IF '$DATA(PROVS)
- SET IBLN=$$SET^IBJPS3(0,$$SETSTR^VALM1("No "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Providers found.","",15,35))
- +23 SET VALMCNT=IBLN
- SET VALMBG=1
- +24 QUIT
- +25 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 DO CLEAR^VALM1
- DO CLEAN^VALM10
- +2 QUIT
- +3 ;
- BLD(DFLT,PROVS,IBTCFLAG) ; build array of pay-to providers and divisions
- +1 NEW ALLDIVS,DIEN,DIVDATA,I,IB0,IEN4,PIEN,IBNODE
- +2 IF DFLT'>0
- QUIT
- +3 SET IBNODE=$$NODE(IBTCFLAG)
- +4 ;
- +5 ; create list of all pay-to providers
- +6 SET I=0
- FOR
- SET I=$ORDER(^IBE(350.9,1,IBNODE,I))
- if 'I
- QUIT
- Begin DoDot:1
- +7 SET IB0=$GET(^IBE(350.9,1,IBNODE,I,0))
- IF 'IB0
- QUIT
- +8 IF $PIECE(IB0,U,5)=""
- SET PROVS(I)=$PIECE(IB0,U,2)
- +9 QUIT
- End DoDot:1
- +10 IF $DATA(PROVS)
- Begin DoDot:1
- +11 ; add divisions to the list
- +12 DO LIST^DIC(40.8,,"@;.01;.07I","PQ",,,,,,,"ALLDIVS")
- +13 IF $DATA(ALLDIVS)
- SET I=0
- FOR
- SET I=$ORDER(ALLDIVS("DILIST",I))
- if I=""
- QUIT
- Begin DoDot:2
- +14 ; make sure that we have a file 4 ien to work with
- +15 SET DIVDATA=$GET(ALLDIVS("DILIST",I,0))
- SET IEN4=$PIECE(DIVDATA,U,3)
- IF IEN4=""
- QUIT
- +16 SET DIEN=$ORDER(^IBE(350.9,1,IBNODE,"B",IEN4,""))
- +17 ; if there is an entry in 350.9 for this division, get corresponding pay-to provider
- +18 ; otherwise, use default pay-to provider
- +19 SET PIEN=$SELECT(DIEN:$$GETPROV(DIEN,IBTCFLAG),1:DFLT)
- +20 ; add this division to the list as division name ^ station number
- +21 SET PROVS(PIEN,IEN4)=$PIECE(DIVDATA,U,2)_U_$$GET1^DIQ(4,IEN4,99)
- +22 QUIT
- End DoDot:2
- +23 QUIT
- End DoDot:1
- +24 DO CLEAN^DILF
- +25 QUIT
- +26 ;
- SEL() ; select division
- +1 ; returns ien of selected division, or 0 if nothing is selected
- +2 NEW DIR,IEN,MAX,X,Y
- +3 SET IEN=0
- SET MAX=+$ORDER(@VALMAR@("ZIDX",""),-1)
- +4 IF MAX>0
- Begin DoDot:1
- +5 if MAX=1
- SET Y=1
- IF MAX>1
- SET DIR("A")="Select Division (1-"_MAX_"): "
- SET DIR(0)="NA^"_1_":"_MAX_":0"
- DO ^DIR
- +6 if +Y>0
- SET IEN=$ORDER(@VALMAR@("ZIDX",Y,""))
- +7 QUIT
- End DoDot:1
- +8 QUIT +IEN
- +9 ;
- DIVADD(IBTCFLAG) ; associate division with a pay-to provider
- +1 NEW DA,DFLT,DIC,DIE,DIEN,DIR,DNAME,DR,IEN4,IEN19,Y,IBNODE
- +2 SET IBNODE=$$NODE(IBTCFLAG)
- +3 ;
- +4 DO FULL^VALM1
- +5 SET VALMBCK="R"
- +6 SET IEN4=$$SEL
- IF IEN4>0
- Begin DoDot:1
- +7 SET IEN19=$ORDER(^IBE(350.9,1,IBNODE,"B",IEN4,""))
- IF IEN19=""
- Begin DoDot:2
- +8 ; create a new entry in 350.9
- +9 SET DIEN=$$FIND1^DIC(40.8,,"QX",IEN4,"AD")
- IF 'DIEN
- QUIT
- +10 SET DNAME=$$GET1^DIQ(40.8,DIEN,.01)
- SET DFLT=$$GETDFLT^IBJPS3(IBTCFLAG)
- IF 'DFLT
- QUIT
- +11 IF IEN4=+$GET(^IBE(350.9,1,IBNODE,DFLT,0))
- DO ERR
- QUIT
- +12 SET DIC="^IBE(350.9,1,"_IBNODE_","
- SET DIC(0)="L"
- SET DIC("DR")=".02////"_DNAME_";.05////"_DFLT
- SET X=IEN4
- SET DLAYGO=350.9
- SET DA(1)=1
- +13 KILL DD,DO
- DO FILE^DICN
- IF +Y>0
- SET IEN19=+Y
- +14 KILL DIC,DD,DO,DLAYGO
- +15 QUIT
- End DoDot:2
- +16 IF +IEN19>0
- Begin DoDot:2
- +17 IF $PIECE($GET(^IBE(350.9,1,IBNODE,IEN19,0)),U,5)=""
- DO ERR
- QUIT
- +18 SET DIR(0)="P^IBE(350.9,1,"_IBNODE_",:M"
- SET DIR("S")="I $P(^(0),U,5)="""""
- +19 SET DA(1)=1
- SET DIR("A")="Select "_$SELECT(IBTCFLAG:"Non-MCCF ",1:"")_"Pay-To Provider"
- +20 DO ^DIR
- +21 IF +Y>0
- SET DIE="^IBE(350.9,1,"_IBNODE_","
- SET DA=IEN19
- SET DA(1)=1
- SET DR=".05////"_+Y
- DO ^DIE
- End DoDot:2
- +22 QUIT
- End DoDot:1
- +23 DO CLEAN^VALM10
- DO CLEAN^DILF
- DO INIT(IBTCFLAG)
- +24 QUIT
- +25 ;
- ERR ;
- +1 NEW DIR
- +2 SET DIR("A",1)="A division used as a Pay-to Provider cannot be associated"
- +3 SET DIR("A",2)="with another Pay-to Provider."
- +4 SET DIR("A")="Press RETURN to continue: "
- +5 SET DIR(0)="EA"
- DO ^DIR
- +6 QUIT
- +7 ;
- GETPROV(PIEN,IBTCFLAG) ; return pay-to provider ien for a given division, or 0 if provider can't be found
- +1 ; PIEN has to be a valid ien in pay-to providers sub-file
- +2 ;
- +3 NEW PRVZ,NXTPIEN,OUT,IBNODE
- +4 ; this array holds ien's to prevent infinite chain
- SET PRVZ(PIEN)=""
- +5 SET IBNODE=$$NODE(IBTCFLAG)
- +6 ;
- SET OUT=0
- FOR
- SET NXTPIEN=+$PIECE($GET(^IBE(350.9,1,IBNODE,PIEN,0)),U,5)
- Begin DoDot:1
- +7 ; no parent - this is pay-to provider
- IF 'NXTPIEN
- SET OUT=1
- QUIT
- +8 ; we are in an infinite loop, so get out
- IF $DATA(PRVZ(NXTPIEN))
- SET PIEN=0
- SET OUT=1
- QUIT
- +9 ; parent exists, so continue the loop
- SET PIEN=NXTPIEN
- SET PRVZ(NXTPIEN)=""
- +10 QUIT
- End DoDot:1
- if OUT
- QUIT
- +11 QUIT PIEN
- +12 ;
- GETDIVS(PIEN,DIVS,IBTCFLAG) ; return array of divisions associated with pay-to provider PIEN
- +1 NEW I,DIV,PPROV,IBNODE
- +2 SET IBNODE=$$NODE(IBTCFLAG)
- +3 SET I=""
- FOR
- SET I=$ORDER(^IBE(350.9,1,IBNODE,"B",I))
- if I=""
- QUIT
- Begin DoDot:1
- +4 SET DIV=$ORDER(^IBE(350.9,1,IBNODE,"B",I,""))
- +5 if +DIV'>0
- QUIT
- SET PPROV=$$GETPROV(DIV,IBTCFLAG)
- +6 IF PPROV=PIEN
- IF DIV'=PIEN
- SET DIVS(DIV)=$PIECE($GET(^IBE(350.9,1,IBNODE,DIV,0)),U,2)
- +7 QUIT
- End DoDot:1
- +8 QUIT
- +9 ;
- NODE(IBTCFLAG) ; Determine appropriate pay-to provide node within ^IBE(350.9).
- +1 ; '29' for TRICARE, otherwise '19'.
- +2 QUIT $SELECT(IBTCFLAG:29,1:19)
- +3 ;
- SCRN4(IEN) ; Screen for INSTITUTION(#4) file
- +1 NEW DIERR,IENS,FIELDS,Z,ZERR
- +2 SET IENS=+IEN_","
- SET FIELDS="11;13;101"
- +3 DO GETS^DIQ(4,IENS,FIELDS,"IE","Z","ZERR")
- +4 IF $DATA(DIERR)
- QUIT 0
- +5 ;Check to see if National
- +6 IF Z(4,IENS,11,"I")'="N"
- QUIT 0
- +7 ;Check to see if Inactive
- +8 IF Z(4,IENS,101,"I")
- QUIT 0
- +9 ;Check to see if Pharmacy
- +10 IF "^PHARM^CMOP^MSN^"[(U_Z(4,IENS,13,"E")_U)
- QUIT 0
- +11 ;Default
- +12 QUIT 1
- +13 ;
- TRICARE(IBIFN) ; Determine whether this bill/claim is TRICARE or not.
- +1 ; Return '1' if TRICARE, '0' if not. There are two rate types that
- +2 ; should return '1': TRICARE and TRICARE REIMB. INS.
- +3 ;
- +4 ; This has been modified to reflect Non-MCCF Claims and not just TRICARE. - IB*2.0*608 - vd (US2599)
- +5 ;
- +6 IF '$GET(IBIFN)
- QUIT 0
- +7 NEW IBRATE
- +8 SET IBRATE=$PIECE(^DGCR(399,IBIFN,0),U,7)
- +9 IF 'IBRATE
- QUIT 0
- +10 ;
- +11 ;/Begin IB*2.0*608 - vd (US2599) - Replaced the following lines
- +12 ; I $P($G(^DGCR(399.3,IBRATE,0)),U)'["TRICARE" Q 0
- +13 ; Not a Non-MCCF Pay-to Provider Rate Type.
- IF '$DATA(^IBE(350.9,1,28,"B",IBRATE))
- QUIT 0
- +14 ;/End IB*2.0*608 - vd
- +15 ;
- +16 ; At this point, the claim has a Non-MCCF rate type However,
- +17 ; quit with a '1' only if a default Non-MCCF-specific pay-to
- +18 ; provider is defined. Otherwise, quit with a '0'.
- +19 ;
- +20 IF $$GETDFLT^IBJPS3(1)
- QUIT 1
- +21 QUIT 0