source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVITMU.m@ 623

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

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1PRCVITMU ;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 ;
5TRANS ;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 ;
19CHK() ;
20 Q $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
21 ;
22MIN() ;
23 Q $S($$CHK:150000,1:1)
24 ;
25AMIN() ;
26 Q $S($$CHK:100000,1:1)
27NEW ;
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 ;
40SET ;
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 ;
58KILL ;
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 ;
89FIND(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
Note: See TracBrowser for help on using the repository browser.