source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOSRV.m@ 1326

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

initial load of FOIAVistA 6/30/08 version

File size: 5.3 KB
Line 
1PRCOSRV ;WISC/RMP-Server interface to IFCAP from ISMS ;3/12/97 11:32
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5SERVER ;
6 N ACTION,MSG,PRCMG,PRCETIME,PRCRTN,CNT,TOTS,PRCKEY,PRCEND,PRCDA
7 N PRCAH,PRCXM,S1,PRCOXMRG,PRCOSOP,PRCOMSG,PRCOSND,PRCOSUB
8 F D THDR,PERROR^PRCOSRV1:$D(PRCXM),TRETRY:$D(PRETRY) Q:XMER'=0 Q:$D(PRCEND)
9 D DKILL
10 S ZTREQ="@"
11 Q
12 ;
13THDR ; Transaction header segment reader
14 X XMREC
15 Q:XMER'=0
16 Q:"IFC,ISM"'[$P(XMRG,U)
17 ;
18 ; SOME VARIABLES TO DISPLAY IF THERE IS AN ERROR.
19 S PRCOXMRG=XMRG ; THE LINE OF TEXT BEING EXAMINED.
20 S PRCOSOP=XQSOP ; THE SERVER OPTION NAME.
21 S PRCOMSG=XQMSG ; THE SERVER REQUEST MESSAGE NUMBER (MAILMAN NUMBER).
22 S PRCOSND=XQSND ; NETWORK ADDRESS OF THE SENDER.
23 S PRCOSUB=XQSUB ; SUBJECT HEADING OF THE SERVER REQUEST MESSAGE.
24 ;
25 I $P(XMRG,U,11)'="|" S XMRG=""
26 S ACTION=$S(+$P(XMRG,U,9)>1:"MANY",+$P(XMRG,U,9)=1:"ONE",1:"ERR")
27 I ACTION="ERR" S PRCXM(1)=$P($T(ERROR+4),";;",2) Q
28 S PRCKEY=$P(XMRG,U,4,6)_U_$P(XMRG,U,9)
29 S PRCKEY=$TR(PRCKEY,U,"-")
30 S TOTS=+$P(XMRG,U,9)
31 I $P(PRCKEY,"-")=""!($P(PRCKEY,"-",2)="")!($P(PRCKEY,"-",3)="")!($P(PRCKEY,"-",4)="") S PRCXM(1)=$P($T(ERROR+10),";;",2) Q
32 S Y=$O(^PRCF(423.6,"B",PRCKEY,0))
33 S PRCDA=+Y
34 D LTC
35 D @ACTION:'$D(PRCXM)
36 Q
37 ;
38ONE ; Single Message Transaction process
39 S PRCDA=0
40 D TFILER^PRCOSRV1
41 I S1'=1 D Q
42 . S PRCXM(1)=$P($T(ERROR+5),";;",2)
43 . D TSKKILL
44 . D PERROR^PRCOSRV1
45 . D TRADEL(PRCDA)
46 . K PRCXM
47 . S PRCEND=""
48 . Q
49 D TRTN:'$D(PRCXM)
50 Q
51 ;
52MANY ; Distributed transaction process
53 D TFILER^PRCOSRV1
54 I $P($G(^PRCF(423.6,PRCDA,0)),U,2)'>0 D TSKSET Q
55 I '$$SEQ(PRCDA,TOTS) Q
56 L +^PRCF(423.6,PRCDA):1
57 Q:'$T
58 S MSG=^PRCF(423.6,PRCDA,1,10000,0)
59 I $P(MSG,U,9)'="001" D
60 . S $P(MSG,U,8)="001"
61 . S $P(MSG,U,9)="001"
62 . S ^PRCF(423.6,PRCDA,1,10000,0)=MSG
63 . D TSKKILL
64 . D TRTN
65 . Q
66 L -^PRCF(423.6,PRCDA)
67 Q
68 ;
69LTC ; Look up Transaction Code
70 S PRCETIME=$P($G(^PRC(411,$P(XMRG,U,3),7)),U)
71 S PRCETIME=$S(PRCETIME]"":PRCETIME,1:86400)
72 N Y,X,X1
73 S Y=$O(^PRCF(423.5,"B",$P(XMRG,U)_"-"_$P(XMRG,U,4),0))
74 I +Y'>0 S PRCXM(1)=$P($T(ERROR+1),";;",2) Q
75 S X1=$G(^PRCF(423.5,+Y,0))
76 I X1="" S PRCXM(1)=$P($T(ERROR+9),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
77 S PRCMG=$P(X1,U,2)
78 I PRCMG'>0 S PRCXM(1)=$P($T(ERROR+6),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
79 S PRCMG=$G(^XMB(3.8,$P(X1,U,2),0))
80 I PRCMG="" S PRCXM(1)=$P($T(ERROR+7),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
81 S PRCMG=$P(PRCMG,U)
82 I PRCMG="" S PRCXM(1)=$P($T(ERROR+8),";;",2)_" "_$P(XMRG,U)_"-"_$P(XMRG,U,4)_"." Q
83 S PRCRTN=$P(X1,U,3,4)
84 S X=$P(X1,U,4)
85 I X="" S PRCXM(1)=$P($T(ERROR+3),";;",2)_" is missing." Q
86 X ^%ZOSF("TEST")
87 S:'$T PRCXM(1)=$P($T(ERROR+3),";;",2)_" "_PRCRTN_" missing in RD."
88 Q
89 ;
90TRTN ; Task transaction process
91 N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
92 S (ZTSAVE("PRCDA"),ZTSAVE("DT"),ZTSAVE("U"),ZTSAVE("DUZ"))=""
93 S ZTSAVE("ZTREQ")="@"
94 S ZTRTN=PRCRTN
95 S ZTDTH=$H
96 S ZTIO=""
97 D ^%ZTLOAD
98 L +^PRCF(423.6,PRCDA):1
99 S $P(^PRCF(423.6,PRCDA,0),U,2)=ZTSK
100 L -^PRCF(423.6,PRCDA)
101 Q
102 ;
103TRADEL(X) ; Process to delete transaction from transaction file
104 ;N DIK,DA,Y S DIK="^PRCF(423.6,",DA=X D ^DIK
105 Q
106 ;
107TRAPRGE ; Purge old, incomplete, sequenced transactions
108 D TRADEL(PRCDA)
109 S PRCXM(1)=$P($T(ERROR+2),";;",2)
110 D PERROR^PRCOSRV1
111 Q
112 ;
113TSKKILL ; KILL Tasked PURGE process
114 N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
115 S ZTSK=+$P(^PRCF(423.6,PRCDA,0),U,2)
116 D KILL^%ZTLOAD
117 Q
118 ;
119TSKSET ; TASKs a PURGE transaction process
120 N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
121 ;IF THERE IS ALREADY A TASK SET IN THE RECORD DON'T START ANOTHER ONE
122 Q:$P($G(^PRCF(423.6,PRCDA,0)),U,2)>0
123 S (ZTSAVE("XMFROM"),ZTSAVE("PRCDA"),ZTSAVE("DUZ"),ZTSAVE("XMDUZ"),ZTSAVE("XMZ"))=""
124 S (ZTSAVE("PRCOXMRG"),ZTSAVE("PRCOSOP"),ZTSAVE("PRCOMSG"),ZTSAVE("PRCOSND"),ZTSAVE("PRCOSUB"))=""
125 S ZTSAVE("ZTREQ")="@"
126 S ZTRTN="TRAPRGE^PRCOSRV"
127 S ZTDTH=$$DTC(PRCETIME)
128 S ZTIO=""
129 D ^%ZTLOAD
130 S $P(^PRCF(423.6,PRCDA,0),U,2)=ZTSK
131 Q
132 ;
133TRETRY ; Task to reprocess transaction
134 K PRETRY,PRCEND
135 D TFILER^PRCOSRV1
136 N ZTSK,ZTDTH,ZTUCI,ZTSAVE,ZTIO,ZTDESC,ZTRTN
137 S (ZTSAVE("XMFROM"),ZTSAVE("PRCDA"),ZTSAVE("DUZ"),ZTSAVE("DUN"),ZTSAVE("XMSUB"),ZTSAVE("XMY("))=""
138 S ZTSAVE("ZTREQ")="@"
139 S ZTRTN="TRETRY1^PRCOSRV"
140 S ZTDTH=$$DTC(PRCETIME)
141 S ZTIO=""
142 D ^%ZTLOAD
143 Q
144 ;
145TRETRY1 ; Resend transaction in a new message
146 S XMTEXT="^PRCF(423.6,"_PRCDA_",1,"
147 D ^XMD
148 Q
149 ;
150SEQ(X,Y) ;
151 N CNT,Z
152 S CNT=0
153 F Z=10000:10000:Y*10000 S:$D(^PRCF(423.6,X,1,Z,0)) CNT=CNT+1
154 Q $S(CNT=Y:1,1:0)
155 ;
156DTC(SEC) ; Adds seconds to $H
157 N TIME,%H
158 D NOW^%DTC
159 S TIME=$P(%H,",")+(SEC+$P(%H,",",2)\86400)_","_(SEC+$P(%H,",",2)#86400)
160 Q TIME
161 ;
162DKILL ; Delete mail message from postmaster mailbox
163 N XMZ
164 S XMSER="S."_XQSOP
165 S XMZ=XQMSG
166 D REMSBMSG^XMA1C
167 Q
168 ;
169ERROR ;
170 ;;Transaction code does not exist in PRC IFCAP MESSAGE ROUTER file (423.5) "B" x-ref.
171 ;;All parts of this multipart message did not arrive.
172 ;;Routine to process this transaction does not exist, routine
173 ;;Can not figure out if this is a single or multipart transaction.
174 ;;This transaction has no ending $.
175 ;;There is no mail group pointer from file 423.5 entry
176 ;;There is no mail group entry in file 3.8 for the pointer from file 423.5 entry
177 ;;There is no mail group name in file 3.8 from file 423.5 entry
178 ;;There is a "B" x-ref but no record in file 423.5 for entry
179 ;;One or more parts of this transaction's key is missing.
Note: See TracBrowser for help on using the repository browser.