source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCESRV1.m@ 811

Last change on this file since 811 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1IBCESRV1 ;ALB/TMP - Server interface to IB from Austin ;03/05/96
2 ;;2.0;INTEGRATED BILLING;**137,181,191**;21-MAR-94
3 Q
4PERROR(IBERR,IBTDA,IBEMG,IBXMZ) ; Process Errors - Send bulletin to mail group
5 ; IBERR = Error text array
6 ; IBTDA = Message File Entry # array
7 ; IBEMG = name of the mail group to which these errors should be sent
8 ; IBXMZ = the internal entry # of the mailman message (file 3.9)
9 N CT,XMDUZ,XMSUBJ,XMBODY,XMB,XMINSTR,XMTYPE,XMFULL,XMTO,IBXM,XMZ,XMERR
10 ;
11 S CT=0
12 ;
13 I $G(IBEMG)="" S CT=CT+1,IBXM(CT)=$P($T(ERROR+2),";;",2),XMTO(.5)=""
14 ;
15 I $D(IBEMG) D
16 . S:IBEMG="" IBEMG="IB EDI"
17 . ;
18 . S:$E(IBEMG,1,2)'="G." IBEMG="G."_IBEMG
19 . ;
20 . S XMTO("I:"_IBEMG)=""
21 ;
22 I $O(XMTO(.5))="" S XMTO("I:G.IB EDI")=""
23 D EMFORM(CT,.IBERR,.IBXM,IBXMZ)
24 ;
25 S XMDUZ=""
26 S XMSUBJ="EDI RETURN MESSAGE ROUTER ERROR",XMBODY="IBXM"
27 D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
28 Q
29 ;
30EMFORM(CT,IBERR,IBXM,IBXMZ) ;
31 ; INPUT:
32 ; CT = the number of lines previously populated in error message
33 ; IBERR = the array of errors
34 ;
35 ; OUTPUT:
36 ; IBXM = the array containing the complete error text
37 ;
38 N THDR,TDATE,TDATE1,TTIME,TTIME1,TTYP,Z,Z0,Z1,BATCH,BILL
39 ;
40 S IBTDA=+$O(IBTDA("")),THDR=$G(^IBA(364.2,IBTDA,0))
41 ;
42 I THDR'="" D ;Messages partially filed
43 . S TDATE=$P(THDR,U,10),TTIME=$P(TDATE,".",2)_"000000",TDATE=$$FMTE^XLFDT(TDATE,"2D")
44 . S TDATE1=$P(THDR,U,3),TTIME1=$P(TDATE1,".",2)_"000000",TDATE1=$$FMTE^XLFDT(TDATE1,"2D")
45 . S TTYP=$G(^IBE(364.3,+$P(THDR,U,2),0)),BATCH=$P(THDR,U,4),BILL=$P(THDR,U,5)
46 ;
47 I THDR="" D ;No messages filed
48 . S TDATE=$G(^TMP("IBERR",$J,"DATE")),TTIME=$P(TDATE,".",2)_"000000",TDATE=$$FMTE^XLFDT($P(TDATE,"."),"2D")
49 . S TDATE1=$$NOW^XLFDT(),TTIME1=$P(TDATE1,".",2)_"000000",TDATE1=$$FMTE^XLFDT($P(TDATE1,"."),"2D")
50 . S TTYP=$G(^TMP("IBERR",$J,"TYPE")),BATCH=$G(^TMP("IBERR",$J,"BATCH")),BILL=$G(^TMP("IBERR",$J,"BILL"))
51 ;
52 S CT=CT+1
53 S IBXM(CT)=" Return Message Code: "_$P(TTYP,U)_" "_$P(TTYP,U,5)
54 ;
55 S CT=CT+2
56 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
57 ;
58 S CT=CT+2
59 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)
60 ;
61 I BATCH S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",25)_"Batch #: "_$P($G(^IBA(364.1,BATCH,0)),U)
62 ;
63 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)
64 ;
65 I IBTDA S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",11)_"Return Message File #(s): " D
66 . 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
67 ;
68 S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=$J("",15)_"Mailman Message #: "_$G(IBXMZ)
69 ;
70 I $G(IBERR)'="",IBERR?1A.E S CT=CT+2,IBXM(CT-1)=" ",IBXM(CT)=IBERR
71 I $G(^TMP("IBERR",$J,"TEXT"))'="" S CT=CT+2,IBXM(CT)=^("TEXT"),IBXM(CT-1)=" "
72 ;
73 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)
74 S Z=0 F S Z=$O(^TMP("IBERR",$J,"MSG",Z)) Q:'Z S CT=CT+1,IBXM(CT)=^(Z)
75 ;
76 S Z=+$O(^TMP("IB-HOLD",$J,""),-1) S:'Z Z="cannot be determined"
77 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))
78 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:"
79 ;
80 I IBTDA D
81 . 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)
82 Q
83 ;
84ERROR ;
85 ;;Invalid mailgroup designated for EDI errors
86 ;;Message header error
87 ;
88EXTERR(IBERR,IBTDA,IBE) ; Put error into error array
89 N IBZ,Q
90 S IBE="",IBERR=4,IBTDA(IBTDA)=1
91 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_";;"
92 Q
93 ;
94ERRUPD(IBGBL,IBERR) ; Set up global array to hold message data
95 ;
96 N Z,Z0,Z1,Z11,Z2,Z3,CT,IBE,IBTXN1
97 ;
98 K ^TMP("IBERR",$J)
99 S CT=0,IBTXN1=$G(@IBGBL)
100 ;
101 S ^TMP("IBERR",$J,"DATE")=IBDATE
102 S ^TMP("IBERR",$J,"TYPE")=$P(IBTXN1,U)
103 S ^TMP("IBERR",$J,"SUBJ")=$G(IBD("SUBJ"))
104 ;
105 I $G(IBERR),IBERR<20 D
106 . S Z="ERROR+"_IBERR_"^IBCESRV"
107 . S IBE=$P($T(@Z),";;",2)
108 . I IBE'="" S ^TMP("IBERR",$J,"TEXT")=IBE
109 ;
110 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
111 . I $L(IBE) S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=$S(IBE:$P($T(ERROR+IBE),";;",2),1:IBE)
112 . 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
113 .. S IBTXN1=$G(@IBGBL@(Z,Z0,0))
114 .. S:$G(^TMP("IBERR",$J,"BATCH"))="" ^("BATCH")=$S(Z0="BATCH":Z11,1:"")
115 .. S:$G(^TMP("IBERR",$J,"BILL"))="" ^("BILL")=$S(Z0="CLAIM":Z11,1:"")
116 .. S:$G(^TMP("IBERR",$J,"TYPE"))="" ^("TYPE")=$P(IBTXN1,U,6)
117 . S Z1=""
118 . 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
119 .. S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=Z3
120 ;
121 I $D(@IBGBL@("BATCH",0)) D
122 . 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
123 .. S CT=CT+1,^TMP("IBERR",$J,"MSG",CT)=Z3
124 ;
125 Q
126 ;
127DKILL(IBXMZ) ; Delete server mail message from postmaster mailbox
128 ;
129 D ZAPSERV^XMXAPI("S.IBCE MESSAGES SERVER",IBXMZ)
130 ;
131 Q
132 ;
133TRTN(IBTDA,ZTSK) ; Auto-update task message process
134 ; IBTDA = internal entry # of message (file 364.2)
135 ; ZTSK = if passed by reference, returns the task #
136 ;
137 N ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN,DIE,DR,DA
138 S (ZTSAVE("IBTDA"),ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))="",ZTSAVE("ZTREQ")="@",ZTRTN=IBRTN,ZTDTH=$H,ZTIO=""
139 I $P($G(^IBE(364.3,+$P($G(^IBA(364.2,IBTDA,0)),U,2),0)),U)="REPORT" S ZTSAVE("XMZ")=$G(^IBA(364.2,IBTDA,0))\1
140 D ^%ZTLOAD
141 I $G(ZTSK),$G(^IBA(364.2,IBTDA,0)) S DIE="^IBA(364.2,",DA=IBTDA,DR=".11////"_ZTSK_";.06////U" D ^DIE
142 Q
143 ;
144TRADEL(X) ; Process to delete message from temporary message holding file
145 ;
146 N DIK,DA,Y S DIK="^IBA(364.2,",DA=X D ^DIK
147 Q
148 ;
Note: See TracBrowser for help on using the repository browser.