PRCPDAP1 ;WISC/RFJ-drug accountability/prime vendor (process data) ;15 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PROCESS ; process data on invoice
N %,DATA,GSDATA,ISADATA,ITCOUNT,ITEMDA,LASTSEG,LINE,LINEITEM,NDC,NEXTSEG,NTYPE,P,STCOUNT,STCTRL,STDATA,VDC,VENDA
K ^TMP($J,"PRCPDAPV SET"),PRCPFLAG,PRCPFERR
S LASTSEG=""
S LINE=0 F S LINE=$O(^TMP($J,"PRCPDAPVS",LINE)) Q:'LINE S DATA=^(LINE) D Q:$G(PRCPFLAG)
. ; check segment order
. D ORDER^PRCPDAPE I $G(PRCPFLAG) Q
. S LASTSEG=$P(DATA,"^")
. ; control header
. I $P(DATA,"^")="ISA" S ISADATA=DATA D Q
. . I $L($P(DATA,"^",14))'=9 D ERROR^PRCPDAPE("'ISA' CONTROL HEADER, CONTROL NUMBER (piece 14) SHOULD BE 9 CHARACTERS IN LENGTH")
. ; control trailer
. I $P(DATA,"^")="IEA" D Q
. . 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)_")")
. ; group header
. I $P(DATA,"^")="GS" S GSDATA=DATA D Q
. . 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
. ; group trailer
. I $P(DATA,"^")="GE" D Q
. . 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)_")")
. ; set header
. I $P(DATA,"^")="ST" D Q
. . S STDATA=DATA,STCTRL=$P(DATA,"^",3),STCOUNT=1,ITCOUNT=0,NTYPE=""
. . I $L(STCTRL)'=9 D ERROR^PRCPDAPE("'ST' SET HEADER, CONTROL NUMBER (piece 3) SHOULD BE 9 CHARACTERS IN LENGTH") Q
. . I $D(^TMP($J,"PRCPDAPV SET",STCTRL)) D ERROR^PRCPDAPE("'ST' SET HEADER, CONTROL NUMBER (piece 3) IS USED MORE THAN ONCE")
. ; set trailer
. I $P(DATA,"^")="SE" S STCOUNT=STCOUNT+1 D Q
. . 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
. . I STCOUNT'=$P(DATA,"^",2) D ERROR^PRCPDAPE("'SE' SET TRAILER, COUNT OF SEGMENTS (piece 2) SHOULD EQUAL NUMBER OF SEGMENTS ("_STCOUNT_")")
. ; beginning segment for invoice
. I $P(DATA,"^")="BIG" S STCOUNT=STCOUNT+1 D Q
. . I $P(DATA,"^",4)="" S $P(DATA,"^",4)=$P(DATA,"^",2)
. . S $P(DATA,"^",5)=$TR($P(DATA,"^",5)," ")
. . S ^TMP($J,"PRCPDAPV SET",STCTRL,"IN")=$P(DATA,"^",2,5)
. ; (not used)
. I $P(DATA,"^")="REF" S STCOUNT=STCOUNT+1 Q
. ; buyer, seller, shipping info
. I $P(DATA,"^")="N1" S STCOUNT=STCOUNT+1,NTYPE=$P(DATA,"^",2) D Q
. . I NTYPE'="BY",NTYPE'="DS",NTYPE'="ST" D ERROR^PRCPDAPE("THE 'N1' SEGMENT, PIECE 2 SHOULD EQUAL 'BY', 'DS' OR 'ST'") Q
. . S $P(^TMP($J,"PRCPDAPV SET",STCTRL,NTYPE),"^")=$P(DATA,"^",3),$P(^(NTYPE),"^",2)=$P(DATA,"^",5)
. 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
. 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
. 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
. ; term discount
. I $P(DATA,"^")="ITD" S $P(^TMP($J,"PRCPDAPV SET",STCTRL,"IN"),"^",6,11)=$P(DATA,"^",4,9),STCOUNT=STCOUNT+1 Q
. ; date time reference
. I $P(DATA,"^")="DTM" S STCOUNT=STCOUNT+1 D Q
. . S %=$S($P(DATA,"^",2)="002":12,$P(DATA,"^",2)="035":13,1:0) I '% Q
. . S $P(^TMP($J,"PRCPDAPV SET",STCTRL,"IN"),"^",%)=$P(DATA,"^",3)
. ; invoice line item
. I $P(DATA,"^")="IT1" S STCOUNT=STCOUNT+1,ITCOUNT=ITCOUNT+1 D ITEM^PRCPDAPI Q
. ; item count
. I $P(DATA,"^")="CTT" S STCOUNT=STCOUNT+1 D Q
. . I ITCOUNT'=$P(DATA,"^",2) D ERROR^PRCPDAPE("'CTT' TRANSACTION TOTALS, LINE ITEM COUNT (piece 2) SHOULD EQUAL NUMBER OF LINE ITEMS ("_ITCOUNT_")")
. ; unknown segement
. D ERROR^PRCPDAPE("SEGMENT IS UNKNOWN")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPDAP1 4340 printed Dec 13, 2024@02:13:23 Page 2
PRCPDAP1 ;WISC/RFJ-drug accountability/prime vendor (process data) ;15 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PROCESS ; process data on invoice
+1 NEW %,DATA,GSDATA,ISADATA,ITCOUNT,ITEMDA,LASTSEG,LINE,LINEITEM,NDC,NEXTSEG,NTYPE,P,STCOUNT,STCTRL,STDATA,VDC,VENDA
+2 KILL ^TMP($JOB,"PRCPDAPV SET"),PRCPFLAG,PRCPFERR
+3 SET LASTSEG=""
+4 SET LINE=0
FOR
SET LINE=$ORDER(^TMP($JOB,"PRCPDAPVS",LINE))
if 'LINE
QUIT
SET DATA=^(LINE)
Begin DoDot:1
+5 ; check segment order
+6 DO ORDER^PRCPDAPE
IF $GET(PRCPFLAG)
QUIT
+7 SET LASTSEG=$PIECE(DATA,"^")
+8 ; control header
+9 IF $PIECE(DATA,"^")="ISA"
SET ISADATA=DATA
Begin DoDot:2
+10 IF $LENGTH($PIECE(DATA,"^",14))'=9
DO ERROR^PRCPDAPE("'ISA' CONTROL HEADER, CONTROL NUMBER (piece 14) SHOULD BE 9 CHARACTERS IN LENGTH")
End DoDot:2
QUIT
+11 ; control trailer
+12 IF $PIECE(DATA,"^")="IEA"
Begin DoDot:2
+13 IF $PIECE(DATA,"^",3)'=$PIECE(ISADATA,"^",14)
DO ERROR^PRCPDAPE("'IEA' CONTROL TRAILER, CONTROL NUMBER (piece 3) SHOULD EQUAL 'ISA' CONTROL HEADER, CONTROL NUMBER (piece 14 = "_$PIECE(ISADATA,"^",14)_")")
End DoDot:2
QUIT
+14 ; group header
+15 IF $PIECE(DATA,"^")="GS"
SET GSDATA=DATA
Begin DoDot:2
+16 FOR %=3:1:6
SET P=$SELECT(%=3:7,1:%+5)
IF $PIECE(DATA,"^",%)'=$TRANSLATE($PIECE(ISADATA,"^",P)," ")
DO ERROR^PRCPDAPE("'GS' GROUP HEADER, (piece "_%_") SHOULD EQUAL 'ISA' CONTROL HEADER (piece "_P_" = "_$TRANSLATE($PIECE(ISADATA,"^",P)," "))
QUIT
End DoDot:2
QUIT
+17 ; group trailer
+18 IF $PIECE(DATA,"^")="GE"
Begin DoDot:2
+19 IF $PIECE(DATA,"^",3)'=$PIECE($GET(GSDATA),"^",7)
DO ERROR^PRCPDAPE("'GE' GROUP TRAILER, CONTROL NUMBER (piece 3) SHOULD EQUAL 'GS' GROUP HEADER, CONTROL NUMBER (piece 7 = "_$PIECE($GET(GSDATA),"^",7)_")")
End DoDot:2
QUIT
+20 ; set header
+21 IF $PIECE(DATA,"^")="ST"
Begin DoDot:2
+22 SET STDATA=DATA
SET STCTRL=$PIECE(DATA,"^",3)
SET STCOUNT=1
SET ITCOUNT=0
SET NTYPE=""
+23 IF $LENGTH(STCTRL)'=9
DO ERROR^PRCPDAPE("'ST' SET HEADER, CONTROL NUMBER (piece 3) SHOULD BE 9 CHARACTERS IN LENGTH")
QUIT
+24 IF $DATA(^TMP($JOB,"PRCPDAPV SET",STCTRL))
DO ERROR^PRCPDAPE("'ST' SET HEADER, CONTROL NUMBER (piece 3) IS USED MORE THAN ONCE")
End DoDot:2
QUIT
+25 ; set trailer
+26 IF $PIECE(DATA,"^")="SE"
SET STCOUNT=STCOUNT+1
Begin DoDot:2
+27 IF $PIECE(DATA,"^",3)'=STCTRL
DO ERROR^PRCPDAPE("'SE' SET TRAILER, CONTROL NUMBER (piece 3) SHOULD EQUAL 'ST' SET HEADER, CONTROL NUMBER (piece 3 = "_STCTRL_")")
QUIT
+28 IF STCOUNT'=$PIECE(DATA,"^",2)
DO ERROR^PRCPDAPE("'SE' SET TRAILER, COUNT OF SEGMENTS (piece 2) SHOULD EQUAL NUMBER OF SEGMENTS ("_STCOUNT_")")
End DoDot:2
QUIT
+29 ; beginning segment for invoice
+30 IF $PIECE(DATA,"^")="BIG"
SET STCOUNT=STCOUNT+1
Begin DoDot:2
+31 IF $PIECE(DATA,"^",4)=""
SET $PIECE(DATA,"^",4)=$PIECE(DATA,"^",2)
+32 SET $PIECE(DATA,"^",5)=$TRANSLATE($PIECE(DATA,"^",5)," ")
+33 SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"IN")=$PIECE(DATA,"^",2,5)
End DoDot:2
QUIT
+34 ; (not used)
+35 IF $PIECE(DATA,"^")="REF"
SET STCOUNT=STCOUNT+1
QUIT
+36 ; buyer, seller, shipping info
+37 IF $PIECE(DATA,"^")="N1"
SET STCOUNT=STCOUNT+1
SET NTYPE=$PIECE(DATA,"^",2)
Begin DoDot:2
+38 IF NTYPE'="BY"
IF NTYPE'="DS"
IF NTYPE'="ST"
DO ERROR^PRCPDAPE("THE 'N1' SEGMENT, PIECE 2 SHOULD EQUAL 'BY', 'DS' OR 'ST'")
QUIT
+39 SET $PIECE(^TMP($JOB,"PRCPDAPV SET",STCTRL,NTYPE),"^")=$PIECE(DATA,"^",3)
SET $PIECE(^(NTYPE),"^",2)=$PIECE(DATA,"^",5)
End DoDot:2
QUIT
+40 IF $PIECE(DATA,"^")="N2"
DO NONTYPE^PRCPDAPE
if $GET(PRCPFLAG)
QUIT
SET %=$GET(^TMP($JOB,"PRCPDAPV SET",STCTRL,NTYPE))
SET $PIECE(^(NTYPE),"^")=$PIECE(%,"^")_" "_$PIECE(DATA,"^",2)_" "_$PIECE(DATA,"^",3)
SET STCOUNT=STCOUNT+1
QUIT
+41 IF $PIECE(DATA,"^")="N3"
DO NONTYPE^PRCPDAPE
if $GET(PRCPFLAG)
QUIT
SET $PIECE(^TMP($JOB,"PRCPDAPV SET",STCTRL,NTYPE),"^",3)=$PIECE(DATA,"^",2)_" "_$PIECE(DATA,"^",3)
SET STCOUNT=STCOUNT+1
QUIT
+42 IF $PIECE(DATA,"^")="N4"
DO NONTYPE^PRCPDAPE
if $GET(PRCPFLAG)
QUIT
SET $PIECE(^TMP($JOB,"PRCPDAPV SET",STCTRL,NTYPE),"^",4,6)=$PIECE(DATA,"^",2,4)
SET STCOUNT=STCOUNT+1
SET NTYPE=""
QUIT
+43 ; term discount
+44 IF $PIECE(DATA,"^")="ITD"
SET $PIECE(^TMP($JOB,"PRCPDAPV SET",STCTRL,"IN"),"^",6,11)=$PIECE(DATA,"^",4,9)
SET STCOUNT=STCOUNT+1
QUIT
+45 ; date time reference
+46 IF $PIECE(DATA,"^")="DTM"
SET STCOUNT=STCOUNT+1
Begin DoDot:2
+47 SET %=$SELECT($PIECE(DATA,"^",2)="002":12,$PIECE(DATA,"^",2)="035":13,1:0)
IF '%
QUIT
+48 SET $PIECE(^TMP($JOB,"PRCPDAPV SET",STCTRL,"IN"),"^",%)=$PIECE(DATA,"^",3)
End DoDot:2
QUIT
+49 ; invoice line item
+50 IF $PIECE(DATA,"^")="IT1"
SET STCOUNT=STCOUNT+1
SET ITCOUNT=ITCOUNT+1
DO ITEM^PRCPDAPI
QUIT
+51 ; item count
+52 IF $PIECE(DATA,"^")="CTT"
SET STCOUNT=STCOUNT+1
Begin DoDot:2
+53 IF ITCOUNT'=$PIECE(DATA,"^",2)
DO ERROR^PRCPDAPE("'CTT' TRANSACTION TOTALS, LINE ITEM COUNT (piece 2) SHOULD EQUAL NUMBER OF LINE ITEMS ("_ITCOUNT_")")
End DoDot:2
QUIT
+54 ; unknown segement
+55 DO ERROR^PRCPDAPE("SEGMENT IS UNKNOWN")
End DoDot:1
if $GET(PRCPFLAG)
QUIT
+56 QUIT
