source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOACT.m@ 767

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1PRCOACT ;WISC/DJM-"ACT" & "PRJ" TRANSACTIONS FROM AUSTIN ;7/21/96 21:45
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5START ;THIS ROUTINE WILL SAVE THE INCOMMING "ACT" OR "PRJ" TRANSACTION
6 ;IN THE "EDI STATUS" FILE (#443.75) WITHIN AN EXISTING RECORD. THIS
7 ;ROUTINE WILL START UP WHEN AN "ACT" OR "PRJ" TRANSACTION ARRIVES
8 ;FROM AUSTIN AND IS SAVED IN FILE 423.6. AFTER SAVING IN 423.6 THE
9 ;SERVER WILL START UP A BACKGROUND TASK THAT CALLS THIS ROUTINE.
10 ;
11 ;THE BACKGROUND TASK WILL SET UP **PRCDA**, THE INTERNAL ENTRY
12 ;NUMBER FROM FILE 423.6. THE RECORD AT **PRCDA** CONTAINS THE DATA
13 ;FROM THE "ACT" OR "PRJ" TRANSACTION THAT 'ARRIVED' FROM AUSTIN.
14 ;
15 N COUNT,COUNTER,I,LINE,MGP,PONO,PRC,PRCMG,PRCTC,PRCTT,PRCXM,RFQ,RECORD,ERRCNT
16 N RRC,SEGT,STATION,STCK,TEXT,VENDOR,X,X1,X2
17 ;
18 ;NOW LETS VERIFY THAT THE TRANSACTION BELONGS TO THIS SITE.
19 ;
20 S LINE=$G(^PRCF(423.6,PRCDA,1,10000,0))
21 S MGP=$O(^PRCF(423.5,"B",$P(LINE,U)_"-"_$P(LINE,U,4),0))
22 I MGP="" S PRCXM(1)=$P($T(ERROR+8),";;",2)_$P(LINE,U)_"-"_$P(LINE,U,4)_"." G EXIT
23 S MGP=$G(^PRCF(423.5,MGP,0))
24 I MGP="" S PRCXM(1)=$P($T(ERROR+9),";;",2) G EXIT
25 I $P(MGP,U,2)="" S PRCXM(1)=$P($T(ERROR+10),";;",2) G EXIT
26 I $P(MGP,U,2)]"" S PRCMG=$P($G(^XMB(3.8,$P(MGP,U,2),0)),U)
27 I PRCMG="" S PRCXM(1)=$P($T(ERROR+11),";;",2) G EXIT
28 D I $D(PRCXM(1)) G EXIT
29 . I ",ACT,PRJ,"'[","_$P(LINE,U,4)_"," S PRCXM(1)=$P($T(ERROR+1),";;",2)_$P(LINE,U,4)_"." Q
30 . S STATION=$P(LINE,U,3) I STATION="" S PRCXM(1)=$P($T(ERROR+4),";;",2)_$G(PRCDA)_"." Q
31 . S STCK=$O(^PRC(411,"B",STATION,0)) I STCK'>0 S PRCXM(1)=$P($T(ERROR+2),";;",2)_$G(STATION)_"." Q
32 . Q
33 S PRCTC=$P(LINE,U,4)
34 ;
35 ;GATHER THE DATA FROM THE 'AT' SEGMENT OF THE TRANSACTION.
36 ;
37 S LINE=$G(^PRCF(423.6,PRCDA,1,10001,0))
38 I $P(LINE,U,1)'="AT" S PRCXM(1)=$P($T(ERROR+3),";;",2)_$P($G(LINE),U)_"." G EXIT
39 S PRCTT=$P(LINE,U,2)
40 I PRCTT="" S PRCXM(1)=$P($T(ERROR+13),";;",2)_$G(PRCDA)_"." G EXIT
41 S COUNT=+$P(LINE,U,3)
42 ;
43 ;NOW GET THE DATA FROM EACH 'TR' OR 'RJ' SEGMENT.
44 ;
45 S I=10001
46 S COUNTER=0,ERRCNT=1
47 K PRCXM
48 F S I=$O(^PRCF(423.6,PRCDA,1,I)) Q:I'>0 D D:$O(PRCXM(0)) PERROR^PRCOACT0 Q:LINE["$"
49 . K PRC
50 . S LINE=$G(^PRCF(423.6,PRCDA,1,I,0))
51 . Q:$E(LINE,1)="$"
52 . S SEGT=$P(LINE,U)
53 . Q:",TR,RJ,"'[","_SEGT_","
54 . S PRC(1,443.75,"?+1,",9)=PRCTC
55 . S PRC(1,443.75,"?+1,",21)=COUNT
56 . S PONO=$P(LINE,U,2)
57 . I PRCTT="PHA" D
58 . . F Q:$A(PONO,$L(PONO))'=32 S PONO=$E(PONO,1,$L(PONO)-1)
59 . . S PONO=$E(PONO,1,3)_"-"_$E(PONO,4,$L(PONO))
60 . . Q
61 . S X1=$E($P(LINE,U,5),1,4)-1700_"0101"
62 . S X2=$E($P(LINE,U,5),5,7)-1
63 . D C^%DTC
64 . S PRC(1,443.75,"?+1,",10)=X_"."_$P(LINE,U,6)
65 . S PRC(1,443.75,"?+1,",22)=$S(PRCTC="ACT":$P(LINE,U,7),1:$P(LINE,U,14))
66 . S VENDOR=$P(LINE,U,3)
67 . S:PRCTT="RFQ" RFQ=$S(PRCTC="ACT":$P(LINE,U,8),1:$P(LINE,U,16))
68 . S:PRCTT="TXT" TEXT=$P(LINE,U,4)
69 . I PONO="" S PRCXM(ERRCNT)=$P($T(ERROR+14),";;",2)_$G(PRCDA)_"." D ERRCNT Q
70 . I PRCTT'="PHA",VENDOR="" S PRCXM(ERRCNT)=$P($T(ERROR+15),";;",2)_$G(PRCDA)_"." D ERRCNT Q
71 . I PRCTT="RFQ",RFQ="" S PRCXM(ERRCNT)=$P($T(ERROR+16),";;",2)_$G(PRCDA)_"." D ERRCNT Q
72 . I PRCTT="TXT",TEXT="" S PRCXM(ERRCNT)=$P($T(ERROR+17),";;",2)_$G(PRCDA)_"." D ERRCNT Q
73 . S RECORD=""
74 . I PRCTT="PHA" D Q:$O(PRCXM(0))
75 . . I VENDOR]"" S RECORD=$O(^PRC(443.75,"AO",PRCTT,PONO,VENDOR,0))
76 . . I 'RECORD D I 'RECORD S PRCXM(ERRCNT)=$P($T(ERROR+19),";;",2)_$G(PRCDA)_"." D ERRCNT Q
77 . . . S RECORD=$O(^PRC(443.75,"AR",PONO,0))
78 . . Q:$O(PRCXM(0))
79 . . S VENDOR(1)=$P($G(^PRC(443.75,+$G(RECORD),0)),U,6)
80 . . I VENDOR]"",VENDOR(1)]""&(VENDOR'=VENDOR(1)) S PRCXM(ERRCNT)=$P($T(ERROR+20),";;",2)_$G(RECORD)_"." D ERRCNT Q
81 . S:PRCTT="RFQ" RECORD=$O(^PRC(443.75,"AC",PRCTT,PONO,VENDOR,RFQ,0))
82 . S:PRCTT="TXT" RECORD=$O(^PRC(443.75,"AF",PRCTT,PONO,VENDOR,TEXT,0))
83 . I $G(^PRC(443.75,+$G(RECORD),0))']"" S PRCXM(ERRCNT)=$P($T(ERROR+12),";;",2)_$G(PONO)_"." D ERRCNT Q
84 . L +^PRC(443.75,RECORD):180 E S PRCXM(ERRCNT)=$P($T(ERROR+18),";;",2)_$G(RECORD)_"." D ERRCNT Q
85 . ;
86 . I SEGT="RJ" D
87 . . S PRC(1,443.75,"?+1,",11)=$P(LINE,U,7)
88 . . S PRC(1,443.75,"?+1,",12)=$P(LINE,U,8)
89 . . S PRC(1,443.75,"?+1,",13)=$P(LINE,U,9)
90 . . S:$P(LINE,U,12)]"" PRC(1,443.75,"?+1,",17)=$P(LINE,U,12)
91 . . S:$P(LINE,U,13)]"" PRC(1,443.75,"?+1,",18)=$P(LINE,U,13)
92 . . S:$P(LINE,U,10)]"" PRC(1,443.75,"?+1,",14)=$P(LINE,U,10)
93 . . S RRC=$$EXTRL^PRCOACT0($P(LINE,U,15),1)
94 . . I RRC']"" S PRCXM(ERRCNT)=$P($T(ERROR+5),";;",2)_$G(PRCDA)_"." D ERRCNT
95 . . I RRC']"" S PRC(1,443.75,"?+1,",19)="E"
96 . . I RRC']"" S PRC(1,443.75,"?+1,",20)=$P($T(ERROR+5),";;",3) Q
97 . . S RRC=$O(^PRC(443.76,"B",RRC,0))
98 . . I RRC'>0 S PRCXM(ERRCNT)=$P($T(ERROR+6),";;",2)_$G(PRCDA)_" (Error Code is "_$$EXTRL^PRCOACT0($P(LINE,U,15),1)_")." D ERRCNT
99 . . I RRC'>0 S PRC(1,443.75,"?+1,",19)="E"
100 . . I RRC'>0 S PRC(1,443.75,"?+1,",20)=$P($T(ERROR+6),";;",3) Q
101 . . S PRC(1,443.75,"?+1,",15)=RRC
102 . . Q
103 . S PRC(1,443.75,"?+1,",.01)=+$P($G(^PRC(443.75,RECORD,0)),U)
104 . D UPDATE^DIE("","PRC(1)")
105 . S COUNTER=COUNTER+1
106STOP . L:$G(RECORD) -^PRC(443.75,RECORD)
107 . Q
108 I $G(RECORD),COUNTER'=COUNT S PRCXM(ERRCNT)=$P($T(ERROR+7),";;",2)_$G(PRCDA)_"." D ERRCNT
109 ;
110EXIT I $O(PRCXM(0)) D PERROR^PRCOACT0
111 Q
112ERRCNT ;increment counter for multiple errors within RJ,TR processing
113 S ERRCNT=ERRCNT+1
114 Q
115 ;
116ERROR ;HERE IS THE LIST OF ERROR MESSAGES
117 ;;Expected an ACT or a PRJ transaction. Received a ;;A1
118 ;;The STATION number sent from EDI can not be found. The number is ;;A2
119 ;;The second segment is not the expected AT segment. It was a ;;A3
120 ;;There is no STATION number sent from EDI. IEN for 423.6 is ;;A4
121 ;;No REJECT REASON CODE from EDI. The record IEN in 423.6 is ;;A5
122 ;;The ERROR CODE can not be found in the EDI ERROR CODES file. The record IEN in 423.6 is ;;A6
123 ;;There is a difference in the number of TR or RJ segments expected and how many found. File 423.6 entry is ;;A7
124 ;;There is no "B" cross-reference entry for this transaction in file 423.5. The entry is ;;A8
125 ;;There is a "B" cross-reference entry for this transaction but no record.;;A9
126 ;;There is a record for this transaction but no mail group pointer is listed.;;A10
127 ;;The mail group entered in the record in file 423.5 can not be found in the mail group file.;;A11
128 ;;The incoming record can't be found in file 443.75. The RFQ/PO# is ;;A12
129 ;;Required field TYPE OF TRANSACTION is blank. IEN for file 423.6 is ;;A13
130 ;;Required field REF NUMBER is blank. IEN for file 423.6 is ;;A14
131 ;;Required field VENDOR ID NUMBER is blank. IEN for file 423.6 is ;;A15
132 ;;Required field TYPE OF RFQ is blank. IEN for file 423.6 is ;;A16
133 ;;Required field TXT MESSAGE NUMBER is blank. IEN for file 423.6 is ;;A17
134 ;;Unable to access record in file 443.75. IEN is ;;A18
135 ;;Unable to locate entry in file 443.75. IEN for file 423.6 is ;;A19
136 ;;VENDOR ID on transmission does not match 443.75 entry. The IEN is ;;A20
Note: See TracBrowser for help on using the repository browser.