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