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 ---[H[J[2J[HPRCHNPOB 1537 printed Dec 13, 2024@02:09:03 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
