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

IBJPS4.m

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