source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m@ 1397

IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
 ;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57
 ;;Per VHA Directive 2004-038, this routine should not be modified.
 ;
RCHK(X) ; -- Input transform for different revenue codes in file 36
 ;    Returns 1 if passes, 0 if not pass input transform
 ;
 N I,Y,RC,NO S Y=0
 I $G(X)="" G RCHKQ
 F I=1:1 S RC=$P(X,",",I) Q:RC=""  I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q
 I '$G(NO) S Y=1
RCHKQ Q Y
 ;
BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK) ; -- Return entry in Benefits Used file
 ;     Input:  IBCDFN  = pointer to patient file policy (2.312)
 ;             DFN     = patient pointer        
 ;             IBCPOL  = pointer to health insurance policy file
 ;             IBYR    = fileman internal date, year will be calendar
 ;                       year of the internal date, Default = dt
 ;             IBASK   = 1 if want to ask okay to add new entry
 ;
 ;    Output:  IBCBU   = pointer to Benefits Used file if added,
 ;                       else null
 ;
 N DIR,IBCBU
 S IBCBU=""
 I $G(IBCPOL)="" G BUQ
 I $G(IBYR)="" S IBYR=DT
 ;
 ;if no match display message
 I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ
 ;
 ; -- try to find entry for policy for year
 S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
 ;
 ; -- if no match add new entry
 I 'IBCBU D
 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
 .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN)
 .Q
 ;
BUQ Q IBCBU
 ;
ADDBU(DFN,IBCPOL,IBYR,IBCDFN) ; -- add entries to Benefits Used file
 ;     Input:  DFN     = pointer to patient file
 ;             IBCDFN  = point to patient policy (2.312)
 ;             IBCPOL  = pointer to health insurance policy file
 ;             IBYR    = fileman internal date, year will be calendar
 ;                       year of the internal date, Default = dt
 ;
 ;    Output:  IBCBU   = pointer to Benefits Used file if added,
 ;                       else null
 ;
 N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD
 S IBCBU=""
 I $G(IBCDFN)="" G ADDBUQ
 I $G(IBCPOL)="" G ADDBUQ
 I $G(IBYR)="" S IBYR=DT
 K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5
 ;
 ;S IBYR=$E(IBYR,1,3)_"0000"
 S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ
 S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ
 D ^DIE K DIC,DIE,DA,DR
ADDBUQ Q IBCBU
 ;
VET() ; -- Input Transform for sub-file 2.312, Name of Insured (#17)
 ;    Quit 1 to stuff Patient Name
 ;    Quit 0 to not stuff and allow editing
 ;
 N IBY,IB0 S IBY=0
 G VETQ    ; IB*2*371 - Allow edits to the patient name in all cases
 S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
 I $P(IB0,"^",6)'="v" G VETQ
 I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
 I '$D(X),$P(IB0,"^",17)="" S IBY=1
VETQ Q IBY
 ;
 ;
SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
 N NODE,L,R,CHAR,X1
 S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
 S NODE=^DPT(DA(1),.312,DA,0)
 ;
 ; - if the policy is a Medicare policy, make sure the subscriber ID
 ;   is a valid HICN number
 I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
 ;
 S R=$P(NODE,U,16)
 S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
 S R=$S(R="01":1,R="":1,1:0)
 ;
 ; - if subscriber ID is the SSN of patient, remove all extraneous
 ;   characters
 S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
 ;
 K:$L(X)>20!($L(X)<3) X
 Q
 ;
 ;
HICN(DFN) ; -- return Patient's Medicare HIC number
 ;    Return HICN of Medicare WNR Part A or Part B
 ;    Return -1 if none exits
 ;
 N IBWNR,IBX,IBY,IB0
 S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
 I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
 S IBX=0 F  S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"")  D
 .S IB0=$G(^DPT(DFN,.312,IBX,0))
 .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
 .; 8/18/2003 - Added translation code to remove hyphens if they exist.
 .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
 S:IBY="" IBY=-1
HICNQ Q IBY
 ;
CHKQUAL(DFN,IEN,QUAL,PC1,PC2) ; check for duplicate qualifiers for patient
 ; and subscriber secondary ID's.  All parameters required.
 ;
 ;   DFN - internal patient#
 ;   IEN - ien of 2.312 subfile
 ;  QUAL - passed in response of the user (this is what is being 
 ;         checked to see if it is valid)
 ;   PC1 - this is the piece# for one of the other qualifiers
 ;   PC2 - this is the piece# for one of the other qualifiers
 ;
 ; Function returns 1 if the entered qualifier is OK.
 ; Function returns 0 if the entered qualifier is not OK.  It is either
 ;                    a duplicate or is otherwise invalid.
 ;
 NEW OK,DATA,INS
 S OK=1
 I $G(QUAL)="" G CHKQUALX
 S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5))
 I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX   ; duplicate
 I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX   ; duplicate
 ;
 ; prevent the SSN qualifier when Medicare is the payer
 S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0))
 I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX
 ;
CHKQUALX ;
 Q OK
 ;
CQ1 ; specific error message#1
 S OK=0
 D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!")
 D EN^DDIOL("",,"!!?5")
 Q
 ;
CQ2 ; specific error message#2
 S OK=0
 D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!")
 D EN^DDIOL("",,"!!?5")
 Q
 ;