- 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 Apr 23, 2025@18:26:57 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 ;
