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