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 Apr 09, 2024@21:06:50 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
