LEXSRC ;ISL/KER - Classification Code Source ;08/17/2011
;;2.0;LEXICON UTILITY;**7,25,26,38,73,81**;Sep 23, 1996;Build 1
;
; External References
; None
;
ONE(LEXI,LEXS,LEXVDT) ; Return a single primary code of a source
S LEXI=+($G(LEXI)),LEXS=$G(LEXS) S LEXI=$$CODE(LEXI,LEXS,$G(LEXVDT)) Q LEXI
ALL(LEXI,LEXS,LEXVDT) ; Return all codes of a source
S LEXI=+($G(LEXI)),LEXS=$G(LEXS)
D CODES(LEXI,LEXS,$G(LEXVDT))
Q
CODE(LEXI,LEXS,LEXVDT) ; Return a single primary code
N LEXSRC D CODES(LEXI,LEXS,$G(LEXVDT))
S LEXI=$G(LEXSRC(1)) Q LEXI
CODES(LEXI,LEXS,LEXVDT) ; Build an array LEXSRC of codes
S LEXI=+($G(LEXI)) Q:LEXI=0 Q:'$D(^LEX(757.01,LEXI))
S LEXS=$G(LEXS) Q:'$D(^LEX(757.03,"ASAB",LEXS))
N LEXMC S LEXMC=+($G(^LEX(757.01,LEXI,1))) Q:'$D(^LEX(757,LEXMC,0))
N LEXMCE S LEXMCE=+($G(^LEX(757,LEXMC,0))) Q:'$D(^LEX(757.01,LEXMCE,0))
N LEXUNI,LEXSA,LEXN,LEXSAB,LEXSTA,LEXPRI,LEXNOM,LEXCC,LEXX S LEXSA=0
F S LEXSA=$O(^LEX(757.02,"AMC",LEXMC,LEXSA)) Q:+LEXSA=0 D
. N LEXLD,LEXLS,LEXSR,LEXHC,LEXHE,LEXHI,LEXHN,LEXHS,LEXN
. S LEXN=$G(^LEX(757.02,LEXSA,0))
. S LEXHC=$S(+LEXVDT>0:(LEXVDT_".99999"),1:" ")
. S LEXHE=$O(^LEX(757.02,+LEXSA,4,"B",LEXHC),-1) Q:+LEXHE'>0
. S LEXHI=$O(^LEX(757.02,+LEXSA,4,"B",+LEXHE," "),-1)
. S LEXHN=$G(^LEX(757.02,+LEXSA,4,+LEXHI,0)),LEXHS=$P(LEXHN,"^",2) Q:+($G(LEXHS))'>0
. S LEXCC=$P(LEXN,"^",2) Q:LEXCC="" S LEXSR=$P(LEXN,"^",3) Q:+LEXSR'>0
. S LEXSAB=+($P(LEXN,"^",3)),LEXSAB=$E($G(^LEX(757.03,LEXSAB,0)),1,3) Q:LEXSAB'=LEXS
. S LEXPRI=+($P(LEXN,"^",7)),LEXCC=$P(LEXN,"^",2) Q:LEXCC=""
. D:LEXPRI>0 PRI(LEXCC) D:LEXPRI=0 NOM(LEXCC)
D COMP
Q
PRI(LEXX) ; Primary Code
N LEXCC S LEXCC=$G(LEXX) Q:LEXCC="" S LEXX=+($G(LEXPRI(0))),LEXX=LEXX+1
S LEXPRI(LEXX)=LEXCC,LEXPRI(0)=LEXX Q
NOM(LEXX) ; Normal Code
N LEXCC S LEXCC=$G(LEXX) Q:LEXCC="" S LEXX=+($G(LEXNOM(0))),LEXX=LEXX+1
S LEXNOM(LEXX)=LEXCC,LEXNOM(0)=LEXX Q
COMP ; Compile array from Primary and Normal Codes
N LEXUNI,LEXCT,LEXNT S (LEXCT,LEXNT)=0
I $L($G(LEXPRI(1))) D
. S LEXCT=LEXCT+1,LEXSRC(LEXCT)=LEXPRI(1)
. S LEXSRC(0)=LEXCT,LEXUNI(LEXPRI(1))=""
F S LEXNT=$O(LEXNOM(LEXNT)) Q:+LEXNT=0 D
. Q:$D(LEXUNI(LEXNOM(LEXNT)))
. I $L($G(LEXNOM(LEXNT))) D
. . S LEXCT=LEXCT+1,LEXSRC(LEXCT)=LEXNOM(LEXNT),LEXSRC(0)=LEXCT,LEXUNI(LEXNOM(LEXNT))=""
K LEXPRI,LEXNOM,LEXUNI Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXSRC 2370 printed Apr 09, 2024@21:09:56 Page 2
LEXSRC ;ISL/KER - Classification Code Source ;08/17/2011
+1 ;;2.0;LEXICON UTILITY;**7,25,26,38,73,81**;Sep 23, 1996;Build 1
+2 ;
+3 ; External References
+4 ; None
+5 ;
ONE(LEXI,LEXS,LEXVDT) ; Return a single primary code of a source
+1 SET LEXI=+($GET(LEXI))
SET LEXS=$GET(LEXS)
SET LEXI=$$CODE(LEXI,LEXS,$GET(LEXVDT))
QUIT LEXI
ALL(LEXI,LEXS,LEXVDT) ; Return all codes of a source
+1 SET LEXI=+($GET(LEXI))
SET LEXS=$GET(LEXS)
+2 DO CODES(LEXI,LEXS,$GET(LEXVDT))
+3 QUIT
CODE(LEXI,LEXS,LEXVDT) ; Return a single primary code
+1 NEW LEXSRC
DO CODES(LEXI,LEXS,$GET(LEXVDT))
+2 SET LEXI=$GET(LEXSRC(1))
QUIT LEXI
CODES(LEXI,LEXS,LEXVDT) ; Build an array LEXSRC of codes
+1 SET LEXI=+($GET(LEXI))
if LEXI=0
QUIT
if '$DATA(^LEX(757.01,LEXI))
QUIT
+2 SET LEXS=$GET(LEXS)
if '$DATA(^LEX(757.03,"ASAB",LEXS))
QUIT
+3 NEW LEXMC
SET LEXMC=+($GET(^LEX(757.01,LEXI,1)))
if '$DATA(^LEX(757,LEXMC,0))
QUIT
+4 NEW LEXMCE
SET LEXMCE=+($GET(^LEX(757,LEXMC,0)))
if '$DATA(^LEX(757.01,LEXMCE,0))
QUIT
+5 NEW LEXUNI,LEXSA,LEXN,LEXSAB,LEXSTA,LEXPRI,LEXNOM,LEXCC,LEXX
SET LEXSA=0
+6 FOR
SET LEXSA=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSA))
if +LEXSA=0
QUIT
Begin DoDot:1
+7 NEW LEXLD,LEXLS,LEXSR,LEXHC,LEXHE,LEXHI,LEXHN,LEXHS,LEXN
+8 SET LEXN=$GET(^LEX(757.02,LEXSA,0))
+9 SET LEXHC=$SELECT(+LEXVDT>0:(LEXVDT_".99999"),1:" ")
+10 SET LEXHE=$ORDER(^LEX(757.02,+LEXSA,4,"B",LEXHC),-1)
if +LEXHE'>0
QUIT
+11 SET LEXHI=$ORDER(^LEX(757.02,+LEXSA,4,"B",+LEXHE," "),-1)
+12 SET LEXHN=$GET(^LEX(757.02,+LEXSA,4,+LEXHI,0))
SET LEXHS=$PIECE(LEXHN,"^",2)
if +($GET(LEXHS))'>0
QUIT
+13 SET LEXCC=$PIECE(LEXN,"^",2)
if LEXCC=""
QUIT
SET LEXSR=$PIECE(LEXN,"^",3)
if +LEXSR'>0
QUIT
+14 SET LEXSAB=+($PIECE(LEXN,"^",3))
SET LEXSAB=$EXTRACT($GET(^LEX(757.03,LEXSAB,0)),1,3)
if LEXSAB'=LEXS
QUIT
+15 SET LEXPRI=+($PIECE(LEXN,"^",7))
SET LEXCC=$PIECE(LEXN,"^",2)
if LEXCC=""
QUIT
+16 if LEXPRI>0
DO PRI(LEXCC)
if LEXPRI=0
DO NOM(LEXCC)
End DoDot:1
+17 DO COMP
+18 QUIT
PRI(LEXX) ; Primary Code
+1 NEW LEXCC
SET LEXCC=$GET(LEXX)
if LEXCC=""
QUIT
SET LEXX=+($GET(LEXPRI(0)))
SET LEXX=LEXX+1
+2 SET LEXPRI(LEXX)=LEXCC
SET LEXPRI(0)=LEXX
QUIT
NOM(LEXX) ; Normal Code
+1 NEW LEXCC
SET LEXCC=$GET(LEXX)
if LEXCC=""
QUIT
SET LEXX=+($GET(LEXNOM(0)))
SET LEXX=LEXX+1
+2 SET LEXNOM(LEXX)=LEXCC
SET LEXNOM(0)=LEXX
QUIT
COMP ; Compile array from Primary and Normal Codes
+1 NEW LEXUNI,LEXCT,LEXNT
SET (LEXCT,LEXNT)=0
+2 IF $LENGTH($GET(LEXPRI(1)))
Begin DoDot:1
+3 SET LEXCT=LEXCT+1
SET LEXSRC(LEXCT)=LEXPRI(1)
+4 SET LEXSRC(0)=LEXCT
SET LEXUNI(LEXPRI(1))=""
End DoDot:1
+5 FOR
SET LEXNT=$ORDER(LEXNOM(LEXNT))
if +LEXNT=0
QUIT
Begin DoDot:1
+6 if $DATA(LEXUNI(LEXNOM(LEXNT)))
QUIT
+7 IF $LENGTH($GET(LEXNOM(LEXNT)))
Begin DoDot:2
+8 SET LEXCT=LEXCT+1
SET LEXSRC(LEXCT)=LEXNOM(LEXNT)
SET LEXSRC(0)=LEXCT
SET LEXUNI(LEXNOM(LEXNT))=""
End DoDot:2
End DoDot:1
+9 KILL LEXPRI,LEXNOM,LEXUNI
QUIT
