44 lines
2.4 KiB
Mathematica
44 lines
2.4 KiB
Mathematica
PRCPWPU1 ;WISC/RFJ-get number series for issue books ;11 Mar 94
|
|
;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
;
|
|
;
|
|
IBCNS(SERIES) ; return next issue book common numbering series number
|
|
; series=460-I4 where 460 is station number, 4 is fiscal year
|
|
N %,DA,DATA,NEXT,X
|
|
S DA=+$O(^PRC(442.6,"B",SERIES,0))
|
|
I '$D(^PRC(442.6,DA,0)) K X S X(1)="Before performing this option you need to set up a common numbering series for "_SERIES_"." D DISPLAY^PRCPUX2(5,75,.X) Q ""
|
|
;
|
|
L +^PRC(442.6,DA,0)
|
|
S DATA=^PRC(442.6,DA,0),NEXT=$P(DATA,"^",4) I NEXT<1!(NEXT>9999) S NEXT=1
|
|
;
|
|
; check lower and upper bounds
|
|
I $P(DATA,"^",2)'=1 D S $P(^PRC(442.6,DA,0),"^",2)=1
|
|
. S %=$S($P(DATA,"^",2)="":"<null>",1:$P(DATA,"^",2))
|
|
. K X S X(1)="PLEASE NOTE: The lower bound for the common numbering series "_SERIES_" should be set to 1 (not "_%_"). I will automatically make the change." D DISPLAY^PRCPUX2(5,75,.X)
|
|
I $P(DATA,"^",3)'=9999 D S $P(^PRC(442.6,DA,0),"^",3)=9999
|
|
. S %=$S($P(DATA,"^",3)="":"<null>",1:$P(DATA,"^",3))
|
|
. K X S X(1)="PLEASE NOTE: The upper bound for the common numbering series "_SERIES_" should be set to 9999 (not "_%_"). I will automatically make the change." D DISPLAY^PRCPUX2(5,75,.X)
|
|
;
|
|
; check for duplicates
|
|
I $D(^PRCP(445.2,"V",$P(SERIES,"-",2)_$E("0000",$L(NEXT)+1,4)_NEXT)) D I 'NEXT L -^PRC(442.6,DA,0) Q ""
|
|
. K X S X(1)="PLEASE NOTE: The next number listed in the common numbering series "_SERIES_" is "_NEXT_" which has already been used ("_$P(SERIES,"-",2)_$E("0000",$L(NEXT)+1,4)_NEXT_")."
|
|
. S X(2)="Starting with "_NEXT_", I will search to 9999 and try to find a unique unused reference number. If one cannot be found, I will start the search with number 1."
|
|
. D DISPLAY^PRCPUX2(5,75,.X)
|
|
. S NEXT=$$MISSING(NEXT)
|
|
. I 'NEXT S NEXT=$$MISSING(1)
|
|
;
|
|
S $P(^PRC(442.6,DA,0),"^",4)=NEXT+1
|
|
L -^PRC(442.6,DA,0)
|
|
Q $P(SERIES,"-",2)_$E("0000",$L(NEXT)+1,4)_NEXT
|
|
;
|
|
;
|
|
MISSING(START) ; search for missing numbers
|
|
; return missing one or null if none found
|
|
W !?5,"SEARCHING FOR A UNIQUE REFERENCE NUMBER..."
|
|
F %=START:1:10000 Q:'$D(^PRCP(445.2,"V",$P(SERIES,"-",2)_$E("0000",$L(%)+1,4)_%))
|
|
I %'=10000 W " ",$P(SERIES,"-",2),$E("0000",$L(%)+1,4),%," IS UNIQUE" Q %
|
|
K X S X(1)="WARNING: Unable to find an available unique reference number. Either change the common numbering series or call your local OIFO." D DISPLAY^PRCPUX2(5,75,.X)
|
|
Q ""
|