| 1 | PRCVITMU ;WOIFO/GJW - Item utilities ; 4/20/05 5:20pm
|
|---|
| 2 | ;;5.1;IFCAP;**81**;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | TRANS ;Called by the input transform on 441/.01
|
|---|
| 6 | N PRCVX,PRCVFLG
|
|---|
| 7 | S PRCVFLG=0
|
|---|
| 8 | Q:'$D(X)
|
|---|
| 9 | S X=$TR(X,"new","NEW") ;other letters are irrelevant
|
|---|
| 10 | D:X="NEW"
|
|---|
| 11 | .S PRCVFLG=1
|
|---|
| 12 | .D NEW
|
|---|
| 13 | Q:'$D(X)
|
|---|
| 14 | I +X'=X K X Q
|
|---|
| 15 | I X?.E1"."1N.N K X Q
|
|---|
| 16 | I X<$S(PRCVFLG:$$MIN,1:$$AMIN) K X Q
|
|---|
| 17 | Q
|
|---|
| 18 | ;
|
|---|
| 19 | CHK() ;
|
|---|
| 20 | Q $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
|
|---|
| 21 | ;
|
|---|
| 22 | MIN() ;
|
|---|
| 23 | Q $S($$CHK:150000,1:1)
|
|---|
| 24 | ;
|
|---|
| 25 | AMIN() ;
|
|---|
| 26 | Q $S($$CHK:100000,1:1)
|
|---|
| 27 | NEW ;
|
|---|
| 28 | N MIN
|
|---|
| 29 | S MIN=150000 ;starting value for allocating item #'s at DM sites
|
|---|
| 30 | I '$$CHK D
|
|---|
| 31 | .;call appropriate routine
|
|---|
| 32 | .D EN2^PRCHUTL
|
|---|
| 33 | E D
|
|---|
| 34 | .S PRCVX=$O(^PRC(441,"AFREE",MIN-1))
|
|---|
| 35 | .S PRCVX(1)=$O(^PRC(441,"AFREE",PRCVX),-1)
|
|---|
| 36 | .S PRCVX(2)=$O(^PRC(441,"AFREE",PRCVX(1)))
|
|---|
| 37 | .S X=$S(PRCVX(1)'<MIN:PRCVX(1),1:PRCVX(2))
|
|---|
| 38 | Q
|
|---|
| 39 | ;
|
|---|
| 40 | SET ;
|
|---|
| 41 | N ROOT,FIRST,SECOND
|
|---|
| 42 | S ROOT=$NA(^PRC(441,"AFREE"))
|
|---|
| 43 | S:'$D(@ROOT) @ROOT@(1,999999)=""
|
|---|
| 44 | S FIRST=$$FIND(X)
|
|---|
| 45 | I FIRST="" D Q
|
|---|
| 46 | .;Do we need anything here?
|
|---|
| 47 | S SECOND=$O(@ROOT@(FIRST,""))
|
|---|
| 48 | ;Remove X from free list
|
|---|
| 49 | K @ROOT@(FIRST,SECOND)
|
|---|
| 50 | I SECOND>FIRST D
|
|---|
| 51 | .S:FIRST=X @ROOT@(FIRST+1,SECOND)=""
|
|---|
| 52 | .S:SECOND=X @ROOT@(FIRST,SECOND-1)=""
|
|---|
| 53 | .I ((FIRST'=X)&(SECOND'=X)) D
|
|---|
| 54 | ..S @ROOT@(FIRST,X-1)=""
|
|---|
| 55 | ..S @ROOT@(X+1,SECOND)=""
|
|---|
| 56 | Q
|
|---|
| 57 | ;
|
|---|
| 58 | KILL ;
|
|---|
| 59 | N ROOT,FIRST,SECOND,LOWER,UPPER
|
|---|
| 60 | S ROOT=$NA(^PRC(441,"AFREE"))
|
|---|
| 61 | S:'$D(@ROOT) @ROOT@(1,999999)=""
|
|---|
| 62 | S FIRST=$$FIND(X)
|
|---|
| 63 | I FIRST'="" D
|
|---|
| 64 | .;return it to free list
|
|---|
| 65 | .S SECOND=$O(@ROOT@(FIRST,""))
|
|---|
| 66 | .I ((X<FIRST)!(X>SECOND)) D
|
|---|
| 67 | ..;Error
|
|---|
| 68 | E D
|
|---|
| 69 | .S @ROOT@(X,X)=""
|
|---|
| 70 | .;Can lists be merged?
|
|---|
| 71 | .;Could X+1 be a lower limit?
|
|---|
| 72 | .I $D(@ROOT@(X+1)) D
|
|---|
| 73 | ..S UPPER=$O(@ROOT@(X+1,""))
|
|---|
| 74 | ..S LOWER=X+1
|
|---|
| 75 | ..I UPPER'="" D
|
|---|
| 76 | ...K @ROOT@(X)
|
|---|
| 77 | ...K @ROOT@(LOWER)
|
|---|
| 78 | ...S @ROOT@(X,UPPER)=""
|
|---|
| 79 | .;Could X-1 be an upper limit?
|
|---|
| 80 | .S LOWER=$$FIND(X-1)
|
|---|
| 81 | .I LOWER'="" D
|
|---|
| 82 | ..S UPPER=$O(@ROOT@(LOWER,""))
|
|---|
| 83 | ..I $G(UPPER)=(X-1) D
|
|---|
| 84 | ...K @ROOT@(X)
|
|---|
| 85 | ...K @ROOT@(LOWER)
|
|---|
| 86 | ...S @ROOT@(LOWER,X)=""
|
|---|
| 87 | Q
|
|---|
| 88 | ;
|
|---|
| 89 | FIND(I) ;
|
|---|
| 90 | N ROOT,X,Y
|
|---|
| 91 | S ROOT=$NA(^PRC(441,"AFREE"))
|
|---|
| 92 | Q:$D(@ROOT@(I)) I
|
|---|
| 93 | S X=$O(@ROOT@(I),-1)
|
|---|
| 94 | S:X="" X=$O(@ROOT@(""))
|
|---|
| 95 | Q:X="" ""
|
|---|
| 96 | S Y=$O(@ROOT@(X,""))
|
|---|
| 97 | I Y<I D
|
|---|
| 98 | .;W !,"NOT FOUND!"
|
|---|
| 99 | .S X=""
|
|---|
| 100 | Q X
|
|---|
