source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPWPU1.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1PRCPWPU1 ;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 ;
7IBCNS(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 ;
37MISSING(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 ""
Note: See TracBrowser for help on using the repository browser.