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

LEX10PR.m

Go to the documentation of this file. 
  1. LEX10PR ;ISL/KER - ICD-10 Procedure Code ;05/23/2017
  1.  ;;2.0;LEXICON UTILITY;**80,103**;Sep 23, 1996;Build 2
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^LEX(757.033        N/A
  1.  ;               
  1.  ; External References
  1.  ;    $$IMP^ICDEX         ICR   5747
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$FMTE^XLFDT        ICR  10103
  1.  ;               
  1. NEXT(LEXC,LEXA,LEXD) ; Next Allowable Character
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;   LEXC    Partial Proc Code    Required
  1.  ;  .LEXA    Local Array (by Ref) Required
  1.  ;   LEXD    Date (FM Format)     Optional (Default TODAY)
  1.  ;  
  1.  ; Output
  1.  ; 
  1.  ;   LEXA(<input>,0)= # of characters
  1.  ;   LEXA(<input>,<character>)=""
  1.  ; 
  1.  N LEX1,LEX2,LEXCDT,LEXCHK,LEXCHR,LEXCT,LEXE,LEXLEN,LEXID,LEXNC,LEXNN
  1.  N LEXNAM,LEXOR,LEXPRE,LEXS,LEXSO S LEXC=$$TM(LEXC) S (LEXID,LEXSO)=LEXC
  1.  S LEXCDT=$G(LEXD) S:LEXCDT'?7N LEXCDT=$$DT^XLFDT S LEXLEN=$L(LEXC)
  1.  I LEXLEN>6 D  Q X
  1.  . S X="-1^Input is of Maximum length, no next character available"
  1.  I LEXLEN>1 D
  1.  . S LEXOR=$E(LEXSO,1,($L(LEXSO)-1))_$C($A($E(LEXSO,$L(LEXSO)))-1)_"~"
  1.  S:LEXLEN=1 LEXOR=$C($A(LEXSO)-1)_"~" S:LEXLEN'>0 LEXOR="/~"
  1.  S LEXCHK=0 S:LEXLEN'>0 LEXCHK=1 S:LEXLEN>0&(LEXLEN<7) LEXCHK=LEXLEN+1
  1.  Q:+LEXCHK'>0 "-1^Character position not specified"
  1.  S:LEXLEN=0 LEXID="<null>" S:'$L(LEXID) LEXID="<unknown>"
  1.  S LEXNN="^LEX(757.02,""APR"","""_LEXOR_" "")"
  1.  S LEXNC="^LEX(757.02,""APR"","""_LEXSO,LEXCT=0
  1.  F  S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC)  D
  1.  . N LEXC,LEXD,LEXE,LEXS,LEX1,LEX2
  1.  . S LEXC=$P(LEXNN,",",3),LEXC=$TR(LEXC,"""",""),LEXC=$$TM(LEXC)
  1.  . S LEXD=+($P(LEXNN,",",4)) Q:LEXD'?7N  Q:(LEXCDT+.001)'>LEXD
  1.  . I $E(LEXC,1,$L(LEXSO))=LEXSO,$L(LEXC)'<LEXCHK D  Q
  1.  . . N LEXCHR,LEXFUL S LEXCHR=$E(LEXC,LEXCHK) Q:'$L(LEXCHR)
  1.  . . S LEXFUL=LEXID_LEXCHR Q:$$IS(LEXFUL)'>0
  1.  . . I '$D(LEXA(LEXID,LEXCHR)) D
  1.  . . . N LEXNAM S LEXNAM=$$NAM((LEXID_LEXCHR))
  1.  . . . S LEXA(LEXID,LEXCHR)=LEXNAM,LEXCT=LEXCT+1
  1.  . . S LEXOR=$E(LEXC,1,LEXCHK)_"~"
  1.  . . S LEXNN="^LEX(757.02,""APR"","""_LEXOR_""")"
  1.  S LEXNAM=$$NAM(LEXID) S:$L(LEXNAM) LEXA(LEXID)=LEXNAM
  1.  I $L(LEXID)>1 D
  1.  . F LEX1=($L(LEXID)-1):-1:1  D
  1.  . . N LEXNN S LEXNN=$E(LEXID,1,LEX1),LEXNAM=$$NAM(LEXNN)
  1.  . . S:$L(LEXNN)&($L(LEXNAM)) LEXA(LEXNN)=LEXNAM
  1.  Q +($G(LEXCT))
  1. NAM(X) ; Name
  1.  N LEXC,LEXCIEN,LEXEFF,LEXNAM S LEXC=$G(X) Q:'$L(LEXC) ""
  1.  S LEXEFF=$O(^LEX(757.033,"AFRAG",31,(LEXC_" "),(LEXCDT+.001)),-1)
  1.  S LEXCIEN=$O(^LEX(757.033,"AFRAG",31,(LEXC_" "),LEXEFF," "),-1)
  1.  S LEXNAM=$$SN(LEXCIEN) S X=LEXNAM
  1.  Q X
  1. SN(X,EFF) ; Short Name
  1.  N IEN,CDT,IMP,EFF,HIS S IEN=+($G(X)),CDT=$G(LEXVDT) S:$G(EFF)?7N CDT=$G(EFF)
  1.  S IMP=$$IMP^ICDEX(31) S:CDT'?7N CDT=$$DT^XLFDT S:CDT'>IMP&(IMP?7N) CDT=IMP
  1.  S EFF=$O(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
  1.  S HIS=$O(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
  1.  S X=$G(^LEX(757.033,+IEN,2,+HIS,1))
  1.  Q X
  1. IS(X) ; Is a Root Code
  1.  N LEXC,LEXL,LEXO,LEXN S LEXC=$G(X) Q:'$L(LEXC) 0  S LEXL=$L(LEXC)
  1.  S:LEXL>1 LEXO=$E(LEXC,1,($L(LEXC)-1))_$C($A($E(LEXC,$L(LEXC)))-1)_"~"
  1.  S:LEXL=1 LEXO=$C($A(LEXC)-1)_"~" S LEXN=$O(^LEX(757.02,"APR",(LEXOR_" ")))
  1.  I $E(LEXN,1,LEXL)=LEXC Q 1
  1.  Q 0
  1. FIN(X,LEXVDT,ARY) ; Fragment Info
  1.  ;
  1.  ; Input
  1.  ; 
  1.  ;    X         IEN of Code Fragment
  1.  ;    LEXVDT    Versioning date (busines rules apply)
  1.  ;   .ARY       Local Array, passed by reference
  1.  ;   
  1.  ; Output
  1.  ; 
  1.  ;    $$FIN     1 on success
  1.  ;             -1 ^ error message on error
  1.  ;    
  1.  ;    ARY(0)    5 piece "^" delimited strig
  1.  ;                1  Unique Id
  1.  ;                2  Code Fragment
  1.  ;                3  Date Entered
  1.  ;                4  Source
  1.  ;                5  Details
  1.  ;                
  1.  ;    ARY(1)    4 piece "^" delimited string
  1.  ;                1  Effective Date
  1.  ;                2  Status
  1.  ;                3  Effective Date External
  1.  ;                4  Status External
  1.  ;               
  1.  ;    ARY(2)    Name/Title
  1.  ;    ARY(3)    Description
  1.  ;    ARY(4)    Explanation
  1.  ;    ARY(5,0)  # of synonyms included
  1.  ;    ARY(5,n)  included synonyms
  1.  ;    
  1.  N CDT,EFF,ENT,FRG,IEN,IMP,N0,NOD,NODC,NODI,REC,SAB,SRC K ARY
  1.  S U="^",IEN=+($G(X)) Q:IEN'>0 "-1^Invalid IEN number"
  1.  S N0=$G(^LEX(757.033,IEN,0)) Q:'$L(N0) "-1^IEN not found number"
  1.  S SAB=$E(N0,1,3),FRG=$P(N0,U,2),ENT=$P(N0,U,3),SRC=$P(N0,U,4)
  1.  S IMP=$$IMPDATE^LEXU(SRC) S CDT=$G(LEXVDT) S:'$L(CDT) CDT=$$DT^XLFDT
  1.  S:CDT?7N&(IMP?7N)&(CDT<IMP) CDT=IMP
  1.  S EFF=$O(^LEX(757.033,+IEN,1,"B",(CDT+.001)),-1)
  1.  S REC=$O(^LEX(757.033,+IEN,1,"B",+EFF," "),-1)
  1.  S NOD=$G(^LEX(757.033,IEN,1,+REC,0)) S ARY(0)=N0
  1.  S ARY(0,"TXT")="Unique ID^Code Fragment^Date Entered^Source"
  1.  S ARY(1)=NOD_"^"_$$FMTE^XLFDT($P(NOD,"^",1),"5Z")_"^"_$S($P(NOD,"^",2)="1":"Active",$P(NOD,"^",2)="0":"Inactive",1:"")
  1.  S ARY(1,"TXT")="Effective Date^Status"
  1.  S EFF=$O(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
  1.  S REC=$O(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
  1.  S NOD=$G(^LEX(757.033,IEN,2,+REC,1))
  1.  S:$L(NOD) ARY(2)=NOD
  1.  S:$L(NOD) ARY(2,"TXT")="Name/Title"
  1.  S EFF=$O(^LEX(757.033,+IEN,3,"B",(CDT+.001)),-1)
  1.  S REC=$O(^LEX(757.033,+IEN,3,"B",+EFF," "),-1)
  1.  S NOD=$G(^LEX(757.033,IEN,3,+REC,1))
  1.  S:$L(NOD) ARY(3)=NOD
  1.  S:$L(NOD) ARY(3,"TXT")="Description"
  1.  S EFF=$O(^LEX(757.033,+IEN,4,"B",(CDT+.001)),-1)
  1.  S REC=$O(^LEX(757.033,+IEN,4,"B",+EFF," "),-1)
  1.  S NOD=$G(^LEX(757.033,IEN,4,+REC,1))
  1.  S:$L(NOD) ARY(4)=NOD
  1.  S:$L(NOD) ARY(4,"TXT")="Explanation"
  1.  S EFF=$O(^LEX(757.033,+IEN,5,"B",(CDT+.001)),-1)
  1.  S REC=$O(^LEX(757.033,+IEN,5,"B",+EFF," "),-1)
  1.  S (NODC,NODI)=0 F  S NODI=$O(^LEX(757.033,IEN,5,+REC,1,NODI)) Q:+NODI'>0  D
  1.  . S NOD=$$TM($G(^LEX(757.033,IEN,5,REC,1,NODI,0))) Q:'$L(NOD)
  1.  . S NODC=NODC+1 S ARY(5,0)=NODC,ARY(5,"TXT")="Include",ARY(5,NODC)=NOD
  1.  Q 1
  1. INF(X) ;
  1.  N FRAG,CDT,IMP,C1,C2,ARY,IEN S C1=15,C2=26 K ARY
  1.  S FRAG=$G(X) Q:'$L(FRAG)  S CDT=$G(LEXVDT) S:CDT'?7N CDT=$$DT^XLFDT S IMP=$$IMP^ICDEX(31)
  1.  S IEN=$O(^LEX(757.033,"B",("10P"_FRAG),0))
  1.  S:CDT?7N&(IMP?7N)&(CDT<IMP) CDT=IMP K ARY S X=$$FIN(IEN,CDT,.ARY)
  1.  W:$L(FRAG) !," Fragment:",?C1,FRAG
  1.  W:$L(FRAG) ?C2,"Character:  ",$E(FRAG,$L(FRAG))
  1.  S TMP=$G(ARY(1)),EFF=$P(TMP,"^",3),STA=$P(TMP,"^",4)
  1.  I $L(EFF),$L(STA) D
  1.  . W !," Status:",?C1,STA,?C2,"Effective:  ",EFF
  1.  S TMP=$G(ARY(2))
  1.  I $L(TMP) D
  1.  . N TXT,I S TXT(1)=TMP D PR^LEXU(.TXT,(79-C1)) Q:'$L($G(TXT(1)))
  1.  . W !!," Title:",?C1,$G(TXT(1))
  1.  . S I=1 F  S I=$O(TXT(I)) Q:+I'>0  W !,?C1,$G(TXT(I))
  1.  S TMP=$G(ARY(3))
  1.  I $L(TMP) D
  1.  . N TXT,I S TXT(1)=TMP D PR^LEXU(.TXT,(79-C1)) Q:'$L($G(TXT(1)))
  1.  . W !!," Definition:",?C1,$G(TXT(1))
  1.  . S I=1 F  S I=$O(TXT(I)) Q:+I'>0  W !,?C1,$G(TXT(I))
  1.  S TMP=$G(ARY(4))
  1.  I $L(TMP) D
  1.  . N TXT,I S TXT(1)=TMP D PR^LEXU(.TXT,(79-C1)) Q:'$L($G(TXT(1)))
  1.  . W !!," Explanation:",?C1,$G(TXT(1))
  1.  . S I=1 F  S I=$O(TXT(I)) Q:+I'>0  W !,?C1,$G(TXT(I))
  1.  N INI,INC S (INI,INC)=0  F  S INI=$O(ARY(5,INI)) Q:+INI'>0  D
  1.  . N INT S INT(1)=$G(ARY(5,INI)) D PR^LEXU(.INT,(79-C1))
  1.  . S:$L($G(INT(1))) INC=INC+1
  1.  . W:INC=1 !!," Include(s):" W:INC>1 ! W ?C1,$G(INT(1))
  1.  . S I=1 F  S I=$O(INT(I)) Q:+I'>0  W !,?C1,$G(INT(I))
  1.  Q
  1.  ; Miscellaneous
  1. TM(X,Y) ;   Trim Character Y - Default " "
  1.  S X=$G(X) Q:X="" X  S Y=$G(Y) S:'$L(Y) Y=" "
  1.  F  Q:$E(X,1)'=Y  S X=$E(X,2,$L(X))
  1.  F  Q:$E(X,$L(X))'=Y  S X=$E(X,1,($L(X)-1))
  1.  Q X