- 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 Mar 13, 2025@21:21:38 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 ""
