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

LEXSRC.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; External References
  1. ; None
  1. ;
  1. ONE(LEXI,LEXS,LEXVDT) ; Return a single primary code of a source
  1. S LEXI=+($G(LEXI)),LEXS=$G(LEXS) S LEXI=$$CODE(LEXI,LEXS,$G(LEXVDT)) Q LEXI
  1. ALL(LEXI,LEXS,LEXVDT) ; Return all codes of a source
  1. S LEXI=+($G(LEXI)),LEXS=$G(LEXS)
  1. D CODES(LEXI,LEXS,$G(LEXVDT))
  1. Q
  1. CODE(LEXI,LEXS,LEXVDT) ; Return a single primary code
  1. N LEXSRC D CODES(LEXI,LEXS,$G(LEXVDT))
  1. S LEXI=$G(LEXSRC(1)) Q LEXI
  1. CODES(LEXI,LEXS,LEXVDT) ; Build an array LEXSRC of codes
  1. S LEXI=+($G(LEXI)) Q:LEXI=0 Q:'$D(^LEX(757.01,LEXI))
  1. S LEXS=$G(LEXS) Q:'$D(^LEX(757.03,"ASAB",LEXS))
  1. N LEXMC S LEXMC=+($G(^LEX(757.01,LEXI,1))) Q:'$D(^LEX(757,LEXMC,0))
  1. N LEXMCE S LEXMCE=+($G(^LEX(757,LEXMC,0))) Q:'$D(^LEX(757.01,LEXMCE,0))
  1. N LEXUNI,LEXSA,LEXN,LEXSAB,LEXSTA,LEXPRI,LEXNOM,LEXCC,LEXX S LEXSA=0
  1. F S LEXSA=$O(^LEX(757.02,"AMC",LEXMC,LEXSA)) Q:+LEXSA=0 D
  1. . N LEXLD,LEXLS,LEXSR,LEXHC,LEXHE,LEXHI,LEXHN,LEXHS,LEXN
  1. . S LEXN=$G(^LEX(757.02,LEXSA,0))
  1. . S LEXHC=$S(+LEXVDT>0:(LEXVDT_".99999"),1:" ")
  1. . S LEXHE=$O(^LEX(757.02,+LEXSA,4,"B",LEXHC),-1) Q:+LEXHE'>0
  1. . S LEXHI=$O(^LEX(757.02,+LEXSA,4,"B",+LEXHE," "),-1)
  1. . S LEXHN=$G(^LEX(757.02,+LEXSA,4,+LEXHI,0)),LEXHS=$P(LEXHN,"^",2) Q:+($G(LEXHS))'>0
  1. . S LEXCC=$P(LEXN,"^",2) Q:LEXCC="" S LEXSR=$P(LEXN,"^",3) Q:+LEXSR'>0
  1. . S LEXSAB=+($P(LEXN,"^",3)),LEXSAB=$E($G(^LEX(757.03,LEXSAB,0)),1,3) Q:LEXSAB'=LEXS
  1. . S LEXPRI=+($P(LEXN,"^",7)),LEXCC=$P(LEXN,"^",2) Q:LEXCC=""
  1. . D:LEXPRI>0 PRI(LEXCC) D:LEXPRI=0 NOM(LEXCC)
  1. D COMP
  1. Q
  1. PRI(LEXX) ; Primary Code
  1. N LEXCC S LEXCC=$G(LEXX) Q:LEXCC="" S LEXX=+($G(LEXPRI(0))),LEXX=LEXX+1
  1. S LEXPRI(LEXX)=LEXCC,LEXPRI(0)=LEXX Q
  1. NOM(LEXX) ; Normal Code
  1. N LEXCC S LEXCC=$G(LEXX) Q:LEXCC="" S LEXX=+($G(LEXNOM(0))),LEXX=LEXX+1
  1. S LEXNOM(LEXX)=LEXCC,LEXNOM(0)=LEXX Q
  1. COMP ; Compile array from Primary and Normal Codes
  1. N LEXUNI,LEXCT,LEXNT S (LEXCT,LEXNT)=0
  1. I $L($G(LEXPRI(1))) D
  1. . S LEXCT=LEXCT+1,LEXSRC(LEXCT)=LEXPRI(1)
  1. . S LEXSRC(0)=LEXCT,LEXUNI(LEXPRI(1))=""
  1. F S LEXNT=$O(LEXNOM(LEXNT)) Q:+LEXNT=0 D
  1. . Q:$D(LEXUNI(LEXNOM(LEXNT)))
  1. . I $L($G(LEXNOM(LEXNT))) D
  1. . . S LEXCT=LEXCT+1,LEXSRC(LEXCT)=LEXNOM(LEXNT),LEXSRC(0)=LEXCT,LEXUNI(LEXNOM(LEXNT))=""
  1. K LEXPRI,LEXNOM,LEXUNI Q