- 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 Feb 18, 2025@23:41:12 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