RORUPR1 ;HCIOFO/SG - SELECTION RULES PREPARATION ;11/20/05 4:56pm
;;1.5;CLINICAL CASE REGISTRIES;**12,19,24,26**;Feb 17, 2006;Build 53
;
;01/04/2011 BAY/KAM ROR*1.5*12 Remedy Call 421530 Populate a variable
; to assist with Lab Test Result Code
; identification in GCPR^LA7QRY
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;ROR*1.5*24 AUG 2014 T KOPP Change to lookup for selection rule names
; longer than 30 characters
; Added NEW of variable DIERR at FILETREE
; and METADATA
;ROR*1.5*26 APR 2015 T KOPP Added code to support PTF procedure rule
;******************************************************************************
;******************************************************************************
;
Q
;
;***** MARKS PARENT FILES TO PROCESS
;
; This function analyzes file dependencies defined by the 'ROR
; METADATA' file and guaranties that all necessary files will be
; processed during the registry update.
;
FILETREE() ;
N FILE,PF,RC,DIERR
S FILE="",RC=0
F S FILE=$O(RORUPD("SR",FILE)) Q:FILE="" D Q:RC<0
. S PF=+FILE,RC=0
. ;--- Follow a path that leads from this file to
. ; the root of the "file-processing tree".
. F D Q:RC
. . ;--- Check if metadata for the file is defined
. . I '$D(^ROR(799.2,PF)) D Q
. . . S RC=$$ERROR^RORERR(-63,,,,PF)
. . ;--- Get the number of the parent file
. . S PF=+$$GET1^DIQ(799.2,PF_",",1,"I",,"RORMSG")
. . I $G(DIERR) D Q
. . . S RC=$$DBS^RORERR("RORMSG",-9)
. . ;--- Stop if the root of the "file-processing tree" has been
. . ; reached or the file is already marked for processing.
. . ; Otherwise, mark the file and continue moving up.
. . I 'PF!$D(RORUPD("SR",PF)) S RC=1 Q
. . S RORUPD("SR",PF)=""
Q $S(RC<0:RC,1:0)
;
;***** RETURNS LEVEL OF THE FILE IN 'THE FILE PROCESSING' TREE
;
; FILE File number
;
FLEVEL(FILE) ;
N LEVEL
S LEVEL=1
F S FILE=+$P($G(^ROR(799.2,FILE,0)),U,2) Q:'FILE S LEVEL=LEVEL+1
Q LEVEL
;
;***** LOADS AND PREPARES LAB SEARCH INDICATORS
;
; Return Values:
; 0 Ok
; <0 Error code
;
LABSRCH() ;
N I,IND,IR,LRCODE,LSICNT,LSIEN,RC,RORBUF,RORMSG,TMP,VAL
K RORLRC
;--- Browse through the list of Lab searches
S LSIEN="",RC=0
F S LSIEN=$O(@RORUPDPI@(4,LSIEN)) Q:LSIEN="" D Q:RC<0
. K RORBUF S TMP=","_LSIEN_","
. D LIST^DIC(798.92,TMP,"@;.01;.02;1I;2",,,,,"B",,,"RORBUF","RORMSG")
. S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
. ;--- Browse through the list of search indicators
. S IR="",LSICNT=0
. F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D Q:RC<0
. . K LRCODE
. . ;--- Check if the indicator should be ignored
. . S IND=$G(RORBUF("DILIST","ID",IR,1)) Q:IND'>0
. . ;--- Get the result code (LOINC and/or NLT)
. . S LRCODE=$G(RORBUF("DILIST","ID",IR,.01))
. . I LRCODE>0 D Q:LRCODE<0 S LRCODE(LRCODE_"^LN")=""
. . . S LRCODE=$$LNCODE^RORUTL02(LRCODE)
. . S LRCODE=$G(RORBUF("DILIST","ID",IR,.02))
. . S:LRCODE>0 LRCODE(LRCODE_"^NLT")=""
. . ;--- Either LOINC or NLT must be defined
. . Q:$D(LRCODE)<10
. . M RORLRC("B")=LRCODE
. . ;--- Prepare and store the search indicator
. . S VAL=$G(RORBUF("DILIST","ID",IR,2))
. . I VAL="",IND'=1,IND'=6 Q
. . S LSICNT=LSICNT+1
. . S LRCODE=""
. . F S LRCODE=$O(LRCODE(LRCODE)) Q:LRCODE="" D
. . . S I=$O(@RORUPDPI@("LS",LRCODE,LSIEN,""),-1)+1
. . . S @RORUPDPI@("LS",LRCODE,LSIEN,I)=IND_U_VAL
. Q:(RC<0)!(LSICNT>0)
. ;--- Record a warning if no indicators are defined
. S TMP=$$GET1^DIQ(798.9,LSIEN_",",.01,,,"RORMSG")
. S TMP=$$ERROR^RORERR(-55,,,,TMP)
Q:RC<0 RC
;--- Prepare a list of Lab result codes for GCPR^LA7QRY
;01/04/2011 BAY/KAM ROR*1.5*12 added RORLRC variable set to next line
S LRCODE="",RORLRC="CH"
F IR=1:1 S LRCODE=$O(RORLRC("B",LRCODE)) Q:LRCODE="" D
. S RORLRC(IR)=LRCODE
K RORLRC("B")
Q 0
;
;***** LOADS SELECTION RULES DATA
;
; .REGLST Reference to a local array containing registry names
; as subscripts and optional registry IENs as values
;
; Return Values:
; 0 Ok
; <0 Error code
;
LOAD(REGLST) ;
N I,IENS,RC,REGIEN,REGNAME,RORBUF,RORMSG,RULENAME
K RORUPD("LM1")
S REGNAME="",RC=0
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
. S REGIEN=+$G(REGLST(REGNAME))
. I REGIEN'>0 D I REGIEN'>0 S RC=REGIEN Q
. . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
. S @RORUPDPI@(2,REGIEN)=REGNAME
. ;--- Load selection rules
. K RORBUF S IENS=","_REGIEN_","
. D LIST^DIC(798.13,IENS,"@;.01E","U",,,,"B",,,"RORBUF","RORMSG")
. S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
. S I=""
. F S I=$O(RORBUF("DILIST","ID",I)) Q:I="" D Q:RC<0
. . S RULENAME=RORBUF("DILIST","ID",I,.01)
. . S RC=$$LOADRULE(RULENAME,REGIEN)
Q $S(RC<0:RC,1:0)
;
;***** LOADS THE SELECTION RULE
;
; RULENAME Name of the rule
; REGIEN Registry IEN
; [LEVEL] Level of the rule (O for top level rules)
;
; Return Values:
; 0 Ok
; <0 Error code
;
LOADRULE(RULENAME,REGIEN,LEVEL) ;
;--- Quit if the rule has already been loaded
I $D(@RORUPDPI@(3,RULENAME)) D Q 0
. S @RORUPDPI@(3,RULENAME,2,REGIEN)=""
;---
N DATELMT,DEPRLC,EXPR,FILE,I,IENS,RORBUF,RORMSG,RULIEN,TMP
;--- Load the rule data
;D FIND^DIC(798.2,,"@;1;2I","X",RULENAME,2,"B",,,"RORBUF","RORMSG")
D FIND^DIC(798.2,,"@;1;2I;7I","KO",RULENAME,2,,,,"RORBUF","RORMSG") ;load the new coding system internal value
S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0 RC
Q:$G(RORBUF("DILIST",0))<1 $$ERROR^RORERR(-3,,RULENAME)
Q:$G(RORBUF("DILIST",0))>1 $$ERROR^RORERR(-4,,RULENAME)
S RULIEN=+RORBUF("DILIST",2,1),IENS=","_RULIEN_","
S FILE=+RORBUF("DILIST","ID",1,2)
;--- Put the rule data into the temporary global
S @RORUPDPI@(1,FILE,"S",RULENAME)=""
S @RORUPDPI@(3,RULENAME)=RULIEN_U_FILE_"^^"_'$G(LEVEL)
S RC=$$PARSER^RORUPEX(FILE,RORBUF("DILIST","ID",1,1),.EXPR)
Q:RC<0 RC
S @RORUPDPI@(3,RULENAME,1)=EXPR
S @RORUPDPI@(3,RULENAME,2,REGIEN)=""
S @RORUPDPI@(3,RULENAME,4)=RORBUF("DILIST","ID",1,7) ;store the coding system
M @RORUPDPI@(1,FILE,"F")=EXPR("F")
S:'$G(LEVEL) RORUPD("LM1",RULENAME)=""
M @RORUPDPI@(4)=EXPR("L")
;--- Load the rules that this rule depends on
S DEPRLC=""
F S DEPRLC=$O(EXPR("R",DEPRLC)) Q:DEPRLC="" D Q:RC<0
. S RC=$$LOADRULE(DEPRLC,REGIEN,$G(LEVEL)+1)
. S:RC'<0 @RORUPDPI@(3,RULENAME,3,DEPRLC)=""
Q:RC<0 RC
;--- Load a list of additional data elements
K EXPR,RORBUF,RORMSG
D LIST^DIC(798.26,IENS,"@;.01I;1I",,,,,"B",,,"RORBUF","RORMSG")
S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0 RC
S I=""
F S I=$O(RORBUF("DILIST","ID",I)) Q:I="" D
. S DATELMT=RORBUF("DILIST","ID",I,.01)
. S TMP=$G(RORBUF("DILIST","ID",I,1)) S:TMP="" TMP="EI"
. S:TMP["E" @RORUPDPI@(1,FILE,"F",DATELMT,"E")=""
. S:TMP["I" @RORUPDPI@(1,FILE,"F",DATELMT,"I")=""
Q 0
;
;***** LOADS AND PREPARES THE METADATA
METADATA() ;
N API,DATELMT,DEFL,DIERR,FILE,I,IENS,IS,PIF,RC,ROOT,RORBUF,RORMSG,TMP,VT
S RC=$$FILETREE() Q:RC<0 RC
S DEFL="@;.02I;1I;4I;4.1;4.2;6I"
;--- Load and process the metadata
S FILE="",RC=0
F S FILE=$O(RORUPD("SR",FILE)) Q:FILE="" D Q:RC<0
. S IENS=","_FILE_",",PIF=$NA(@RORUPDPI@(1,FILE))
. ;--- Global root of the file
. S RORUPD("ROOT",FILE)=$$ROOT^DILFD(FILE,,1)
. ;--- Associate data elements with APIs
. S DATELMT=""
. F S DATELMT=$O(@PIF@("F",DATELMT)) Q:DATELMT="" D Q:RC<0
. . ;--- Find and load defintion of the data element
. . K RORBUF,RORMSG
. . D FIND^DIC(799.22,IENS,DEFL,"X",DATELMT,,"C",,,"RORBUF","RORMSG")
. . I $G(DIERR) D Q
. . . S RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
. . ;--- Check if search on this element is supported
. . S API=+$G(RORBUF("DILIST","ID",1,1))
. . I 'API D Q
. . . S RC=$$ERROR^RORERR(-64,,,,FILE,DATELMT)
. . ;--- Store the field number (if necessary)
. . I API=1 D S RORUPD("SR",FILE,"F",API,DATELMT)=TMP
. . . S TMP=$G(RORBUF("DILIST","ID",1,6))
. . I API=3,FILE=45 D Q
. . . S RORUPD("SR",45,"F",3,DATELMT)=0
. . . S RORUPD("SR",45,"F",3,DATELMT,"I")="",RC=0
. . ;--- Associate the data element with the API
. . S VT=$G(RORBUF("DILIST","ID",1,4)),RC=0
. . F I="E","I" I $D(@PIF@("F",DATELMT,I)) D Q:RC<0
. . . ;--- Check if type of the requested value is supported
. . . I VT'[I D Q
. . . . S TMP=$$EXTERNAL^DILFD(799.22,4,,I,"RORMSG")
. . . . S RC=$$ERROR^RORERR(-65,,,,FILE,DATELMT,TMP)
. . . ;--- Add the API-Element pair to the list
. . . S TMP=$G(RORBUF("DILIST","ID",1,$$VTFN(I)))
. . . S RORUPD("SR",FILE,"F",API,DATELMT,I)=TMP
. Q:RC<0
. ;--- Add required elements (if any) to the list
. K RORBUF,RORMSG
. D FIND^DIC(799.22,IENS,DEFL,"X",1,,"AR",,,"RORBUF","RORMSG")
. I $G(DIERR) D Q
. . S RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
. S IS=""
. F S IS=$O(RORBUF("DILIST","ID",IS)) Q:IS="" D
. . S DATELMT=+$G(RORBUF("DILIST","ID",IS,.02)) Q:'DATELMT
. . S API=+$G(RORBUF("DILIST","ID",IS,1)) Q:'API
. . S VT=$G(RORBUF("DILIST","ID",IS,4))
. . F I="E","I" D:VT[I
. . . S TMP=$G(RORBUF("DILIST","ID",IS,$$VTFN(I)))
. . . S RORUPD("SR",FILE,"F",API,DATELMT,I)=TMP
. . ;--- Store the field number (if necessary)
. . I API=1 D S RORUPD("SR",FILE,"F",API,DATELMT)=TMP
. . . S TMP=$G(RORBUF("DILIST","ID",IS,6))
. ;--- Compile a list of fields (separated by ';') for the GETS^DIQ
. Q:$D(RORUPD("SR",FILE,"F",1))<10
. S (DATELMT,RORBUF)=""
. F S DATELMT=$O(RORUPD("SR",FILE,"F",1,DATELMT)) Q:DATELMT="" D
. . S TMP=+$G(RORUPD("SR",FILE,"F",1,DATELMT))
. . S:TMP>0 RORBUF=RORBUF_";"_TMP
. S RORUPD("SR",FILE,"F",1)=$S(RORBUF'="":$P(RORBUF,";",2,999),1:"")
Q $S(RC<0:RC,1:0)
;
;***** RETURNS FIELD NUMBER OF ADDITIONAL DATA
VTFN(VT) ;
Q $S(VT="E":4.1,1:4.2)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUPR1 10426 printed Apr 09, 2024@20:49:03 Page 2
RORUPR1 ;HCIOFO/SG - SELECTION RULES PREPARATION ;11/20/05 4:56pm
+1 ;;1.5;CLINICAL CASE REGISTRIES;**12,19,24,26**;Feb 17, 2006;Build 53
+2 ;
+3 ;01/04/2011 BAY/KAM ROR*1.5*12 Remedy Call 421530 Populate a variable
+4 ; to assist with Lab Test Result Code
+5 ; identification in GCPR^LA7QRY
+6 ;******************************************************************************
+7 ;******************************************************************************
+8 ; --- ROUTINE MODIFICATION LOG ---
+9 ;
+10 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+11 ;----------- ---------- ----------- ----------------------------------------
+12 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+13 ;ROR*1.5*24 AUG 2014 T KOPP Change to lookup for selection rule names
+14 ; longer than 30 characters
+15 ; Added NEW of variable DIERR at FILETREE
+16 ; and METADATA
+17 ;ROR*1.5*26 APR 2015 T KOPP Added code to support PTF procedure rule
+18 ;******************************************************************************
+19 ;******************************************************************************
+20 ;
+21 QUIT
+22 ;
+23 ;***** MARKS PARENT FILES TO PROCESS
+24 ;
+25 ; This function analyzes file dependencies defined by the 'ROR
+26 ; METADATA' file and guaranties that all necessary files will be
+27 ; processed during the registry update.
+28 ;
FILETREE() ;
+1 NEW FILE,PF,RC,DIERR
+2 SET FILE=""
SET RC=0
+3 FOR
SET FILE=$ORDER(RORUPD("SR",FILE))
if FILE=""
QUIT
Begin DoDot:1
+4 SET PF=+FILE
SET RC=0
+5 ;--- Follow a path that leads from this file to
+6 ; the root of the "file-processing tree".
+7 FOR
Begin DoDot:2
+8 ;--- Check if metadata for the file is defined
+9 IF '$DATA(^ROR(799.2,PF))
Begin DoDot:3
+10 SET RC=$$ERROR^RORERR(-63,,,,PF)
End DoDot:3
QUIT
+11 ;--- Get the number of the parent file
+12 SET PF=+$$GET1^DIQ(799.2,PF_",",1,"I",,"RORMSG")
+13 IF $GET(DIERR)
Begin DoDot:3
+14 SET RC=$$DBS^RORERR("RORMSG",-9)
End DoDot:3
QUIT
+15 ;--- Stop if the root of the "file-processing tree" has been
+16 ; reached or the file is already marked for processing.
+17 ; Otherwise, mark the file and continue moving up.
+18 IF 'PF!$DATA(RORUPD("SR",PF))
SET RC=1
QUIT
+19 SET RORUPD("SR",PF)=""
End DoDot:2
if RC
QUIT
End DoDot:1
if RC<0
QUIT
+20 QUIT $SELECT(RC<0:RC,1:0)
+21 ;
+22 ;***** RETURNS LEVEL OF THE FILE IN 'THE FILE PROCESSING' TREE
+23 ;
+24 ; FILE File number
+25 ;
FLEVEL(FILE) ;
+1 NEW LEVEL
+2 SET LEVEL=1
+3 FOR
SET FILE=+$PIECE($GET(^ROR(799.2,FILE,0)),U,2)
if 'FILE
QUIT
SET LEVEL=LEVEL+1
+4 QUIT LEVEL
+5 ;
+6 ;***** LOADS AND PREPARES LAB SEARCH INDICATORS
+7 ;
+8 ; Return Values:
+9 ; 0 Ok
+10 ; <0 Error code
+11 ;
LABSRCH() ;
+1 NEW I,IND,IR,LRCODE,LSICNT,LSIEN,RC,RORBUF,RORMSG,TMP,VAL
+2 KILL RORLRC
+3 ;--- Browse through the list of Lab searches
+4 SET LSIEN=""
SET RC=0
+5 FOR
SET LSIEN=$ORDER(@RORUPDPI@(4,LSIEN))
if LSIEN=""
QUIT
Begin DoDot:1
+6 KILL RORBUF
SET TMP=","_LSIEN_","
+7 DO LIST^DIC(798.92,TMP,"@;.01;.02;1I;2",,,,,"B",,,"RORBUF","RORMSG")
+8 SET RC=$$DBS^RORERR("RORMSG",-9)
if RC<0
QUIT
+9 ;--- Browse through the list of search indicators
+10 SET IR=""
SET LSICNT=0
+11 FOR
SET IR=$ORDER(RORBUF("DILIST","ID",IR))
if IR=""
QUIT
Begin DoDot:2
+12 KILL LRCODE
+13 ;--- Check if the indicator should be ignored
+14 SET IND=$GET(RORBUF("DILIST","ID",IR,1))
if IND'>0
QUIT
+15 ;--- Get the result code (LOINC and/or NLT)
+16 SET LRCODE=$GET(RORBUF("DILIST","ID",IR,.01))
+17 IF LRCODE>0
Begin DoDot:3
+18 SET LRCODE=$$LNCODE^RORUTL02(LRCODE)
End DoDot:3
if LRCODE<0
QUIT
SET LRCODE(LRCODE_"^LN")=""
+19 SET LRCODE=$GET(RORBUF("DILIST","ID",IR,.02))
+20 if LRCODE>0
SET LRCODE(LRCODE_"^NLT")=""
+21 ;--- Either LOINC or NLT must be defined
+22 if $DATA(LRCODE)<10
QUIT
+23 MERGE RORLRC("B")=LRCODE
+24 ;--- Prepare and store the search indicator
+25 SET VAL=$GET(RORBUF("DILIST","ID",IR,2))
+26 IF VAL=""
IF IND'=1
IF IND'=6
QUIT
+27 SET LSICNT=LSICNT+1
+28 SET LRCODE=""
+29 FOR
SET LRCODE=$ORDER(LRCODE(LRCODE))
if LRCODE=""
QUIT
Begin DoDot:3
+30 SET I=$ORDER(@RORUPDPI@("LS",LRCODE,LSIEN,""),-1)+1
+31 SET @RORUPDPI@("LS",LRCODE,LSIEN,I)=IND_U_VAL
End DoDot:3
End DoDot:2
if RC<0
QUIT
+32 if (RC<0)!(LSICNT>0)
QUIT
+33 ;--- Record a warning if no indicators are defined
+34 SET TMP=$$GET1^DIQ(798.9,LSIEN_",",.01,,,"RORMSG")
+35 SET TMP=$$ERROR^RORERR(-55,,,,TMP)
End DoDot:1
if RC<0
QUIT
+36 if RC<0
QUIT RC
+37 ;--- Prepare a list of Lab result codes for GCPR^LA7QRY
+38 ;01/04/2011 BAY/KAM ROR*1.5*12 added RORLRC variable set to next line
+39 SET LRCODE=""
SET RORLRC="CH"
+40 FOR IR=1:1
SET LRCODE=$ORDER(RORLRC("B",LRCODE))
if LRCODE=""
QUIT
Begin DoDot:1
+41 SET RORLRC(IR)=LRCODE
End DoDot:1
+42 KILL RORLRC("B")
+43 QUIT 0
+44 ;
+45 ;***** LOADS SELECTION RULES DATA
+46 ;
+47 ; .REGLST Reference to a local array containing registry names
+48 ; as subscripts and optional registry IENs as values
+49 ;
+50 ; Return Values:
+51 ; 0 Ok
+52 ; <0 Error code
+53 ;
LOAD(REGLST) ;
+1 NEW I,IENS,RC,REGIEN,REGNAME,RORBUF,RORMSG,RULENAME
+2 KILL RORUPD("LM1")
+3 SET REGNAME=""
SET RC=0
+4 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+5 SET REGIEN=+$GET(REGLST(REGNAME))
+6 IF REGIEN'>0
Begin DoDot:2
+7 SET REGIEN=$$REGIEN^RORUTL02(REGNAME)
End DoDot:2
IF REGIEN'>0
SET RC=REGIEN
QUIT
+8 SET @RORUPDPI@(2,REGIEN)=REGNAME
+9 ;--- Load selection rules
+10 KILL RORBUF
SET IENS=","_REGIEN_","
+11 DO LIST^DIC(798.13,IENS,"@;.01E","U",,,,"B",,,"RORBUF","RORMSG")
+12 SET RC=$$DBS^RORERR("RORMSG",-9)
if RC<0
QUIT
+13 SET I=""
+14 FOR
SET I=$ORDER(RORBUF("DILIST","ID",I))
if I=""
QUIT
Begin DoDot:2
+15 SET RULENAME=RORBUF("DILIST","ID",I,.01)
+16 SET RC=$$LOADRULE(RULENAME,REGIEN)
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+17 QUIT $SELECT(RC<0:RC,1:0)
+18 ;
+19 ;***** LOADS THE SELECTION RULE
+20 ;
+21 ; RULENAME Name of the rule
+22 ; REGIEN Registry IEN
+23 ; [LEVEL] Level of the rule (O for top level rules)
+24 ;
+25 ; Return Values:
+26 ; 0 Ok
+27 ; <0 Error code
+28 ;
LOADRULE(RULENAME,REGIEN,LEVEL) ;
+1 ;--- Quit if the rule has already been loaded
+2 IF $DATA(@RORUPDPI@(3,RULENAME))
Begin DoDot:1
+3 SET @RORUPDPI@(3,RULENAME,2,REGIEN)=""
End DoDot:1
QUIT 0
+4 ;---
+5 NEW DATELMT,DEPRLC,EXPR,FILE,I,IENS,RORBUF,RORMSG,RULIEN,TMP
+6 ;--- Load the rule data
+7 ;D FIND^DIC(798.2,,"@;1;2I","X",RULENAME,2,"B",,,"RORBUF","RORMSG")
+8 ;load the new coding system internal value
DO FIND^DIC(798.2,,"@;1;2I;7I","KO",RULENAME,2,,,,"RORBUF","RORMSG")
+9 SET RC=$$DBS^RORERR("RORMSG",-9)
if RC<0
QUIT RC
+10 if $GET(RORBUF("DILIST",0))<1
QUIT $$ERROR^RORERR(-3,,RULENAME)
+11 if $GET(RORBUF("DILIST",0))>1
QUIT $$ERROR^RORERR(-4,,RULENAME)
+12 SET RULIEN=+RORBUF("DILIST",2,1)
SET IENS=","_RULIEN_","
+13 SET FILE=+RORBUF("DILIST","ID",1,2)
+14 ;--- Put the rule data into the temporary global
+15 SET @RORUPDPI@(1,FILE,"S",RULENAME)=""
+16 SET @RORUPDPI@(3,RULENAME)=RULIEN_U_FILE_"^^"_'$GET(LEVEL)
+17 SET RC=$$PARSER^RORUPEX(FILE,RORBUF("DILIST","ID",1,1),.EXPR)
+18 if RC<0
QUIT RC
+19 SET @RORUPDPI@(3,RULENAME,1)=EXPR
+20 SET @RORUPDPI@(3,RULENAME,2,REGIEN)=""
+21 ;store the coding system
SET @RORUPDPI@(3,RULENAME,4)=RORBUF("DILIST","ID",1,7)
+22 MERGE @RORUPDPI@(1,FILE,"F")=EXPR("F")
+23 if '$GET(LEVEL)
SET RORUPD("LM1",RULENAME)=""
+24 MERGE @RORUPDPI@(4)=EXPR("L")
+25 ;--- Load the rules that this rule depends on
+26 SET DEPRLC=""
+27 FOR
SET DEPRLC=$ORDER(EXPR("R",DEPRLC))
if DEPRLC=""
QUIT
Begin DoDot:1
+28 SET RC=$$LOADRULE(DEPRLC,REGIEN,$GET(LEVEL)+1)
+29 if RC'<0
SET @RORUPDPI@(3,RULENAME,3,DEPRLC)=""
End DoDot:1
if RC<0
QUIT
+30 if RC<0
QUIT RC
+31 ;--- Load a list of additional data elements
+32 KILL EXPR,RORBUF,RORMSG
+33 DO LIST^DIC(798.26,IENS,"@;.01I;1I",,,,,"B",,,"RORBUF","RORMSG")
+34 SET RC=$$DBS^RORERR("RORMSG",-9)
if RC<0
QUIT RC
+35 SET I=""
+36 FOR
SET I=$ORDER(RORBUF("DILIST","ID",I))
if I=""
QUIT
Begin DoDot:1
+37 SET DATELMT=RORBUF("DILIST","ID",I,.01)
+38 SET TMP=$GET(RORBUF("DILIST","ID",I,1))
if TMP=""
SET TMP="EI"
+39 if TMP["E"
SET @RORUPDPI@(1,FILE,"F",DATELMT,"E")=""
+40 if TMP["I"
SET @RORUPDPI@(1,FILE,"F",DATELMT,"I")=""
End DoDot:1
+41 QUIT 0
+42 ;
+43 ;***** LOADS AND PREPARES THE METADATA
METADATA() ;
+1 NEW API,DATELMT,DEFL,DIERR,FILE,I,IENS,IS,PIF,RC,ROOT,RORBUF,RORMSG,TMP,VT
+2 SET RC=$$FILETREE()
if RC<0
QUIT RC
+3 SET DEFL="@;.02I;1I;4I;4.1;4.2;6I"
+4 ;--- Load and process the metadata
+5 SET FILE=""
SET RC=0
+6 FOR
SET FILE=$ORDER(RORUPD("SR",FILE))
if FILE=""
QUIT
Begin DoDot:1
+7 SET IENS=","_FILE_","
SET PIF=$NAME(@RORUPDPI@(1,FILE))
+8 ;--- Global root of the file
+9 SET RORUPD("ROOT",FILE)=$$ROOT^DILFD(FILE,,1)
+10 ;--- Associate data elements with APIs
+11 SET DATELMT=""
+12 FOR
SET DATELMT=$ORDER(@PIF@("F",DATELMT))
if DATELMT=""
QUIT
Begin DoDot:2
+13 ;--- Find and load defintion of the data element
+14 KILL RORBUF,RORMSG
+15 DO FIND^DIC(799.22,IENS,DEFL,"X",DATELMT,,"C",,,"RORBUF","RORMSG")
+16 IF $GET(DIERR)
Begin DoDot:3
+17 SET RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
End DoDot:3
QUIT
+18 ;--- Check if search on this element is supported
+19 SET API=+$GET(RORBUF("DILIST","ID",1,1))
+20 IF 'API
Begin DoDot:3
+21 SET RC=$$ERROR^RORERR(-64,,,,FILE,DATELMT)
End DoDot:3
QUIT
+22 ;--- Store the field number (if necessary)
+23 IF API=1
Begin DoDot:3
+24 SET TMP=$GET(RORBUF("DILIST","ID",1,6))
End DoDot:3
SET RORUPD("SR",FILE,"F",API,DATELMT)=TMP
+25 IF API=3
IF FILE=45
Begin DoDot:3
+26 SET RORUPD("SR",45,"F",3,DATELMT)=0
+27 SET RORUPD("SR",45,"F",3,DATELMT,"I")=""
SET RC=0
End DoDot:3
QUIT
+28 ;--- Associate the data element with the API
+29 SET VT=$GET(RORBUF("DILIST","ID",1,4))
SET RC=0
+30 FOR I="E","I"
IF $DATA(@PIF@("F",DATELMT,I))
Begin DoDot:3
+31 ;--- Check if type of the requested value is supported
+32 IF VT'[I
Begin DoDot:4
+33 SET TMP=$$EXTERNAL^DILFD(799.22,4,,I,"RORMSG")
+34 SET RC=$$ERROR^RORERR(-65,,,,FILE,DATELMT,TMP)
End DoDot:4
QUIT
+35 ;--- Add the API-Element pair to the list
+36 SET TMP=$GET(RORBUF("DILIST","ID",1,$$VTFN(I)))
+37 SET RORUPD("SR",FILE,"F",API,DATELMT,I)=TMP
End DoDot:3
if RC<0
QUIT
End DoDot:2
if RC<0
QUIT
+38 if RC<0
QUIT
+39 ;--- Add required elements (if any) to the list
+40 KILL RORBUF,RORMSG
+41 DO FIND^DIC(799.22,IENS,DEFL,"X",1,,"AR",,,"RORBUF","RORMSG")
+42 IF $GET(DIERR)
Begin DoDot:2
+43 SET RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
End DoDot:2
QUIT
+44 SET IS=""
+45 FOR
SET IS=$ORDER(RORBUF("DILIST","ID",IS))
if IS=""
QUIT
Begin DoDot:2
+46 SET DATELMT=+$GET(RORBUF("DILIST","ID",IS,.02))
if 'DATELMT
QUIT
+47 SET API=+$GET(RORBUF("DILIST","ID",IS,1))
if 'API
QUIT
+48 SET VT=$GET(RORBUF("DILIST","ID",IS,4))
+49 FOR I="E","I"
if VT[I
Begin DoDot:3
+50 SET TMP=$GET(RORBUF("DILIST","ID",IS,$$VTFN(I)))
+51 SET RORUPD("SR",FILE,"F",API,DATELMT,I)=TMP
End DoDot:3
+52 ;--- Store the field number (if necessary)
+53 IF API=1
Begin DoDot:3
+54 SET TMP=$GET(RORBUF("DILIST","ID",IS,6))
End DoDot:3
SET RORUPD("SR",FILE,"F",API,DATELMT)=TMP
End DoDot:2
+55 ;--- Compile a list of fields (separated by ';') for the GETS^DIQ
+56 if $DATA(RORUPD("SR",FILE,"F",1))<10
QUIT
+57 SET (DATELMT,RORBUF)=""
+58 FOR
SET DATELMT=$ORDER(RORUPD("SR",FILE,"F",1,DATELMT))
if DATELMT=""
QUIT
Begin DoDot:2
+59 SET TMP=+$GET(RORUPD("SR",FILE,"F",1,DATELMT))
+60 if TMP>0
SET RORBUF=RORBUF_";"_TMP
End DoDot:2
+61 SET RORUPD("SR",FILE,"F",1)=$SELECT(RORBUF'="":$PIECE(RORBUF,";",2,999),1:"")
End DoDot:1
if RC<0
QUIT
+62 QUIT $SELECT(RC<0:RC,1:0)
+63 ;
+64 ;***** RETURNS FIELD NUMBER OF ADDITIONAL DATA
VTFN(VT) ;
+1 QUIT $SELECT(VT="E":4.1,1:4.2)
