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

IBCNEHLU.m

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