source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPDAP1.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1PRCPDAP1 ;WISC/RFJ-drug accountability/prime vendor (process data) ;15 Mar 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7PROCESS ; process data on invoice
8 N %,DATA,GSDATA,ISADATA,ITCOUNT,ITEMDA,LASTSEG,LINE,LINEITEM,NDC,NEXTSEG,NTYPE,P,STCOUNT,STCTRL,STDATA,VDC,VENDA
9 K ^TMP($J,"PRCPDAPV SET"),PRCPFLAG,PRCPFERR
10 S LASTSEG=""
11 S LINE=0 F S LINE=$O(^TMP($J,"PRCPDAPVS",LINE)) Q:'LINE S DATA=^(LINE) D Q:$G(PRCPFLAG)
12 . ; check segment order
13 . D ORDER^PRCPDAPE I $G(PRCPFLAG) Q
14 . S LASTSEG=$P(DATA,"^")
15 . ; control header
16 . I $P(DATA,"^")="ISA" S ISADATA=DATA D Q
17 . . I $L($P(DATA,"^",14))'=9 D ERROR^PRCPDAPE("'ISA' CONTROL HEADER, CONTROL NUMBER (piece 14) SHOULD BE 9 CHARACTERS IN LENGTH")
18 . ; control trailer
19 . I $P(DATA,"^")="IEA" D Q
20 . . I $P(DATA,"^",3)'=$P(ISADATA,"^",14) D ERROR^PRCPDAPE("'IEA' CONTROL TRAILER, CONTROL NUMBER (piece 3) SHOULD EQUAL 'ISA' CONTROL HEADER, CONTROL NUMBER (piece 14 = "_$P(ISADATA,"^",14)_")")
21 . ; group header
22 . I $P(DATA,"^")="GS" S GSDATA=DATA D Q
23 . . F %=3:1:6 S P=$S(%=3:7,1:%+5) I $P(DATA,"^",%)'=$TR($P(ISADATA,"^",P)," ") D ERROR^PRCPDAPE("'GS' GROUP HEADER, (piece "_%_") SHOULD EQUAL 'ISA' CONTROL HEADER (piece "_P_" = "_$TR($P(ISADATA,"^",P)," ")) Q
24 . ; group trailer
25 . I $P(DATA,"^")="GE" D Q
26 . . I $P(DATA,"^",3)'=$P($G(GSDATA),"^",7) D ERROR^PRCPDAPE("'GE' GROUP TRAILER, CONTROL NUMBER (piece 3) SHOULD EQUAL 'GS' GROUP HEADER, CONTROL NUMBER (piece 7 = "_$P($G(GSDATA),"^",7)_")")
27 . ; set header
28 . I $P(DATA,"^")="ST" D Q
29 . . S STDATA=DATA,STCTRL=$P(DATA,"^",3),STCOUNT=1,ITCOUNT=0,NTYPE=""
30 . . I $L(STCTRL)'=9 D ERROR^PRCPDAPE("'ST' SET HEADER, CONTROL NUMBER (piece 3) SHOULD BE 9 CHARACTERS IN LENGTH") Q
31 . . I $D(^TMP($J,"PRCPDAPV SET",STCTRL)) D ERROR^PRCPDAPE("'ST' SET HEADER, CONTROL NUMBER (piece 3) IS USED MORE THAN ONCE")
32 . ; set trailer
33 . I $P(DATA,"^")="SE" S STCOUNT=STCOUNT+1 D Q
34 . . I $P(DATA,"^",3)'=STCTRL D ERROR^PRCPDAPE("'SE' SET TRAILER, CONTROL NUMBER (piece 3) SHOULD EQUAL 'ST' SET HEADER, CONTROL NUMBER (piece 3 = "_STCTRL_")") Q
35 . . I STCOUNT'=$P(DATA,"^",2) D ERROR^PRCPDAPE("'SE' SET TRAILER, COUNT OF SEGMENTS (piece 2) SHOULD EQUAL NUMBER OF SEGMENTS ("_STCOUNT_")")
36 . ; beginning segment for invoice
37 . I $P(DATA,"^")="BIG" S STCOUNT=STCOUNT+1 D Q
38 . . I $P(DATA,"^",4)="" S $P(DATA,"^",4)=$P(DATA,"^",2)
39 . . S $P(DATA,"^",5)=$TR($P(DATA,"^",5)," ")
40 . . S ^TMP($J,"PRCPDAPV SET",STCTRL,"IN")=$P(DATA,"^",2,5)
41 . ; (not used)
42 . I $P(DATA,"^")="REF" S STCOUNT=STCOUNT+1 Q
43 . ; buyer, seller, shipping info
44 . I $P(DATA,"^")="N1" S STCOUNT=STCOUNT+1,NTYPE=$P(DATA,"^",2) D Q
45 . . I NTYPE'="BY",NTYPE'="DS",NTYPE'="ST" D ERROR^PRCPDAPE("THE 'N1' SEGMENT, PIECE 2 SHOULD EQUAL 'BY', 'DS' OR 'ST'") Q
46 . . S $P(^TMP($J,"PRCPDAPV SET",STCTRL,NTYPE),"^")=$P(DATA,"^",3),$P(^(NTYPE),"^",2)=$P(DATA,"^",5)
47 . I $P(DATA,"^")="N2" D NONTYPE^PRCPDAPE Q:$G(PRCPFLAG) S %=$G(^TMP($J,"PRCPDAPV SET",STCTRL,NTYPE)),$P(^(NTYPE),"^")=$P(%,"^")_" "_$P(DATA,"^",2)_" "_$P(DATA,"^",3),STCOUNT=STCOUNT+1 Q
48 . I $P(DATA,"^")="N3" D NONTYPE^PRCPDAPE Q:$G(PRCPFLAG) S $P(^TMP($J,"PRCPDAPV SET",STCTRL,NTYPE),"^",3)=$P(DATA,"^",2)_" "_$P(DATA,"^",3),STCOUNT=STCOUNT+1 Q
49 . I $P(DATA,"^")="N4" D NONTYPE^PRCPDAPE Q:$G(PRCPFLAG) S $P(^TMP($J,"PRCPDAPV SET",STCTRL,NTYPE),"^",4,6)=$P(DATA,"^",2,4),STCOUNT=STCOUNT+1,NTYPE="" Q
50 . ; term discount
51 . I $P(DATA,"^")="ITD" S $P(^TMP($J,"PRCPDAPV SET",STCTRL,"IN"),"^",6,11)=$P(DATA,"^",4,9),STCOUNT=STCOUNT+1 Q
52 . ; date time reference
53 . I $P(DATA,"^")="DTM" S STCOUNT=STCOUNT+1 D Q
54 . . S %=$S($P(DATA,"^",2)="002":12,$P(DATA,"^",2)="035":13,1:0) I '% Q
55 . . S $P(^TMP($J,"PRCPDAPV SET",STCTRL,"IN"),"^",%)=$P(DATA,"^",3)
56 . ; invoice line item
57 . I $P(DATA,"^")="IT1" S STCOUNT=STCOUNT+1,ITCOUNT=ITCOUNT+1 D ITEM^PRCPDAPI Q
58 . ; item count
59 . I $P(DATA,"^")="CTT" S STCOUNT=STCOUNT+1 D Q
60 . . I ITCOUNT'=$P(DATA,"^",2) D ERROR^PRCPDAPE("'CTT' TRANSACTION TOTALS, LINE ITEM COUNT (piece 2) SHOULD EQUAL NUMBER OF LINE ITEMS ("_ITCOUNT_")")
61 . ; unknown segement
62 . D ERROR^PRCPDAPE("SEGMENT IS UNKNOWN")
63 Q
Note: See TracBrowser for help on using the repository browser.