- 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 Feb 18, 2025@23:46:28 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