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 ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPU1 2507 printed Apr 09, 2024@21:01:31 Page 2
PRCPWPU1 ;WISC/RFJ-get number series for issue books ;11 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
IBCNS(SERIES) ; return next issue book common numbering series number
+1 ; series=460-I4 where 460 is station number, 4 is fiscal year
+2 NEW %,DA,DATA,NEXT,X
+3 SET DA=+$ORDER(^PRC(442.6,"B",SERIES,0))
+4 IF '$DATA(^PRC(442.6,DA,0))
KILL X
SET X(1)="Before performing this option you need to set up a common numbering series for "_SERIES_"."
DO DISPLAY^PRCPUX2(5,75,.X)
QUIT ""
+5 ;
+6 LOCK +^PRC(442.6,DA,0)
+7 SET DATA=^PRC(442.6,DA,0)
SET NEXT=$PIECE(DATA,"^",4)
IF NEXT<1!(NEXT>9999)
SET NEXT=1
+8 ;
+9 ; check lower and upper bounds
+10 IF $PIECE(DATA,"^",2)'=1
Begin DoDot:1
+11 SET %=$SELECT($PIECE(DATA,"^",2)="":"<null>",1:$PIECE(DATA,"^",2))
+12 KILL X
SET 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."
DO DISPLAY^PRCPUX2(5,75,.X)
End DoDot:1
SET $PIECE(^PRC(442.6,DA,0),"^",2)=1
+13 IF $PIECE(DATA,"^",3)'=9999
Begin DoDot:1
+14 SET %=$SELECT($PIECE(DATA,"^",3)="":"<null>",1:$PIECE(DATA,"^",3))
+15 KILL X
SET 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."
DO DISPLAY^PRCPUX2(5,75,.X)
End DoDot:1
SET $PIECE(^PRC(442.6,DA,0),"^",3)=9999
+16 ;
+17 ; check for duplicates
+18 IF $DATA(^PRCP(445.2,"V",$PIECE(SERIES,"-",2)_$EXTRACT("0000",$LENGTH(NEXT)+1,4)_NEXT))
Begin DoDot:1
+19 KILL X
SET X(1)="PLEASE NOTE: The next number listed in the common numbering series "_SERIES_" is "_NEXT_" which has already been used ("_$PIECE(SERIES,"-",2)_$EXTRACT("0000",$LENGTH(NEXT)+1,4)_NEXT_")."
+20 SET 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."
+21 DO DISPLAY^PRCPUX2(5,75,.X)
+22 SET NEXT=$$MISSING(NEXT)
+23 IF 'NEXT
SET NEXT=$$MISSING(1)
End DoDot:1
IF 'NEXT
LOCK -^PRC(442.6,DA,0)
QUIT ""
+24 ;
+25 SET $PIECE(^PRC(442.6,DA,0),"^",4)=NEXT+1
+26 LOCK -^PRC(442.6,DA,0)
+27 QUIT $PIECE(SERIES,"-",2)_$EXTRACT("0000",$LENGTH(NEXT)+1,4)_NEXT
+28 ;
+29 ;
MISSING(START) ; search for missing numbers
+1 ; return missing one or null if none found
+2 WRITE !?5,"SEARCHING FOR A UNIQUE REFERENCE NUMBER..."
+3 FOR %=START:1:10000
if '$DATA(^PRCP(445.2,"V",$PIECE(SERIES,"-",2)_$EXTRACT("0000",$LENGTH(%)+1,4)_%))
QUIT
+4 IF %'=10000
WRITE " ",$PIECE(SERIES,"-",2),$EXTRACT("0000",$LENGTH(%)+1,4),%," IS UNIQUE"
QUIT %
+5 KILL X
SET X(1)="WARNING: Unable to find an available unique reference number. Either change the common numbering series or call your local OIFO."
DO DISPLAY^PRCPUX2(5,75,.X)
+6 QUIT ""
