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