IBCNEHLU ;DAOU/ALA - HL7 Utilities ;10-JUN-2002 ; Compiled December 16, 2004 15:36:12
;;2.0;INTEGRATED BILLING;**184,300,416,438,497,549,702,752,771**;21-MAR-94;Build 26
;;Per VA Directive 6402, this routine should not be modified.
;
HLP(PROTOCOL) ; Find the Protocol IEN
Q +$O(^ORD(101,"B",PROTOCOL,0))
;
NAME(NM) ; Convert a name that isn't in standard VISTA format -
NEW LNM,FNM,MI
;
I NM?." " Q NM
; LastName,FirstName MI
I NM["," Q NM
;
; Remove double-spaces from name
F Q:$L(NM," ")<2 S NM=$P(NM," ",1)_" "_$P(NM," ",2,9999)
;
; Trim leading/trailing spaces
S NM=$$TRIM^XLFSTR(NM)
;
; Find number of spaces in name
S II=$L(NM," ")
;
I II>3 Q NM
I II=3 S FNM=$P(NM," ",1),MI=" "_$P(NM," ",2),LNM=$P(NM," ",3)
I II=2 S FNM=$P(NM," ",1),LNM=$P(NM," ",2),MI=""
I II<2 Q NM
Q LNM_","_FNM_MI
;
DODCK(DFN,DOD,MGRP,NAME,RIEN,SSN) ; Date of death check
;
; Input Variables
; DFN, DOD, MGRP, NAME, RIEN, SSN
;
N CDOD,CIDDSP,IDDSP,IDSSN,MSG,XMSUB
S CDOD=$P($G(^DPT(DFN,.35)),U,1),CIDDSP=$$FMTE^XLFDT(CDOD,"5Z")
S IDDSP=$$FMTE^XLFDT(DOD,"5Z")
S IDSSN=$E(SSN,$L(SSN)-3,$L(SSN))
;
; If the two dates of death are the same, quit
I CDOD=DOD G DODCKX
;
; If no current date of death but payer sent one
I CDOD="" D G DODCKX
. ; Send an email message
. S XMSUB="Date of Death Received"
. S MSG(1)="A Date of Death ("_IDDSP_") was received for patient: "_NAME_"/"_IDSSN_" "_$$GETDOB^IBCNEDEQ(DFN)_" from"
. S MSG(2)="payer "_$$GET1^DIQ(365,RIEN,.03,"E")_". There is no current Date of Death on file for "
. S MSG(3)="this patient."
. D TXT^IBCNEUT7("MSG")
. D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
;
S XMSUB="Variant Date of Death"
S MSG(1)="A Date of Death ("_IDDSP_") was received for patient: "_NAME_"/"_IDSSN_" "_$$GETDOB^IBCNEDEQ(DFN)_" from payer "_$$GET1^DIQ(365,RIEN,.03,"E")_"."
S MSG(2)="This Date of Death does not currently match the Date of Death ("_CIDDSP_") on file for this patient. "
D TXT^IBCNEUT7("MSG")
D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
DODCKX ;
Q
;
SPAR ; Segment Parsing
;
; This tag will parse the current segment referenced by the HCT index
; and place the results in the IBSEG array.
;
; Input Variables
; HCT
;
; Output Variables
; IBSEG (ARRAY of fields in segment)
;
N II,IJ,IK,IM,IS,ISBEG,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
;
;Reset IBSEG
K IBSEG
;
S ISCT="",II=0,IS=0
F S ISCT=$O(^TMP($J,"IBCNEHLI",HCT,ISCT)) Q:ISCT="" D
. S IS=IS+1
. S ISDATA(IS)=$G(^TMP($J,"IBCNEHLI",HCT,ISCT))
. I $O(^TMP($J,"IBCNEHLI",HCT,ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
. S ISPEC(IS)=$L(ISDATA(IS),HLFS)
;
S IM=0,LSDATA=""
LP S IM=IM+1 Q:IM>IS
S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
F IJ=1:1:NPC-1 D
. S II=II+1,IBSEG(II)=$$CLNSTR($P(LSDATA,HLFS,IJ),$E(HL("ECH"),1,2)_$E(HL("ECH"),4),$E(HL("ECH")))
S LSDATA=$P(LSDATA,HLFS,NPC)
G LP
CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents in the HL7 seg
;
N NUMPEC,PEC,RTSTRING
;
S RTSTRING=$$RTRIMCH(STRING,CHARS)
; Now we have string w/o trailing chars, remove from subs
S NUMPEC=$L(RTSTRING,SUBSEP)
F PEC=1:1:NUMPEC S $P(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($P(RTSTRING,SUBSEP,PEC),CHARS)
Q RTSTRING
;
RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
;
N R,L
;
S L=1,CHRS=$G(CHRS," ")
F R=$L(STR):-1:1 Q:CHRS'[$E(STR,R)
I L=R,(CHRS[$E(STR)) S STR=""
Q $E(STR,L,R)
;
;
GTICNM(ICN,NAME) ; Retrieve PID segment and set ICN and patient name
;
N HCT,ERFLG,SEG,IBSEG
S (HCT,ICN,NAME)="",ERFLG=0
F S HCT=$O(^TMP($J,"IBCNEHLI",HCT)) Q:HCT="" D Q:ERFLG
. D SPAR
. S SEG=$G(IBSEG(1)) Q:SEG'="PID"
. S ICN=$G(IBSEG(4)),NAME=$G(IBSEG(6)),ERFLG=1
Q
;
PATISSUB(IDATA0) ; check if patient is the subscriber
; IDATA0 - 0 node of file 2.312
;
; returns 1 if patient is the subscriber, 0 otherwise
;
N PREL,RES
S RES=0
; check field 2.312/16 first
S PREL=$P(IDATA0,U,16) I PREL'="" S:PREL="01" RES=1 Q RES
; if 2.312/16 is empty, try field 2.312/6
I $P(IDATA0,U,6)="v" S RES=1
Q RES
;
ONEPOL(PIEN,IEN2) ; check if patient has only one policy on file for a given payer
; PIEN - payer ien
; IEN2 - patient ien (file 2)
;
; returns 1 if only one policy is found, 0 otherwise
N CNT,DAYS,EXPDT,IEN36,IEN312,RES
S (CNT,RES)=0
I +$G(PIEN)'>0!(+$G(IEN2)'>0) Q RES
;IB*702/TAZ - Get EIV NO GRP NUM A/U
S DAYS=$$GET1^DIQ(350.9,"1,",51.34,"I")
S IEN36="" F S IEN36=$O(^DIC(36,"AC",PIEN,IEN36)) Q:IEN36="" D
. S IEN312="" F S IEN312=$O(^DPT(IEN2,.312,"B",IEN36,IEN312)) Q:IEN312="" D
.. ;IB*702/TAZ - Compare EIV NO GRP NUM A/U with current date
.. S EXPDT=$$GET1^DIQ(2.312,IEN312_","_IEN2_",",3,"I")
.. I +EXPDT,$$FMDIFF^XLFDT(DT,EXPDT)>DAYS Q ;don't count for auto-update purposes
.. S CNT=CNT+1
I CNT=1 S RES=1
Q RES
;
MCRDT(RIEN,EBIEN) ; find effective date for Medicare response
; RIEN - file 365 ien
; EBIEN - subfile 365.02 ien
;
; returns date in FM format or "" if effective date was not found
;
N DONE,DTIEN,IENS,RES,Z
S RES="",DONE=0
S Z="" F S Z=$O(^IBCN(365,RIEN,2,EBIEN,8,"B",Z)) Q:Z=""!DONE D
.S DTIEN=$O(^IBCN(365,RIEN,2,EBIEN,8,"B",Z,"")) I 'DTIEN Q
.S IENS=DTIEN_","_EBIEN_","_RIEN_","
.; effective date has "eligibility" qualifier
.I $$GET1^DIQ(365.28,IENS,.03)=307 S RES=$$FMDATE^HLFNC($$GET1^DIQ(365.28,IENS,.02)),DONE=1
.Q
Q RES
;
ISMCR(RIEN) ; Check if response is for Medicare part A/B
; Input: RIEN - Internal ien for file 365
; Returns A1^A2^A3^A4^A5 Where:
; A1 - 1 if response if for Medicare, 0 otherwise
; A2 - "MA" if response is for Medicare Part A
; "MB" if response is for Medicare Part B
; "B" if response is for both Part A and Part B
; "" if response if not for Medicare
; A3 - Effective date for Medicare Part A if response if for
; Part A or both parts, "" otherwise
; A4 - Effective date for Medicare Part B if response if for
; Part B or both parts, "" otherwise
; A5 - "MA" - Response is for active Medicare Part A only
; "MB" - Response is for active Medicare Part B only
; "B" - Response is for active Medicare Parts A and B
; "" - Response is not for active Medicare
; IB*2.0*549 - added return of A5
;
N ACTIVE,DONE,EBIEN,RES,TYPE,TYPEA,TYPEB,Z,ZZ ;IB*2.0*549 added ACTIVE,TYPEA,TYPEB,ZZ
S RES="0^",DONE=0,(TYPEA,TYPEB)=0 ;IB*2.0*549 added ,(TYPEA,TYPEB)=0
I +RIEN'>0 Q RES
I '$D(^IBCN(365,RIEN)) Q RES
S Z="" F S Z=$O(^IBCN(365,RIEN,2,"B",Z)) Q:Z=""!DONE D
. S EBIEN=$O(^IBCN(365,RIEN,2,"B",Z,""))
. S TYPE=$$GET1^DIQ(365.02,EBIEN_","_RIEN_",",.05)
. ;
. ; IB*2.0*549 added next two lines
. S ACTIVE=$$GET1^DIQ(365.02,EBIEN_","_RIEN_",",.02,"I")
. S ACTIVE=$S(ACTIVE=1:1,1:0)
. I TYPE="MA" D
. . S:ACTIVE TYPEA=1 ;IB*2.0*549 added line
. . S ZZ=$P(RES,U,2) ;IB*2.0*549 added line
. . S $P(RES,U)=1,$P(RES,U,2)=$S(ZZ="":"MA",ZZ="MA":"MA",1:"B")
. . S $P(RES,U,3)=$$MCRDT(RIEN,EBIEN)
. . ;
. . ; IB*2.0*549 added line
. . S:ACTIVE $P(RES,U,5)=$S((TYPEA&TYPEB):"B",1:"MA")
. I TYPE="MB" D
. . S:ACTIVE TYPEB=1 ;IB*2.0*549 added line
. . S ZZ=$P(RES,U,2) ;IB*2.0*549 added line
. . S $P(RES,U)=1,$P(RES,U,2)=$S(ZZ="":"MB",ZZ="MB":"MB",1:"B")
. . S $P(RES,U,4)=$$MCRDT(RIEN,EBIEN)
. . ;
. . ; IB*2.0*549 added line
. . S:ACTIVE $P(RES,U,5)=$S((TYPEA&TYPEB):"B",1:"MB")
. I $P(RES,U,2)="B" S DONE=1
Q RES
;
ERRACT(RIEN) ; Pick error action code to use for re-transmission
; Input: RIEN - IEN in file 365 (Transmission file)
; Returns: Error action^Error condition; "" if no error found
;
; If any of C,N,S,Y action codes are found, the first one encountered is returned.
; Otherwise, if W action code is found, it is returned.
; Otherwise, if X action code is found, it is returned.
; Otherwise, one of the P,R action codes is returned.
;
N ACODE,AIEN,ECCODE,ECIEN,DONE,IEN,RES,Z
S RES=""
I '+$G(RIEN) G ERRACTX
S DONE=0
S Z="" F S IEN=$O(^IBCN(365,RIEN,6,"B",Z)) Q:Z=""!DONE D
. S IEN=+$O(^IBCN(365,RIEN,6,"B",Z,""))
. Q:'IEN
. S ECIEN=+$P(^IBCN(365,RIEN,6,IEN,0),U,3)
. Q:'ECIEN
. S AIEN=+$P(^IBCN(365,RIEN,6,IEN,0),U,4)
. Q:'AIEN
. S ACODE=$P(^IBE(365.018,AIEN,0),U),ECCODE=$P(^IBE(365.017,ECIEN,0),U)
. ;
. ; One of "do not retransmit" codes
. I ".C.N.S.Y"[("."_ACODE_".") S RES=ACODE_U_ECCODE,DONE=1 Q
. ;
. ; Retransmit after 30 days code
. I ACODE="W" S RES=ACODE_U_ECCODE Q
. ;
. ; Retransmit after 10 days code
. I ACODE="X" S:RES'="W" RES=ACODE_U_ECCODE Q
. ;
. ; Retransmit whenever codes
. I RES'="W",RES'="X" S RES=ACODE_U_ECCODE
ERRACTX ;
Q RES
;
NAMECMP(NAME1,NAME2) ; check if 2 names have the same first name and last name components
; NAME1, NAME2 - names to compare, should be in "last,first [middle]" format
;
; returns 1 if both first name and last name are the same between two names, returns 0 otherwise
N NM1,NM2,RES
S RES=0
S NM1=$$HLNAME^HLFNC(NAME1),NM2=$$HLNAME^HLFNC(NAME2)
I $P(NM1,U)=$P(NM2,U),$P(NM1,U,2)=$P(NM2,U,2) S RES=1
Q RES
;
TRNCWARN(GNUM,TRACE) ; send group number truncation warning message
N MSG
S MSG(1)="WARNING: Group number in the Response Message from the EC has been truncated"
S MSG(2)="----------------------------------------------------------------------------"
S MSG(3)="Original group number (in the eIV response received): "_$G(GNUM)
S MSG(4)="Truncated group number (filed into response file): "_$E($G(GNUM),1,17)
S MSG(5)=" "
S MSG(6)="The associated Trace # is "_$S($G(TRACE)="":"Unknown",1:TRACE)
S MSG(7)=" "
D MSG^IBCNEUT5($G(MGRP),MSG(1),"MSG(")
Q
;
CODECHK(RSUPDT) ; IB*2*497
; need to determine if codes and qualifiers sent in the 271 HL7 message
; are new. If code/qualifier does not exist in table then file new code into table
; input -
; RSUPDT = FDA array that will be passed to the DBS filer to update the
; entry/subentry into the IIV RESPONSE file
; example: RSUPDT(365.02,IENS,".02") = data to be filed into 365.02 subfile at field .02
; order through the RSUPDT array and determine if pointer to file
; if pointer to file then pass file name and value of code/qualifier
;
; IB*752 Fix existing bug - only allow certain files to be updated. See array XXFILE.
;
N IBXMY,IENS,FLD,FILE,FSCMSG,RES,SITE,SITENUM,TOFILE,NEWARRY,XX,XXFILE,Z,ZIENS
S (IENS,FILE,FLD)="",Z=0
F XX=11:1:18,21 S XXFILE("365.0"_XX)="" ;IB*771/DW Add original set of tables
F XX=22:1:29,31:1:39,41:1:46 S XXFILE("365.0"_XX)=""
F S FILE=$O(RSUPDT(FILE)) Q:FILE="" F S IENS=$O(RSUPDT(FILE,IENS)) Q:IENS="" D
. F S FLD=$O(RSUPDT(FILE,IENS,FLD)) Q:FLD="" D
. . Q:RSUPDT(FILE,IENS,FLD)="" ; value was not sent by payer; no need to continue
. . D FIELD^DID(FILE,FLD,"","POINTER","RES") ; get the name of the file that is pointed to (if any)
. . Q:RES("POINTER")="" ; field is not defined as a pointer to a file
. . S TOFILE=$P($P(RES("POINTER"),","),"(",2) ; example: RES("POINTER")="IBE(365.011,"
. . Q:+TOFILE=0
. . I '$D(XXFILE(TOFILE)) Q ;IB*752
. . Q:$$FIND1^DIC(TOFILE,"","X",RSUPDT(FILE,IENS,FLD)) ; code is already in file. No need to update the pointed-to-file
. . S Z=Z+1,ZIENS="+"_Z_","
. . S NEWARRY(TOFILE,ZIENS,.01)=RSUPDT(FILE,IENS,FLD) ; code passed into VistA from 271 message
. . S NEWARRY(TOFILE,ZIENS,.02)="OTHER" ; Description of code
. . S NEWARRY(TOFILE,ZIENS,.03)=0 ; INACTIVE FLAG
. . S NEWARRY(TOFILE,ZIENS,.05)=0 ; FSC CONTROLLED ;IB*752 indicate not controlled
. . ;IB*752/CKB - notify FSC that a new code was learned on the fly
. . S SITE=$$SITE^VASITE,SITENUM=$P(SITE,U,3)
. . S FSCMSG=TOFILE_U_SITENUM_U_RSUPDT(FILE,IENS,FLD)_U_$$GET1^DIQ(365,$G(RIEN)_",",.09)
. . D MSG005^IBCNEMS1(FSCMSG)
. . ;IB*771/DW Corrected call to send to FSC outlook address (was sent in wrong parameter)
. . ;D MSG^IBCNEUT5("FSCECADMIN@domain.ext","X12 271 VistA tables, site #"_SITENUM_" new code added","MSG(")
. . S IBXMY="" I $$PROD^XUPROD(1) S IBXMY("FSCECADMIN@domain.ext")=""
. . D MSG^IBCNEUT5(,"X12 271 VistA tables, site #"_SITENUM_" new code added","MSG(",,.IBXMY)
I $D(NEWARRY) D UPDATE^DIE("","NEWARRY")
Q
;
PREL(FILE,FIELD,CODE) ; IB*2*497 code from x12 271 message may need to be converted to 'other' if there is no match. Refer to tag SETLST
;
; INPUT - FILE = file # of the file that will be evaluated
; FIELD = field # that is defined with the SET OF CODE values
; CODE = patient relationship code sent by the X12 271 message
; OUTPUT - = converted or non-converted coded value
N STRING,CODESTR,ARRAY,VAL,I,DEF
S CODE=$G(CODE)
I CODE="" Q CODE ; quit when code was not sent from payer
D FIELD^DID(FILE,FIELD,"","TYPE","DEF")
I DEF("TYPE")="SET" D
. S CODESTR=$P($G(^DD(FILE,FIELD,0)),U,3)
. F I=1:1 S VAL=$P($P(CODESTR,";",I),":") Q:VAL="" S ARRAY(VAL)=$P($P(CODESTR,";",I),":",2)
Q $S($D(ARRAY(CODE)):CODE,1:"G8") ; if coded value does not exist in the array of codes then this is a new code sent by X12 271 message and will default to OTHER
;
SETLST ; SET OF CODES defined to 355.33,60.14 and 2.312,4.03; this tag is not referenced in any procedure. It's here for documentation purposes.
;;01^SPOUSE
;;18^SELF
;;19^CHILD
;;20^EMPLOYEE
;;29^SIGNIFICANT OTHER
;;32^MOTHER
;;33^FATHER
;;39^ORGAN DONOR
;;41^INJURED PLAINTIFF
;;53^LIFE PARTNER
;;G8^OTHER RELATIONSHIP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEHLU 13947 printed Sep 23, 2025@19:51:02 Page 2
IBCNEHLU ;DAOU/ALA - HL7 Utilities ;10-JUN-2002 ; Compiled December 16, 2004 15:36:12
+1 ;;2.0;INTEGRATED BILLING;**184,300,416,438,497,549,702,752,771**;21-MAR-94;Build 26
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
HLP(PROTOCOL) ; Find the Protocol IEN
+1 QUIT +$ORDER(^ORD(101,"B",PROTOCOL,0))
+2 ;
NAME(NM) ; Convert a name that isn't in standard VISTA format -
+1 NEW LNM,FNM,MI
+2 ;
+3 IF NM?." "
QUIT NM
+4 ; LastName,FirstName MI
+5 IF NM[","
QUIT NM
+6 ;
+7 ; Remove double-spaces from name
+8 FOR
if $LENGTH(NM," ")<2
QUIT
SET NM=$PIECE(NM," ",1)_" "_$PIECE(NM," ",2,9999)
+9 ;
+10 ; Trim leading/trailing spaces
+11 SET NM=$$TRIM^XLFSTR(NM)
+12 ;
+13 ; Find number of spaces in name
+14 SET II=$LENGTH(NM," ")
+15 ;
+16 IF II>3
QUIT NM
+17 IF II=3
SET FNM=$PIECE(NM," ",1)
SET MI=" "_$PIECE(NM," ",2)
SET LNM=$PIECE(NM," ",3)
+18 IF II=2
SET FNM=$PIECE(NM," ",1)
SET LNM=$PIECE(NM," ",2)
SET MI=""
+19 IF II<2
QUIT NM
+20 QUIT LNM_","_FNM_MI
+21 ;
DODCK(DFN,DOD,MGRP,NAME,RIEN,SSN) ; Date of death check
+1 ;
+2 ; Input Variables
+3 ; DFN, DOD, MGRP, NAME, RIEN, SSN
+4 ;
+5 NEW CDOD,CIDDSP,IDDSP,IDSSN,MSG,XMSUB
+6 SET CDOD=$PIECE($GET(^DPT(DFN,.35)),U,1)
SET CIDDSP=$$FMTE^XLFDT(CDOD,"5Z")
+7 SET IDDSP=$$FMTE^XLFDT(DOD,"5Z")
+8 SET IDSSN=$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))
+9 ;
+10 ; If the two dates of death are the same, quit
+11 IF CDOD=DOD
GOTO DODCKX
+12 ;
+13 ; If no current date of death but payer sent one
+14 IF CDOD=""
Begin DoDot:1
+15 ; Send an email message
+16 SET XMSUB="Date of Death Received"
+17 SET MSG(1)="A Date of Death ("_IDDSP_") was received for patient: "_NAME_"/"_IDSSN_" "_$$GETDOB^IBCNEDEQ(DFN)_" from"
+18 SET MSG(2)="payer "_$$GET1^DIQ(365,RIEN,.03,"E")_". There is no current Date of Death on file for "
+19 SET MSG(3)="this patient."
+20 DO TXT^IBCNEUT7("MSG")
+21 DO MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
End DoDot:1
GOTO DODCKX
+22 ;
+23 SET XMSUB="Variant Date of Death"
+24 SET MSG(1)="A Date of Death ("_IDDSP_") was received for patient: "_NAME_"/"_IDSSN_" "_$$GETDOB^IBCNEDEQ(DFN)_" from payer "_$$GET1^DIQ(365,RIEN,.03,"E")_"."
+25 SET MSG(2)="This Date of Death does not currently match the Date of Death ("_CIDDSP_") on file for this patient. "
+26 DO TXT^IBCNEUT7("MSG")
+27 DO MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
DODCKX ;
+1 QUIT
+2 ;
SPAR ; Segment Parsing
+1 ;
+2 ; This tag will parse the current segment referenced by the HCT index
+3 ; and place the results in the IBSEG array.
+4 ;
+5 ; Input Variables
+6 ; HCT
+7 ;
+8 ; Output Variables
+9 ; IBSEG (ARRAY of fields in segment)
+10 ;
+11 NEW II,IJ,IK,IM,IS,ISBEG,ISCT,ISDATA,ISEND,ISPEC,LSDATA,NPC
+12 ;
+13 ;Reset IBSEG
+14 KILL IBSEG
+15 ;
+16 SET ISCT=""
SET II=0
SET IS=0
+17 FOR
SET ISCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT,ISCT))
if ISCT=""
QUIT
Begin DoDot:1
+18 SET IS=IS+1
+19 SET ISDATA(IS)=$GET(^TMP($JOB,"IBCNEHLI",HCT,ISCT))
+20 IF $ORDER(^TMP($JOB,"IBCNEHLI",HCT,ISCT))=""
SET ISDATA(IS)=ISDATA(IS)_HLFS
+21 SET ISPEC(IS)=$LENGTH(ISDATA(IS),HLFS)
End DoDot:1
+22 ;
+23 SET IM=0
SET LSDATA=""
LP SET IM=IM+1
if IM>IS
QUIT
+1 SET LSDATA=LSDATA_ISDATA(IM)
SET NPC=ISPEC(IM)
+2 FOR IJ=1:1:NPC-1
Begin DoDot:1
+3 SET II=II+1
SET IBSEG(II)=$$CLNSTR($PIECE(LSDATA,HLFS,IJ),$EXTRACT(HL("ECH"),1,2)_$EXTRACT(HL("ECH"),4),$EXTRACT(HL("ECH")))
End DoDot:1
+4 SET LSDATA=$PIECE(LSDATA,HLFS,NPC)
+5 GOTO LP
CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents in the HL7 seg
+1 ;
+2 NEW NUMPEC,PEC,RTSTRING
+3 ;
+4 SET RTSTRING=$$RTRIMCH(STRING,CHARS)
+5 ; Now we have string w/o trailing chars, remove from subs
+6 SET NUMPEC=$LENGTH(RTSTRING,SUBSEP)
+7 FOR PEC=1:1:NUMPEC
SET $PIECE(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($PIECE(RTSTRING,SUBSEP,PEC),CHARS)
+8 QUIT RTSTRING
+9 ;
RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
+1 ;
+2 NEW R,L
+3 ;
+4 SET L=1
SET CHRS=$GET(CHRS," ")
+5 FOR R=$LENGTH(STR):-1:1
if CHRS'[$EXTRACT(STR,R)
QUIT
+6 IF L=R
IF (CHRS[$EXTRACT(STR))
SET STR=""
+7 QUIT $EXTRACT(STR,L,R)
+8 ;
+9 ;
GTICNM(ICN,NAME) ; Retrieve PID segment and set ICN and patient name
+1 ;
+2 NEW HCT,ERFLG,SEG,IBSEG
+3 SET (HCT,ICN,NAME)=""
SET ERFLG=0
+4 FOR
SET HCT=$ORDER(^TMP($JOB,"IBCNEHLI",HCT))
if HCT=""
QUIT
Begin DoDot:1
+5 DO SPAR
+6 SET SEG=$GET(IBSEG(1))
if SEG'="PID"
QUIT
+7 SET ICN=$GET(IBSEG(4))
SET NAME=$GET(IBSEG(6))
SET ERFLG=1
End DoDot:1
if ERFLG
QUIT
+8 QUIT
+9 ;
PATISSUB(IDATA0) ; check if patient is the subscriber
+1 ; IDATA0 - 0 node of file 2.312
+2 ;
+3 ; returns 1 if patient is the subscriber, 0 otherwise
+4 ;
+5 NEW PREL,RES
+6 SET RES=0
+7 ; check field 2.312/16 first
+8 SET PREL=$PIECE(IDATA0,U,16)
IF PREL'=""
if PREL="01"
SET RES=1
QUIT RES
+9 ; if 2.312/16 is empty, try field 2.312/6
+10 IF $PIECE(IDATA0,U,6)="v"
SET RES=1
+11 QUIT RES
+12 ;
ONEPOL(PIEN,IEN2) ; check if patient has only one policy on file for a given payer
+1 ; PIEN - payer ien
+2 ; IEN2 - patient ien (file 2)
+3 ;
+4 ; returns 1 if only one policy is found, 0 otherwise
+5 NEW CNT,DAYS,EXPDT,IEN36,IEN312,RES
+6 SET (CNT,RES)=0
+7 IF +$GET(PIEN)'>0!(+$GET(IEN2)'>0)
QUIT RES
+8 ;IB*702/TAZ - Get EIV NO GRP NUM A/U
+9 SET DAYS=$$GET1^DIQ(350.9,"1,",51.34,"I")
+10 SET IEN36=""
FOR
SET IEN36=$ORDER(^DIC(36,"AC",PIEN,IEN36))
if IEN36=""
QUIT
Begin DoDot:1
+11 SET IEN312=""
FOR
SET IEN312=$ORDER(^DPT(IEN2,.312,"B",IEN36,IEN312))
if IEN312=""
QUIT
Begin DoDot:2
+12 ;IB*702/TAZ - Compare EIV NO GRP NUM A/U with current date
+13 SET EXPDT=$$GET1^DIQ(2.312,IEN312_","_IEN2_",",3,"I")
+14 ;don't count for auto-update purposes
IF +EXPDT
IF $$FMDIFF^XLFDT(DT,EXPDT)>DAYS
QUIT
+15 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+16 IF CNT=1
SET RES=1
+17 QUIT RES
+18 ;
MCRDT(RIEN,EBIEN) ; find effective date for Medicare response
+1 ; RIEN - file 365 ien
+2 ; EBIEN - subfile 365.02 ien
+3 ;
+4 ; returns date in FM format or "" if effective date was not found
+5 ;
+6 NEW DONE,DTIEN,IENS,RES,Z
+7 SET RES=""
SET DONE=0
+8 SET Z=""
FOR
SET Z=$ORDER(^IBCN(365,RIEN,2,EBIEN,8,"B",Z))
if Z=""!DONE
QUIT
Begin DoDot:1
+9 SET DTIEN=$ORDER(^IBCN(365,RIEN,2,EBIEN,8,"B",Z,""))
IF 'DTIEN
QUIT
+10 SET IENS=DTIEN_","_EBIEN_","_RIEN_","
+11 ; effective date has "eligibility" qualifier
+12 IF $$GET1^DIQ(365.28,IENS,.03)=307
SET RES=$$FMDATE^HLFNC($$GET1^DIQ(365.28,IENS,.02))
SET DONE=1
+13 QUIT
End DoDot:1
+14 QUIT RES
+15 ;
ISMCR(RIEN) ; Check if response is for Medicare part A/B
+1 ; Input: RIEN - Internal ien for file 365
+2 ; Returns A1^A2^A3^A4^A5 Where:
+3 ; A1 - 1 if response if for Medicare, 0 otherwise
+4 ; A2 - "MA" if response is for Medicare Part A
+5 ; "MB" if response is for Medicare Part B
+6 ; "B" if response is for both Part A and Part B
+7 ; "" if response if not for Medicare
+8 ; A3 - Effective date for Medicare Part A if response if for
+9 ; Part A or both parts, "" otherwise
+10 ; A4 - Effective date for Medicare Part B if response if for
+11 ; Part B or both parts, "" otherwise
+12 ; A5 - "MA" - Response is for active Medicare Part A only
+13 ; "MB" - Response is for active Medicare Part B only
+14 ; "B" - Response is for active Medicare Parts A and B
+15 ; "" - Response is not for active Medicare
+16 ; IB*2.0*549 - added return of A5
+17 ;
+18 ;IB*2.0*549 added ACTIVE,TYPEA,TYPEB,ZZ
NEW ACTIVE,DONE,EBIEN,RES,TYPE,TYPEA,TYPEB,Z,ZZ
+19 ;IB*2.0*549 added ,(TYPEA,TYPEB)=0
SET RES="0^"
SET DONE=0
SET (TYPEA,TYPEB)=0
+20 IF +RIEN'>0
QUIT RES
+21 IF '$DATA(^IBCN(365,RIEN))
QUIT RES
+22 SET Z=""
FOR
SET Z=$ORDER(^IBCN(365,RIEN,2,"B",Z))
if Z=""!DONE
QUIT
Begin DoDot:1
+23 SET EBIEN=$ORDER(^IBCN(365,RIEN,2,"B",Z,""))
+24 SET TYPE=$$GET1^DIQ(365.02,EBIEN_","_RIEN_",",.05)
+25 ;
+26 ; IB*2.0*549 added next two lines
+27 SET ACTIVE=$$GET1^DIQ(365.02,EBIEN_","_RIEN_",",.02,"I")
+28 SET ACTIVE=$SELECT(ACTIVE=1:1,1:0)
+29 IF TYPE="MA"
Begin DoDot:2
+30 ;IB*2.0*549 added line
if ACTIVE
SET TYPEA=1
+31 ;IB*2.0*549 added line
SET ZZ=$PIECE(RES,U,2)
+32 SET $PIECE(RES,U)=1
SET $PIECE(RES,U,2)=$SELECT(ZZ="":"MA",ZZ="MA":"MA",1:"B")
+33 SET $PIECE(RES,U,3)=$$MCRDT(RIEN,EBIEN)
+34 ;
+35 ; IB*2.0*549 added line
+36 if ACTIVE
SET $PIECE(RES,U,5)=$SELECT((TYPEA&TYPEB):"B",1:"MA")
End DoDot:2
+37 IF TYPE="MB"
Begin DoDot:2
+38 ;IB*2.0*549 added line
if ACTIVE
SET TYPEB=1
+39 ;IB*2.0*549 added line
SET ZZ=$PIECE(RES,U,2)
+40 SET $PIECE(RES,U)=1
SET $PIECE(RES,U,2)=$SELECT(ZZ="":"MB",ZZ="MB":"MB",1:"B")
+41 SET $PIECE(RES,U,4)=$$MCRDT(RIEN,EBIEN)
+42 ;
+43 ; IB*2.0*549 added line
+44 if ACTIVE
SET $PIECE(RES,U,5)=$SELECT((TYPEA&TYPEB):"B",1:"MB")
End DoDot:2
+45 IF $PIECE(RES,U,2)="B"
SET DONE=1
End DoDot:1
+46 QUIT RES
+47 ;
ERRACT(RIEN) ; Pick error action code to use for re-transmission
+1 ; Input: RIEN - IEN in file 365 (Transmission file)
+2 ; Returns: Error action^Error condition; "" if no error found
+3 ;
+4 ; If any of C,N,S,Y action codes are found, the first one encountered is returned.
+5 ; Otherwise, if W action code is found, it is returned.
+6 ; Otherwise, if X action code is found, it is returned.
+7 ; Otherwise, one of the P,R action codes is returned.
+8 ;
+9 NEW ACODE,AIEN,ECCODE,ECIEN,DONE,IEN,RES,Z
+10 SET RES=""
+11 IF '+$GET(RIEN)
GOTO ERRACTX
+12 SET DONE=0
+13 SET Z=""
FOR
SET IEN=$ORDER(^IBCN(365,RIEN,6,"B",Z))
if Z=""!DONE
QUIT
Begin DoDot:1
+14 SET IEN=+$ORDER(^IBCN(365,RIEN,6,"B",Z,""))
+15 if 'IEN
QUIT
+16 SET ECIEN=+$PIECE(^IBCN(365,RIEN,6,IEN,0),U,3)
+17 if 'ECIEN
QUIT
+18 SET AIEN=+$PIECE(^IBCN(365,RIEN,6,IEN,0),U,4)
+19 if 'AIEN
QUIT
+20 SET ACODE=$PIECE(^IBE(365.018,AIEN,0),U)
SET ECCODE=$PIECE(^IBE(365.017,ECIEN,0),U)
+21 ;
+22 ; One of "do not retransmit" codes
+23 IF ".C.N.S.Y"[("."_ACODE_".")
SET RES=ACODE_U_ECCODE
SET DONE=1
QUIT
+24 ;
+25 ; Retransmit after 30 days code
+26 IF ACODE="W"
SET RES=ACODE_U_ECCODE
QUIT
+27 ;
+28 ; Retransmit after 10 days code
+29 IF ACODE="X"
if RES'="W"
SET RES=ACODE_U_ECCODE
QUIT
+30 ;
+31 ; Retransmit whenever codes
+32 IF RES'="W"
IF RES'="X"
SET RES=ACODE_U_ECCODE
End DoDot:1
ERRACTX ;
+1 QUIT RES
+2 ;
NAMECMP(NAME1,NAME2) ; check if 2 names have the same first name and last name components
+1 ; NAME1, NAME2 - names to compare, should be in "last,first [middle]" format
+2 ;
+3 ; returns 1 if both first name and last name are the same between two names, returns 0 otherwise
+4 NEW NM1,NM2,RES
+5 SET RES=0
+6 SET NM1=$$HLNAME^HLFNC(NAME1)
SET NM2=$$HLNAME^HLFNC(NAME2)
+7 IF $PIECE(NM1,U)=$PIECE(NM2,U)
IF $PIECE(NM1,U,2)=$PIECE(NM2,U,2)
SET RES=1
+8 QUIT RES
+9 ;
TRNCWARN(GNUM,TRACE) ; send group number truncation warning message
+1 NEW MSG
+2 SET MSG(1)="WARNING: Group number in the Response Message from the EC has been truncated"
+3 SET MSG(2)="----------------------------------------------------------------------------"
+4 SET MSG(3)="Original group number (in the eIV response received): "_$GET(GNUM)
+5 SET MSG(4)="Truncated group number (filed into response file): "_$EXTRACT($GET(GNUM),1,17)
+6 SET MSG(5)=" "
+7 SET MSG(6)="The associated Trace # is "_$SELECT($GET(TRACE)="":"Unknown",1:TRACE)
+8 SET MSG(7)=" "
+9 DO MSG^IBCNEUT5($GET(MGRP),MSG(1),"MSG(")
+10 QUIT
+11 ;
CODECHK(RSUPDT) ; IB*2*497
+1 ; need to determine if codes and qualifiers sent in the 271 HL7 message
+2 ; are new. If code/qualifier does not exist in table then file new code into table
+3 ; input -
+4 ; RSUPDT = FDA array that will be passed to the DBS filer to update the
+5 ; entry/subentry into the IIV RESPONSE file
+6 ; example: RSUPDT(365.02,IENS,".02") = data to be filed into 365.02 subfile at field .02
+7 ; order through the RSUPDT array and determine if pointer to file
+8 ; if pointer to file then pass file name and value of code/qualifier
+9 ;
+10 ; IB*752 Fix existing bug - only allow certain files to be updated. See array XXFILE.
+11 ;
+12 NEW IBXMY,IENS,FLD,FILE,FSCMSG,RES,SITE,SITENUM,TOFILE,NEWARRY,XX,XXFILE,Z,ZIENS
+13 SET (IENS,FILE,FLD)=""
SET Z=0
+14 ;IB*771/DW Add original set of tables
FOR XX=11:1:18,21
SET XXFILE("365.0"_XX)=""
+15 FOR XX=22:1:29,31:1:39,41:1:46
SET XXFILE("365.0"_XX)=""
+16 FOR
SET FILE=$ORDER(RSUPDT(FILE))
if FILE=""
QUIT
FOR
SET IENS=$ORDER(RSUPDT(FILE,IENS))
if IENS=""
QUIT
Begin DoDot:1
+17 FOR
SET FLD=$ORDER(RSUPDT(FILE,IENS,FLD))
if FLD=""
QUIT
Begin DoDot:2
+18 ; value was not sent by payer; no need to continue
if RSUPDT(FILE,IENS,FLD)=""
QUIT
+19 ; get the name of the file that is pointed to (if any)
DO FIELD^DID(FILE,FLD,"","POINTER","RES")
+20 ; field is not defined as a pointer to a file
if RES("POINTER")=""
QUIT
+21 ; example: RES("POINTER")="IBE(365.011,"
SET TOFILE=$PIECE($PIECE(RES("POINTER"),","),"(",2)
+22 if +TOFILE=0
QUIT
+23 ;IB*752
IF '$DATA(XXFILE(TOFILE))
QUIT
+24 ; code is already in file. No need to update the pointed-to-file
if $$FIND1^DIC(TOFILE,"","X",RSUPDT(FILE,IENS,FLD))
QUIT
+25 SET Z=Z+1
SET ZIENS="+"_Z_","
+26 ; code passed into VistA from 271 message
SET NEWARRY(TOFILE,ZIENS,.01)=RSUPDT(FILE,IENS,FLD)
+27 ; Description of code
SET NEWARRY(TOFILE,ZIENS,.02)="OTHER"
+28 ; INACTIVE FLAG
SET NEWARRY(TOFILE,ZIENS,.03)=0
+29 ; FSC CONTROLLED ;IB*752 indicate not controlled
SET NEWARRY(TOFILE,ZIENS,.05)=0
+30 ;IB*752/CKB - notify FSC that a new code was learned on the fly
+31 SET SITE=$$SITE^VASITE
SET SITENUM=$PIECE(SITE,U,3)
+32 SET FSCMSG=TOFILE_U_SITENUM_U_RSUPDT(FILE,IENS,FLD)_U_$$GET1^DIQ(365,$GET(RIEN)_",",.09)
+33 DO MSG005^IBCNEMS1(FSCMSG)
+34 ;IB*771/DW Corrected call to send to FSC outlook address (was sent in wrong parameter)
+35 ;D MSG^IBCNEUT5("FSCECADMIN@domain.ext","X12 271 VistA tables, site #"_SITENUM_" new code added","MSG(")
+36 SET IBXMY=""
IF $$PROD^XUPROD(1)
SET IBXMY("FSCECADMIN@domain.ext")=""
+37 DO MSG^IBCNEUT5(,"X12 271 VistA tables, site #"_SITENUM_" new code added","MSG(",,.IBXMY)
End DoDot:2
End DoDot:1
+38 IF $DATA(NEWARRY)
DO UPDATE^DIE("","NEWARRY")
+39 QUIT
+40 ;
PREL(FILE,FIELD,CODE) ; IB*2*497 code from x12 271 message may need to be converted to 'other' if there is no match. Refer to tag SETLST
+1 ;
+2 ; INPUT - FILE = file # of the file that will be evaluated
+3 ; FIELD = field # that is defined with the SET OF CODE values
+4 ; CODE = patient relationship code sent by the X12 271 message
+5 ; OUTPUT - = converted or non-converted coded value
+6 NEW STRING,CODESTR,ARRAY,VAL,I,DEF
+7 SET CODE=$GET(CODE)
+8 ; quit when code was not sent from payer
IF CODE=""
QUIT CODE
+9 DO FIELD^DID(FILE,FIELD,"","TYPE","DEF")
+10 IF DEF("TYPE")="SET"
Begin DoDot:1
+11 SET CODESTR=$PIECE($GET(^DD(FILE,FIELD,0)),U,3)
+12 FOR I=1:1
SET VAL=$PIECE($PIECE(CODESTR,";",I),":")
if VAL=""
QUIT
SET ARRAY(VAL)=$PIECE($PIECE(CODESTR,";",I),":",2)
End DoDot:1
+13 ; if coded value does not exist in the array of codes then this is a new code sent by X12 271 message and will default to OTHER
QUIT $SELECT($DATA(ARRAY(CODE)):CODE,1:"G8")
+14 ;
SETLST ; SET OF CODES defined to 355.33,60.14 and 2.312,4.03; this tag is not referenced in any procedure. It's here for documentation purposes.
+1 ;;01^SPOUSE
+2 ;;18^SELF
+3 ;;19^CHILD
+4 ;;20^EMPLOYEE
+5 ;;29^SIGNIFICANT OTHER
+6 ;;32^MOTHER
+7 ;;33^FATHER
+8 ;;39^ORGAN DONOR
+9 ;;41^INJURED PLAINTIFF
+10 ;;53^LIFE PARTNER
+11 ;;G8^OTHER RELATIONSHIP
