source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOSRV3.m@ 1638

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

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1PRCOSRV3 ;WISC/DJM-Server interface to IFCAP from FMS ;12/9/96 11:12 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6PERROR ; Process Errors
7 N X,XMDUN,XMSUB,XMTEXT,XMB,XMY,XMZ
8 S PRCEND=""
9 S XMRG=PRCOXMRG
10 I $D(PRCMG),PRCMG]"" D
11 . S:PRCMG'["G." PRCMG="G."_PRCMG
12 . S X=PRCMG
13 . S XMDUZ="IFCAP FMS MESSAGE SERVER"
14 . D WHO^XMA21
15 . ;
16 . ; If the mail group found in file 423.5 for this transaction
17 . ; failed the lookup send the bulletin to G.FMS. If G.FMS
18 . ; also failed its lookup then send the bulletin to POSTMASTER.
19 . ;
20 . I Y=-1 D
21 . . S PRCXM(2)=$P($T(ERROR+1),";;",2)
22 . . S PRETRY=""
23 . . I PRCMG="G.FMS" S XMY(.5)="" Q
24 . . S X="G.FMS"
25 . . S XMDUZ="IFCAP FMS MESSAGE SERVER"
26 . . D WHO^XMA21
27 . . I Y=-1 S XMY(.5)=""
28 . . Q
29 . Q
30 ;
31 ; If there is no mail group defined when this ERROR routine is called
32 ; send the bulletin to G.FMS. If G.FMS failed the lookup then send
33 ; the bulletin to POSTMASTER.
34 ;
35 I $G(PRCMG)="" D
36 . S PRCXM(2)=$P($T(ERROR+2),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,5)_"."
37 . S X="G.FMS"
38 . S XMDUZ="IFCAP FMS MESSAGE SERVER"
39 . D WHO^XMA21
40 . I Y=-1 S XMY(.5)=""
41 . Q
42 ;
43 D EMFORM
44 S XMDUN="IFCAP SERVER ERROR"
45 S XMSUB="IFCAP message router error"
46 S XMTEXT="PRCXM("
47 D ^XMD
48 K PRCXM
49 Q
50 ;
51ERROR ;
52 ;;Mailgroup designated in file 423.5 could not list its members.
53 ;;There is no mail group listed for transaction
54 ;
55EMFORM ; FIRST DISPLAY INFORMATION ABOUT THE INCOMMING MAIL MESSAGE
56 ;
57 N I,J
58 F I=1:1 S J=$O(PRCXM(I)) Q:J=""
59 S I=I+1
60 S PRCXM(I)=" "
61 S I=I+1
62 S PRCXM(I)=" Sent to Server: "_PRCOSOP
63 S I=I+1
64 S PRCXM(I)=" "
65 S I=I+1
66 S PRCXM(I)=" MailMan Message #: "_PRCOMSG
67 S I=I+1
68 S PRCXM(I)=" "
69 S I=I+1
70 S PRCXM(I)=" Sent From: "_PRCOSND
71 S I=I+1
72 S PRCXM(I)=" "
73 S I=I+1
74 S PRCXM(I)=" Message Subject: "_PRCOSUB
75 S I=I+1
76 S PRCXM(I)=" "
77 S I=I+1
78 S PRCXM(I)=" What this server thinks is the CONTROL segment of the transaction:"
79 S I=I+1
80 S PRCXM(I)=" "_XMRG
81 ;
82 ; HERE IS THE DATA FROM THE CONTROL SEGMENT SAVED IN FILE 423.6
83 ;
84 I $D(PRCDA),$D(^PRCF(423.6,PRCDA,1,10000,0)) D
85 . N THDR,TDATE,Y
86 . S THDR=^PRCF(423.6,PRCDA,1,10000,0)
87 . S Y=$P(THDR,U,10)
88 . S Y=($E(Y,1,4)-1700)_$E(Y,5,8)
89 . D DD^%DT
90 . S TDATE=Y
91 . S I=I+1
92 . S PRCXM(I)=" "
93 . S I=I+1
94 . S PRCXM(I)=" This is the CONTROL segment from the saved transaction in file 423.6:"
95 . S I=I+1
96 . S PRCXM(I)=" "_THDR
97 . S I=I+1
98 . S PRCXM(I)=" "
99 . S I=I+1
100 . S PRCXM(I)=" System ID: "_$P(THDR,U,2)
101 . S I=I+1
102 . S PRCXM(I)=" "
103 . S I=I+1
104 . S PRCXM(I)=" Recieving Station #: "_$P(THDR,U,4)_" "_"Transaction Code : "_$P(THDR,U,5)
105 . S I=I+1
106 . S PRCXM(I)=" "
107 . S I=I+1
108 . S PRCXM(I)=" Transaction Date : "_TDATE_" "_"Transaction Time : "_$E($P(THDR,U,11),1,2)_":"_$E($P(THDR,U,11),3,4)_":"_$E($P(THDR,U,11),5,6)
109 . S I=I+1
110 . I $L($P(THDR,U,9))>0 D
111 . . S PRCXM(I)=" "
112 . . S I=I+1
113 . . S PRCXM(I)=" Sales or Order #: "_$P(THDR,U,9)
114 . . S I=I+1
115 . . Q
116 . S PRCXM(I)=" "
117 . S I=I+1
118 . S PRCXM(I)=" Interface Version #: "_$P(THDR,U,14)_" Message File (423.6) #: "_PRCDA
119 Q
120 ;
121TFILER ;Transaction Filer
122 N OK,REM,REM1,YY
123 I PRCDA=0 D
124 . F L +^PRCF(423.6,0):1 Q:$T
125 . S YY=$O(^PRCF(423.6,"B",PRCKEY,0))
126 . I YY>0 S PRCDA=YY L -^PRCF(423.6,0) Q
127 . S CNT=$P($G(^PRCF(423.6,0)),U,3)
128 . F S CNT=CNT+1 Q:$G(^PRCF(423.6,CNT,0))=""
129 . S $P(^PRCF(423.6,0),U,3)=CNT
130 . S PRCDA=CNT
131 . S $P(^PRCF(423.6,0),U,4)=$P(^PRCF(423.6,0),U,4)+1
132 . F L +^PRCF(423.6,PRCDA):1 Q:$T
133 . S ^PRCF(423.6,PRCDA,0)=PRCKEY
134 . S ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
135 . S $P(^PRCF(423.6,PRCDA,1,0),U,2)=$P(^DD(423.6,1,0),U,2)
136 . K CNT
137 . L -^PRCF(423.6,0)
138 . L -^PRCF(423.6,PRCDA)
139 F L +^PRCF(423.6,PRCDA):1 Q:$T
140 N II,EOM,LEN,OCNT,SCNT
141 S (OCNT,SCNT)=10000*(+$P(XMRG,U,12))
142 I +$P(XMRG,U,12)=1 D
143 . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
144 . S SCNT=SCNT+1
145 S (OK,REM,REM1,S1)=""
146 F D Q:XMER'=0 I S1>0 Q
147 . I REM["}" S S1=2 Q
148 . S:XMRG["{" S1=1,XMRG=""
149 . X:S1="" XMREC
150 . Q:XMER<0
151 . S:$L(REM)+$L(REM1)<241 REM=REM_REM1,REM1=""
152 . S:$L(REM)+$L(XMRG)<241 XMRG=REM_XMRG,REM=""
153 . I $L(REM)+$L(XMRG)>240 D
154 . . S REM1=$E(XMRG,241-$L(REM),$L(XMRG))
155 . . S XMRG=REM_$E(XMRG,1,240-$L(REM))
156 . . Q
157 . S EOM=$F(XMRG,"}")
158 . I EOM>2 S XMRG=$E(XMRG,1,EOM-1),S1=2,REM1=""
159 . I EOM=2 S S1=2 Q
160 . S LEN=$F(XMRG,"~")
161 . I LEN>1,LEN<241 D Q
162 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,LEN-1)
163 . . S SCNT=SCNT+1
164 . . S REM=$E(XMRG,LEN,$L(XMRG))
165 . . Q
166 . I $L(XMRG)>0,$L(XMRG)<241 D Q
167 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
168 . . S SCNT=SCNT+1
169 . . S REM=""
170 . . Q
171 . I $E(XMRG,1,240)["^" F II=240:-1:1 I $E(XMRG,II)="^" D Q
172 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
173 . . S SCNT=SCNT+1
174 . . S REM=$E(XMRG,II+1,$L(XMRG))
175 . . S OK=1
176 . . Q
177 . Q:OK=1
178 . F II=240:-1:1 I $E(XMRG,II)=" " D Q
179 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
180 . . S REM=$E(XMRG,II+1,$L(XMRG))
181 . . Q
182 . Q
183 S $P(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
184 S $P(^PRCF(423.6,PRCDA,1,0),U,4)=(SCNT-OCNT)+$P(^PRCF(423.6,PRCDA,1,0),U,4)
185 L -^PRCF(423.6,PRCDA)
186 Q
187 ;
188KILL(PRCDA) ;ENTER HERE TO REMOVE THE 423.6 RECORD THAT YOU HAVE FINISHED WITH.
189 N DA,DIK
190 S DA=PRCDA
191 S DIK="^PRCF(423.6,"
192 D ^DIK
193 Q
Note: See TracBrowser for help on using the repository browser.