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