PRCPDAPE.m

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 ---PRCPDAPE   1818     printed  Mar 13, 2025@21:18:14                                                                                                                                                                                                    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