- 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 Apr 23, 2025@18:23:32 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
