source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOSRV1.m@ 897

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1PRCOSRV1 ;WISC/RMP-Server interface to IFCAP from ISMS ;12/9/96 11:11 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 ISMS 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.ISM. If G.ISM
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),PRETRY=""
22 . . I PRCMG="G.ISM" S XMY(.5)="" Q
23 . . S X="G.ISM"
24 . . S XMDUZ="IFCAP ISMS MESSAGE SERVER"
25 . . D WHO^XMA21
26 . . I Y=-1 S XMY(.5)=""
27 . . Q
28 . Q
29 ;
30 ; If there is no mail group defined when this ERROR routine is called
31 ; send the bulletin to G.ISM. If G.ISM failed the lookup then send
32 ; the bulletin to POSTMASTER.
33 ;
34 I $G(PRCMG)="" D
35 . S PRCXM(2)=$P($T(ERROR+2),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"."
36 . S X="G.ISM"
37 . S XMDUZ="IFCAP ISMS MESSAGE SERVER"
38 . D WHO^XMA21
39 . I Y=-1 S XMY(.5)=""
40 . Q
41 ;
42 D EMFORM
43 S XMDUN="IFCAP SERVER ERROR"
44 S XMSUB="IFCAP message router error"
45 S XMTEXT="PRCXM("
46 D ^XMD
47 K PRCXM
48 Q
49 ;
50ERROR ;
51 ;;Mailgroup designated in file 423.5 could not list its members.
52 ;;There is no mail group listed for transaction
53 ;
54EMFORM ; FIRST DISPLAY INFORMATION ABOUT THE INCOMMING MAIL MESSAGE
55 ;
56 N I,J
57 F I=1:1 S J=$O(PRCXM(I)) Q:J=""
58 S I=I+1
59 S PRCXM(I)=" "
60 S I=I+1
61 S PRCXM(I)=" Sent to Server: "_PRCOSOP
62 S I=I+1
63 S PRCXM(I)=" "
64 S I=I+1
65 S PRCXM(I)=" MailMan Message #: "_PRCOMSG
66 S I=I+1
67 S PRCXM(I)=" "
68 S I=I+1
69 S PRCXM(I)=" Sent From: "_PRCOSND
70 S I=I+1
71 S PRCXM(I)=" "
72 S I=I+1
73 S PRCXM(I)=" Message Subject: "_PRCOSUB
74 S I=I+1
75 S PRCXM(I)=" "
76 S I=I+1
77 S PRCXM(I)=" What this server thinks is the CONTROL segment of the transaction:"
78 S I=I+1
79 S PRCXM(I)=" "_XMRG
80 ;
81 ; HERE IS THE DATA FROM THE CONTROL SEGMENT SAVED IN FILE 423.6
82 ;
83 I $D(PRCDA),$D(^PRCF(423.6,PRCDA,1,10000,0)) D
84 . N THDR,TDATE,X1,X2,Y
85 . S THDR=^PRCF(423.6,PRCDA,1,10000,0)
86 . S X1=($E($P(THDR,U,5),1,4)-1700)_"0101"
87 . S X2=$E($P(THDR,U,5),5,7)
88 . D C^%DTC
89 . D YX^%DTC
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)_" "_"Sending Station #: "_$P(THDR,U,2)
101 . S I=I+1
102 . S PRCXM(I)=" "
103 . S I=I+1
104 . S PRCXM(I)=" Receiving Station #: "_$P(THDR,U,3)_" "_"Transaction Code : "_$P(THDR,U,4)
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,6),1,2)_":"_$E($P(THDR,U,6),3,4)_":"_$E($P(THDR,U,6),5,6)
109 . S I=I+1
110 . I $L($P(THDR,U,7))>0 D
111 . . S PRCXM(I)=" "
112 . . S I=I+1
113 . . S PRCXM(I)=" Sales or Order #: "_$P(THDR,U,7)
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,10)_" Message File (423.6) #: "_PRCDA
119 Q
120 ;
121TFILER ;Transaction Filer
122 ;
123 N OK,REM,REM1,YY
124 I PRCDA=0 D
125 . F L +^PRCF(423.6,0):1 Q:$T
126 . S YY=+$O(^PRCF(423.6,"B",PRCKEY,0))
127 . I YY>0 S PRCDA=YY L -^PRCF(423.6,0) Q
128 . S CNT=$P($G(^PRCF(423.6,0)),U,3)
129 . F S CNT=CNT+1 Q:$G(^PRCF(423.6,CNT,0))=""
130 . S $P(^PRCF(423.6,0),U,3)=CNT
131 . S PRCDA=CNT
132 . S $P(^PRCF(423.6,0),U,4)=$P(^PRCF(423.6,0),U,4)+1
133 . F L +^PRCF(423.6,PRCDA):1 Q:$T
134 . S ^PRCF(423.6,PRCDA,0)=PRCKEY
135 . S ^PRCF(423.6,"B",PRCKEY,PRCDA)=""
136 . S $P(^PRCF(423.6,PRCDA,1,0),U,2)=$P(^DD(423.6,1,0),U,2)
137 . K CNT
138 . L -^PRCF(423.6,0)
139 . L -^PRCF(423.6,PRCDA)
140 F L +^PRCF(423.6,PRCDA):1 Q:$T
141 N II,LEN,OCNT,SCNT
142 S (OCNT,SCNT)=10000*(+$P(XMRG,U,8))
143 I +$P(XMRG,U,8)=1 D
144 . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
145 . S SCNT=SCNT+1
146 S (OK,REM,REM1,S1)=""
147 F D Q:XMER'=0 I S1>0 Q
148 . S:REM["~" S1=2
149 . Q:REM["~"
150 . S:XMRG["$" S1=1,XMRG=""
151 . X:S1="" XMREC
152 . Q:XMER<0
153 . S:$L(REM)+$L(REM1)<241 REM=REM_REM1,REM1=""
154 . S:$L(REM)+$L(XMRG)<241 XMRG=REM_XMRG,REM=""
155 . I $L(REM)+$L(XMRG)>240 D
156 . . S REM1=$E(XMRG,241-$L(REM),$L(XMRG))
157 . . S XMRG=REM_$E(XMRG,1,240-$L(REM))
158 . . Q
159 . S LEN=$F(XMRG,"|")
160 . I LEN>1,LEN<241 D Q
161 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,LEN-1)
162 . . S SCNT=SCNT+1
163 . . S REM=$E(XMRG,LEN,$L(XMRG))
164 . . Q
165 . I $L(XMRG)>0,$L(XMRG)<241 D Q
166 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=XMRG
167 . . S SCNT=SCNT+1
168 . . S REM=""
169 . . Q
170 . I $E(XMRG,1,240)["^" F II=240:-1:1 I $E(XMRG,II)="^" D Q
171 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
172 . . S SCNT=SCNT+1
173 . . S REM=$E(XMRG,II+1,$L(XMRG))
174 . . S OK=1
175 . . Q
176 . Q:OK=1
177 . F II=240:-1:1 I $E(XMRG,II)=" " D Q
178 . . S ^PRCF(423.6,PRCDA,1,SCNT,0)=$E(XMRG,1,II)
179 . . S REM=$E(XMRG,II+1,$L(XMRG))
180 . . Q
181 . Q
182 S $P(^PRCF(423.6,PRCDA,1,0),U,3)=SCNT-1
183 S $P(^PRCF(423.6,PRCDA,1,0),U,4)=(SCNT-OCNT)+$P(^PRCF(423.6,PRCDA,1,0),U,4)
184 L -^PRCF(423.6,PRCDA)
185 Q
Note: See TracBrowser for help on using the repository browser.