PRCHNPOB.m

PRCHNPOB ;RGB-TRANSACTION UTILITY PROGRAM ; 4/2/01 10:18 AM

V ;;5.1;IFCAP;**184,194**;Oct 20, 2000;Build 3

 ;Per VA Directive 6402, this routine should not be modified.

 ;

 ;PRC*5.1*184 RGB 9/5/13 Check to insure Purchase card orders for   

 ;selected FCP have >5 requisition entries still available for use,

 ;otherwise PCard order will prevent user from continuing.

 ;

 ;PRC*5.1*194 Insure $$ call of routine returns a value when

 ;            new FY 410.1 entry not defined as yet.

 ;

EN(SITE,FCP) ;CHECK FOR NEW TRANSACTION (FILE 410) NUMBER AVAILABILITY FOR PCARD ORDERS

EN1 N PRCHFCPA,PRCHDA,PRCHSEQ,PRCHSEQN,PRCHTOT,PRCHIEN,PRCHEND,PRCHMSG,PRCHI,PRCHREQ

 S PRCHMSG="",PRCHEND=0,PRCHFCPA=SITE_"-"_PRC("FY")_"-"_$P(FCP," "),PRCHTOT=0

 I '$D(^PRCS(410.1,"B",PRCHFCPA)) Q 0     ;PRC*5.1*194

 S PRCHDA=$O(^PRCS(410.1,"B",PRCHFCPA,0)) S PRCHSEQ=$P(^PRCS(410.1,PRCHDA,0),"^",2)+1 S:PRCHSEQ>9999 PRCHSEQ=1

CHK F PRCHI=PRCHSEQ:1:9999 S PRCHSEQN="000"_PRCHI,PRCHSEQ=$E(PRCHSEQN,$L(PRCHSEQN)-3,$L(PRCHSEQN)),PRCHREQ=$P(PRCHFCPA,"-",1,2)_"-"_PRC("QTR")_"-"_$P(PRCHFCPA,"-",3)_"-"_PRCHSEQ D  Q:PRCHTOT>5

 . I '$D(^PRCS(410,"B",PRCHREQ)) S PRCHTOT=PRCHTOT+1 Q

 . S PRCHIEN=$O(^PRCS(410,"B",PRCHREQ,0))

 . I $P($G(^PRCS(410,PRCHIEN,0)),U,2)="CA" S PRCHTOT=PRCHTOT+1 W !,PRCHIEN,!,^PRCS(410,PRCHIEN,0)

 I PRCHEND=0,PRCHTOT'>5 S PRCHSEQ=1,PRCHEND=1,PRCHTOT=0 G CHK

CER I PRCHTOT'>5 S PRCHMSG=1 W !!,"ORDER ABORTED ==>>",!,"Insufficient sequence numbers remaining for "_$P(PRCHREQ,"-",1,4)_" during ORDER ENTRY",!

 Q PRCHMSG

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCHNPOB   1537     printed  Apr 09, 2024@21:06:04                                                                                                                                                                                                    Page 2

PRCHNPOB  ;RGB-TRANSACTION UTILITY PROGRAM ; 4/2/01 10:18 AM

V         ;;5.1;IFCAP;**184,194**;Oct 20, 2000;Build 3

 +1       ;Per VA Directive 6402, this routine should not be modified.

 +2       ;

 +3       ;PRC*5.1*184 RGB 9/5/13 Check to insure Purchase card orders for   

 +4       ;selected FCP have >5 requisition entries still available for use,

 +5       ;otherwise PCard order will prevent user from continuing.

 +6       ;

 +7       ;PRC*5.1*194 Insure $$ call of routine returns a value when

 +8       ;            new FY 410.1 entry not defined as yet.

 +9       ;

EN(SITE,FCP) ;CHECK FOR NEW TRANSACTION (FILE 410) NUMBER AVAILABILITY FOR PCARD ORDERS

EN1        NEW PRCHFCPA,PRCHDA,PRCHSEQ,PRCHSEQN,PRCHTOT,PRCHIEN,PRCHEND,PRCHMSG,PRCHI,PRCHREQ

 +1        SET PRCHMSG=""

           SET PRCHEND=0

           SET PRCHFCPA=SITE_"-"_PRC("FY")_"-"_$PIECE(FCP," ")

           SET PRCHTOT=0

 +2       ;PRC*5.1*194

           IF '$DATA(^PRCS(410.1,"B",PRCHFCPA))

               QUIT 0

 +3        SET PRCHDA=$ORDER(^PRCS(410.1,"B",PRCHFCPA,0))

           SET PRCHSEQ=$PIECE(^PRCS(410.1,PRCHDA,0),"^",2)+1

           if PRCHSEQ>9999

               SET PRCHSEQ=1

CHK        FOR PRCHI=PRCHSEQ:1:9999

               SET PRCHSEQN="000"_PRCHI

               SET PRCHSEQ=$EXTRACT(PRCHSEQN,$LENGTH(PRCHSEQN)-3,$LENGTH(PRCHSEQN))

               SET PRCHREQ=$PIECE(PRCHFCPA,"-",1,2)_"-"_PRC("QTR")_"-"_$PIECE(PRCHFCPA,"-",3)_"-"_PRCHSEQ

               Begin DoDot:1

 +1                IF '$DATA(^PRCS(410,"B",PRCHREQ))

                       SET PRCHTOT=PRCHTOT+1

                       QUIT 

 +2                SET PRCHIEN=$ORDER(^PRCS(410,"B",PRCHREQ,0))

 +3                IF $PIECE($GET(^PRCS(410,PRCHIEN,0)),U,2)="CA"

                       SET PRCHTOT=PRCHTOT+1

                       WRITE !,PRCHIEN,!,^PRCS(410,PRCHIEN,0)

               End DoDot:1

               if PRCHTOT>5

                   QUIT 

 +4        IF PRCHEND=0

               IF PRCHTOT'>5

                   SET PRCHSEQ=1

                   SET PRCHEND=1

                   SET PRCHTOT=0

                   GOTO CHK

CER        IF PRCHTOT'>5

               SET PRCHMSG=1

               WRITE !!,"ORDER ABORTED ==>>",!,"Insufficient sequence numbers remaining for "_$PIECE(PRCHREQ,"-",1,4)_" during ORDER ENTRY",!

 +1        QUIT PRCHMSG