IBCESRV ;ALB/TMP - Server interface to IB from Austin ;8/6/03 10:04am
;;2.0;INTEGRATED BILLING;**137,181,196,232,296,320,407,623,641**;21-MAR-94;Build 61
;;Per VA Directive 6402, this routine should not be modified.
SERVER ; Entry point for server option to process EDI msgs received from Austin
;
N IBEFLG,IBERR,IBTDA,XMER,IBXMZ,IBHOLDCT
K ^TMP("IBERR",$J),^TMP("IBMSG",$J),^TMP("IBMSGH",$J),^TMP("IB-HOLD",$J),^TMP("IBMSG-H",$J)
S IBXMZ=$G(XMZ)
S IBEFLG=$$MSG(.XMER,.IBTDA,IBXMZ)
D:$G(IBEFLG) PERROR^IBCESRV1(.IBERR,.IBTDA,"G.IB EDI",IBXMZ)
N ZTREQ
D DKILL^IBCESRV1(IBXMZ) S ZTREQ="@"
K ^TMP("IBERR",$J),^TMP("IBMSG",$J),^TMP("IBMSGH",$J),^TMP("IB-HOLD",$J),^TMP("IBMSG-H",$J)
Q
;
MSG(XMER,IBTDA,IBXMZ) ; Read/Store message lines
;
I '$D(XMER) S XMER="" ;JWS IB*2.0*623
; Return message formats:
; Ref: Your <queue name> message #<msg#> with Austin ID #<id #>,
; is assigned confirmation number <confirmation #>.
; Generates an 837REC0 message
; 277STAT - claim status messages - Generates one or more 837REC1
; 837REC2 or 837REJ1 messages
; 837DEL - bill entry # from File 364
; 835EOB - Explanation of Benefits messages
; REPORT - Free text Envoy report file - may contain one or more
; reports that are turned into bulletins
;
; OUTPUT:
; Function returns flag ... 0 = no errors 1 = errors
; IBTDA - array subscripted by ien of message file entries created
; If array entry = 1, the message was only partially stored
;
N IBLAST,IBTYP,IBTYP1,IB0,IBBTCH,IBDATE,IBHD,IBMG,IBRTN,IBTXN,IBTXND,XMDUZ,IBGBL,IBD,IBEFLG,IBHOLDCT,IBWANT,X,Y,Z
K ^TMP("IBERR",$J),^TMP("IBMSG",$J),^TMP("IBMSGH",$J),^TMP("IB-HOLD",$J)
;
S (IBEFLG,IBERR,IBTXN)="",IBGBL="IBTXN",IBLAST=0
S IBD("MSG#")=IBXMZ
S IBHD=$$NET^XMRENT(IBXMZ)
S IBD("SUBJ")=$P(IBHD,U,6)
S (X,IBDATE)=$P(IBHD,U)
I X'="" D ;Reformat date, if needed
. I X'["@" S X=$P(X," ",1,3)_"@"_$P(X," ",4)
. N %DT
. S %DT="XTS" D ^%DT S:Y>0 IBDATE=Y\.0001*.0001
;
K ^TMP("IB-HOLD",$J) N IBHOLDCT S IBHOLDCT=0
S IBD("Q")=$E(IBD("SUBJ"),1,3)
I $G(IBD("SUBJ"))?.E1(1" MCR",1" MCT",1" MCH")1" Confirmation" D G MSGQ:$G(IBERR),MSG1
. S IBD("Q")="MC"_$E($P(IBD("SUBJ")," MC",2))
. ;Austin confirmation
. X XMREC ; Line 1 of message
. S:XMER'<0 IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
. I XMER<0 D Q
.. S IBERR=3
.. S ^TMP("IBERR",$J,"MSG",1)=IBHD
.. S ^TMP("IBERR",$J,"MSG",2)=$G(XMRG)
. ;JWS;IB*2.0*641;initialize IBBTCH=0
. S IBTXN=XMRG,IBBTCH=0
. ;JWS;IB*2.0*641v15;don't want to take chance if value matches in FHIR, check if FHIR is off
. I '$$GET1^DIQ(350.9,"1,",8.21,"I") S IBBTCH=+$O(^IBA(364.1,"MSG",+$P(IBTXN,"#",2)\1,""),-1)
. ;;JWS;IB*2.0*623 - looking for original message #, but there won't be one
. ;;JWS;IB*2.0*641v14;wrong value was being passed as Batch number pointer
. ;; old 623 I 'IBBTCH S IBBTCH=$P($P(IBTXN,"#",2),")")
. ;;JWS;IB*2.0*641v15;clean up getting IBBTCH internal pointer value, check for 837 FHIR on
. I $$GET1^DIQ(350.9,"1,",8.21,"I") S IBBTCH=+$P(IBTXN,"(",3) I IBBTCH S IBBTCH=$O(^IBA(364.1,"B",IBBTCH,0))
. ;I 'IBBTCH S IBBTCH=$P($P($P(IBTXN,"#",2),"(",2),")") I IBBTCH S IBBTCH=$O(^IBA(364.1,"B",IBBTCH,0))
. I 'IBBTCH S IBERR=6 D REST(.IBTXN,IBGBL) Q ;No msgs match conf recpt
. S IBTXN("BATCH",IBBTCH,0)="837REC0^"_IBD("MSG#")_U_+$E($P(IBD("SUBJ")," "),4,14)_"^^"_IBBTCH_U_IBDATE
. X XMREC ;Get second line of the message
. I XMER<0 S IBERR=2 Q
. S IBTXN("BATCH",IBBTCH,1)=IBTXN_" "_XMRG_"$",IBTXN=IBTXN("BATCH",IBBTCH,0)
. S IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
. S IBLAST=1
. Q
; Read header line of non-confirmation message (line 1)
F X XMREC Q:$S(XMER<0:1,1:$E(XMRG,1,13)'="RACUBOTH RUCH")
S:XMER'<0 IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
I XMER<0 D G MSGQ
. S IBERR=3
. S ^TMP("IBERR",$J,"MSG",1)=IBHD
. S ^TMP("IBERR",$J,"MSG",2)=$G(XMRG)
;
S IBTXN=XMRG
MSG1 I $E(IBTXN,$L(IBTXN)-3,$L(IBTXN))?3A1"."!(IBTXN="NNNN"),IBHOLDCT>1 S XMER=-1,IBLAST=1 G MSGQ
;
S IBTYP1=$S($P(IBTXN,U)="277STAT":"837REC1",1:$P(IBTXN,U))
S IBTYP=$S(IBTYP1="":"",1:$O(^IBE(364.3,"B",IBTYP1,"")))
I IBTYP="" S IBERR=1 D REST(.IBTXN,IBGBL) G MSGQ ;Bad msg type
;
S IB0=$G(^IBE(364.3,IBTYP,0)),IBRTN=$P(IB0,U,3,4),IBMG=$P(IB0,U,2)
I $TR(IBRTN,U)="" S IBERR=5 D REST(.IBTXN,IBGBL) G MSGQ ;No routine defined
;
S IBWANT=1
I 'IBLAST,XMER'<0 D G:IBLAST&(XMER<0) MSGQ ;Message is other than Austin confirmation
. S IBGBL="^TMP(""IBMSG"","_$J_")"
. S @IBGBL=$P(IBTXN,U),^TMP("IBMSGH",$J,0)=IBTXN
. ;
. I $P(IBTXN,U)="277STAT" D Q ;Claim status message
.. F X XMREC Q:XMER<0 D Q:IBLAST ;Extract rest of message
... S IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
... I +XMRG=99,$P(XMRG,U,2)="$" S IBLAST=1 Q
... S IBD=XMRG,Z=+XMRG_"^IBCE277(.IBD)"
... S IBTXN=XMRG
... I '$$CKLABEL(Z,.IBTXN,IBGBL) S IBLAST=1,IBWANT=0,XMER=-1,IBERR=7 Q
... D @Z
. ;
. I $P(IBTXN,U)="835EOB" D Q ;Explanation of Benefits message
.. F X XMREC Q:XMER<0 D Q:IBLAST ;Extract rest of message
... S IBHOLDCT=IBHOLDCT+1,^TMP("IB-HOLD",$J,IBHOLDCT)=XMRG
... I +XMRG=99,$P(XMRG,U,2)="$" S IBLAST=1 Q
... S IBD=XMRG,Z=+XMRG_"^IBCE835(.IBD)"
... S IBTXN=XMRG
... I '$$CKLABEL(Z,.IBTXN,IBGBL) S IBLAST=1,IBWANT=0,XMER=-1,IBERR=7 Q
... D @Z
. ;
. I $P(IBTXN,U)="REPORT" D Q ; Report file
.. D REPORT^IBCERPT(IBHD,IBDATE,.IBD,IBTXN)
.. I '$O(^TMP("IBMSG",$J,"REPORT",0,"D",0,0)) S IBWANT=0
. ;
. ; ****** Insert code for additional message types here and in ^IBCEM
;
I IBLAST,IBWANT D ADD(IBGBL,.IBTDA,.IBERR)
;
I 'IBLAST,'$G(IBERR) K @IBGBL S IBERR=2 ;No $ as last character of message
MSGQ I $G(IBERR) D ERRUPD^IBCESRV1(IBGBL,.IBERR) S IBEFLG=1
Q IBEFLG
;
REST(IBTXN,IBGBL) ;Extract raw message data if not id-ed or can't process
N CT,Z
S CT=0
S Z=0 F S Z=$O(^TMP("IB-HOLD",$J,Z)) Q:'Z S CT=CT+1,@IBGBL@("BATCH",0,"D",0,CT)="##RAW DATA: "_$G(^TMP("IB-HOLD",$J,Z))
F X XMREC Q:XMER<0 S:XMRG'="" CT=CT+1,@IBGBL@("BATCH",0,"D",0,CT)="##RAW DATA: "_XMRG
Q
;
ADD(IBGBL,IBTDA,IBERR) ; Add message(s) in @IBGBL to file #364.2
; Errors returned in IBERR
; Message entry #'s are returned in IBTDA(ien)=""
;
N IB,IBA,IBB,IBC,IBDATA,IBHDR,IBLINE,IBTYP,IBRTN
S IBA="" F S IBA=$O(@IBGBL@(IBA)) Q:IBA=""!(IBERR=3) S IBB="" F S IBB=$O(@IBGBL@(IBA,IBB)) Q:IBB=""!(IBERR=3) D
. S IBHDR=$G(@IBGBL@(IBA,IBB,0))
. Q:IBHDR=""
. S IBTYP=$S($P(IBHDR,U)="":"",1:$O(^IBE(364.3,"B",$P(IBHDR,U),""))),IBRTN=$P($G(^IBE(364.3,IBTYP,0)),U,3,4)
. S IBTDA=$$ADDTXN(IBHDR) ;File message hdr data
. I IBTDA'>0 S IBERR=3 Q ;msg hdr can't be filed
. S IBTDA(IBTDA)=""
. D LOADDET(IBA,IBB,.IBTDA,IBGBL,.IBERR,$P(IBHDR,U,1))
. Q:$G(IBERR) ;Message not completely filed
. D TRTN^IBCESRV1(IBTDA):$TR(IBRTN,U)'="" ;Task update to run
Q
;
ADDTXN(IBDATA,REPORT) ; Add a trxn for msg in IBDATA to file 364.2
; REPORT = 1 if storing a report format message
;Function returns ien of the new entry in file 364.2 or "" if an error
;
N A,IBDA,IBBTCH,IBBILL,IBDT,IBTEST,DLAYGO,DIC,DD,DO,X,Y,Z,IBIFN
;
S IBDA="",IBBTCH=$P(IBDATA,U,5),IBBILL=$P(IBDATA,U,4),IBIFN=0
I IBBILL S IBIFN=+$G(^IBA(364,IBBILL,0))
S IBDT=$P(IBDATA,U,6)
S IBTEST=0
I $E($G(IBD("Q")),1,3)="MCT" D
. I IBBILL,'$P($G(^IBA(364,IBBILL,0)),U,7),$D(^IBM(361.4,IBIFN,0)) S IBTEST=1 Q ; Resubmit live claim for test (make sure 361.4 exists)
. I IBBTCH,$O(^IBM(361.4,"C",IBBTCH,0)) S IBTEST=1 Q ; Resubmit live claim as test batch
;
S (X,A)=$G(IBD("MSG#")) ; Use msg ID for .01 field
F Z=1:1 Q:'$D(^IBA(364.2,"B",A)) S A=X_"."_Z
S X=A
S DIC(0)="L",DIC="^IBA(364.2,",DLAYGO=364.2
S DIC("DR")=".02///"_$P(IBDATA,U)_";.03///^S X=""NOW"";.08////"_($P(IBDATA,U,7)="Y")_";.13////"_$P(IBDATA,U,8)_$S(IBBILL="":"",1:";.05////"_IBBILL)_";.06////P;.1////"_IBDT_$S(IBBTCH="":"",1:";.04////"_IBBTCH)_";.14////"_IBTEST
D FILE^DICN
S:Y>0 IBDA=+Y
;
Q IBDA
;
LOADDET(IB1,IB2,IBTDA,IBGBL,IBERR,IBTNM) ; Load the rest of the message text into the message
; IB1 = "BATCH" or "CLAIM" or "REPORT"
; IB2 = batch # or claim # or 0
; IBTDA = ien in file 364.2 being updated
; IBGBL = name of the array holding the detail message text to be loaded
; IBTNM = message name (i.e. "835EOB","837REC0","REPORT",etc.)
;
; OUTPUT: IBERR if any errors found, pass by reference
; IBTDA(IBTDA)=1 if errors - pass by reference
;
S IBTDA=+$G(IBTDA)
N CT,IB3,IBE,IBZ,Q
;
K ^TMP("IBTEXT",$J)
;
S (CT,IB3)=0 ;Put formatted data into msg
F S IB3=$O(@IBGBL@(IB1,IB2,IB3)) Q:'IB3 S CT=CT+1,^TMP("IBTEXT",$J,CT)=@IBGBL@(IB1,IB2,IB3)
; Add identifying data from hdr record
S IB3=0 F S IB3=$O(^TMP("IBMSG-H",$J,IB1,IB2,IB3)) Q:'IB3 S CT=CT+1,^TMP("IBTEXT",$J,CT)=^TMP("IBMSG-H",$J,IB1,IB2,IB3)
;
; Put raw data into msg
I $G(IBTNM)'="835EOB" D
. S IBZ="" F S IBZ=$O(@IBGBL@(IB1,IB2,"D",IBZ)) Q:IBZ="" S IB3=0 F S IB3=$O(@IBGBL@(IB1,IB2,"D",IBZ,IB3)) Q:'IB3 S CT=CT+1,^TMP("IBTEXT",$J,CT)=@IBGBL@(IB1,IB2,"D",IBZ,IB3)
I $G(IBTNM)="835EOB" D
. S IB3=0 F S IB3=$O(@IBGBL@(IB1,IB2,"D1",IB3)) Q:'IB3 S IBZ="" F S IBZ=$O(@IBGBL@(IB1,IB2,"D1",IB3,IBZ)) Q:IBZ="" S CT=CT+1,^TMP("IBTEXT",$J,CT)=@IBGBL@(IB1,IB2,"D1",IB3,IBZ)
;
D STOREM^IBCESRV2(IBTDA,"^TMP(""IBTEXT"",$J)",.IBE)
;
I $D(IBE("DIERR")) D S:$L($G(IBE)) IBERR(IBTDA,IB1,IB2)=IBE ; Extract error
. D EXTERR^IBCESRV1(.IBERR,.IBTDA,.IBE)
K ^TMP("IBTEXT",$J)
Q
;
CKLABEL(Z,IBTXN,IBGBL) ; Checks to be sure label in Z exists.
; If it doesn't exist, files an error and returns 0
; OR returns 1 if it does exist
N X,LAB
S X=1,LAB=$P(Z,"(")
I $S('LAB!($L($P(LAB,U))>8):1,1:$T(@LAB)="") S X=0 D REST(.IBTXN,IBGBL)
Q X
;
ERROR ; Error condition messages
;;Message code does not exist in IB MESSAGE ROUTER file (364.3).
;;This message has no ending $.
;;Message file problem - no message stored.
;;Message file problem - message partially stored.
;;Routine to process this message type does not exist.
;;Batch does not exist for this confirmation message.
;;Bad message format found - cannot store message.
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCESRV 10321 printed Nov 22, 2024@17:22:30 Page 2
IBCESRV ;ALB/TMP - Server interface to IB from Austin ;8/6/03 10:04am
+1 ;;2.0;INTEGRATED BILLING;**137,181,196,232,296,320,407,623,641**;21-MAR-94;Build 61
+2 ;;Per VA Directive 6402, this routine should not be modified.
SERVER ; Entry point for server option to process EDI msgs received from Austin
+1 ;
+2 NEW IBEFLG,IBERR,IBTDA,XMER,IBXMZ,IBHOLDCT
+3 KILL ^TMP("IBERR",$JOB),^TMP("IBMSG",$JOB),^TMP("IBMSGH",$JOB),^TMP("IB-HOLD",$JOB),^TMP("IBMSG-H",$JOB)
+4 SET IBXMZ=$GET(XMZ)
+5 SET IBEFLG=$$MSG(.XMER,.IBTDA,IBXMZ)
+6 if $GET(IBEFLG)
DO PERROR^IBCESRV1(.IBERR,.IBTDA,"G.IB EDI",IBXMZ)
+7 NEW ZTREQ
+8 DO DKILL^IBCESRV1(IBXMZ)
SET ZTREQ="@"
+9 KILL ^TMP("IBERR",$JOB),^TMP("IBMSG",$JOB),^TMP("IBMSGH",$JOB),^TMP("IB-HOLD",$JOB),^TMP("IBMSG-H",$JOB)
+10 QUIT
+11 ;
MSG(XMER,IBTDA,IBXMZ) ; Read/Store message lines
+1 ;
+2 ;JWS IB*2.0*623
IF '$DATA(XMER)
SET XMER=""
+3 ; Return message formats:
+4 ; Ref: Your <queue name> message #<msg#> with Austin ID #<id #>,
+5 ; is assigned confirmation number <confirmation #>.
+6 ; Generates an 837REC0 message
+7 ; 277STAT - claim status messages - Generates one or more 837REC1
+8 ; 837REC2 or 837REJ1 messages
+9 ; 837DEL - bill entry # from File 364
+10 ; 835EOB - Explanation of Benefits messages
+11 ; REPORT - Free text Envoy report file - may contain one or more
+12 ; reports that are turned into bulletins
+13 ;
+14 ; OUTPUT:
+15 ; Function returns flag ... 0 = no errors 1 = errors
+16 ; IBTDA - array subscripted by ien of message file entries created
+17 ; If array entry = 1, the message was only partially stored
+18 ;
+19 NEW IBLAST,IBTYP,IBTYP1,IB0,IBBTCH,IBDATE,IBHD,IBMG,IBRTN,IBTXN,IBTXND,XMDUZ,IBGBL,IBD,IBEFLG,IBHOLDCT,IBWANT,X,Y,Z
+20 KILL ^TMP("IBERR",$JOB),^TMP("IBMSG",$JOB),^TMP("IBMSGH",$JOB),^TMP("IB-HOLD",$JOB)
+21 ;
+22 SET (IBEFLG,IBERR,IBTXN)=""
SET IBGBL="IBTXN"
SET IBLAST=0
+23 SET IBD("MSG#")=IBXMZ
+24 SET IBHD=$$NET^XMRENT(IBXMZ)
+25 SET IBD("SUBJ")=$PIECE(IBHD,U,6)
+26 SET (X,IBDATE)=$PIECE(IBHD,U)
+27 ;Reformat date, if needed
IF X'=""
Begin DoDot:1
+28 IF X'["@"
SET X=$PIECE(X," ",1,3)_"@"_$PIECE(X," ",4)
+29 NEW %DT
+30 SET %DT="XTS"
DO ^%DT
if Y>0
SET IBDATE=Y\.0001*.0001
End DoDot:1
+31 ;
+32 KILL ^TMP("IB-HOLD",$JOB)
NEW IBHOLDCT
SET IBHOLDCT=0
+33 SET IBD("Q")=$EXTRACT(IBD("SUBJ"),1,3)
+34 IF $GET(IBD("SUBJ"))?.E1(1" MCR",1" MCT",1" MCH")1" Confirmation"
Begin DoDot:1
+35 SET IBD("Q")="MC"_$EXTRACT($PIECE(IBD("SUBJ")," MC",2))
+36 ;Austin confirmation
+37 ; Line 1 of message
XECUTE XMREC
+38 if XMER'<0
SET IBHOLDCT=IBHOLDCT+1
SET ^TMP("IB-HOLD",$JOB,IBHOLDCT)=XMRG
+39 IF XMER<0
Begin DoDot:2
+40 SET IBERR=3
+41 SET ^TMP("IBERR",$JOB,"MSG",1)=IBHD
+42 SET ^TMP("IBERR",$JOB,"MSG",2)=$GET(XMRG)
End DoDot:2
QUIT
+43 ;JWS;IB*2.0*641;initialize IBBTCH=0
+44 SET IBTXN=XMRG
SET IBBTCH=0
+45 ;JWS;IB*2.0*641v15;don't want to take chance if value matches in FHIR, check if FHIR is off
+46 IF '$$GET1^DIQ(350.9,"1,",8.21,"I")
SET IBBTCH=+$ORDER(^IBA(364.1,"MSG",+$PIECE(IBTXN,"#",2)\1,""),-1)
+47 ;;JWS;IB*2.0*623 - looking for original message #, but there won't be one
+48 ;;JWS;IB*2.0*641v14;wrong value was being passed as Batch number pointer
+49 ;; old 623 I 'IBBTCH S IBBTCH=$P($P(IBTXN,"#",2),")")
+50 ;;JWS;IB*2.0*641v15;clean up getting IBBTCH internal pointer value, check for 837 FHIR on
+51 IF $$GET1^DIQ(350.9,"1,",8.21,"I")
SET IBBTCH=+$PIECE(IBTXN,"(",3)
IF IBBTCH
SET IBBTCH=$ORDER(^IBA(364.1,"B",IBBTCH,0))
+52 ;I 'IBBTCH S IBBTCH=$P($P($P(IBTXN,"#",2),"(",2),")") I IBBTCH S IBBTCH=$O(^IBA(364.1,"B",IBBTCH,0))
+53 ;No msgs match conf recpt
IF 'IBBTCH
SET IBERR=6
DO REST(.IBTXN,IBGBL)
QUIT
+54 SET IBTXN("BATCH",IBBTCH,0)="837REC0^"_IBD("MSG#")_U_+$EXTRACT($PIECE(IBD("SUBJ")," "),4,14)_"^^"_IBBTCH_U_IBDATE
+55 ;Get second line of the message
XECUTE XMREC
+56 IF XMER<0
SET IBERR=2
QUIT
+57 SET IBTXN("BATCH",IBBTCH,1)=IBTXN_" "_XMRG_"$"
SET IBTXN=IBTXN("BATCH",IBBTCH,0)
+58 SET IBHOLDCT=IBHOLDCT+1
SET ^TMP("IB-HOLD",$JOB,IBHOLDCT)=XMRG
+59 SET IBLAST=1
+60 QUIT
End DoDot:1
if $GET(IBERR)
GOTO MSGQ
GOTO MSG1
+61 ; Read header line of non-confirmation message (line 1)
+62 FOR
XECUTE XMREC
if $SELECT(XMER<0
QUIT
+63 if XMER'<0
SET IBHOLDCT=IBHOLDCT+1
SET ^TMP("IB-HOLD",$JOB,IBHOLDCT)=XMRG
+64 IF XMER<0
Begin DoDot:1
+65 SET IBERR=3
+66 SET ^TMP("IBERR",$JOB,"MSG",1)=IBHD
+67 SET ^TMP("IBERR",$JOB,"MSG",2)=$GET(XMRG)
End DoDot:1
GOTO MSGQ
+68 ;
+69 SET IBTXN=XMRG
MSG1 IF $EXTRACT(IBTXN,$LENGTH(IBTXN)-3,$LENGTH(IBTXN))?3A1"."!(IBTXN="NNNN")
IF IBHOLDCT>1
SET XMER=-1
SET IBLAST=1
GOTO MSGQ
+1 ;
+2 SET IBTYP1=$SELECT($PIECE(IBTXN,U)="277STAT":"837REC1",1:$PIECE(IBTXN,U))
+3 SET IBTYP=$SELECT(IBTYP1="":"",1:$ORDER(^IBE(364.3,"B",IBTYP1,"")))
+4 ;Bad msg type
IF IBTYP=""
SET IBERR=1
DO REST(.IBTXN,IBGBL)
GOTO MSGQ
+5 ;
+6 SET IB0=$GET(^IBE(364.3,IBTYP,0))
SET IBRTN=$PIECE(IB0,U,3,4)
SET IBMG=$PIECE(IB0,U,2)
+7 ;No routine defined
IF $TRANSLATE(IBRTN,U)=""
SET IBERR=5
DO REST(.IBTXN,IBGBL)
GOTO MSGQ
+8 ;
+9 SET IBWANT=1
+10 ;Message is other than Austin confirmation
IF 'IBLAST
IF XMER'<0
Begin DoDot:1
+11 SET IBGBL="^TMP(""IBMSG"","_$JOB_")"
+12 SET @IBGBL=$PIECE(IBTXN,U)
SET ^TMP("IBMSGH",$JOB,0)=IBTXN
+13 ;
+14 ;Claim status message
IF $PIECE(IBTXN,U)="277STAT"
Begin DoDot:2
+15 ;Extract rest of message
FOR
XECUTE XMREC
if XMER<0
QUIT
Begin DoDot:3
+16 SET IBHOLDCT=IBHOLDCT+1
SET ^TMP("IB-HOLD",$JOB,IBHOLDCT)=XMRG
+17 IF +XMRG=99
IF $PIECE(XMRG,U,2)="$"
SET IBLAST=1
QUIT
+18 SET IBD=XMRG
SET Z=+XMRG_"^IBCE277(.IBD)"
+19 SET IBTXN=XMRG
+20 IF '$$CKLABEL(Z,.IBTXN,IBGBL)
SET IBLAST=1
SET IBWANT=0
SET XMER=-1
SET IBERR=7
QUIT
+21 DO @Z
End DoDot:3
if IBLAST
QUIT
End DoDot:2
QUIT
+22 ;
+23 ;Explanation of Benefits message
IF $PIECE(IBTXN,U)="835EOB"
Begin DoDot:2
+24 ;Extract rest of message
FOR
XECUTE XMREC
if XMER<0
QUIT
Begin DoDot:3
+25 SET IBHOLDCT=IBHOLDCT+1
SET ^TMP("IB-HOLD",$JOB,IBHOLDCT)=XMRG
+26 IF +XMRG=99
IF $PIECE(XMRG,U,2)="$"
SET IBLAST=1
QUIT
+27 SET IBD=XMRG
SET Z=+XMRG_"^IBCE835(.IBD)"
+28 SET IBTXN=XMRG
+29 IF '$$CKLABEL(Z,.IBTXN,IBGBL)
SET IBLAST=1
SET IBWANT=0
SET XMER=-1
SET IBERR=7
QUIT
+30 DO @Z
End DoDot:3
if IBLAST
QUIT
End DoDot:2
QUIT
+31 ;
+32 ; Report file
IF $PIECE(IBTXN,U)="REPORT"
Begin DoDot:2
+33 DO REPORT^IBCERPT(IBHD,IBDATE,.IBD,IBTXN)
+34 IF '$ORDER(^TMP("IBMSG",$JOB,"REPORT",0,"D",0,0))
SET IBWANT=0
End DoDot:2
QUIT
+35 ;
+36 ; ****** Insert code for additional message types here and in ^IBCEM
End DoDot:1
if IBLAST&(XMER<0)
GOTO MSGQ
+37 ;
+38 IF IBLAST
IF IBWANT
DO ADD(IBGBL,.IBTDA,.IBERR)
+39 ;
+40 ;No $ as last character of message
IF 'IBLAST
IF '$GET(IBERR)
KILL @IBGBL
SET IBERR=2
MSGQ IF $GET(IBERR)
DO ERRUPD^IBCESRV1(IBGBL,.IBERR)
SET IBEFLG=1
+1 QUIT IBEFLG
+2 ;
REST(IBTXN,IBGBL) ;Extract raw message data if not id-ed or can't process
+1 NEW CT,Z
+2 SET CT=0
+3 SET Z=0
FOR
SET Z=$ORDER(^TMP("IB-HOLD",$JOB,Z))
if 'Z
QUIT
SET CT=CT+1
SET @IBGBL@("BATCH",0,"D",0,CT)="##RAW DATA: "_$GET(^TMP("IB-HOLD",$JOB,Z))
+4 FOR
XECUTE XMREC
if XMER<0
QUIT
if XMRG'=""
SET CT=CT+1
SET @IBGBL@("BATCH",0,"D",0,CT)="##RAW DATA: "_XMRG
+5 QUIT
+6 ;
ADD(IBGBL,IBTDA,IBERR) ; Add message(s) in @IBGBL to file #364.2
+1 ; Errors returned in IBERR
+2 ; Message entry #'s are returned in IBTDA(ien)=""
+3 ;
+4 NEW IB,IBA,IBB,IBC,IBDATA,IBHDR,IBLINE,IBTYP,IBRTN
+5 SET IBA=""
FOR
SET IBA=$ORDER(@IBGBL@(IBA))
if IBA=""!(IBERR=3)
QUIT
SET IBB=""
FOR
SET IBB=$ORDER(@IBGBL@(IBA,IBB))
if IBB=""!(IBERR=3)
QUIT
Begin DoDot:1
+6 SET IBHDR=$GET(@IBGBL@(IBA,IBB,0))
+7 if IBHDR=""
QUIT
+8 SET IBTYP=$SELECT($PIECE(IBHDR,U)="":"",1:$ORDER(^IBE(364.3,"B",$PIECE(IBHDR,U),"")))
SET IBRTN=$PIECE($GET(^IBE(364.3,IBTYP,0)),U,3,4)
+9 ;File message hdr data
SET IBTDA=$$ADDTXN(IBHDR)
+10 ;msg hdr can't be filed
IF IBTDA'>0
SET IBERR=3
QUIT
+11 SET IBTDA(IBTDA)=""
+12 DO LOADDET(IBA,IBB,.IBTDA,IBGBL,.IBERR,$PIECE(IBHDR,U,1))
+13 ;Message not completely filed
if $GET(IBERR)
QUIT
+14 ;Task update to run
if $TRANSLATE(IBRTN,U)'=""
DO TRTN^IBCESRV1(IBTDA)
End DoDot:1
+15 QUIT
+16 ;
ADDTXN(IBDATA,REPORT) ; Add a trxn for msg in IBDATA to file 364.2
+1 ; REPORT = 1 if storing a report format message
+2 ;Function returns ien of the new entry in file 364.2 or "" if an error
+3 ;
+4 NEW A,IBDA,IBBTCH,IBBILL,IBDT,IBTEST,DLAYGO,DIC,DD,DO,X,Y,Z,IBIFN
+5 ;
+6 SET IBDA=""
SET IBBTCH=$PIECE(IBDATA,U,5)
SET IBBILL=$PIECE(IBDATA,U,4)
SET IBIFN=0
+7 IF IBBILL
SET IBIFN=+$GET(^IBA(364,IBBILL,0))
+8 SET IBDT=$PIECE(IBDATA,U,6)
+9 SET IBTEST=0
+10 IF $EXTRACT($GET(IBD("Q")),1,3)="MCT"
Begin DoDot:1
+11 ; Resubmit live claim for test (make sure 361.4 exists)
IF IBBILL
IF '$PIECE($GET(^IBA(364,IBBILL,0)),U,7)
IF $DATA(^IBM(361.4,IBIFN,0))
SET IBTEST=1
QUIT
+12 ; Resubmit live claim as test batch
IF IBBTCH
IF $ORDER(^IBM(361.4,"C",IBBTCH,0))
SET IBTEST=1
QUIT
End DoDot:1
+13 ;
+14 ; Use msg ID for .01 field
SET (X,A)=$GET(IBD("MSG#"))
+15 FOR Z=1:1
if '$DATA(^IBA(364.2,"B",A))
QUIT
SET A=X_"."_Z
+16 SET X=A
+17 SET DIC(0)="L"
SET DIC="^IBA(364.2,"
SET DLAYGO=364.2
+18 SET DIC("DR")=".02///"_$PIECE(IBDATA,U)_";.03///^S X=""NOW"";.08////"_($PIECE(IBDATA,U,7)="Y")_";.13////"_$PIECE(IBDATA,U,8)_$SELECT(IBBILL="":"",1:";.05////"_IBBILL)_";.06////P;.1////"_IBDT_$SELECT(IBBTCH="":"",1:";.04////"_IBBTCH)_";.14////"_
IBTEST
+19 DO FILE^DICN
+20 if Y>0
SET IBDA=+Y
+21 ;
+22 QUIT IBDA
+23 ;
LOADDET(IB1,IB2,IBTDA,IBGBL,IBERR,IBTNM) ; Load the rest of the message text into the message
+1 ; IB1 = "BATCH" or "CLAIM" or "REPORT"
+2 ; IB2 = batch # or claim # or 0
+3 ; IBTDA = ien in file 364.2 being updated
+4 ; IBGBL = name of the array holding the detail message text to be loaded
+5 ; IBTNM = message name (i.e. "835EOB","837REC0","REPORT",etc.)
+6 ;
+7 ; OUTPUT: IBERR if any errors found, pass by reference
+8 ; IBTDA(IBTDA)=1 if errors - pass by reference
+9 ;
+10 SET IBTDA=+$GET(IBTDA)
+11 NEW CT,IB3,IBE,IBZ,Q
+12 ;
+13 KILL ^TMP("IBTEXT",$JOB)
+14 ;
+15 ;Put formatted data into msg
SET (CT,IB3)=0
+16 FOR
SET IB3=$ORDER(@IBGBL@(IB1,IB2,IB3))
if 'IB3
QUIT
SET CT=CT+1
SET ^TMP("IBTEXT",$JOB,CT)=@IBGBL@(IB1,IB2,IB3)
+17 ; Add identifying data from hdr record
+18 SET IB3=0
FOR
SET IB3=$ORDER(^TMP("IBMSG-H",$JOB,IB1,IB2,IB3))
if 'IB3
QUIT
SET CT=CT+1
SET ^TMP("IBTEXT",$JOB,CT)=^TMP("IBMSG-H",$JOB,IB1,IB2,IB3)
+19 ;
+20 ; Put raw data into msg
+21 IF $GET(IBTNM)'="835EOB"
Begin DoDot:1
+22 SET IBZ=""
FOR
SET IBZ=$ORDER(@IBGBL@(IB1,IB2,"D",IBZ))
if IBZ=""
QUIT
SET IB3=0
FOR
SET IB3=$ORDER(@IBGBL@(IB1,IB2,"D",IBZ,IB3))
if 'IB3
QUIT
SET CT=CT+1
SET ^TMP("IBTEXT",$JOB,CT)=@IBGBL@(IB1,IB2,"D",IBZ,IB3)
End DoDot:1
+23 IF $GET(IBTNM)="835EOB"
Begin DoDot:1
+24 SET IB3=0
FOR
SET IB3=$ORDER(@IBGBL@(IB1,IB2,"D1",IB3))
if 'IB3
QUIT
SET IBZ=""
FOR
SET IBZ=$ORDER(@IBGBL@(IB1,IB2,"D1",IB3,IBZ))
if IBZ=""
QUIT
SET CT=CT+1
SET ^TMP("IBTEXT",$JOB,CT)=@IBGBL@(IB1,IB2,"D1",IB3,IBZ)
End DoDot:1
+25 ;
+26 DO STOREM^IBCESRV2(IBTDA,"^TMP(""IBTEXT"",$J)",.IBE)
+27 ;
+28 ; Extract error
IF $DATA(IBE("DIERR"))
Begin DoDot:1
+29 DO EXTERR^IBCESRV1(.IBERR,.IBTDA,.IBE)
End DoDot:1
if $LENGTH($GET(IBE))
SET IBERR(IBTDA,IB1,IB2)=IBE
+30 KILL ^TMP("IBTEXT",$JOB)
+31 QUIT
+32 ;
CKLABEL(Z,IBTXN,IBGBL) ; Checks to be sure label in Z exists.
+1 ; If it doesn't exist, files an error and returns 0
+2 ; OR returns 1 if it does exist
+3 NEW X,LAB
+4 SET X=1
SET LAB=$PIECE(Z,"(")
+5 IF $SELECT('LAB!($LENGTH($PIECE(LAB,U))>8):1,1:$TEXT(@LAB)="")
SET X=0
DO REST(.IBTXN,IBGBL)
+6 QUIT X
+7 ;
ERROR ; Error condition messages
+1 ;;Message code does not exist in IB MESSAGE ROUTER file (364.3).
+2 ;;This message has no ending $.
+3 ;;Message file problem - no message stored.
+4 ;;Message file problem - message partially stored.
+5 ;;Routine to process this message type does not exist.
+6 ;;Batch does not exist for this confirmation message.
+7 ;;Bad message format found - cannot store message.
+8 ;
