BSTSMAP1 ;GDIT/HS/BEE-Standard Terminology API Program - Mapping Logic ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
SAVEMAP(CONCDA,BSTSC,GL) ;Save ICD10 Condition Map Rules
;
;Called by UPDATE^BSTSDTS0
;
Q:CONCDA=""
Q:GL=""
;
;Clear out existing entries
D
. NEW MP
. S MP=0 F S MP=$O(^BSTS(9002318.4,CONCDA,14,MP)) Q:'MP D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=MP
.. S DIK="^BSTS(9002318.4,"_DA(1)_",14," D ^DIK
;
;Now save mappings
I $D(@GL@("A10C"))>1 D
. ;
. NEW MG,MP,MC
. S MG="" F S MG=$O(@GL@("A10C",MG)) Q:MG="" S MP="" F S MP=$O(@GL@("A10C",MG,MP)) Q:MP="" S MC="" F S MC=$O(@GL@("A10C",MG,MP,MC)) Q:MC="" D
.. ;
.. NEW DIC,X,Y,DA,IENS,DLAYGO,NODE,MICD,PC,CNDLST,COND,RULE
.. S NODE=$G(@GL@("A10C",MG,MP,MC))
.. S MICD=$P(NODE,U) Q:MICD="" ;Get mapped ICD
.. S CNDLST=$P(NODE,U,2)
.. S DA(1)=CONCDA
.. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",14,"
.. S X=MC
.. S DLAYGO=9002318.414 D ^DIC
.. ;
.. ;Quit on fail
.. I +Y<0 Q
.. ;
.. ;Save remaining fields
.. S (RULE,DA)=+Y,IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.414,IENS,".02")=MG
.. S BSTSC(9002318.414,IENS,".03")=MP
.. S BSTSC(9002318.414,IENS,".04")=MICD
.. ;
.. ;Save Conditions
.. F PC=1:1:$L(CNDLST,";") S COND=$P(CNDLST,";",PC) D
... ;
... I PC>1,COND="" Q
... ;
... NEW VAR,OPER,VALUE,DA,IENS,DIC,DLAYGO,X,Y
... ;
... ;Handle Unconditionals
... S:COND="" COND="TRUE = 1"
... S VAR=$P(COND," ") ;Condition
... S OPER=$P(COND," ",2) ;Operator
... S VALUE=$P(COND," ",3,99) ;Value
... ;
... ;Special variable handling
... I VAR="AAO",VALUE[" days" S VAR="AAOD",VALUE=$P(VALUE," ")
... I VAR="AAO",VALUE[" years" S VAR="AAOY",VALUE=$P(VALUE," ")
... S DA(2)=CONCDA,DA(1)=RULE
... S X=VAR,DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(2)_",14,"_DA(1)_",1,"
... S DLAYGO=9002318.4141
... K DO,DD D FILE^DICN
... I +Y<0 Q
... S DA=+Y,IENS=$$IENS^DILF(.DA)
... ;
... ;Save remaining fields
... S BSTSC(9002318.4141,IENS,.02)=OPER
... S BSTSC(9002318.4141,IENS,.03)=VALUE
... S BSTSC(9002318.4141,IENS,.04)=COND
;
;Capture the status
I $D(@GL@("CSTS")) D
. NEW CSTS,CIEN
. S CIEN=$O(@GL@("CSTS","")) Q:CIEN=""
. S CSTS=$P($G(@GL@("CSTS",CIEN)),U) S:CSTS="" CSTS="@"
. S BSTSC(9002318.4,CONCDA_",",.14)=CSTS
;
Q
;
PLIST(CONCID) ;Return conditional parameters used for that concepts conditional logic
;
I $G(CONCID)="" Q ""
;
NEW VAR,RETURN
;
;Compile list of parameters that are used
S (RETURN,VAR)="" F S VAR=$O(^BSTS(9002318.4,"J",36,CONCID,VAR)) Q:VAR="" D
. S RETURN=RETURN_$S(RETURN]"":"^",1:"")_VAR
;
;Return List
Q RETURN
;
;Return AAOD
AAOD(VIEN) ;Return Age in Days
;
;Input: VIEN - The visit IEN
;
Q:VIEN="" ""
;
NEW AAOD,DOB,VDT,DFN,X1,X2,X,%Y
;
S AAOD=""
;
;Visit Date
S VDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I") Q:VDT="" ""
;
;Date of Birth
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") Q:DFN="" ""
S DOB=$$GET1^DIQ(2,DFN,.03,"I") Q:DOB="" ""
;
;Get difference in dates in days
S X2=DOB,X1=VDT D ^%DTC
I +X>0 S AAOD=+X
;
Q AAOD
;
;Return AAOY
AAOY(VIEN) ;Return Age in Years
;
;Input: VIEN - The visit IEN
;
Q:VIEN="" ""
;
NEW AAOY,DOB,VDT,DFN,X1,X2,X,%Y
;
S AAOY=""
;
;Visit Date
S VDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I") Q:VDT="" ""
;
;Date of Birth
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") Q:DFN="" ""
;
;Get the Age in Years
S AAOY=$$GET1^DIQ(2,DFN,.033,"E")
;
Q AAOY
;
AC(CONC) ;Return Acute/Chronic value for the concept
;
I $G(CONC)="" Q ""
;
NEW STS,CIEN
;
;Get the internal CIEN
S CIEN=$O(^BSTS(9002318.4,"C",36,CONC,"")) Q:CIEN=""
;
;Pull the status from local cache
S STS=$$GET1^DIQ(9002318.4,CIEN_",",.14,"I")
S STS=$S(STS="A":"Acute",STS="C":"Chronic",1:"")
Q STS
;
SEX(VIEN) ;Return patient sex
;
;Input: VIEN - The visit IEN
;
I $G(VIEN)="" Q ""
;
NEW DFN,SEX
;
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") Q:DFN="" ""
S SEX=$$GET1^DIQ(2,DFN,.02,"I")
S SEX=$S(SEX="M":"Male",SEX="F":"Female",1:"")
;
Q SEX
;
;Return Converted Parameter Value for Mapping
CVPARM(TYPE,PARM) ;Return the converted value
;
I $G(PARM)="" Q ""
I $G(TYPE)="" Q ""
;
;Look for a mapping translation in BSTS SNOMED MAPPING CONV
S PARM=$O(^BSTS(9002318.6,"C",TYPE,PARM,""))
;
;Return the translated value
Q PARM
;
TRI(VIEN) ;Return Trimester
;
;Input: VIEN - The visit IEN
;
I $G(VIEN)="" Q ""
;
NEW DFN,TRI
;
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") Q:DFN="" ""
;
;Return the trimester in weeks
S TRI=$$LASTMSR^BSTSMSR($G(DFN),"EGA",0,0)
;
;Convert to weeks
I +TRI'>0 S TRI="" ;No trimester
E I +TRI<14 S TRI="First"
E I +TRI<28 S TRI="Second"
E S TRI="Third"
;
Q TRI
;
BMI(VIEN) ;Return BMI
;
;Input: VIEN - The visit IEN
;
I $G(VIEN)="" Q ""
;
NEW DFN,BMI
;
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") Q:DFN="" 0
;
;Return the latest BMI
S BMI=$$LASTMSR^BSTSMSR($G(DFN),"BMI",0,0)
;
;Handle no BMI
I +BMI'>0 S BMI=""
;
Q BMI
;
AF(AF) ;Return Abnormal Findings
;
I $G(AF)="" Q ""
;
;Handle invalid AF entries
Q $S(AF="With":AF,AF="Without":AF,1:"")
;
HEAL(HEAL) ;Fracture Healing
;
I $G(HEAL)="" Q ""
;
;Handle invalid HEAL entries
Q $S(HEAL="Routine":"NL Union",1:HEAL)
;
LAT(PRB,FH) ;Return Laterality
;
I $G(PRB)="",$G(FH)="" Q ""
;
NEW LAT,ATR
;
;Pull laterality from the PROBLEM file or FAMILY HISTORY file
S LAT=""
I PRB]"" S LAT=$$GET1^DIQ(9000011,PRB_",",".22","I")
I FH]"",LAT="" S LAT=$$GET1^DIQ(9000014,FH_",",".17","I")
Q:$TR(LAT,"|")="" ""
;
;Quit if attribute not "Laterality"
S ATR=$P(LAT,"|") Q:ATR="" ""
S LAT=$P(LAT,"|",2) Q:LAT="" ""
I ATR?1N.N,$O(^BSTS(9002318.6,"C","LAT",ATR,""))'="Laterality" Q ""
I ATR'?1N.N,ATR'="Laterality" Q
;
;If SNOMED, convert and return
I LAT?1N.N S LAT=$$CVPARM("LAT",LAT) Q $S(LAT="Right and left":"Bilateral",1:LAT)
;
;If text, convert Right and left -> Bilateral
Q $S(LAT="Right and left":"Bilateral",1:LAT)
;
SEV(PRB) ;Return Severity
;
I $G(PRB)="" Q ""
;
NEW SEV,I,FND
;
;Pull Severity from the PROBLEM file
S (SEV,FND,I)=0 F S I=$O(^AUPNPROB(PRB,13,I)) Q:'+I D Q:FND
. NEW SNO
. S SNO=$P($G(^AUPNPROB(PRB,13,I,0)),U,1)
. I SNO'="",$$CVPARM^BSTSMAP1("SEV",SNO)'="Severity" S SEV=SNO,FND=1
;
Q SEV
;
CMAP(CONC,PARMS) ;Return the conditional ICD10 mappings for a concept
;
;This function accepts a Concept ID and a string of parameters and based on mapping logic
;returns the mapped ICD10 code(s) for that concept
;
;Input:
; CONC - Concept ID
; PARMS - Parameter string. Ex. "EPI=255217005;VST=2087365;PRB=123456"
;
;Output: Returns a ";" string of ICD10 maps to that concept
;
;Mapping Overview
;Concepts with conditional mapping will have one or more map groups. Each map group can have 0 or 1
;ICD10 codes associated with it. A concept can therefore have more than one ICD10 mapping, up to 1
;per map group. Within each map group there can be multiple priorities. Each priority
;can have one or more condition checks associated with it. The ICD10 code assigned to the first
;priority that ALL the checks pass on will get assigned for that map group.
;
I $G(CONC)="" Q "" ;No Concept Id
I $G(PARMS)="" Q "" ;No mapping parameters passed in
;
NEW PC,VAL,FND,ICD,VAR,CDARY,MGRP,VARRAY,FH,HEAL,VDT
NEW EPI,VST,AF,SEV,PRB,OC,AAOD,AAOY,AC,BMI,SEX,LAT,TRI,TRUE
;
;Parse the passed in PARMS and set the variables
S (EPI,VST,AF,SEV,PRB,OC,AAOD,AAOY,AC,BMI,SEX,LAT,TRI,FH,HEAL)="",TRUE=1 ;Preset possible variables
F PC=1:1:$L(PARMS,";") S VAL=$P(PARMS,";",PC) I VAL]"" D
. ;
. ;Handle invalid parameters passed in
. I VAL'["=" Q ;No equal sign
. I (",EPI,VST,AF,SEV,PRB,HEAL,OC,")'[(","_$P(VAL,"=")_",") Q ;Incorrect first parameter
. I $P(VAL,"=",2)="" Q ;Null value, already set
. ;
. ;Set the parameter variable (adding quotes)
. S VAL="S "_$P(VAL,"=")_"="_$C(34)_$P(VAL,"=",2)_$C(34)
. X VAL
;
;Locate the variables used by this concept
S (FND,ICD,VAR)="" F S VAR=$O(^BSTS(9002318.4,"J",36,CONC,VAR)) Q:VAR="" D
. ;
. ;Found a conditional map
. S FND=1
. ;
. ;Record that variable is needed for the mapping
. S VARRAY(VAR)=""
;
;Quit if no conditional mapping
I FND="" Q ICD
;
;Determine the parameter values
S VAR="" F S VAR=$O(VARRAY(VAR)) Q:VAR="" D
. ;
. ;Acute/Chronic
. I VAR="AC" S AC=$$AC(CONC) Q
. ;
. ;Age at onset - Days
. I VAR="AAOD" S AAOD=$$AAOD(VST) Q
. ;
. ;Age at onset - Years
. I VAR="AAOY" S AAOY=$$AAOY(VST) Q
. ;
. ;Episodicity
. I VAR="EPI" S EPI=$$CVPARM("EPI",EPI) Q
. ;
. ;Gender
. I VAR="SEX" S SEX=$$SEX(VST) Q
. ;
. ;Laterality
. I VAR="LAT" S LAT=$$LAT(PRB,FH) Q
. ;
. ;BMI
. I VAR="BMI" S BMI=$$BMI(VST) Q
. ;
. ;Trimester
. I VAR="TRI" S TRI=$$TRI(VST) Q
. ;
. ;Severity
. I VAR="SEV" D Q
.. S:SEV="" SEV=$$SEV(PRB)
.. S SEV=$$CVPARM("SEV",SEV)
. ;
. ;Abnormal Findings
. I VAR="AF" S AF=$$AF(AF) Q
. ;
. ;Fracture Healing
. I VAR="HEAL" S HEAL=$$HEAL(HEAL) Q
;
;Assemble the conditions
D BCOND^BSTSMAP1(CONC,.CDARY)
;
;Visit Date
S VDT=$$GET1^DIQ(9000010,$G(VST)_",",.01,"I") S:VDT="" VDT=DT
;
;Process each group
S MGRP="" F S MGRP=$O(CDARY(MGRP)) Q:MGRP="" D
. ;
. NEW CNTR,GFND
. ;
. ;Loop by Counter/Priority - Quit if entry found for the group
. S (GFND,CNTR)="" F S CNTR=$O(CDARY(MGRP,CNTR)) Q:CNTR="" D Q:GFND
.. ;
.. NEW COD,FAIL
.. ;
.. ;Get the code
.. S COD=$G(CDARY(MGRP,CNTR))
.. ;
.. NEW CNDCT
.. ;
.. ;Loop through each condition for the priority
.. S (FAIL,CNDCT)="" F S CNDCT=$O(CDARY(MGRP,CNTR,CNDCT)) Q:CNDCT="" D Q:FAIL
... ;
... NEW PASS,COND
... ;
... ;Get the condition and execute
... S PASS=0,COND=CDARY(MGRP,CNTR,CNDCT) X COND
... S:'PASS FAIL=1
.. ;
.. ;Quit priority if any check failed
.. I FAIL Q
.. ;
.. ;Quit if COD is inactive
.. I '$$VRSN^BSTSVICD(COD,VDT) Q
.. ;
.. ;Add code to the list and mark that one was found for the group
.. S ICD=$G(ICD)_$S(ICD]"":";",1:"")_COD
.. S GFND=1
;
Q ICD
;
BCOND(CONC,CDARY) ;Build the condition array
;
;Returns a list of conditions for an array and the CODE for each
;CDARY(MGRP,CNTR)=ICD10 code
;CDARY(MGRP,CNTR,#)=Executable M code for the condition
; Condition will return PASS=0 (Fail) or PASS=1 (Success) if all conditions pass
; then the ICD10 for that priority/counter will be assigned for that map group
;
;Where:
;MGRP - The map group
;CNTR - The priority/counter within the group
;# - The condition entry or entries for that priority/counter
;
NEW CIEN,MGRP
;
;Get the internal CIEN
S CIEN=$O(^BSTS(9002318.4,"C",36,CONC,"")) Q:CIEN=""
;
;Loop through each map group
S MGRP=0 F S MGRP=$O(^BSTS(9002318.4,CIEN,14,"C",MGRP)) Q:'MGRP D
. ;
. NEW MPRI
. ;
. ;Loop through by priority
. S MPRI="" F S MPRI=$O(^BSTS(9002318.4,CIEN,14,"C",MGRP,MPRI)) Q:MPRI="" D
.. ;
.. NEW CNTR
.. ;
.. ;Loop through by counter - counter needed because priority may not be unique
.. S CNTR="" F S CNTR=$O(^BSTS(9002318.4,CIEN,14,"C",MGRP,MPRI,CNTR)) Q:CNTR="" D
... ;
... NEW CIEN1
... ;
... ;Loop through by CIEN1 (IEN of the ICD CONDITIONAL MAPPING multiple)
... S CIEN1="" F S CIEN1=$O(^BSTS(9002318.4,CIEN,14,"C",MGRP,MPRI,CNTR,CIEN1)) Q:CIEN1="" D
.... ;
.... ;Capture the ICD10 code assigned to that priority/counter
.... NEW CIEN2,COD,DA,IENS
.... S DA(1)=CIEN,DA=CIEN1,IENS=$$IENS^DILF(.DA)
.... S COD=$$GET1^DIQ(9002318.414,IENS,".04","E") Q:COD="" ;Code
.... S CDARY(MGRP,CNTR)=COD
.... ;
.... ;Loop through by Condition (priority/counters could have >1 condition - AND logic applies)
.... S CIEN2=0 F S CIEN2=$O(^BSTS(9002318.4,CIEN,14,CIEN1,1,CIEN2)) Q:'CIEN2 D
..... ;
..... NEW VAR,OP,VAL,DA,IENS,COND
..... ;
..... ;Parse the condition
..... S DA(2)=CIEN,DA(1)=CIEN1,DA=CIEN2,IENS=$$IENS^DILF(.DA)
..... S VAR=$$GET1^DIQ(9002318.4141,IENS,".01","E") ;Variable
..... S OP=$$GET1^DIQ(9002318.4141,IENS,".02","E") ;Condition
..... S VAL=$$GET1^DIQ(9002318.4141,IENS,".03","E") ;Value
..... S:VAL]"" VAL=$C(34)_VAL_$C(34) ;Add quotes to value
..... ;
..... ;Assemble the condition
..... ;Need special logic to handle if the patient value is null (so if check is AAO<29 and no visit
..... ;passed in AAO value would be null. In this case do not pass the check (even though ""<29). If
..... ;the condition is looking for a null though (Ex. AC="") allow it.
..... S COND="S PASS=0 I ("_VAR_"]"""")!("_VAR_"=""""&("_VAL_"="""")),"_VAR_OP_VAL_" S PASS=1"
..... ;
..... ;Set up the array
..... S CDARY(MGRP,CNTR,CIEN2)=COND
;
Q
;
HLCHC(LST) ;Return list of healing choices for a concept
;
NEW CHOICE,TERM
;
S (TERM,CHOICE)="" F S TERM=$O(^BSTS(9002318.6,"D","HEAL",TERM)) Q:TERM="" D
. NEW SNOMED
. S SNOMED=$O(^BSTS(9002318.6,"D","HEAL",TERM,"")) Q:SNOMED=""
. I TERM="NL Union",LST["R" S CHOICE=CHOICE_$S(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
. I TERM="Delayed",LST["D" S CHOICE=CHOICE_$S(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
. I TERM="Malunion",LST["M" S CHOICE=CHOICE_$S(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
. I TERM="Nonunion",LST["N" S CHOICE=CHOICE_$S(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
;
Q CHOICE
BSTSMAP1 ;GDIT/HS/BEE-Standard Terminology API Program - Mapping Logic ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
SAVEMAP(CONCDA,BSTSC,GL) ;Save ICD10 Condition Map Rules
+1 ;
+2 ;Called by UPDATE^BSTSDTS0
+3 ;
+4 IF CONCDA=""
QUIT
+5 IF GL=""
QUIT
+6 ;
+7 ;Clear out existing entries
+8 Begin DoDot:1
+9 NEW MP
+10 SET MP=0
FOR
SET MP=$ORDER(^BSTS(9002318.4,CONCDA,14,MP))
IF 'MP
QUIT
Begin DoDot:2
+11 NEW DA,DIK
+12 SET DA(1)=CONCDA
SET DA=MP
+13 SET DIK="^BSTS(9002318.4,"_DA(1)_",14,"
DO ^DIK
End DoDot:2
End DoDot:1
+14 ;
+15 ;Now save mappings
+16 IF $DATA(@GL@("A10C"))>1
Begin DoDot:1
+17 ;
+18 NEW MG,MP,MC
+19 SET MG=""
FOR
SET MG=$ORDER(@GL@("A10C",MG))
IF MG=""
QUIT
SET MP=""
FOR
SET MP=$ORDER(@GL@("A10C",MG,MP))
IF MP=""
QUIT
SET MC=""
FOR
SET MC=$ORDER(@GL@("A10C",MG,MP,MC))
IF MC=""
QUIT
Begin DoDot:2
+20 ;
+21 NEW DIC,X,Y,DA,IENS,DLAYGO,NODE,MICD,PC,CNDLST,COND,RULE
+22 SET NODE=$GET(@GL@("A10C",MG,MP,MC))
+23 ;Get mapped ICD
SET MICD=$PIECE(NODE,U)
IF MICD=""
QUIT
+24 SET CNDLST=$PIECE(NODE,U,2)
+25 SET DA(1)=CONCDA
+26 SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(1)_",14,"
+27 SET X=MC
+28 SET DLAYGO=9002318.414
DO ^DIC
+29 ;
+30 ;Quit on fail
+31 IF +Y<0
QUIT
+32 ;
+33 ;Save remaining fields
+34 SET (RULE,DA)=+Y
SET IENS=$$IENS^DILF(.DA)
+35 SET BSTSC(9002318.414,IENS,".02")=MG
+36 SET BSTSC(9002318.414,IENS,".03")=MP
+37 SET BSTSC(9002318.414,IENS,".04")=MICD
+38 ;
+39 ;Save Conditions
+40 FOR PC=1:1:$LENGTH(CNDLST,";")
SET COND=$PIECE(CNDLST,";",PC)
Begin DoDot:3
+41 ;
+42 IF PC>1
IF COND=""
QUIT
+43 ;
+44 NEW VAR,OPER,VALUE,DA,IENS,DIC,DLAYGO,X,Y
+45 ;
+46 ;Handle Unconditionals
+47 IF COND=""
SET COND="TRUE = 1"
+48 ;Condition
SET VAR=$PIECE(COND," ")
+49 ;Operator
SET OPER=$PIECE(COND," ",2)
+50 ;Value
SET VALUE=$PIECE(COND," ",3,99)
+51 ;
+52 ;Special variable handling
+53 IF VAR="AAO"
IF VALUE[" days"
SET VAR="AAOD"
SET VALUE=$PIECE(VALUE," ")
+54 IF VAR="AAO"
IF VALUE[" years"
SET VAR="AAOY"
SET VALUE=$PIECE(VALUE," ")
+55 SET DA(2)=CONCDA
SET DA(1)=RULE
+56 SET X=VAR
SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(2)_",14,"_DA(1)_",1,"
+57 SET DLAYGO=9002318.4141
+58 KILL DO,DD
DO FILE^DICN
+59 IF +Y<0
QUIT
+60 SET DA=+Y
SET IENS=$$IENS^DILF(.DA)
+61 ;
+62 ;Save remaining fields
+63 SET BSTSC(9002318.4141,IENS,.02)=OPER
+64 SET BSTSC(9002318.4141,IENS,.03)=VALUE
+65 SET BSTSC(9002318.4141,IENS,.04)=COND
End DoDot:3
End DoDot:2
End DoDot:1
+66 ;
+67 ;Capture the status
+68 IF $DATA(@GL@("CSTS"))
Begin DoDot:1
+69 NEW CSTS,CIEN
+70 SET CIEN=$ORDER(@GL@("CSTS",""))
IF CIEN=""
QUIT
+71 SET CSTS=$PIECE($GET(@GL@("CSTS",CIEN)),U)
IF CSTS=""
SET CSTS="@"
+72 SET BSTSC(9002318.4,CONCDA_",",.14)=CSTS
End DoDot:1
+73 ;
+74 QUIT
+75 ;
PLIST(CONCID) ;Return conditional parameters used for that concepts conditional logic
+1 ;
+2 IF $GET(CONCID)=""
QUIT ""
+3 ;
+4 NEW VAR,RETURN
+5 ;
+6 ;Compile list of parameters that are used
+7 SET (RETURN,VAR)=""
FOR
SET VAR=$ORDER(^BSTS(9002318.4,"J",36,CONCID,VAR))
IF VAR=""
QUIT
Begin DoDot:1
+8 SET RETURN=RETURN_$SELECT(RETURN]"":"^",1:"")_VAR
End DoDot:1
+9 ;
+10 ;Return List
+11 QUIT RETURN
+12 ;
+13 ;Return AAOD
AAOD(VIEN) ;Return Age in Days
+1 ;
+2 ;Input: VIEN - The visit IEN
+3 ;
+4 IF VIEN=""
QUIT ""
+5 ;
+6 NEW AAOD,DOB,VDT,DFN,X1,X2,X,%Y
+7 ;
+8 SET AAOD=""
+9 ;
+10 ;Visit Date
+11 SET VDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I")
IF VDT=""
QUIT ""
+12 ;
+13 ;Date of Birth
+14 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF DFN=""
QUIT ""
+15 SET DOB=$$GET1^DIQ(2,DFN,.03,"I")
IF DOB=""
QUIT ""
+16 ;
+17 ;Get difference in dates in days
+18 SET X2=DOB
SET X1=VDT
DO ^%DTC
+19 IF +X>0
SET AAOD=+X
+20 ;
+21 QUIT AAOD
+22 ;
+23 ;Return AAOY
AAOY(VIEN) ;Return Age in Years
+1 ;
+2 ;Input: VIEN - The visit IEN
+3 ;
+4 IF VIEN=""
QUIT ""
+5 ;
+6 NEW AAOY,DOB,VDT,DFN,X1,X2,X,%Y
+7 ;
+8 SET AAOY=""
+9 ;
+10 ;Visit Date
+11 SET VDT=$$GET1^DIQ(9000010,VIEN_",",.01,"I")
IF VDT=""
QUIT ""
+12 ;
+13 ;Date of Birth
+14 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF DFN=""
QUIT ""
+15 ;
+16 ;Get the Age in Years
+17 SET AAOY=$$GET1^DIQ(2,DFN,.033,"E")
+18 ;
+19 QUIT AAOY
+20 ;
AC(CONC) ;Return Acute/Chronic value for the concept
+1 ;
+2 IF $GET(CONC)=""
QUIT ""
+3 ;
+4 NEW STS,CIEN
+5 ;
+6 ;Get the internal CIEN
+7 SET CIEN=$ORDER(^BSTS(9002318.4,"C",36,CONC,""))
IF CIEN=""
QUIT
+8 ;
+9 ;Pull the status from local cache
+10 SET STS=$$GET1^DIQ(9002318.4,CIEN_",",.14,"I")
+11 SET STS=$SELECT(STS="A":"Acute",STS="C":"Chronic",1:"")
+12 QUIT STS
+13 ;
SEX(VIEN) ;Return patient sex
+1 ;
+2 ;Input: VIEN - The visit IEN
+3 ;
+4 IF $GET(VIEN)=""
QUIT ""
+5 ;
+6 NEW DFN,SEX
+7 ;
+8 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF DFN=""
QUIT ""
+9 SET SEX=$$GET1^DIQ(2,DFN,.02,"I")
+10 SET SEX=$SELECT(SEX="M":"Male",SEX="F":"Female",1:"")
+11 ;
+12 QUIT SEX
+13 ;
+14 ;Return Converted Parameter Value for Mapping
CVPARM(TYPE,PARM) ;Return the converted value
+1 ;
+2 IF $GET(PARM)=""
QUIT ""
+3 IF $GET(TYPE)=""
QUIT ""
+4 ;
+5 ;Look for a mapping translation in BSTS SNOMED MAPPING CONV
+6 SET PARM=$ORDER(^BSTS(9002318.6,"C",TYPE,PARM,""))
+7 ;
+8 ;Return the translated value
+9 QUIT PARM
+10 ;
TRI(VIEN) ;Return Trimester
+1 ;
+2 ;Input: VIEN - The visit IEN
+3 ;
+4 IF $GET(VIEN)=""
QUIT ""
+5 ;
+6 NEW DFN,TRI
+7 ;
+8 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF DFN=""
QUIT ""
+9 ;
+10 ;Return the trimester in weeks
+11 SET TRI=$$LASTMSR^BSTSMSR($GET(DFN),"EGA",0,0)
+12 ;
+13 ;Convert to weeks
+14 ;No trimester
IF +TRI'>0
SET TRI=""
+15 IF '$TEST
IF +TRI<14
SET TRI="First"
+16 IF '$TEST
IF +TRI<28
SET TRI="Second"
+17 IF '$TEST
SET TRI="Third"
+18 ;
+19 QUIT TRI
+20 ;
BMI(VIEN) ;Return BMI
+1 ;
+2 ;Input: VIEN - The visit IEN
+3 ;
+4 IF $GET(VIEN)=""
QUIT ""
+5 ;
+6 NEW DFN,BMI
+7 ;
+8 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF DFN=""
QUIT 0
+9 ;
+10 ;Return the latest BMI
+11 SET BMI=$$LASTMSR^BSTSMSR($GET(DFN),"BMI",0,0)
+12 ;
+13 ;Handle no BMI
+14 IF +BMI'>0
SET BMI=""
+15 ;
+16 QUIT BMI
+17 ;
AF(AF) ;Return Abnormal Findings
+1 ;
+2 IF $GET(AF)=""
QUIT ""
+3 ;
+4 ;Handle invalid AF entries
+5 QUIT $SELECT(AF="With":AF,AF="Without":AF,1:"")
+6 ;
HEAL(HEAL) ;Fracture Healing
+1 ;
+2 IF $GET(HEAL)=""
QUIT ""
+3 ;
+4 ;Handle invalid HEAL entries
+5 QUIT $SELECT(HEAL="Routine":"NL Union",1:HEAL)
+6 ;
LAT(PRB,FH) ;Return Laterality
+1 ;
+2 IF $GET(PRB)=""
IF $GET(FH)=""
QUIT ""
+3 ;
+4 NEW LAT,ATR
+5 ;
+6 ;Pull laterality from the PROBLEM file or FAMILY HISTORY file
+7 SET LAT=""
+8 IF PRB]""
SET LAT=$$GET1^DIQ(9000011,PRB_",",".22","I")
+9 IF FH]""
IF LAT=""
SET LAT=$$GET1^DIQ(9000014,FH_",",".17","I")
+10 IF $TRANSLATE(LAT,"|")=""
QUIT ""
+11 ;
+12 ;Quit if attribute not "Laterality"
+13 SET ATR=$PIECE(LAT,"|")
IF ATR=""
QUIT ""
+14 SET LAT=$PIECE(LAT,"|",2)
IF LAT=""
QUIT ""
+15 IF ATR?1N.N
IF $ORDER(^BSTS(9002318.6,"C","LAT",ATR,""))'="Laterality"
QUIT ""
+16 IF ATR'?1N.N
IF ATR'="Laterality"
QUIT
+17 ;
+18 ;If SNOMED, convert and return
+19 IF LAT?1N.N
SET LAT=$$CVPARM("LAT",LAT)
QUIT $SELECT(LAT="Right and left":"Bilateral",1:LAT)
+20 ;
+21 ;If text, convert Right and left -> Bilateral
+22 QUIT $SELECT(LAT="Right and left":"Bilateral",1:LAT)
+23 ;
SEV(PRB) ;Return Severity
+1 ;
+2 IF $GET(PRB)=""
QUIT ""
+3 ;
+4 NEW SEV,I,FND
+5 ;
+6 ;Pull Severity from the PROBLEM file
+7 SET (SEV,FND,I)=0
FOR
SET I=$ORDER(^AUPNPROB(PRB,13,I))
IF '+I
QUIT
Begin DoDot:1
+8 NEW SNO
+9 SET SNO=$PIECE($GET(^AUPNPROB(PRB,13,I,0)),U,1)
+10 IF SNO'=""
IF $$CVPARM^BSTSMAP1("SEV",SNO)'="Severity"
SET SEV=SNO
SET FND=1
End DoDot:1
IF FND
QUIT
+11 ;
+12 QUIT SEV
+13 ;
CMAP(CONC,PARMS) ;Return the conditional ICD10 mappings for a concept
+1 ;
+2 ;This function accepts a Concept ID and a string of parameters and based on mapping logic
+3 ;returns the mapped ICD10 code(s) for that concept
+4 ;
+5 ;Input:
+6 ; CONC - Concept ID
+7 ; PARMS - Parameter string. Ex. "EPI=255217005;VST=2087365;PRB=123456"
+8 ;
+9 ;Output: Returns a ";" string of ICD10 maps to that concept
+10 ;
+11 ;Mapping Overview
+12 ;Concepts with conditional mapping will have one or more map groups. Each map group can have 0 or 1
+13 ;ICD10 codes associated with it. A concept can therefore have more than one ICD10 mapping, up to 1
+14 ;per map group. Within each map group there can be multiple priorities. Each priority
+15 ;can have one or more condition checks associated with it. The ICD10 code assigned to the first
+16 ;priority that ALL the checks pass on will get assigned for that map group.
+17 ;
+18 ;No Concept Id
IF $GET(CONC)=""
QUIT ""
+19 ;No mapping parameters passed in
IF $GET(PARMS)=""
QUIT ""
+20 ;
+21 NEW PC,VAL,FND,ICD,VAR,CDARY,MGRP,VARRAY,FH,HEAL,VDT
+22 NEW EPI,VST,AF,SEV,PRB,OC,AAOD,AAOY,AC,BMI,SEX,LAT,TRI,TRUE
+23 ;
+24 ;Parse the passed in PARMS and set the variables
+25 ;Preset possible variables
SET (EPI,VST,AF,SEV,PRB,OC,AAOD,AAOY,AC,BMI,SEX,LAT,TRI,FH,HEAL)=""
SET TRUE=1
+26 FOR PC=1:1:$LENGTH(PARMS,";")
SET VAL=$PIECE(PARMS,";",PC)
IF VAL]""
Begin DoDot:1
+27 ;
+28 ;Handle invalid parameters passed in
+29 ;No equal sign
IF VAL'["="
QUIT
+30 ;Incorrect first parameter
IF (",EPI,VST,AF,SEV,PRB,HEAL,OC,")'[(","_$PIECE(VAL,"=")_",")
QUIT
+31 ;Null value, already set
IF $PIECE(VAL,"=",2)=""
QUIT
+32 ;
+33 ;Set the parameter variable (adding quotes)
+34 SET VAL="S "_$PIECE(VAL,"=")_"="_$CHAR(34)_$PIECE(VAL,"=",2)_$CHAR(34)
+35 XECUTE VAL
End DoDot:1
+36 ;
+37 ;Locate the variables used by this concept
+38 SET (FND,ICD,VAR)=""
FOR
SET VAR=$ORDER(^BSTS(9002318.4,"J",36,CONC,VAR))
IF VAR=""
QUIT
Begin DoDot:1
+39 ;
+40 ;Found a conditional map
+41 SET FND=1
+42 ;
+43 ;Record that variable is needed for the mapping
+44 SET VARRAY(VAR)=""
End DoDot:1
+45 ;
+46 ;Quit if no conditional mapping
+47 IF FND=""
QUIT ICD
+48 ;
+49 ;Determine the parameter values
+50 SET VAR=""
FOR
SET VAR=$ORDER(VARRAY(VAR))
IF VAR=""
QUIT
Begin DoDot:1
+51 ;
+52 ;Acute/Chronic
+53 IF VAR="AC"
SET AC=$$AC(CONC)
QUIT
+54 ;
+55 ;Age at onset - Days
+56 IF VAR="AAOD"
SET AAOD=$$AAOD(VST)
QUIT
+57 ;
+58 ;Age at onset - Years
+59 IF VAR="AAOY"
SET AAOY=$$AAOY(VST)
QUIT
+60 ;
+61 ;Episodicity
+62 IF VAR="EPI"
SET EPI=$$CVPARM("EPI",EPI)
QUIT
+63 ;
+64 ;Gender
+65 IF VAR="SEX"
SET SEX=$$SEX(VST)
QUIT
+66 ;
+67 ;Laterality
+68 IF VAR="LAT"
SET LAT=$$LAT(PRB,FH)
QUIT
+69 ;
+70 ;BMI
+71 IF VAR="BMI"
SET BMI=$$BMI(VST)
QUIT
+72 ;
+73 ;Trimester
+74 IF VAR="TRI"
SET TRI=$$TRI(VST)
QUIT
+75 ;
+76 ;Severity
+77 IF VAR="SEV"
Begin DoDot:2
+78 IF SEV=""
SET SEV=$$SEV(PRB)
+79 SET SEV=$$CVPARM("SEV",SEV)
End DoDot:2
QUIT
+80 ;
+81 ;Abnormal Findings
+82 IF VAR="AF"
SET AF=$$AF(AF)
QUIT
+83 ;
+84 ;Fracture Healing
+85 IF VAR="HEAL"
SET HEAL=$$HEAL(HEAL)
QUIT
End DoDot:1
+86 ;
+87 ;Assemble the conditions
+88 DO BCOND^BSTSMAP1(CONC,.CDARY)
+89 ;
+90 ;Visit Date
+91 SET VDT=$$GET1^DIQ(9000010,$GET(VST)_",",.01,"I")
IF VDT=""
SET VDT=DT
+92 ;
+93 ;Process each group
+94 SET MGRP=""
FOR
SET MGRP=$ORDER(CDARY(MGRP))
IF MGRP=""
QUIT
Begin DoDot:1
+95 ;
+96 NEW CNTR,GFND
+97 ;
+98 ;Loop by Counter/Priority - Quit if entry found for the group
+99 SET (GFND,CNTR)=""
FOR
SET CNTR=$ORDER(CDARY(MGRP,CNTR))
IF CNTR=""
QUIT
Begin DoDot:2
+100 ;
+101 NEW COD,FAIL
+102 ;
+103 ;Get the code
+104 SET COD=$GET(CDARY(MGRP,CNTR))
+105 ;
+106 NEW CNDCT
+107 ;
+108 ;Loop through each condition for the priority
+109 SET (FAIL,CNDCT)=""
FOR
SET CNDCT=$ORDER(CDARY(MGRP,CNTR,CNDCT))
IF CNDCT=""
QUIT
Begin DoDot:3
+110 ;
+111 NEW PASS,COND
+112 ;
+113 ;Get the condition and execute
+114 SET PASS=0
SET COND=CDARY(MGRP,CNTR,CNDCT)
XECUTE COND
+115 IF 'PASS
SET FAIL=1
End DoDot:3
IF FAIL
QUIT
+116 ;
+117 ;Quit priority if any check failed
+118 IF FAIL
QUIT
+119 ;
+120 ;Quit if COD is inactive
+121 IF '$$VRSN^BSTSVICD(COD,VDT)
QUIT
+122 ;
+123 ;Add code to the list and mark that one was found for the group
+124 SET ICD=$GET(ICD)_$SELECT(ICD]"":";",1:"")_COD
+125 SET GFND=1
End DoDot:2
IF GFND
QUIT
End DoDot:1
+126 ;
+127 QUIT ICD
+128 ;
BCOND(CONC,CDARY) ;Build the condition array
+1 ;
+2 ;Returns a list of conditions for an array and the CODE for each
+3 ;CDARY(MGRP,CNTR)=ICD10 code
+4 ;CDARY(MGRP,CNTR,#)=Executable M code for the condition
+5 ; Condition will return PASS=0 (Fail) or PASS=1 (Success) if all conditions pass
+6 ; then the ICD10 for that priority/counter will be assigned for that map group
+7 ;
+8 ;Where:
+9 ;MGRP - The map group
+10 ;CNTR - The priority/counter within the group
+11 ;# - The condition entry or entries for that priority/counter
+12 ;
+13 NEW CIEN,MGRP
+14 ;
+15 ;Get the internal CIEN
+16 SET CIEN=$ORDER(^BSTS(9002318.4,"C",36,CONC,""))
IF CIEN=""
QUIT
+17 ;
+18 ;Loop through each map group
+19 SET MGRP=0
FOR
SET MGRP=$ORDER(^BSTS(9002318.4,CIEN,14,"C",MGRP))
IF 'MGRP
QUIT
Begin DoDot:1
+20 ;
+21 NEW MPRI
+22 ;
+23 ;Loop through by priority
+24 SET MPRI=""
FOR
SET MPRI=$ORDER(^BSTS(9002318.4,CIEN,14,"C",MGRP,MPRI))
IF MPRI=""
QUIT
Begin DoDot:2
+25 ;
+26 NEW CNTR
+27 ;
+28 ;Loop through by counter - counter needed because priority may not be unique
+29 SET CNTR=""
FOR
SET CNTR=$ORDER(^BSTS(9002318.4,CIEN,14,"C",MGRP,MPRI,CNTR))
IF CNTR=""
QUIT
Begin DoDot:3
+30 ;
+31 NEW CIEN1
+32 ;
+33 ;Loop through by CIEN1 (IEN of the ICD CONDITIONAL MAPPING multiple)
+34 SET CIEN1=""
FOR
SET CIEN1=$ORDER(^BSTS(9002318.4,CIEN,14,"C",MGRP,MPRI,CNTR,CIEN1))
IF CIEN1=""
QUIT
Begin DoDot:4
+35 ;
+36 ;Capture the ICD10 code assigned to that priority/counter
+37 NEW CIEN2,COD,DA,IENS
+38 SET DA(1)=CIEN
SET DA=CIEN1
SET IENS=$$IENS^DILF(.DA)
+39 ;Code
SET COD=$$GET1^DIQ(9002318.414,IENS,".04","E")
IF COD=""
QUIT
+40 SET CDARY(MGRP,CNTR)=COD
+41 ;
+42 ;Loop through by Condition (priority/counters could have >1 condition - AND logic applies)
+43 SET CIEN2=0
FOR
SET CIEN2=$ORDER(^BSTS(9002318.4,CIEN,14,CIEN1,1,CIEN2))
IF 'CIEN2
QUIT
Begin DoDot:5
+44 ;
+45 NEW VAR,OP,VAL,DA,IENS,COND
+46 ;
+47 ;Parse the condition
+48 SET DA(2)=CIEN
SET DA(1)=CIEN1
SET DA=CIEN2
SET IENS=$$IENS^DILF(.DA)
+49 ;Variable
SET VAR=$$GET1^DIQ(9002318.4141,IENS,".01","E")
+50 ;Condition
SET OP=$$GET1^DIQ(9002318.4141,IENS,".02","E")
+51 ;Value
SET VAL=$$GET1^DIQ(9002318.4141,IENS,".03","E")
+52 ;Add quotes to value
IF VAL]""
SET VAL=$CHAR(34)_VAL_$CHAR(34)
+53 ;
+54 ;Assemble the condition
+55 ;Need special logic to handle if the patient value is null (so if check is AAO<29 and no visit
+56 ;passed in AAO value would be null. In this case do not pass the check (even though ""<29). If
+57 ;the condition is looking for a null though (Ex. AC="") allow it.
+58 SET COND="S PASS=0 I ("_VAR_"]"""")!("_VAR_"=""""&("_VAL_"="""")),"_VAR_OP_VAL_" S PASS=1"
+59 ;
+60 ;Set up the array
+61 SET CDARY(MGRP,CNTR,CIEN2)=COND
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+62 ;
+63 QUIT
+64 ;
HLCHC(LST) ;Return list of healing choices for a concept
+1 ;
+2 NEW CHOICE,TERM
+3 ;
+4 SET (TERM,CHOICE)=""
FOR
SET TERM=$ORDER(^BSTS(9002318.6,"D","HEAL",TERM))
IF TERM=""
QUIT
Begin DoDot:1
+5 NEW SNOMED
+6 SET SNOMED=$ORDER(^BSTS(9002318.6,"D","HEAL",TERM,""))
IF SNOMED=""
QUIT
+7 IF TERM="NL Union"
IF LST["R"
SET CHOICE=CHOICE_$SELECT(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
+8 IF TERM="Delayed"
IF LST["D"
SET CHOICE=CHOICE_$SELECT(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
+9 IF TERM="Malunion"
IF LST["M"
SET CHOICE=CHOICE_$SELECT(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
+10 IF TERM="Nonunion"
IF LST["N"
SET CHOICE=CHOICE_$SELECT(CHOICE]"":";",1:"")_TERM_"|"_SNOMED
End DoDot:1
+11 ;
+12 QUIT CHOICE
