- 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 Feb 18, 2025@23:10:17 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)