| 1 | PRCPWPU1 ;WISC/RFJ-get number series for issue books ;11 Mar 94
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | ;
|
|---|
| 7 | IBCNS(SERIES) ; return next issue book common numbering series number
|
|---|
| 8 | ; series=460-I4 where 460 is station number, 4 is fiscal year
|
|---|
| 9 | N %,DA,DATA,NEXT,X
|
|---|
| 10 | S DA=+$O(^PRC(442.6,"B",SERIES,0))
|
|---|
| 11 | 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 ""
|
|---|
| 12 | ;
|
|---|
| 13 | L +^PRC(442.6,DA,0)
|
|---|
| 14 | S DATA=^PRC(442.6,DA,0),NEXT=$P(DATA,"^",4) I NEXT<1!(NEXT>9999) S NEXT=1
|
|---|
| 15 | ;
|
|---|
| 16 | ; check lower and upper bounds
|
|---|
| 17 | I $P(DATA,"^",2)'=1 D S $P(^PRC(442.6,DA,0),"^",2)=1
|
|---|
| 18 | . S %=$S($P(DATA,"^",2)="":"<null>",1:$P(DATA,"^",2))
|
|---|
| 19 | . 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)
|
|---|
| 20 | I $P(DATA,"^",3)'=9999 D S $P(^PRC(442.6,DA,0),"^",3)=9999
|
|---|
| 21 | . S %=$S($P(DATA,"^",3)="":"<null>",1:$P(DATA,"^",3))
|
|---|
| 22 | . 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)
|
|---|
| 23 | ;
|
|---|
| 24 | ; check for duplicates
|
|---|
| 25 | 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 ""
|
|---|
| 26 | . 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_")."
|
|---|
| 27 | . 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."
|
|---|
| 28 | . D DISPLAY^PRCPUX2(5,75,.X)
|
|---|
| 29 | . S NEXT=$$MISSING(NEXT)
|
|---|
| 30 | . I 'NEXT S NEXT=$$MISSING(1)
|
|---|
| 31 | ;
|
|---|
| 32 | S $P(^PRC(442.6,DA,0),"^",4)=NEXT+1
|
|---|
| 33 | L -^PRC(442.6,DA,0)
|
|---|
| 34 | Q $P(SERIES,"-",2)_$E("0000",$L(NEXT)+1,4)_NEXT
|
|---|
| 35 | ;
|
|---|
| 36 | ;
|
|---|
| 37 | MISSING(START) ; search for missing numbers
|
|---|
| 38 | ; return missing one or null if none found
|
|---|
| 39 | W !?5,"SEARCHING FOR A UNIQUE REFERENCE NUMBER..."
|
|---|
| 40 | F %=START:1:10000 Q:'$D(^PRCP(445.2,"V",$P(SERIES,"-",2)_$E("0000",$L(%)+1,4)_%))
|
|---|
| 41 | I %'=10000 W " ",$P(SERIES,"-",2),$E("0000",$L(%)+1,4),%," IS UNIQUE" Q %
|
|---|
| 42 | 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)
|
|---|
| 43 | Q ""
|
|---|
