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

IBMFNHLI.m

Go to the documentation of this file.
  1. IBMFNHLI ;ALB/YMG - HL7 Process Incoming MFN Messages ;14-SEP-2015
  1. ;;2.0;INTEGRATED BILLING;**517,668**;21-MAR-94;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ; entry point
  1. Q ; dw/IB*2.0*668 . April 2021 ... Added this quit & took the option
  1. ; " Health Care Services Review (HCSR) Worklist "
  1. ; [IBT HCSR WORKLIST] out of order. We also added the instructions
  1. ; below which need to be reviewed and considered before this
  1. ; routine is restored.
  1. ;
  1. ; BEFORE RESTORING THIS ROUTINE, review the file #365.12 as the
  1. ; layout changed. The following fields moved or were dropped
  1. ; as obsolete. PAYER file #365.12, subfile APPLICATION #365.121
  1. ; fields (#.07, .08, .09, .1, .11, .12, .14, .15). Renamed the following fields
  1. ; on the PAYER file: (#365.121,.02), (#365.121, .03),
  1. ; (#365.1212, 2) and (#365.1213, 3).
  1. ;
  1. ; The file PAYER APPLICATION #365.13 changed ... the application "IIV" was renamed
  1. ; to "EIV" with IB*2.0*668
  1. ;
  1. ; This routine has code to update file #350.9. This should be
  1. ; reconsidered as no one recalls that being in the original scope
  1. ; of the purpose of this routine for X12 278 logic. Discuss this X12 278
  1. ; logic with eBiz eBilling and eInsurance business teams BEFORE
  1. ; restoring this routine and the associated option listed above.
  1. ;
  1. ; end of changes IB*2.0*668
  1. ;
  1. N APP,CNT,DATA,DATAMFK,DESC,FLN,FSVDY,HCT,HEDI,HLECH,HLFS,HLREP,IBCNACT,IBCNADT,IBSEG,ID,MSG,MSGID,NAFLG
  1. N NEWID,NPFLG,PEDI,PSVDY,REQSUB,SEG,SEGCNT,STAT,STOPFLG,SUBJ,TRUSTED,TSSN,X12TABLE,Z
  1. ;
  1. K ^TMP("IBMFNHLI",$J)
  1. S SUBJ="Incoming table update HL7 message problem" ; subject line for mailman error messages
  1. ; Initialize the HL7 variables
  1. D INIT^HLFNC2("IB TBLUPD IN",.HL)
  1. S HLFS=HL("FS"),HLECH=$E(HL("ECH"),1),HLREP=$E(HL("ECH"),2)
  1. ; put message into a TMP global
  1. F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
  1. .S CNT=0,^TMP("IBMFNHLI",$J,SEGCNT,CNT)=HLNODE
  1. .F S CNT=$O(HLNODE(CNT)) Q:'CNT S ^TMP("IBMFNHLI",$J,SEGCNT,CNT)=HLNODE(CNT)
  1. .Q
  1. S SEG=$G(^TMP("IBMFNHLI",$J,1,0))
  1. I $E(SEG,1,3)'="MSH" D G ENX
  1. .S MSG(1)="MSH Segment is not the first segment found"
  1. .S MSG(2)="Please call the Help Desk and report this problem."
  1. .D MSG(SUBJ,"MSG(")
  1. .Q
  1. S MSGID=$P(SEG,HLFS,10) ; HL7 message control id
  1. ; build list of dictionary file numbers that can be updated (table updates)
  1. F Z=1,11:1:19,2,21:1:23 S X12TABLE("356.0"_Z)=""
  1. F Z=11:1:18 S X12TABLE("365.0"_Z)=""
  1. F Z=21:1:28 S X12TABLE("365.0"_Z)=""
  1. S X12TABLE(350.9)=""
  1. ; Decide if message belongs to "E-Pharm", "eIV", or "HCSR"
  1. S APP="",HCT=0,FLN=""
  1. F S HCT=$O(^TMP("IBMFNHLI",$J,HCT)) Q:HCT="" D SPAR I $G(IBSEG(1))="MFI" S FLN=$P($G(IBSEG(2)),$E(HLECH,1),1) Q
  1. I ",366.01,366.02,366.03,365.12,355.3,"[(","_FLN_",") S APP="E-PHARM"
  1. I $E(FLN,1,5)="356.0" S APP="HCSR"
  1. I $E(FLN,1,5)="365.0" S APP="IIV"
  1. I FLN=365.12 S (STOPFLG,HCT)=0 F S HCT=$O(^TMP("IBMFNHLI",$J,HCT)) Q:HCT="" D Q:STOPFLG
  1. .D SPAR I $G(IBSEG(1))="ZPA" S APP=$G(IBSEG(3)) S:APP'="" STOPFLG=1
  1. .Q
  1. ; If unable to determine application, then quit
  1. I APP="" D G ENX
  1. .S MSG(1)="Unable to determine application this message is for"
  1. .S MSG(2)="Message control id: "_MSGID
  1. .D MSG(SUBJ,"MSG(")
  1. .Q
  1. ;
  1. S HCT=1,(NAFLG,NPFLG,STOPFLG)=0,Z=""
  1. F S HCT=$O(^TMP("IBMFNHLI",$J,HCT)) Q:HCT="" D Q:STOPFLG
  1. .D SPAR S SEG=$G(IBSEG(1))
  1. .I SEG="MFI" D
  1. ..S FLN=$P($G(IBSEG(2)),$E(HLECH,1),1)
  1. ..I APP="E-PHARM" D
  1. ...; Initialize MFK Message (Application Acknowledgement) variables
  1. ...S DATAMFK("MFI-1")=$G(IBSEG(2)) ; Master File Identifier
  1. ...S DATAMFK("MFI-3")=$G(IBSEG(4)) ; File-Level Event Code
  1. ...Q
  1. ..Q
  1. .I SEG="MFE" D
  1. ..I $G(FLN)="" S STOPFLG=1 D Q
  1. ...S MSG(1)="File Number not found in MFN message"
  1. ...S MSG(2)="Message control id: "_MSGID
  1. ...D MSG(SUBJ,"MSG(")
  1. ...Q
  1. ..I '$$VFILE^DILFD(FLN) S STOPFLG=1 D Q
  1. ...S MSG(1)="File "_FLN_" not found in the Data Dictionary"
  1. ...S MSG(2)="Message control id: "_MSGID
  1. ...D MSG(SUBJ,"MSG(")
  1. ...Q
  1. ..I APP="E-PHARM" D
  1. ...; Initialize MFK Message (Application Acknowledgement) variables
  1. ...S DATAMFK("MFE-1")=$G(IBSEG(2)) ; Record-Level Event Code
  1. ...S DATAMFK("MFE-4")=$G(IBSEG(5)) ; Primary Key Value
  1. ...S DATAMFK("MFE-5")=$G(IBSEG(6)) ; Primary Key Value Type
  1. ...; Transfer control to e-Pharmacy
  1. ...D ^IBCNRHLT
  1. ...Q
  1. ..I APP="IIV"!(APP="HCSR") D
  1. ...I FLN'=365.12 D Q
  1. ....S DATA=$G(IBSEG(5))
  1. ....S ID=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),1)),DESC=$$DECHL7^IBCNEHL2($P(DATA,$E(HLECH,1),2))
  1. ....D TFIL
  1. ....Q
  1. ...S IBCNACT=$G(IBSEG(2)) ; Pull the action code
  1. ...S IBCNADT=$G(IBSEG(4)) ; Effective Date
  1. ...Q
  1. ..Q
  1. .I SEG="ZP0" D
  1. ..I APP="IIV"!(APP="HCSR") D
  1. ...S ID=$$DECHL7^IBCNEHL2(IBSEG(3)),NEWID=$$DECHL7^IBCNEHL2(IBSEG(4))
  1. ...S DESC=$$DECHL7^IBCNEHL2(IBSEG(5)),HEDI=$$DECHL7^IBCNEHL2(IBSEG(6)),PEDI=$$DECHL7^IBCNEHL2(IBSEG(7))
  1. ...Q
  1. ..I APP="E-PHARM" D ^IBCNRHLT
  1. ..Q
  1. .I SEG="ZPA" D
  1. ..I APP="IIV"!(APP="HCSR") D
  1. ...S STAT=$S(IBSEG(4)="Y":1,1:0),TSSN=IBSEG(5),REQSUB=IBSEG(7)
  1. ...S FSVDY=IBSEG(8),PSVDY=IBSEG(9),TRUSTED=$S(IBSEG(10)="N":0,1:1)
  1. ...D PFIL
  1. ...Q
  1. ..Q
  1. .; Transfer control to e-Pharmacy on other segments
  1. .I ",ZCM,ZPB,ZPL,ZPT,ZRX,"[(","_SEG_","),APP="E-PHARM" D ^IBCNRHLT
  1. .Q
  1. ;
  1. ; Send MFK Message (Application Acknowledgement)?
  1. I HL("APAT")="AL",$G(EPHARM),'STOPFLG D ^IBCNRMFK
  1. ;
  1. ENX ; exit point
  1. K ^TMP("IBMFNHLI",$J),HL,HLNEXT,HLNODE,HLQUIT
  1. Q
  1. ;
  1. PFIL ; Payer Table Filer
  1. ; Set the action:
  1. ; MAD=Add, MUP=Update, MDC=Deactivate, MAC=Reactivate
  1. N AIEN,APIEN,IBAPP,IBCNTYPE,IBDESC,IBID,IBNOK,IBSTR,IEN,OLDAF,OLDTF
  1. N DA,DD,DIC,DIE,DLAYGO,DO,DR,X,Y
  1. ;
  1. S IBNOK=0,IBAPP=($TR(APP," ")="")
  1. S IBCNADT=$$FMDATE^HLFNC(IBCNADT)
  1. I IBCNADT="" S IBCNADT=$$NOW^XLFDT()
  1. ; If the action is MAD - Add the payer as new
  1. I IBCNACT="MAD" D I IBNOK G PFILX
  1. .; Check certain required fields: Application, VA National & Payer Name
  1. .; If not populated, send MailMan message.
  1. .S IBID=($TR(ID," ")=""),IBDESC=($TR(DESC," ")="")
  1. .S IBNOK=IBAPP!IBID!IBDESC
  1. .I 'IBNOK D MAD(DESC) Q
  1. .S IBSTR="" I IBAPP S IBSTR="Application"
  1. .I IBID S:IBSTR]"" IBSTR=IBSTR_", " S IBSTR=IBSTR_"VA National"
  1. .I IBDESC S:IBSTR]"" IBSTR=IBSTR_", " S IBSTR=IBSTR_"Payer Name"
  1. .S MSG(1)="MAD action received. "_IBSTR_" unknown."
  1. .S MSG(2)="Message control id: "_MSGID
  1. .D MSG(SUBJ,"MSG(")
  1. .Q
  1. I IBCNACT'="MAD" D FND
  1. I IEN<1!IBAPP D G PFILX
  1. .S IBCNTYPE=$S(IBCNACT="MAD":"Add",IBCNACT="MUP":"Update",IBCNACT="MDC":"Deactivate",IBCNACT="MAC":"Reactivate",1:"Unknown")
  1. .S MSG(1)=IBCNTYPE_" ("_IBCNACT_") action received. Payer and/or Application may be unknown."
  1. .S MSG(2)="Message control id: "_MSGID
  1. .S MSG(3)="VA National : "_ID
  1. .S MSG(4)="Payer Name : "_DESC
  1. .S MSG(5)="Application : "_APP
  1. .S MSG(6)=""
  1. .S MSG(7)="Log a Remedy Ticket for this issue."
  1. .S MSG(8)=""
  1. .S MSG(9)="Please include in the Remedy Ticket that VISTA did not receive the required"
  1. .S MSG(10)="information or the accurate information to add/update this Payer."
  1. .D MSG(SUBJ,"MSG(")
  1. .Q
  1. ;
  1. S DESC=$E(DESC,1,80) ;restriction of the field in the DD
  1. S DIC=$$ROOT^DILFD(FLN)
  1. S DR=".01///^S X=DESC;.02////^S X=NEWID;.05////^S X=PEDI;.06////^S X=HEDI"
  1. ; If new payer, add the Date/Time created
  1. I NPFLG S DR=DR_";.04///^S X=$$NOW^XLFDT()"
  1. S DIE=DIC,DA=IEN D ^DIE
  1. ; currently there's nothing to file on application level for HCSR, so we can bail if HCSR application
  1. I APP="HCSR" G PFILX
  1. ;
  1. ; Check for application
  1. S DIC="^IBE(365.13,",DIC(0)="X",X=APP D ^DIC
  1. S AIEN=+Y I AIEN<1 D
  1. .S DLAYGO=365.13,DIC(0)="L",DIC("P")=DLAYGO
  1. .S DIE=DIC,X=APP
  1. .K DD,DO D FILE^DICN K DO
  1. .S AIEN=+Y
  1. .Q
  1. ;
  1. S APIEN=$O(^IBE(365.12,IEN,1,"B",AIEN,""))
  1. I APIEN="" D
  1. .S DLAYGO=365.121,DIC(0)="L",DIC("P")=DLAYGO,DA(1)=IEN,X=AIEN
  1. .S DIC="^IBE(365.12,"_DA(1)_",1,",DIE=DIC
  1. .K DD,DO D FILE^DICN K DO
  1. .S APIEN=+Y,NAFLG=1
  1. ; get current values for Active and Trusted flags
  1. S OLDAF=$P(^IBE(365.12,IEN,1,APIEN,0),U,2),OLDTF=$P(^IBE(365.12,IEN,1,APIEN,0),U,7)
  1. S DA(1)=IEN,DA=APIEN,DIC="^IBE(365.12,"_DA(1)_",1,",DR=""
  1. ;
  1. I IBCNACT="MDC" S DR=DR_".11///^S X=1;.12////^S X=IBCNADT;",STAT=0
  1. I IBCNACT="MAC" S DR=DR_".11///^S X=0;.12///@;"
  1. S DR=DR_".02///^S X=STAT;.06///^S X=$$NOW^XLFDT()"
  1. I APP="IIV" D
  1. .S DR=DR_";.07///^S X=TRUSTED"
  1. .I IBCNACT'="MDC" S DR=DR_";.08///^S X=REQSUB;.1///^S X=TSSN;.14///^S X=FSVDY;.15///^S X=PSVDY"
  1. .Q
  1. ; if new application, add the Date/Time created
  1. I NAFLG S DR=DR_";.13///^S X=$$NOW^XLFDT()"
  1. ;
  1. S DIE=DIC D ^DIE
  1. ; Update flag logs
  1. I APP="IIV" D
  1. .I STAT'=OLDAF D UPDLOG("A",STAT,IEN,APIEN)
  1. .I TRUSTED'=OLDTF D UPDLOG("T",TRUSTED,IEN,APIEN)
  1. .Q
  1. I IBCNACT="MDC" D MDC Q
  1. PFILX ;
  1. Q
  1. ;
  1. TFIL ; Non Payer Tables Filer
  1. N DA,DIC,DIE,DLAYGO,IEN,MAX,X,Y
  1. ;
  1. ; store the FILENAME, FIELDNAME and VALUE if the APP is IIV and FLN is 350.9.
  1. ; For file #350.9, DESC represents the FIELD NUMBER and ID represents the VALUE.
  1. I APP="IIV",FLN=350.9 D Q
  1. .S DIE=FLN,DA=1,DR=DESC_"///"_ID
  1. .D ^DIE
  1. .Q
  1. ;
  1. S DIC(0)="X",X=ID,DIC=$$ROOT^DILFD(FLN)
  1. D ^DIC S IEN=+Y
  1. ; don't update existing entries
  1. I IEN>0 Q
  1. ;
  1. D FIELD^DID(FLN,.02,,"FIELD LENGTH","MAX")
  1. I MAX("FIELD LENGTH")>0 S DESC=$E(DESC,1,MAX("FIELD LENGTH")) ; restriction of the field in the DD
  1. ; add new entry to the table
  1. S DLAYGO=FLN,DIC(0)="L",DIC("DR")=".02///^S X=DESC"
  1. K DD,DO D FILE^DICN K DO
  1. Q
  1. ;
  1. MAD(X) ; Add an entry
  1. D FND
  1. I IEN>0 G MADX
  1. N DD,DIC,DIE,DLAYGO,DO,Y
  1. S DIC=$$ROOT^DILFD(FLN)
  1. S DLAYGO=FLN,DIC(0)="L",DIC("P")=DLAYGO,DIE=DIC
  1. K DD,DO D FILE^DICN K DO
  1. S IEN=+Y,NPFLG=1
  1. MADX ;
  1. Q
  1. ;
  1. FND ; Find an existing Payer entry
  1. N D,DIC,X,Y
  1. S X=ID,DIC(0)="X",D="C",DIC=$$ROOT^DILFD(FLN)
  1. ; do a lookup with the "C" cross-reference
  1. D IX^DIC S IEN=+Y
  1. Q
  1. ;
  1. MDC ; Check for active transmissions and cancel
  1. N BUFF,HIEN,RIEN,STA,TQIEN
  1. F STA=1,2,4,6 S TQIEN="" D
  1. .F S TQIEN=$O(^IBCN(365.1,"AC",STA,TQIEN)) Q:TQIEN="" D
  1. ..; If the record doesn't match the payer, quit
  1. ..I $P(^IBCN(365.1,TQIEN,0),U,3)'=IEN Q
  1. ..; Set the status to 'Cancelled'
  1. ..D SST^IBCNEUT2(TQIEN,7)
  1. ..; If a buffer entry, set to ! (bang)
  1. ..S BUFF=$P(^IBCN(365.1,TQIEN,0),U,5)
  1. ..I BUFF'="" D BUFF^IBCNEUT2(BUFF,17)
  1. ..; Change any responses status also
  1. ..S HIEN=0 F S HIEN=$O(^IBCN(365.1,TQIEN,2,HIEN)) Q:'HIEN D
  1. ...S RIEN=$P(^IBCN(365.1,TQIEN,2,HIEN,0),U,3)
  1. ...; If the Response status is 'Response Received', don't change it
  1. ...I $P(^IBCN(365,RIEN,0),U,6)=3 Q
  1. ...D RSP^IBCNEUT2(RIEN,7)
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. UPDLOG(FLAG,VALUE,PIEN,APIEN) ; Update active/trusted flag logs
  1. ; FLAG - "A" for Active flag, "T" for Trusted flag
  1. ; VALUE - new flag value (0 or 1)
  1. ; PIEN - ien in PAYER file (365.12)
  1. ; APIEN - ien in APPLICATION sub-file (365.121)
  1. ;
  1. N FILE,IENSTR,UPDT
  1. I $G(FLAG)=""!($G(VALUE)="") Q
  1. I +$G(PIEN)=0!(+$G(APIEN)=0) Q
  1. S FILE=$S(FLAG="A":"365.1212",FLAG="T":"365.1213",1:"") I FILE="" Q
  1. S IENSTR="+1,"_APIEN_","_PIEN_","
  1. S UPDT(FILE,IENSTR,.01)=$$NOW^XLFDT()
  1. S UPDT(FILE,IENSTR,.02)=VALUE
  1. D UPDATE^DIE("E","UPDT")
  1. Q
  1. ;
  1. MSG(XMSUB,XMTEXT) ; Send a MailMan Message related to table update HL7 interface
  1. ;
  1. ; Input Parameters
  1. ; XMSUB = Subject Line (required)
  1. ; XMTEXT = Message Text Array Name in open format: "MSG(" (required)
  1. ;
  1. ; New MailMan variables and also some FileMan variables. The FileMan
  1. ; variables are used and not cleaned up when sending to external
  1. ; internet addresses.
  1. N DIFROM,XMDUZ,XMDUN,XMZ,XMMG,XMSTRIP,XMROU,XMY,XMYBLOB
  1. N D0,D1,D2,DG,DIC,DICR,DISYS,DIW
  1. N MGRP,TMPSUB,TMPTEXT,TMPY,XX
  1. ;
  1. S XMDUZ=.5 ; send from postmaster DUZ
  1. ; mail group to send message to
  1. S MGRP="IBTUPD MESSAGE" I $G(MGRP)'="" S XMY("G."_MGRP)=""
  1. ; Store off subject, array reference and array of recipients
  1. S TMPSUB=XMSUB,TMPTEXT=XMTEXT
  1. M TMPY=XMY
  1. D ^XMD
  1. ;
  1. ; Error logic
  1. ; If there's an error message and the message was not originally sent
  1. ; to the postmaster, then send a message to the postmaster with this
  1. ; error message.
  1. ;
  1. I $D(XMMG),'$D(TMPY(.5)) D
  1. .S XMY(.5)="",XMTEXT=TMPTEXT,XMSUB="MailMan Error"
  1. .; Add XMMG error message as the first line of the message
  1. .S XX=999999
  1. .F S XX=$O(@(XMTEXT_"XX)"),-1) Q:'XX S @(XMTEXT_"XX+3)")=@(XMTEXT_"XX)")
  1. .S @(XMTEXT_"1)")=" MailMan Error: "_XMMG
  1. .S @(XMTEXT_"2)")="Original Subject: "_TMPSUB
  1. .S @(XMTEXT_"3)")="------Original Message------"
  1. .D ^XMD
  1. .Q
  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. K IBSEG
  1. S ISCT="",II=0,IS=0 F S ISCT=$O(^TMP("IBMFNHLI",$J,HCT,ISCT)) Q:ISCT="" D
  1. .S IS=IS+1,ISDATA(IS)=$G(^TMP("IBMFNHLI",$J,HCT,ISCT))
  1. .I $O(^TMP("IBMFNHLI",$J,HCT,ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
  1. .S ISPEC(IS)=$L(ISDATA(IS),HLFS)
  1. .Q
  1. ;
  1. S IM=0,LSDATA=""
  1. F S IM=IM+1 Q:IM>IS D
  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^IBCNEHLU($P(LSDATA,HLFS,IJ),$E(HL("ECH"),1,2)_$E(HL("ECH"),4),$E(HL("ECH")))
  1. ..Q
  1. .S LSDATA=$P(LSDATA,HLFS,NPC)
  1. .Q
  1. Q