- 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 Feb 18, 2025@23:39:46 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
