Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCVITMU

PRCVITMU.m

Go to the documentation of this file.
  1. PRCVITMU ;WOIFO/GJW - Item utilities ;1/10/17 10:25
  1. ;;5.1;IFCAP;**81,198**;Oct 20, 2000;Build 6
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;Integration agreements
  1. ; ICR #10078 OP^XQCHK
  1. ;
  1. TRANS ;Called by the input transform on 441/.01
  1. N PRCVX,PRCVFLG,XQORNOD,XQOPT
  1. S PRCVFLG=0
  1. Q:'$D(X)
  1. S X=$TR(X,"new","NEW") ;other letters are irrelevant
  1. D:X="NEW"
  1. .S PRCVFLG=1
  1. .D NEW
  1. Q:'$D(X)
  1. I +X'=X K X Q
  1. I X?.E1"."1N.N K X Q
  1. I X<$S(PRCVFLG:$$MIN,1:$$AMIN) K X Q
  1. I X>19999999 D OP^XQCHK I $P(XQOPT,U)'="PRCHITEM_LOAD",$P(XQOPT,U)'="PRCHITEM_BULK_LOAD_VIA_HFS" K X Q
  1. Q
  1. ;
  1. CHK() ;
  1. Q $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
  1. ;
  1. MIN() ;
  1. Q $S($$CHK:150000,1:1)
  1. ;
  1. AMIN() ;
  1. Q $S($$CHK:100000,1:1)
  1. NEW ;
  1. N MIN
  1. S MIN=150000 ;starting value for allocating item #'s at DM sites
  1. I '$$CHK D
  1. .;call appropriate routine
  1. .D EN2^PRCHUTL
  1. E D
  1. .S PRCVX=$O(^PRC(441,"AFREE",MIN-1))
  1. .S PRCVX(1)=$O(^PRC(441,"AFREE",PRCVX),-1)
  1. .S PRCVX(2)=$O(^PRC(441,"AFREE",PRCVX(1)))
  1. .S X=$S(PRCVX(1)'<MIN:PRCVX(1),1:PRCVX(2))
  1. Q
  1. ;
  1. SET ;
  1. N ROOT,FIRST,SECOND
  1. S ROOT=$NA(^PRC(441,"AFREE"))
  1. S:'$D(@ROOT) @ROOT@(1,999999)=""
  1. S FIRST=$$FIND(X)
  1. I FIRST="" D Q
  1. .;Do we need anything here?
  1. S SECOND=$O(@ROOT@(FIRST,""))
  1. ;Remove X from free list
  1. K @ROOT@(FIRST,SECOND)
  1. I SECOND>FIRST D
  1. .S:FIRST=X @ROOT@(FIRST+1,SECOND)=""
  1. .S:SECOND=X @ROOT@(FIRST,SECOND-1)=""
  1. .I ((FIRST'=X)&(SECOND'=X)) D
  1. ..S @ROOT@(FIRST,X-1)=""
  1. ..S @ROOT@(X+1,SECOND)=""
  1. Q
  1. ;
  1. KILL ;
  1. N ROOT,FIRST,SECOND,LOWER,UPPER
  1. S ROOT=$NA(^PRC(441,"AFREE"))
  1. S:'$D(@ROOT) @ROOT@(1,999999)=""
  1. S FIRST=$$FIND(X)
  1. I FIRST'="" D
  1. .;return it to free list
  1. .S SECOND=$O(@ROOT@(FIRST,""))
  1. .I ((X<FIRST)!(X>SECOND)) D
  1. ..;Error
  1. E D
  1. .S @ROOT@(X,X)=""
  1. .;Can lists be merged?
  1. .;Could X+1 be a lower limit?
  1. .I $D(@ROOT@(X+1)) D
  1. ..S UPPER=$O(@ROOT@(X+1,""))
  1. ..S LOWER=X+1
  1. ..I UPPER'="" D
  1. ...K @ROOT@(X)
  1. ...K @ROOT@(LOWER)
  1. ...S @ROOT@(X,UPPER)=""
  1. .;Could X-1 be an upper limit?
  1. .S LOWER=$$FIND(X-1)
  1. .I LOWER'="" D
  1. ..S UPPER=$O(@ROOT@(LOWER,""))
  1. ..I $G(UPPER)=(X-1) D
  1. ...K @ROOT@(X)
  1. ...K @ROOT@(LOWER)
  1. ...S @ROOT@(LOWER,X)=""
  1. Q
  1. ;
  1. FIND(I) ;
  1. N ROOT,X,Y
  1. S ROOT=$NA(^PRC(441,"AFREE"))
  1. Q:$D(@ROOT@(I)) I
  1. S X=$O(@ROOT@(I),-1)
  1. S:X="" X=$O(@ROOT@(""))
  1. Q:X="" ""
  1. S Y=$O(@ROOT@(X,""))
  1. I Y<I D
  1. .;W !,"NOT FOUND!"
  1. .S X=""
  1. Q X