source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOER4.m@ 623

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1PRCOER4 ;WIRMFO-EDI EXCEPTIONS REPORT ; [8/31/98 1:51pm]
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 W @IOF
6 D RT^PRCOER1 ;ask user date range
7 I $S('$G(PRCOBEG):1,'$G(PRCOSTOP):1,1:0) G STOP^PRCOER2
8 ;
9 S ZTSAVE("PRCOBEG")=""
10 S ZTSAVE("PRCOSTOP")=""
11 S ZTSAVE("SENDER")=""
12 S ZTRTN="START^PRCOER4"
13 S ZTDESC="EC/EDI Exceptions Report"
14 D ZIS^PRCOER2
15 I $G(POP) G STOP^PRCOER2
16 I $G(PRCOPOP) G STOP^PRCOER2
17 ;
18START ; entry to generate Exceptions Report
19 ;
20 U IO
21 I $E(IOST,1,2)="C-" W @IOF
22 ; this section gathers all errors sent from Austin
23 D HED
24 D PRJ
25 I '$G(PRCOUT),$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR G QUIT:$G(DIRUT)
26 W @IOF
27 D HED
28 D POA
29 ;
30QUIT K DUOUT,DIRUT,DTOUT,IT,PO,PRCO,CNT G STOP^PRCOER2 ;return to list manager control
31 ;
32PRJ N I,J,PRCO
33 D HEDPRJ
34 I SENDER=0 S I=PRCOBEG F S I=$O(^PRC(443.75,"AL",2,"PRJ",I)) Q:'I!(I>PRCOSTOP)!($G(PRCOUT)) D
35 . S J=0 F S J=$O(^PRC(443.75,"AL",2,"PRJ",I,J)) Q:'J!($G(PRCOUT)) S PRCO(0)=$G(^PRC(443.75,J,0)),PRCO(1)=^(1) D DISPLAY S CNT=1
36 I SENDER>0 S I=PRCOBEG F S I=$O(^PRC(443.75,"AL1",2,SENDER,"PRJ",I)) Q:'I!(I>PRCOSTOP)!($G(PRCOUT)) D
37 . S J=0 F S J=$O(^PRC(443.75,"AL1",2,SENDER,"PRJ",I,J)) Q:'J!($G(PRCOUT)) S PRCO(0)=$G(^PRC(443.75,J,0)),PRCO(1)=^(1) D DISPLAY S CNT=1
38 I '$G(CNT) D NORECORD
39 Q
40 ;
41DISPLAY ; Come here to show a PRJ exception to the user.
42 ;
43 W !,?1,$P(PRCO(0),U,2),?22,$P(PRCO(0),U,6),?36,$$FMTE^XLFDT($P(PRCO(1),U,2),2),?64,$E($P(PRCO(1),U,3),1,25)
44 W !?2,$P(PRCO(1),U,4),?30,$P(PRCO(1),U,6),?38,$P(PRCO(1),U,8),?50,$P(PRCO(1),U,9),?62,$P(PRCO(1),U,10),?73,$P(PRCO(1),U,14)
45 I $P(PRCO(1),U,5)]"" W !?4,$P(PRCO(1),U,5)
46 I $P(PRCO(1),U,7) W !?4,"Reject Reason Code: ",$P($G(^PRC(443.76,+$P(PRCO(1),U,7),0)),U,2)
47 D HANG Q:$G(PRCOUT)
48 I $Y+5>IOSL W @IOF D HED,HEDPRJ
49 Q
50 ;
51POA N I,J,PRCO
52 K PRCOUT,CNT
53 D HEDPOA
54 S I=PRCOBEG F S I=$O(^PRC(443.75,"AM",3,"POA",I)) Q:'I!(I>PRCOSTOP)!($G(PRCOUT)) D
55 . S J=0 F S J=$O(^PRC(443.75,"AM",3,"POA",I,J)) Q:'J!($G(PRCOUT)) S PRCO(0)=$G(^PRC(443.75,J,0)),PRCO(1)=^(1) D
56 .. S PO=+$P(PRCO(0),U,8) Q:$G(^PRC(442,PO,0))']"" D DISPLAY1
57 I '$G(CNT) D NORECORD
58 Q
59 ;
60DISPLAY1 ; Come here to show a POA exception to a user.
61 ;
62 Q:$P(PRCO(1),U,6)']"" S IT=$O(^PRC(442,PO,2,"B",$P(PRCO(1),U,6),0)) Q:IT=""
63 S PRCO(2)=$G(^PRC(442,+PO,2,+IT,0)),PRCO(3)=$G(^(2))
64 Q:$P($G(PRCO(3)),U,9)="AC"
65 Q:$P($G(PRCO(3)),U,11)="AC"
66 S CNT=1
67 W !?2,$P(PRCO(0),U,2),?26,$P(PRCO(1),U,6),?48,$P(^PRCD(420.5,+$P(PRCO(2),U,3),0),U,2)
68 W !?3,$P(PRCO(2),U,2),?15,$S($P(PRCO(3),U,12):$P(PRCO(3),U,12),1:$P(PRCO(3),U,10))
69 W ?27,$S($P(PRCO(3),U,11)]"":$$CODE($P(PRCO(3),U,11)),1:$$CODE($P(PRCO(3),U,9)))
70 D ERR
71 D HANG Q:$G(PRCOUT)
72 I $Y+5>IOSL W @IOF D HED,HEDPOA
73 Q
74 ;
75HED ; used to print main header for exception report.
76 W !!
77 S HEADER=$S(SENDER=0:"EC/EDI EXCEPTION REPORT",1:"EC/EDI EXCEPTION REPORT for "_$P($G(^VA(200,SENDER,0)),U))
78 W $$CJ^XLFSTR(HEADER,$S($G(IOM):IOM,1:80)),!
79 W $$CJ^XLFSTR($$REPEAT^XLFSTR("-",$L(HEADER)),$S($G(IOM):IOM,1:80)),!
80 W !?2,"Date Range for Report: ",$$FMTE^XLFDT(PRCOBEG)_" to "_$$FMTE^XLFDT(PRCOSTOP),!
81 Q
82HEDPRJ ; write header for PRJ data
83 W !,$$CJ^XLFSTR(">>>> PRJ EXCEPTIONS <<<<",$S($G(IOM):IOM,1:80))
84 W !!?1,"REFERENCE #",?22,"VENDOR ID",?36,"DATE/TIME PROCESSED",?59,"INCORRECT SEGMENT"
85 W !?2,"INCORRECT FIELD",?30,"LINE#",?38,"DESC-LINE#",?50,"DE-SEQ#",?62,"CO-SEQ#",?73,"SEQ #"
86 W !?4,"FIELD CONTENTS"
87 W !,$$REPEAT^XLFSTR("=",$S($G(IOM):IOM,1:80))
88 Q
89 ;
90HEDPOA ; write header for POA exceptions
91 W !,$$CJ^XLFSTR(">>>> POA EXCEPTIONS <<<<",$S($G(IOM):IOM,1:80))
92 W !!?1,"REFERENCE #",?24,"LINE ITEM #",?47,"UNIT OF PURCHASE"
93 W !?2,"QTY ORDERED",?15,"QTY EXCEPTED",?29,"EXCEPTION REASON"
94 W !,$$REPEAT^XLFSTR("=",$S($G(IOM):IOM,1:80))
95 Q
96 ;
97HANG ; call at end of screen if output sent to screen
98 ; returns 'PRCOUT'=1 if user enter '^'
99 N DIRUT,DUOUT,DTOUT
100 K PRCOUT
101 I $Y+5>IOSL,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y PRCOUT=1 Q:$G(PRCOUT)
102 ;
103 ; I $Y+5>IOSL W @IOF D HED
104 ;
105 Q
106 ;
107CODE(X) ; returns external value of set of codes from field 442.01,13
108 ; X = what is stored
109 I $G(X)']"" Q ""
110 N Y,C
111 S Y=X
112 S C=$P(^DD(442.01,13,0),U,2)
113 D Y^DIQ
114 Q Y
115 ;
116ERR ; write out incoming processing errors
117 ;
118 Q:'$O(^PRC(443.75,J,"ERR",0))
119 W !?8,">>> Incoming processing errors <<<"
120 N I S I=0
121 F S I=$O(^PRC(443.75,J,"ERR",I)) Q:'I W !?2,"- ",$G(^(I,0))
122 Q
123 ;
124NORECORD ; write no data to report
125 W !!?3,"No records meet the selection criteria.",!
126 Q
127 ;
128PO ; display selected PURCHASE ORDER
129 S MESS="Enter the line number of the PO/RFQ"
130 D MSG^VALM10(MESS)
131 W !!!!
132AGAIN W !,"LINE NUMBER: " R PONUM:DTIME
133 I PONUM["^"!(PONUM="") G FINI
134 I PONUM'?1.N!(PONUM<1) W !!,?6," Please enter the line number next to the PO/RFQ Number.",$C(7),! G AGAIN
135 I PONUM>VALMCNT W !!,?6," Response must be no greater than "_VALMCNT_".",$C(7),! G AGAIN
136 S PONUM1=$P($G(^PRC(443.75,"PRCOER",$J,PONUM)),U,2)
137 S PONUM2=$G(^PRC(443.75,PONUM1,0))
138 I PONUM2="" W !,"THE ENTRY IN FILE 443.75 IS MISSING" G FINI
139 S PRC("SITE")=$P($P(PONUM2,U,2),"-",1)
140 I $P(PONUM2,"-",3)="RFQ" W !!,?6," Please use option View RFQ [PRCHQ15] to review this line item.",$C(7),! G AGAIN
141 S D0=$P(PONUM2,U,8)
142 D CLEAR^VALM1
143 D ^PRCHDP1
144FINI D PAUSE^VALM1
145 S VALMBCK="R"
146 Q
Note: See TracBrowser for help on using the repository browser.