PRCPDAPE ;WISC/RFJ-drug accountability/prime vendor (errors) ;15 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
NONTYPE ; check for order of buyer, seller, ship
I NTYPE="" D ERROR("THE IDENTIFIER SEGMENT 'N1' NEEDS TO COME BEFORE THE '"_$P(DATA,"^")_"' SEGMENT")
Q
;
;
ERROR(MSG) ; show error
W !,DATA
K X S X(1)=MSG D DISPLAY^PRCPUX2(1,79,.X)
S PRCPFLAG=1
Q
;
;
ORDER ; check order of code sheets
; isa <--------------+
; gs <----------+ |
; st <------+ | |
; | big | | |
; | it1 <--+ | | |
; | ... | | | |--repeats
; | it1 <--+ | | |
; | ctt | | |
; se <------+ | |
; ge <----------+ |
; iea <--------------+
S NEXTSEG=$P(DATA,"^")
I LASTSEG="",NEXTSEG'="ISA" D ORDERROR("",NEXTSEG,"ISA") Q
I LASTSEG="GE",NEXTSEG="GS" Q
I LASTSEG="GE",NEXTSEG'="IEA" D ORDERROR("GE",NEXTSEG,"IEA") Q
;
I LASTSEG="ISA",NEXTSEG'="GS" D ORDERROR("ISA",NEXTSEG,"GS") Q
I LASTSEG="SE",NEXTSEG="ST" Q
I LASTSEG="SE",NEXTSEG'="GE" D ORDERROR("SE",NEXTSEG,"GE") Q
;
I LASTSEG="GS",NEXTSEG'="ST" D ORDERROR("GS",NEXTSEG,"ST") Q
I LASTSEG="CTT",NEXTSEG'="SE" D ORDERROR("CTT",NEXTSEG,"SE") Q
;
I LASTSEG="ST",NEXTSEG'="BIG" D ORDERROR("ST",NEXTSEG,"BIG") Q
;
I LASTSEG="IT1",NEXTSEG="IT1" Q
I LASTSEG="IT1",NEXTSEG'="CTT" D ORDERROR("IT1",NEXTSEG,"CTT") Q
Q
;
;
ORDERROR(LAST,NEW,EXPECT) ; segments out of order
; isa segment should be first
I LAST="" D ERROR("SEGMENTS OUT OF ORDER, THE STARTING SEGMENT SHOULD BE 'ISA', NOT '"_NEW_"'") Q
; segments other than isa
D ERROR("SEGMENTS OUT OF ORDER, THE SEGMENT FOLLOWING '"_LAST_"' SHOULD BE '"_EXPECT_"', NOT '"_NEW_"'") Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPDAPE 1818 printed Sep 23, 2025@19:49:31 Page 2
PRCPDAPE ;WISC/RFJ-drug accountability/prime vendor (errors) ;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 ;
NONTYPE ; check for order of buyer, seller, ship
+1 IF NTYPE=""
DO ERROR("THE IDENTIFIER SEGMENT 'N1' NEEDS TO COME BEFORE THE '"_$PIECE(DATA,"^")_"' SEGMENT")
+2 QUIT
+3 ;
+4 ;
ERROR(MSG) ; show error
+1 WRITE !,DATA
+2 KILL X
SET X(1)=MSG
DO DISPLAY^PRCPUX2(1,79,.X)
+3 SET PRCPFLAG=1
+4 QUIT
+5 ;
+6 ;
ORDER ; check order of code sheets
+1 ; isa <--------------+
+2 ; gs <----------+ |
+3 ; st <------+ | |
+4 ; | big | | |
+5 ; | it1 <--+ | | |
+6 ; | ... | | | |--repeats
+7 ; | it1 <--+ | | |
+8 ; | ctt | | |
+9 ; se <------+ | |
+10 ; ge <----------+ |
+11 ; iea <--------------+
+12 SET NEXTSEG=$PIECE(DATA,"^")
+13 IF LASTSEG=""
IF NEXTSEG'="ISA"
DO ORDERROR("",NEXTSEG,"ISA")
QUIT
+14 IF LASTSEG="GE"
IF NEXTSEG="GS"
QUIT
+15 IF LASTSEG="GE"
IF NEXTSEG'="IEA"
DO ORDERROR("GE",NEXTSEG,"IEA")
QUIT
+16 ;
+17 IF LASTSEG="ISA"
IF NEXTSEG'="GS"
DO ORDERROR("ISA",NEXTSEG,"GS")
QUIT
+18 IF LASTSEG="SE"
IF NEXTSEG="ST"
QUIT
+19 IF LASTSEG="SE"
IF NEXTSEG'="GE"
DO ORDERROR("SE",NEXTSEG,"GE")
QUIT
+20 ;
+21 IF LASTSEG="GS"
IF NEXTSEG'="ST"
DO ORDERROR("GS",NEXTSEG,"ST")
QUIT
+22 IF LASTSEG="CTT"
IF NEXTSEG'="SE"
DO ORDERROR("CTT",NEXTSEG,"SE")
QUIT
+23 ;
+24 IF LASTSEG="ST"
IF NEXTSEG'="BIG"
DO ORDERROR("ST",NEXTSEG,"BIG")
QUIT
+25 ;
+26 IF LASTSEG="IT1"
IF NEXTSEG="IT1"
QUIT
+27 IF LASTSEG="IT1"
IF NEXTSEG'="CTT"
DO ORDERROR("IT1",NEXTSEG,"CTT")
QUIT
+28 QUIT
+29 ;
+30 ;
ORDERROR(LAST,NEW,EXPECT) ; segments out of order
+1 ; isa segment should be first
+2 IF LAST=""
DO ERROR("SEGMENTS OUT OF ORDER, THE STARTING SEGMENT SHOULD BE 'ISA', NOT '"_NEW_"'")
QUIT
+3 ; segments other than isa
+4 DO ERROR("SEGMENTS OUT OF ORDER, THE SEGMENT FOLLOWING '"_LAST_"' SHOULD BE '"_EXPECT_"', NOT '"_NEW_"'")
QUIT
+5 QUIT
