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

LEXTRAN3.m

Go to the documentation of this file. 
  1. LEXTRAN3 ;ISL/FJF - Lexicon Process MFS Mapping Update Change ; 30 Aug 2011  12:27 AM
  1.  ;;2.0;LEXICON UTILITY;**58**;Sep 23, 1996;Build 10
  1.  ; Per VHA Directive 2004-038, this routine should not be modified
  1.  ; 
  1.  ; This routine is invoked by the entry action logic of the
  1.  ; 'LEX MAPPING CHANGE EVENT' protocol which in turn is triggered
  1.  ; by a new style cross-reference field monitor for the either of
  1.  ; the two record indices 'AMAP' or 'AMAPS' on file 757.33.
  1.  ; 
  1.  ; External References
  1.  ; DBIA 5782  SCTMAP^GMPLX1
  1.  ;   
  1. CTRL ; control
  1.  ;
  1.  ; check XUHUIX* arrays to see if before and after are different
  1.  ; if they are the same then take no action
  1.  ; XUHUIX* arrays are inherited from x-reference field monitor and 
  1.  ; thus exist before control passes to this routine (LEXTRAN3)
  1.  ; 
  1.  I '$$CHANGE() Q
  1.  ;
  1.  ; change processing
  1.  N PLSUB,STATUS,RECORD,SCTCDE,ICDCDE,PRFIEN,MAPID,SCTMAPID,MAPORD
  1.  ;initiate variables
  1.  D INIT
  1.  ;
  1.  ; check to ensure SNOMED CT to ICD mapping (no 1 in 757.33)
  1.  I MAPID'=SCTMAPID Q
  1.  ;
  1.  ;obtain preferred term IEN
  1.  S PRFIEN=$$PRFIEN(SCTCDE)
  1.  ;
  1.  ; If the status was set to 1 (active) then move concept into 
  1.  ;   the problem list subset 
  1.  I STATUS=1 D  Q
  1.  .;   add concept to PLS subset, provided that it is not already
  1.  .;   in the subset
  1.  .I '$$INPSUB(PRFIEN,PLSUB) D ADDPLS(PRFIEN,PLSUB)
  1.  .;
  1.  .;   and then update file 9000011
  1.  .D UPDPLP(SCTCDE,ICDCDE,MAPORD)
  1.  ;
  1.  ; Otherwise status was set to 0; thus remove concept from problem
  1.  ;   list subset
  1.  ;
  1.  ;   but first check to see if concept is involved in any other mappings
  1.  ;   if it is then do not remove from problem list subset
  1.  I $$ACTVMAP(SCTCDE,MAPID) Q
  1.  ;
  1.  D DELPLS
  1.  ;
  1.  Q
  1. INIT ; initiate variables
  1.  ; 
  1.  ; record data
  1.  N IMIEN
  1.  S STATUS=XUHUIX(2)
  1.  S IMIEN=$S($D(XUHUIDA(1)):XUHUIDA(1),1:XUHUIDA)
  1.  S RECORD=^LEX(757.33,IMIEN,0)
  1.  S SCTCDE=$P(RECORD,U,2)
  1.  S ICDCDE=$P(RECORD,U,3)
  1.  S MAPID=$P(RECORD,U,4)
  1.  S MAPORD=$P(^LEX(757.33,IMIEN,3),U)
  1.  ;
  1.  ; update data
  1.  ; 
  1.  S PLSUB=7000038 ; problem list subset
  1.  S SCTMAPID=1 ; SNOMED to ICD9 mapping
  1.  Q
  1. PRFIEN(SCTCDE) ; get preferred term IEN in 757.01 for subset update 
  1.  N NOSYNS,LEX,PRFIEN
  1.  S NOSYNS=$$GETSYN^LEXTRAN1("SCT",SCTCDE,,,1)
  1.  S PRFIEN=$P(LEX("P"),U,2)
  1.  Q PRFIEN
  1.  ;
  1. INPSUB(PRF,SUB) ; check if concept PRF is member of subset SUB
  1.  ;
  1.  N IN,SIEN
  1.  S SIEN="",IN=0
  1.  F  S SIEN=$O(^LEX(757.21,"B",PRF,SIEN)) Q:SIEN=""  D  Q:IN=1
  1.  .I $P(^LEX(757.21,SIEN,0),U,2)=SUB S IN=1
  1.  Q IN
  1.  ;
  1. CHANGE() ; check if the after data is different from the before data
  1.  ; i.e. detect if any change
  1.  N XSUB,CHANGE
  1.  S (XSUB,CHANGE)=0
  1.  F  S XSUB=$O(XUHUIX1(XSUB)) Q:+XSUB=0  D  Q:CHANGE=1
  1.  .I XUHUIX1(XSUB)'=XUHUIX2(XSUB) S CHANGE=1 Q
  1.  Q CHANGE
  1.  ;
  1. ADDPLS(PRF,SUB) ; Add the concept to the problem list subset
  1.  ;
  1.  ; determine IEN for preferred term
  1.  N FDA,ORIEN,SUBERR
  1.  S FDA(757.21,"+1,",.01)=PRF
  1.  S FDA(757.21,"+1,",1)=SUB
  1.  S ORIEN(1)=$$SUBIEN()
  1.  D UPDATE^DIE(,"FDA","ORIEN","SUBERR")
  1.  Q
  1.  ;
  1. UPDPLP(SCT,ICD,ORD) ; update patient problem list file
  1.  ; SCTMAP^GMPLX1 is a CPRS problem list function which scans the patient
  1.  ; data file and updates the SNOMED CT code field on the basis of the
  1.  ; mapping change
  1.  ; 
  1.  ; check for existence of function; if not found do not attempt to call
  1.  I $T(SCTMAP^GMPLX1)="" Q
  1.  D SCTMAP^GMPLX1(SCT,ICD,ORD)
  1.  Q
  1.  ;
  1. DELPLS ; remove a concept from subset
  1.  ;
  1.  N FDA,SUBERR
  1.  S FDA(757.21,$$DELIEN()_",",.01)="@"
  1.  D FILE^DIE(,"FDA","SUBERR")
  1.  Q
  1.  ;
  1. ACTVMAP(SRC,MAP) ; return whether active map exists for given code and
  1.  ; mapping identifier
  1.  ;
  1.  N ORD,TAR,IEN,ACT,LDAT,SIEN,STAT
  1.  S (ORD,TAR,IEN)=""
  1.  S ACT=0
  1.  F  S ORD=$O(^LEX(757.33,"C",MAP,SRC,ORD)) Q:ORD=""  D  Q:ACT=1
  1.  .F  S TAR=$O(^LEX(757.33,"C",MAP,SRC,ORD,TAR)) Q:TAR=""  D  Q:ACT=1
  1.  ..F  S IEN=$O(^LEX(757.33,"C",MAP,SRC,ORD,TAR,IEN)) Q:IEN=""  D  Q:ACT=1
  1.  ...S LDAT=$O(^LEX(757.33,IEN,2,"B",""),-1)
  1.  ...S SIEN=$O(^LEX(757.33,IEN,2,"B",LDAT,""))
  1.  ...S STAT=$P(^LEX(757.33,IEN,2,SIEN,0),U,2)
  1.  ...I STAT=1 S ACT=1
  1.  Q ACT
  1.  ;
  1. SUBIEN() ; get next IEN for addition to 757.21
  1.  ;
  1.  N BASE,C
  1.  S BASE=70000000,C=":"
  1.  Q $S($O(^LEX(757.21,C),-1)<BASE:BASE,1:$O(^LEX(757.21,C),-1)+1)
  1.  ;
  1. DELIEN() ; determine IEN of record to be erased from 757.21
  1.  ;
  1.  N SSIEN,DIEN
  1.  S (SSIEN,DIEN)=""
  1.  F  Q:DIEN'=""  S SSIEN=$O(^LEX(757.21,"B",PRFIEN,SSIEN)) Q:SSIEN=""  D
  1.  .I $P(^LEX(757.21,SSIEN,0),U,2)=PLSUB S DIEN=SSIEN
  1.  Q DIEN