PRCVITMU ;WOIFO/GJW - Item utilities ;1/10/17 10:25
;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
;Per VA Directive 6402, this routine should not be modified.
;Integration agreements
; ICR #10078 OP^XQCHK
;
TRANS ;Called by the input transform on 441/.01
N PRCVX,PRCVFLG,XQORNOD,XQOPT
S PRCVFLG=0
Q:'$D(X)
S X=$TR(X,"new","NEW") ;other letters are irrelevant
D:X="NEW"
.S PRCVFLG=1
.D NEW
Q:'$D(X)
I +X'=X K X Q
I X?.E1"."1N.N K X Q
I X<$S(PRCVFLG:$$MIN,1:$$AMIN) K X Q
I X>19999999 D OP^XQCHK I $P(XQOPT,U)'="PRCHITEM_LOAD",$P(XQOPT,U)'="PRCHITEM_BULK_LOAD_VIA_HFS" K X Q
Q
;
CHK() ;
Q $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
;
MIN() ;
Q $S($$CHK:150000,1:1)
;
AMIN() ;
Q $S($$CHK:100000,1:1)
NEW ;
N MIN
S MIN=150000 ;starting value for allocating item #'s at DM sites
I '$$CHK D
.;call appropriate routine
.D EN2^PRCHUTL
E D
.S PRCVX=$O(^PRC(441,"AFREE",MIN-1))
.S PRCVX(1)=$O(^PRC(441,"AFREE",PRCVX),-1)
.S PRCVX(2)=$O(^PRC(441,"AFREE",PRCVX(1)))
.S X=$S(PRCVX(1)'<MIN:PRCVX(1),1:PRCVX(2))
Q
;
SET ;
N ROOT,FIRST,SECOND
S ROOT=$NA(^PRC(441,"AFREE"))
S:'$D(@ROOT) @ROOT@(1,999999)=""
S FIRST=$$FIND(X)
I FIRST="" D Q
.;Do we need anything here?
S SECOND=$O(@ROOT@(FIRST,""))
;Remove X from free list
K @ROOT@(FIRST,SECOND)
I SECOND>FIRST D
.S:FIRST=X @ROOT@(FIRST+1,SECOND)=""
.S:SECOND=X @ROOT@(FIRST,SECOND-1)=""
.I ((FIRST'=X)&(SECOND'=X)) D
..S @ROOT@(FIRST,X-1)=""
..S @ROOT@(X+1,SECOND)=""
Q
;
KILL ;
N ROOT,FIRST,SECOND,LOWER,UPPER
S ROOT=$NA(^PRC(441,"AFREE"))
S:'$D(@ROOT) @ROOT@(1,999999)=""
S FIRST=$$FIND(X)
I FIRST'="" D
.;return it to free list
.S SECOND=$O(@ROOT@(FIRST,""))
.I ((X<FIRST)!(X>SECOND)) D
..;Error
E D
.S @ROOT@(X,X)=""
.;Can lists be merged?
.;Could X+1 be a lower limit?
.I $D(@ROOT@(X+1)) D
..S UPPER=$O(@ROOT@(X+1,""))
..S LOWER=X+1
..I UPPER'="" D
...K @ROOT@(X)
...K @ROOT@(LOWER)
...S @ROOT@(X,UPPER)=""
.;Could X-1 be an upper limit?
.S LOWER=$$FIND(X-1)
.I LOWER'="" D
..S UPPER=$O(@ROOT@(LOWER,""))
..I $G(UPPER)=(X-1) D
...K @ROOT@(X)
...K @ROOT@(LOWER)
...S @ROOT@(LOWER,X)=""
Q
;
FIND(I) ;
N ROOT,X,Y
S ROOT=$NA(^PRC(441,"AFREE"))
Q:$D(@ROOT@(I)) I
S X=$O(@ROOT@(I),-1)
S:X="" X=$O(@ROOT@(""))
Q:X="" ""
S Y=$O(@ROOT@(X,""))
I Y<I D
.;W !,"NOT FOUND!"
.S X=""
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCVITMU 2414 printed Dec 13, 2024@02:20:06 Page 2
PRCVITMU ;WOIFO/GJW - Item utilities ;1/10/17 10:25
+1 ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;Integration agreements
+4 ; ICR #10078 OP^XQCHK
+5 ;
TRANS ;Called by the input transform on 441/.01
+1 NEW PRCVX,PRCVFLG,XQORNOD,XQOPT
+2 SET PRCVFLG=0
+3 if '$DATA(X)
QUIT
+4 ;other letters are irrelevant
SET X=$TRANSLATE(X,"new","NEW")
+5 if X="NEW"
Begin DoDot:1
+6 SET PRCVFLG=1
+7 DO NEW
End DoDot:1
+8 if '$DATA(X)
QUIT
+9 IF +X'=X
KILL X
QUIT
+10 IF X?.E1"."1N.N
KILL X
QUIT
+11 IF X<$SELECT(PRCVFLG:$$MIN,1:$$AMIN)
KILL X
QUIT
+12 IF X>19999999
DO OP^XQCHK
IF $PIECE(XQOPT,U)'="PRCHITEM_LOAD"
IF $PIECE(XQOPT,U)'="PRCHITEM_BULK_LOAD_VIA_HFS"
KILL X
QUIT
+13 QUIT
+14 ;
CHK() ;
+1 QUIT $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
+2 ;
MIN() ;
+1 QUIT $SELECT($$CHK:150000,1:1)
+2 ;
AMIN() ;
+1 QUIT $SELECT($$CHK:100000,1:1)
NEW ;
+1 NEW MIN
+2 ;starting value for allocating item #'s at DM sites
SET MIN=150000
+3 IF '$$CHK
Begin DoDot:1
+4 ;call appropriate routine
+5 DO EN2^PRCHUTL
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 SET PRCVX=$ORDER(^PRC(441,"AFREE",MIN-1))
+8 SET PRCVX(1)=$ORDER(^PRC(441,"AFREE",PRCVX),-1)
+9 SET PRCVX(2)=$ORDER(^PRC(441,"AFREE",PRCVX(1)))
+10 SET X=$SELECT(PRCVX(1)'<MIN:PRCVX(1),1:PRCVX(2))
End DoDot:1
+11 QUIT
+12 ;
SET ;
+1 NEW ROOT,FIRST,SECOND
+2 SET ROOT=$NAME(^PRC(441,"AFREE"))
+3 if '$DATA(@ROOT)
SET @ROOT@(1,999999)=""
+4 SET FIRST=$$FIND(X)
+5 IF FIRST=""
Begin DoDot:1
+6 ;Do we need anything here?
End DoDot:1
QUIT
+7 SET SECOND=$ORDER(@ROOT@(FIRST,""))
+8 ;Remove X from free list
+9 KILL @ROOT@(FIRST,SECOND)
+10 IF SECOND>FIRST
Begin DoDot:1
+11 if FIRST=X
SET @ROOT@(FIRST+1,SECOND)=""
+12 if SECOND=X
SET @ROOT@(FIRST,SECOND-1)=""
+13 IF ((FIRST'=X)&(SECOND'=X))
Begin DoDot:2
+14 SET @ROOT@(FIRST,X-1)=""
+15 SET @ROOT@(X+1,SECOND)=""
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
KILL ;
+1 NEW ROOT,FIRST,SECOND,LOWER,UPPER
+2 SET ROOT=$NAME(^PRC(441,"AFREE"))
+3 if '$DATA(@ROOT)
SET @ROOT@(1,999999)=""
+4 SET FIRST=$$FIND(X)
+5 IF FIRST'=""
Begin DoDot:1
+6 ;return it to free list
+7 SET SECOND=$ORDER(@ROOT@(FIRST,""))
+8 IF ((X<FIRST)!(X>SECOND))
Begin DoDot:2
+9 ;Error
End DoDot:2
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET @ROOT@(X,X)=""
+12 ;Can lists be merged?
+13 ;Could X+1 be a lower limit?
+14 IF $DATA(@ROOT@(X+1))
Begin DoDot:2
+15 SET UPPER=$ORDER(@ROOT@(X+1,""))
+16 SET LOWER=X+1
+17 IF UPPER'=""
Begin DoDot:3
+18 KILL @ROOT@(X)
+19 KILL @ROOT@(LOWER)
+20 SET @ROOT@(X,UPPER)=""
End DoDot:3
End DoDot:2
+21 ;Could X-1 be an upper limit?
+22 SET LOWER=$$FIND(X-1)
+23 IF LOWER'=""
Begin DoDot:2
+24 SET UPPER=$ORDER(@ROOT@(LOWER,""))
+25 IF $GET(UPPER)=(X-1)
Begin DoDot:3
+26 KILL @ROOT@(X)
+27 KILL @ROOT@(LOWER)
+28 SET @ROOT@(LOWER,X)=""
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
FIND(I) ;
+1 NEW ROOT,X,Y
+2 SET ROOT=$NAME(^PRC(441,"AFREE"))
+3 if $DATA(@ROOT@(I))
QUIT I
+4 SET X=$ORDER(@ROOT@(I),-1)
+5 if X=""
SET X=$ORDER(@ROOT@(""))
+6 if X=""
QUIT ""
+7 SET Y=$ORDER(@ROOT@(X,""))
+8 IF Y<I
Begin DoDot:1
+9 ;W !,"NOT FOUND!"
+10 SET X=""
End DoDot:1
+11 QUIT X
