IBCESRV1 ;ALB/TMP - Server interface to IB from Austin ;03/05/96
;;2.0;INTEGRATED BILLING;**137,181,191,400**;21-MAR-94;Build 52
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
PERROR(IBERR,IBTDA,IBEMG,IBXMZ) ; Process Errors - Send bulletin to mail group
; IBERR = Error text array
; IBTDA = Message File Entry # array
; IBEMG = name of the mail group to which these errors should be sent
; IBXMZ = the internal entry # of the mailman message (file 3.9)
N CT,XMDUZ,XMSUBJ,XMBODY,XMB,XMINSTR,XMTYPE,XMFULL,XMTO,IBXM,XMZ,XMERR
;
S CT=0
;
I $G(IBEMG)="" S CT=CT+1,IBXM(CT)=$P($T(ERROR+2),";;",2),XMTO(.5)=""
;
I $D(IBEMG) D
. S:IBEMG="" IBEMG="IB EDI"
. ;
. S:$E(IBEMG,1,2)'="G." IBEMG="G."_IBEMG
. ;
. S XMTO("I:"_IBEMG)=""
;
I $O(XMTO(.5))="" S XMTO("I:G.IB EDI")=""
D EMFORM(CT,.IBERR,.IBXM,IBXMZ)
;
S XMDUZ=""
S XMSUBJ="EDI RETURN MESSAGE ROUTER ERROR",XMBODY="IBXM"
D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
Q
;
EMFORM(CT,IBERR,IBXM,IBXMZ) ;
; INPUT:
; CT = the number of lines previously populated in error message
; IBERR = the array of errors
;
; OUTPUT:
; IBXM = the array containing the complete error text
;
N THDR,TDATE,TDATE1,TTIME,TTIME1,TTYP,Z,Z0,Z1,BATCH,BILL
;
S IBTDA=+$O(IBTDA("")),THDR=$G(^IBA(364.2,IBTDA,0))
;
I THDR'="" D ;Messages partially filed
. S TDATE=$P(THDR,U,10),TTIME=$P(TDATE,".",2)_"000000",TDATE=$$FMTE^XLFDT(TDATE,"2D")
. S TDATE1=$P(THDR,U,3),TTIME1=$P(TDATE1,".",2)_"000000",TDATE1=$$FMTE^XLFDT(TDATE1,"2D")
. S TTYP=$G(^IBE(364.3,+$P(THDR,U,2),0)),BATCH=$P(THDR,U,4),BILL=$P(THDR,U,5)
;
I THDR="" D ;No messages filed
. S TDATE=$G(^TMP("IBERR",$J,"DATE")),TTIME=$P(TDATE,".",2)_"000000",TDATE=$$FMTE^XLFDT($P(TDATE,"."),"2D")
. S TDATE1=$$NOW^XLFDT(),TTIME1=$P(TDATE1,".",2)_"000000",TDATE1=$$FMTE^XLFDT($P(TDATE1,"."),"2D")
. S TTYP=$G(^TMP("IBERR",$J,"TYPE")),BATCH=$G(^TMP("IBERR",$J,"BATCH")),BILL=$G(^TMP("IBERR",$J,"BILL"))
;
S CT=CT+1
S IBXM(CT)=" Return Message Code: "_$P(TTYP,U)_" "_$P(TTYP,U,5)
;
S CT=CT+2
S IBXM(CT-1)=" ",IBXM(CT)=$J("",13)_"Return Message Date: "_TDATE_" Message Time: "_$E(TTIME,1,2)_":"_$E(TTIME,3,4)_":"_$E(TTIME,5,6),CT=CT+1
;
S CT=CT+2
S IBXM(CT-1)=" ",IBXM(CT)=$J("",21)_"Update Date: "_TDATE1_" Update Time: "_$E(TTIME1,1,2)_":"_$E(TTIME1,3,4)_":"_$E(TTIME1,5,6)
;
I BATCH S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",25)_"Batch #: "_$P($G(^IBA(364.1,BATCH,0)),U)
;
I BILL S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",26)_"Bill #: "_$P($G(^DGCR(399,+$G(^IBA(364,+BILL,0)),0)),U)
;
I IBTDA S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",11)_"Return Message File #(s): " D
. S (Z,Z0)=0 F S Z=$O(IBTDA(Z)) Q:'Z I IBTDA(Z) S IBXM(CT)=IBXM(CT)_$S(Z0:",",1:"")_Z,Z0=1
;
S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",15)_"Mailman Message #: "_$G(IBXMZ)
;
I $G(IBERR)'="",IBERR?1A.E S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=IBERR
I $G(^TMP("IBERR",$J,"TEXT"))'="" S CT=CT+2,IBXM(CT)=^("TEXT"),IBXM(CT-1)=" "
;
S Z="" F S Z=$O(IBERR(Z)) Q:Z="" S:$G(^TMP("IBERR",$J,"TEXT"))="" CT=CT+1,IBXM(CT)=" " S Z0="" F S Z0=$O(IBERR(Z,Z0)) Q:Z0="" I $G(IBERR(Z,Z0))'="",IBERR(Z,Z0)'=" " S CT=CT+1,IBXM(CT)=IBERR(Z,Z0)
S Z=0 F S Z=$O(^TMP("IBERR",$J,"MSG",Z)) Q:'Z S CT=CT+1,IBXM(CT)=^(Z)
;
S Z=+$O(^TMP("IB-HOLD",$J,""),-1) S:'Z Z="cannot be determined"
I $S('Z:1,'$D(^TMP("IBMSG",$J,"BATCH",0,"D",0)):0,1:+$O(^TMP("IBMSG",$J,"BATCH",0,"D",0,""),-1)'=Z) S CT=CT+1,IBXM(CT)="Msg Line: "_$G(^TMP("IB-HOLD",$J,Z))
I $O(^IBA(364.2,IBTDA,2,0))!$O(^TMP("IBERR",$J,"MSG",0))!($O(^TMP("IB-HOLD",$J,0))) S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)="Return Message Text:"
;
I IBTDA D
. S Z=0 F S Z=$O(^IBA(364.2,+IBTDA,2,Z)) Q:'Z I $G(^(Z,0))'="" S CT=CT+1,IBXM(CT)=^(0)
Q
;
ERROR ;
;;Invalid mailgroup designated for EDI errors
;;Message header error
;
EXTERR(IBERR,IBTDA,IBE) ; Put error into error array
N IBZ,Q
S IBE="",IBERR=4,IBTDA(IBTDA)=1
S IBZ=0 F S IBZ=$O(IBE("DIERR",IBZ)) Q:'IBZ S Q=$G(IBE("DIERR",IBZ,"TEXT",1)) I $L(Q),$L(Q)+$L(IBE)<99 S IBE=IBE_Q_";;"
Q
;
ERRUPD(IBGBL,IBERR) ; Set up global array to hold message data
;
N Z,Z0,Z1,Z11,Z2,Z3,CT,IBE,IBTXN1
;
K ^TMP("IBERR",$J)
S CT=0,IBTXN1=$G(@IBGBL)
;
S ^TMP("IBERR",$J,"DATE")=IBDATE
S ^TMP("IBERR",$J,"TYPE")=$P(IBTXN1,U)
S ^TMP("IBERR",$J,"SUBJ")=$G(IBD("SUBJ"))
;
I $G(IBERR),IBERR<20 D
. S Z="ERROR+"_IBERR_"^IBCESRV"
. S IBE=$P($T(@Z),";;",2)
. I IBE'="" S ^TMP("IBERR",$J,"TEXT")=IBE
;
S Z="" F S Z=$O(IBERR(Z)) Q:Z="" S Z0="" F S Z0=$O(IBERR(Z,Z0)) Q:Z0="" S IBE=$G(IBERR(Z,Z0)) D
. I $L(IBE) S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=$S(IBE:$P($T(ERROR+IBE),";;",2),1:IBE)
. S Z11="" F S Z11=$O(IBERR(Z,Z0,Z11)) Q:Z11="" S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=$G(IBERR(Z,Z0,Z11)) D
.. S IBTXN1=$G(@IBGBL@(Z,Z0,0))
.. S:$G(^TMP("IBERR",$J,"BATCH"))="" ^("BATCH")=$S(Z0="BATCH":Z11,1:"")
.. S:$G(^TMP("IBERR",$J,"BILL"))="" ^("BILL")=$S(Z0="CLAIM":Z11,1:"")
.. S:$G(^TMP("IBERR",$J,"TYPE"))="" ^("TYPE")=$P(IBTXN1,U,6)
. S Z1=""
. F S Z1=$O(@IBGBL@(Z,Z0,"D",Z1)) Q:Z1="" S Z2=0 F S Z2=$O(@IBGBL@(Z,Z0,"D",Z1,Z2)) Q:'Z2 S Z3=$P(@IBGBL@(Z,Z0,"D",Z1,Z2),"##RAW DATA: ",2) I Z3'="" D
.. S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=Z3
;
I $D(@IBGBL@("BATCH",0)) D
. S Z2="" F S Z2=$O(@IBGBL@("BATCH",0,"D",0,Z2)) Q:Z2="" S Z3=$P(@IBGBL@("BATCH",0,"D",0,Z2),"##RAW DATA: ",2) I Z3'="" D
.. S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=Z3
;
Q
;
DKILL(IBXMZ) ; Delete server mail message from postmaster mailbox
;
D ZAPSERV^XMXAPI("S.IBCE MESSAGES SERVER",IBXMZ)
;
Q
;
TRTN(IBTDA) ; Process incoming EDI message
; IBTDA = internal entry # of message (file 364.2)
; This procedure is called from ADD^IBCESRV with variable IBRTN holding the TAG^ROUTINE to be invoked
NEW IBA,IBB,IBGBL,IBERR ; protect looping variables from ADD^IBCESRV
D @IBRTN
Q
;
TRADEL(X) ; Process to delete message from temporary message holding file
;
N DIK,DA,Y S DIK="^IBA(364.2,",DA=X D ^DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCESRV1 6084 printed Apr 09, 2024@21:17:38 Page 2
IBCESRV1 ;ALB/TMP - Server interface to IB from Austin ;03/05/96
+1 ;;2.0;INTEGRATED BILLING;**137,181,191,400**;21-MAR-94;Build 52
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
PERROR(IBERR,IBTDA,IBEMG,IBXMZ) ; Process Errors - Send bulletin to mail group
+1 ; IBERR = Error text array
+2 ; IBTDA = Message File Entry # array
+3 ; IBEMG = name of the mail group to which these errors should be sent
+4 ; IBXMZ = the internal entry # of the mailman message (file 3.9)
+5 NEW CT,XMDUZ,XMSUBJ,XMBODY,XMB,XMINSTR,XMTYPE,XMFULL,XMTO,IBXM,XMZ,XMERR
+6 ;
+7 SET CT=0
+8 ;
+9 IF $GET(IBEMG)=""
SET CT=CT+1
SET IBXM(CT)=$PIECE($TEXT(ERROR+2),";;",2)
SET XMTO(.5)=""
+10 ;
+11 IF $DATA(IBEMG)
Begin DoDot:1
+12 if IBEMG=""
SET IBEMG="IB EDI"
+13 ;
+14 if $EXTRACT(IBEMG,1,2)'="G."
SET IBEMG="G."_IBEMG
+15 ;
+16 SET XMTO("I:"_IBEMG)=""
End DoDot:1
+17 ;
+18 IF $ORDER(XMTO(.5))=""
SET XMTO("I:G.IB EDI")=""
+19 DO EMFORM(CT,.IBERR,.IBXM,IBXMZ)
+20 ;
+21 SET XMDUZ=""
+22 SET XMSUBJ="EDI RETURN MESSAGE ROUTER ERROR"
SET XMBODY="IBXM"
+23 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
+24 QUIT
+25 ;
EMFORM(CT,IBERR,IBXM,IBXMZ) ;
+1 ; INPUT:
+2 ; CT = the number of lines previously populated in error message
+3 ; IBERR = the array of errors
+4 ;
+5 ; OUTPUT:
+6 ; IBXM = the array containing the complete error text
+7 ;
+8 NEW THDR,TDATE,TDATE1,TTIME,TTIME1,TTYP,Z,Z0,Z1,BATCH,BILL
+9 ;
+10 SET IBTDA=+$ORDER(IBTDA(""))
SET THDR=$GET(^IBA(364.2,IBTDA,0))
+11 ;
+12 ;Messages partially filed
IF THDR'=""
Begin DoDot:1
+13 SET TDATE=$PIECE(THDR,U,10)
SET TTIME=$PIECE(TDATE,".",2)_"000000"
SET TDATE=$$FMTE^XLFDT(TDATE,"2D")
+14 SET TDATE1=$PIECE(THDR,U,3)
SET TTIME1=$PIECE(TDATE1,".",2)_"000000"
SET TDATE1=$$FMTE^XLFDT(TDATE1,"2D")
+15 SET TTYP=$GET(^IBE(364.3,+$PIECE(THDR,U,2),0))
SET BATCH=$PIECE(THDR,U,4)
SET BILL=$PIECE(THDR,U,5)
End DoDot:1
+16 ;
+17 ;No messages filed
IF THDR=""
Begin DoDot:1
+18 SET TDATE=$GET(^TMP("IBERR",$JOB,"DATE"))
SET TTIME=$PIECE(TDATE,".",2)_"000000"
SET TDATE=$$FMTE^XLFDT($PIECE(TDATE,"."),"2D")
+19 SET TDATE1=$$NOW^XLFDT()
SET TTIME1=$PIECE(TDATE1,".",2)_"000000"
SET TDATE1=$$FMTE^XLFDT($PIECE(TDATE1,"."),"2D")
+20 SET TTYP=$GET(^TMP("IBERR",$JOB,"TYPE"))
SET BATCH=$GET(^TMP("IBERR",$JOB,"BATCH"))
SET BILL=$GET(^TMP("IBERR",$JOB,"BILL"))
End DoDot:1
+21 ;
+22 SET CT=CT+1
+23 SET IBXM(CT)=" Return Message Code: "_$PIECE(TTYP,U)_" "_$PIECE(TTYP,U,5)
+24 ;
+25 SET CT=CT+2
+26 SET IBXM(CT-1)=" "
SET IBXM(CT)=$JUSTIFY("",13)_"Return Message Date: "_TDATE_" Message Time: "_$EXTRACT(TTIME,1,2)_":"_$EXTRACT(TTIME,3,4)_":"_$EXTRACT(TTIME,5,6)
SET CT=CT+1
+27 ;
+28 SET CT=CT+2
+29 SET IBXM(CT-1)=" "
SET IBXM(CT)=$JUSTIFY("",21)_"Update Date: "_TDATE1_" Update Time: "_$EXTRACT(TTIME1,1,2)_":"_$EXTRACT(TTIME1,3,4)_":"_$EXTRACT(TTIME1,5,6)
+30 ;
+31 IF BATCH
SET CT=CT+2
SET IBXM(CT-1)=" "
SET IBXM(CT)=$JUSTIFY("",25)_"Batch #: "_$PIECE($GET(^IBA(364.1,BATCH,0)),U)
+32 ;
+33 IF BILL
SET CT=CT+2
SET IBXM(CT-1)=" "
SET IBXM(CT)=$JUSTIFY("",26)_"Bill #: "_$PIECE($GET(^DGCR(399,+$GET(^IBA(364,+BILL,0)),0)),U)
+34 ;
+35 IF IBTDA
SET CT=CT+2
SET IBXM(CT-1)=" "
SET IBXM(CT)=$JUSTIFY("",11)_"Return Message File #(s): "
Begin DoDot:1
+36 SET (Z,Z0)=0
FOR
SET Z=$ORDER(IBTDA(Z))
if 'Z
QUIT
IF IBTDA(Z)
SET IBXM(CT)=IBXM(CT)_$SELECT(Z0:",",1:"")_Z
SET Z0=1
End DoDot:1
+37 ;
+38 SET CT=CT+2
SET IBXM(CT-1)=" "
SET IBXM(CT)=$JUSTIFY("",15)_"Mailman Message #: "_$GET(IBXMZ)
+39 ;
+40 IF $GET(IBERR)'=""
IF IBERR?1A.E
SET CT=CT+2
SET IBXM(CT-1)=" "
SET IBXM(CT)=IBERR
+41 IF $GET(^TMP("IBERR",$JOB,"TEXT"))'=""
SET CT=CT+2
SET IBXM(CT)=^("TEXT")
SET IBXM(CT-1)=" "
+42 ;
+43 SET Z=""
FOR
SET Z=$ORDER(IBERR(Z))
if Z=""
QUIT
if $GET(^TMP("IBERR",$JOB,"TEXT"))=""
SET CT=CT+1
SET IBXM(CT)=" "
SET Z0=""
FOR
SET Z0=$ORDER(IBERR(Z,Z0))
if Z0=""
QUIT
IF $GET(IBERR(Z,Z0))'=""
IF IBERR(Z,Z0)'=" "
SET CT=CT+1
SET IBXM(CT)=IBERR(Z,Z0)
+44 SET Z=0
FOR
SET Z=$ORDER(^TMP("IBERR",$JOB,"MSG",Z))
if 'Z
QUIT
SET CT=CT+1
SET IBXM(CT)=^(Z)
+45 ;
+46 SET Z=+$ORDER(^TMP("IB-HOLD",$JOB,""),-1)
if 'Z
SET Z="cannot be determined"
+47 IF $SELECT('Z:1,'$DATA(^TMP("IBMSG",$JOB,"BATCH",0,"D",0)):0,1:+$ORDER(^TMP("IBMSG",$JOB,"BATCH",0,"D",0,""),-1)'=Z)
SET CT=CT+1
SET IBXM(CT)="Msg Line: "_$GET(^TMP("IB-HOLD",$JOB,Z))
+48 IF $ORDER(^IBA(364.2,IBTDA,2,0))!$ORDER(^TMP("IBERR",$JOB,"MSG",0))!($ORDER(^TMP("IB-HOLD",$JOB,0)))
SET CT=CT+2
SET IBXM(CT-1)=" "
SET IBXM(CT)="Return Message Text:"
+49 ;
+50 IF IBTDA
Begin DoDot:1
+51 SET Z=0
FOR
SET Z=$ORDER(^IBA(364.2,+IBTDA,2,Z))
if 'Z
QUIT
IF $GET(^(Z,0))'=""
SET CT=CT+1
SET IBXM(CT)=^(0)
End DoDot:1
+52 QUIT
+53 ;
ERROR ;
+1 ;;Invalid mailgroup designated for EDI errors
+2 ;;Message header error
+3 ;
EXTERR(IBERR,IBTDA,IBE) ; Put error into error array
+1 NEW IBZ,Q
+2 SET IBE=""
SET IBERR=4
SET IBTDA(IBTDA)=1
+3 SET IBZ=0
FOR
SET IBZ=$ORDER(IBE("DIERR",IBZ))
if 'IBZ
QUIT
SET Q=$GET(IBE("DIERR",IBZ,"TEXT",1))
IF $LENGTH(Q)
IF $LENGTH(Q)+$LENGTH(IBE)<99
SET IBE=IBE_Q_";;"
+4 QUIT
+5 ;
ERRUPD(IBGBL,IBERR) ; Set up global array to hold message data
+1 ;
+2 NEW Z,Z0,Z1,Z11,Z2,Z3,CT,IBE,IBTXN1
+3 ;
+4 KILL ^TMP("IBERR",$JOB)
+5 SET CT=0
SET IBTXN1=$GET(@IBGBL)
+6 ;
+7 SET ^TMP("IBERR",$JOB,"DATE")=IBDATE
+8 SET ^TMP("IBERR",$JOB,"TYPE")=$PIECE(IBTXN1,U)
+9 SET ^TMP("IBERR",$JOB,"SUBJ")=$GET(IBD("SUBJ"))
+10 ;
+11 IF $GET(IBERR)
IF IBERR<20
Begin DoDot:1
+12 SET Z="ERROR+"_IBERR_"^IBCESRV"
+13 SET IBE=$PIECE($TEXT(@Z),";;",2)
+14 IF IBE'=""
SET ^TMP("IBERR",$JOB,"TEXT")=IBE
End DoDot:1
+15 ;
+16 SET Z=""
FOR
SET Z=$ORDER(IBERR(Z))
if Z=""
QUIT
SET Z0=""
FOR
SET Z0=$ORDER(IBERR(Z,Z0))
if Z0=""
QUIT
SET IBE=$GET(IBERR(Z,Z0))
Begin DoDot:1
+17 IF $LENGTH(IBE)
SET CT=CT+1
SET ^TMP("IBERR",$JOB,"MSG",CT)=$SELECT(IBE:$PIECE($TEXT(ERROR+IBE),";;",2),1:IBE)
+18 SET Z11=""
FOR
SET Z11=$ORDER(IBERR(Z,Z0,Z11))
if Z11=""
QUIT
SET CT=CT+1
SET ^TMP("IBERR",$JOB,"MSG",CT)=$GET(IBERR(Z,Z0,Z11))
Begin DoDot:2
+19 SET IBTXN1=$GET(@IBGBL@(Z,Z0,0))
+20 if $GET(^TMP("IBERR",$JOB,"BATCH"))=""
SET ^("BATCH")=$SELECT(Z0="BATCH":Z11,1:"")
+21 if $GET(^TMP("IBERR",$JOB,"BILL"))=""
SET ^("BILL")=$SELECT(Z0="CLAIM":Z11,1:"")
+22 if $GET(^TMP("IBERR",$JOB,"TYPE"))=""
SET ^("TYPE")=$PIECE(IBTXN1,U,6)
End DoDot:2
+23 SET Z1=""
+24 FOR
SET Z1=$ORDER(@IBGBL@(Z,Z0,"D",Z1))
if Z1=""
QUIT
SET Z2=0
FOR
SET Z2=$ORDER(@IBGBL@(Z,Z0,"D",Z1,Z2))
if 'Z2
QUIT
SET Z3=$PIECE(@IBGBL@(Z,Z0,"D",Z1,Z2),"##RAW DATA: ",2)
IF Z3'=""
Begin DoDot:2
+25 SET CT=CT+1
SET ^TMP("IBERR",$JOB,"MSG",CT)=Z3
End DoDot:2
End DoDot:1
+26 ;
+27 IF $DATA(@IBGBL@("BATCH",0))
Begin DoDot:1
+28 SET Z2=""
FOR
SET Z2=$ORDER(@IBGBL@("BATCH",0,"D",0,Z2))
if Z2=""
QUIT
SET Z3=$PIECE(@IBGBL@("BATCH",0,"D",0,Z2),"##RAW DATA: ",2)
IF Z3'=""
Begin DoDot:2
+29 SET CT=CT+1
SET ^TMP("IBERR",$JOB,"MSG",CT)=Z3
End DoDot:2
End DoDot:1
+30 ;
+31 QUIT
+32 ;
DKILL(IBXMZ) ; Delete server mail message from postmaster mailbox
+1 ;
+2 DO ZAPSERV^XMXAPI("S.IBCE MESSAGES SERVER",IBXMZ)
+3 ;
+4 QUIT
+5 ;
TRTN(IBTDA) ; Process incoming EDI message
+1 ; IBTDA = internal entry # of message (file 364.2)
+2 ; This procedure is called from ADD^IBCESRV with variable IBRTN holding the TAG^ROUTINE to be invoked
+3 ; protect looping variables from ADD^IBCESRV
NEW IBA,IBB,IBGBL,IBERR
+4 DO @IBRTN
+5 QUIT
+6 ;
TRADEL(X) ; Process to delete message from temporary message holding file
+1 ;
+2 NEW DIK,DA,Y
SET DIK="^IBA(364.2,"
SET DA=X
DO ^DIK
+3 QUIT
+4 ;
