RORUPR ;HCIOFO/SG - SELECTION RULES PREPARATION ;5/12/05 9:22am
;;1.5;CLINICAL CASE REGISTRIES;**19**;Feb 17, 2006;Build 43
;
;******************************************************************************
;******************************************************************************
; --- ROUTINE MODIFICATION LOG ---
;
;PKG/PATCH DATE DEVELOPER MODIFICATION
;----------- ---------- ----------- ----------------------------------------
;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
;******************************************************************************
;******************************************************************************
;
Q
;
;***** PREPARES SELECTION RULES AND OTHER DATA
;
; .REGLST Reference to a local array containing registry names
; as subscripts and optional registry IENs as values
;
; [LMODE] When stop looping through records of the patient:
; 0 always loop through all records
; 1 all top level rules have been triggered (deflt)
; 2 patient has been marked for addition to all
; registries being processed
;
; [DSBEG] Start date/time of the data scan (the earliest
; registry update date by default)
;
; [DSEND] End date/time of the data scan (NOW by default)
;
; Return Values:
; 0 Ok
; <0 Error code
;
PREPARE(REGLST,LMODE,DSBEG,DSEND) ;
N FILE,I,RC
;--- Clear loop control lists
K RORUPD("LM") S RORUPD("LM")=+$G(LMODE,1)
;--- Load registry parameters
S RC=$$PREPARE1(.REGLST,$G(DSBEG),$G(DSEND)) Q:RC<0 RC
;--- Load selection rules
S RC=$$LOAD^RORUPR1(.REGLST) Q:RC<0 $$ERROR^RORERR(-19)
;--- Load and prepare Lab search data
S RC=$$LABSRCH^RORUPR1() Q:RC<0 $$ERROR^RORERR(-12)
;--- Sort loaded rules
S RC=$$SORT() Q:RC<0 $$ERROR^RORERR(-20)
;--- Load and prepare metadata
S RC=$$METADATA^RORUPR1() Q:RC<0 RC
Q 0
;
;***** LOADS REGISTRY PARAMETERS
;
; .REGLST Reference to a local array containing
; registry names as subscripts
;
; [DSBEG] Start date of the data scan (the earliest registry
; update date by default). Time part of the parameter
; value is ignored.
;
; [DSEND] End date/time of the data scan (NOW by default).
;
; Return Values:
; 0 Ok
; <0 Error code
;
PREPARE1(REGLST,DSBEG,DSEND) ;
N DATE,EVTPROT,I,RC,REGIEN,REGNAME,RORBUF,TMP,UPDSTART
K RORUPD("LD"),RORUPD("LM2"),RORUPD("UPD")
S DSBEG=$G(DSBEG)\1,DSEND=+$G(DSEND)
S UPDSTART=$$DT^XLFDT,EVTPROT=0
;---
S REGNAME="",RC=0
F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
. S TMP="1I;6.1;6.2;15.1;25I;26I"
. S REGIEN=$$REGIEN^RORUTL02(REGNAME,TMP,.RORBUF)
. I REGIEN'>0 S RC=$$ERROR^RORERR(-46,,REGNAME) Q
. ;--- Add an item to the static list of registries
. S RORUPD("LM2",REGIEN)=U_$G(RORBUF("DILIST","ID",1,26))
. ;--- Load and verify update entry points
. S RC=0
. F I=1,2 D Q:RC<0
. . S TMP=$G(RORBUF("DILIST","ID",1,+("6."_I)))
. . S TMP=$$TRIM^XLFSTR(TMP) Q:TMP=""
. . S RC=$$VERIFYEP^RORUTL01(TMP)
. . S:RC'<0 RORUPD("UPD",REGIEN,I)=TMP
. I RC<0 S RC=$$ERROR^RORERR(-6,,REGNAME,,TMP) Q
. ;--- Calculate the earliest update date for the registries
. ; being processed
. S DATE=$G(RORBUF("DILIST","ID",1,1))\1
. I DATE S:DATE<UPDSTART UPDSTART=DATE
. ;--- Calculate the longest lag interval
. S TMP=$G(RORBUF("DILIST","ID",1,15.1))
. S:TMP>$G(RORUPD("LD",1)) RORUPD("LD",1)=TMP
. ;--- Check if event references should be used
. S:$G(RORBUF("DILIST","ID",1,25)) EVTPROT=1
Q:RC<0 RC
;--- Check the lag interval
S:$G(RORUPD("LD",1))'>0 RORUPD("LD",1)=1
;--- Define data scan period
S RORUPD("DT")=$$NOW^XLFDT
S RORUPD("DSBEG")=$S(DSBEG:DSBEG,1:UPDSTART)
S RORUPD("DSEND")=$S(DSEND:DSEND,1:RORUPD("DT"))
;--- Check if we have event references in the file #798.3
S RORUPD("EETS")=$O(^RORDATA(798.3,"AT",""))
S:'RORUPD("EETS") EVTPROT=0
;--- Check the control flags
S:'EVTPROT RORUPD("FLAGS")=$TR($G(RORUPD("FLAGS")),"E")
Q 0
;
;***** PUTS THE RULE INTO THE LIST
;
; RULENAME Name of the rule
; MODE "A" (process after subfiles) or
; "B" (process before subfiles)
; PARENT Name of the parent rule
;
; Return Values:
; 0 Ok
; <0 Error code
;
PUTRULE(RULENAME,MODE,PARENT) ;
N CODE,DSTNODE,DEPNAME,HDR,FILE,IR,IC
S HDR=$G(@RORUPDPI@(3,RULENAME)),FILE=+$P(HDR,U,2)
;--- If the rule has already been processed, try to remove it from
; the dependency list of the parent rule
I $P(HDR,U,3) D REMOVE(RULENAME,FILE,MODE,$G(PARENT)) Q 0
;--- If the rule is in the list of parent rules already, it has been
; mentioned ; somewhere above in the current processing path.
; So, we have "cirle refrenece" (the rule directly or inderectly
; depends on itself)
Q:$D(LSTRUL(RULENAME)) $$ERROR^RORERR(-5,,RULENAME)
;--- Put the rule into the list of parent rules
S LSTRUL(RULENAME)=""
;--- Process the rules that this one depends on
S DEPNAME=""
F S DEPNAME=$O(@RORUPDPI@(3,RULENAME,3,DEPNAME)) Q:DEPNAME="" D Q:RC<0
. S RC=$$PUTRULE(DEPNAME,MODE,RULENAME)
;--- Remove the rule from the list of parent rules
K LSTRUL(RULENAME) Q:RC<0 RC
;--- Process the rule (put it in the sorted list of rules) if there
; are no rules left in its dependency list
D:$D(@RORUPDPI@(3,RULENAME,3))<10
. S IR=$O(RORUPD("SR",FILE,MODE,""),-1)+1
. S DSTNODE=$NA(RORUPD("SR",FILE,MODE,IR))
. S @DSTNODE=RULENAME_U_+HDR_U_$P(HDR,U,4)
. S @DSTNODE@(1)=@RORUPDPI@(3,RULENAME,1)
. M @DSTNODE@(2)=@RORUPDPI@(3,RULENAME,2)
. S @DSTNODE@(3)=@RORUPDPI@(3,RULENAME,4) ;store coding system
. S $P(@RORUPDPI@(3,RULENAME),U,3)=1
. ;--- Try to remove the rule from the dependency list of
. ; the parent rule
. D REMOVE(RULENAME,FILE,MODE,$G(PARENT))
Q 0
;
;***** REMOVES THE RULE FROM THE DEPENDENCY LIST OF THE PARENT RULE
;
; RULENAME Name of the rule
; FILE File number
; MODE "A" (process after subfiles) or
; "B" (process before subfiles)
; PARENT Name of the parent rule
;
; During the first pass of the sort ("before" rules) a rule is
; removed from the parent's dependency list only if the rule is
; associated with the same file as its parent.
;
; Rules are always removed from the dependency list during
; the second sort pass ("after" rules").
;
REMOVE(RULENAME,FILE,MODE,PARENT) ;
Q:$G(PARENT)=""
K:(+$P($G(@RORUPDPI@(3,PARENT)),U,2)=FILE)!(MODE="A") @RORUPDPI@(3,PARENT,3,RULENAME)
Q
;
;***** SORTS SELECTION RULES
;
; Return Values:
; 0 Ok
; <0 Error code
;
SORT() ;
N LSTRUL ; List of names of the parent rules above in the path
;
N FILE,MODE,RC,RULENAME
S RC=0 K RORUPD("SR")
;--- Process "before" selection rules first and then process
; "after" rules
F MODE="B","A" D Q:RC
. S FILE="" ; Loop through affected files
. F S FILE=$O(@RORUPDPI@(1,FILE)) Q:FILE="" D Q:RC
. . S RULENAME="" ; Loop through top level rules
. . F S RULENAME=$O(@RORUPDPI@(1,FILE,"S",RULENAME)) Q:RULENAME="" D Q:RC<0
. . . S RC=$$PUTRULE(RULENAME,MODE)
;---
Q $S(RC<0:RC,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUPR 7539 printed Dec 13, 2024@01:43:53 Page 2
RORUPR ;HCIOFO/SG - SELECTION RULES PREPARATION ;5/12/05 9:22am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**19**;Feb 17, 2006;Build 43
+2 ;
+3 ;******************************************************************************
+4 ;******************************************************************************
+5 ; --- ROUTINE MODIFICATION LOG ---
+6 ;
+7 ;PKG/PATCH DATE DEVELOPER MODIFICATION
+8 ;----------- ---------- ----------- ----------------------------------------
+9 ;ROR*1.5*19 FEB 2012 K GUPTA Support for ICD-10 Coding System
+10 ;******************************************************************************
+11 ;******************************************************************************
+12 ;
+13 QUIT
+14 ;
+15 ;***** PREPARES SELECTION RULES AND OTHER DATA
+16 ;
+17 ; .REGLST Reference to a local array containing registry names
+18 ; as subscripts and optional registry IENs as values
+19 ;
+20 ; [LMODE] When stop looping through records of the patient:
+21 ; 0 always loop through all records
+22 ; 1 all top level rules have been triggered (deflt)
+23 ; 2 patient has been marked for addition to all
+24 ; registries being processed
+25 ;
+26 ; [DSBEG] Start date/time of the data scan (the earliest
+27 ; registry update date by default)
+28 ;
+29 ; [DSEND] End date/time of the data scan (NOW by default)
+30 ;
+31 ; Return Values:
+32 ; 0 Ok
+33 ; <0 Error code
+34 ;
PREPARE(REGLST,LMODE,DSBEG,DSEND) ;
+1 NEW FILE,I,RC
+2 ;--- Clear loop control lists
+3 KILL RORUPD("LM")
SET RORUPD("LM")=+$GET(LMODE,1)
+4 ;--- Load registry parameters
+5 SET RC=$$PREPARE1(.REGLST,$GET(DSBEG),$GET(DSEND))
if RC<0
QUIT RC
+6 ;--- Load selection rules
+7 SET RC=$$LOAD^RORUPR1(.REGLST)
if RC<0
QUIT $$ERROR^RORERR(-19)
+8 ;--- Load and prepare Lab search data
+9 SET RC=$$LABSRCH^RORUPR1()
if RC<0
QUIT $$ERROR^RORERR(-12)
+10 ;--- Sort loaded rules
+11 SET RC=$$SORT()
if RC<0
QUIT $$ERROR^RORERR(-20)
+12 ;--- Load and prepare metadata
+13 SET RC=$$METADATA^RORUPR1()
if RC<0
QUIT RC
+14 QUIT 0
+15 ;
+16 ;***** LOADS REGISTRY PARAMETERS
+17 ;
+18 ; .REGLST Reference to a local array containing
+19 ; registry names as subscripts
+20 ;
+21 ; [DSBEG] Start date of the data scan (the earliest registry
+22 ; update date by default). Time part of the parameter
+23 ; value is ignored.
+24 ;
+25 ; [DSEND] End date/time of the data scan (NOW by default).
+26 ;
+27 ; Return Values:
+28 ; 0 Ok
+29 ; <0 Error code
+30 ;
PREPARE1(REGLST,DSBEG,DSEND) ;
+1 NEW DATE,EVTPROT,I,RC,REGIEN,REGNAME,RORBUF,TMP,UPDSTART
+2 KILL RORUPD("LD"),RORUPD("LM2"),RORUPD("UPD")
+3 SET DSBEG=$GET(DSBEG)\1
SET DSEND=+$GET(DSEND)
+4 SET UPDSTART=$$DT^XLFDT
SET EVTPROT=0
+5 ;---
+6 SET REGNAME=""
SET RC=0
+7 FOR
SET REGNAME=$ORDER(REGLST(REGNAME))
if REGNAME=""
QUIT
Begin DoDot:1
+8 SET TMP="1I;6.1;6.2;15.1;25I;26I"
+9 SET REGIEN=$$REGIEN^RORUTL02(REGNAME,TMP,.RORBUF)
+10 IF REGIEN'>0
SET RC=$$ERROR^RORERR(-46,,REGNAME)
QUIT
+11 ;--- Add an item to the static list of registries
+12 SET RORUPD("LM2",REGIEN)=U_$GET(RORBUF("DILIST","ID",1,26))
+13 ;--- Load and verify update entry points
+14 SET RC=0
+15 FOR I=1,2
Begin DoDot:2
+16 SET TMP=$GET(RORBUF("DILIST","ID",1,+("6."_I)))
+17 SET TMP=$$TRIM^XLFSTR(TMP)
if TMP=""
QUIT
+18 SET RC=$$VERIFYEP^RORUTL01(TMP)
+19 if RC'<0
SET RORUPD("UPD",REGIEN,I)=TMP
End DoDot:2
if RC<0
QUIT
+20 IF RC<0
SET RC=$$ERROR^RORERR(-6,,REGNAME,,TMP)
QUIT
+21 ;--- Calculate the earliest update date for the registries
+22 ; being processed
+23 SET DATE=$GET(RORBUF("DILIST","ID",1,1))\1
+24 IF DATE
if DATE<UPDSTART
SET UPDSTART=DATE
+25 ;--- Calculate the longest lag interval
+26 SET TMP=$GET(RORBUF("DILIST","ID",1,15.1))
+27 if TMP>$GET(RORUPD("LD",1))
SET RORUPD("LD",1)=TMP
+28 ;--- Check if event references should be used
+29 if $GET(RORBUF("DILIST","ID",1,25))
SET EVTPROT=1
End DoDot:1
if RC<0
QUIT
+30 if RC<0
QUIT RC
+31 ;--- Check the lag interval
+32 if $GET(RORUPD("LD",1))'>0
SET RORUPD("LD",1)=1
+33 ;--- Define data scan period
+34 SET RORUPD("DT")=$$NOW^XLFDT
+35 SET RORUPD("DSBEG")=$SELECT(DSBEG:DSBEG,1:UPDSTART)
+36 SET RORUPD("DSEND")=$SELECT(DSEND:DSEND,1:RORUPD("DT"))
+37 ;--- Check if we have event references in the file #798.3
+38 SET RORUPD("EETS")=$ORDER(^RORDATA(798.3,"AT",""))
+39 if 'RORUPD("EETS")
SET EVTPROT=0
+40 ;--- Check the control flags
+41 if 'EVTPROT
SET RORUPD("FLAGS")=$TRANSLATE($GET(RORUPD("FLAGS")),"E")
+42 QUIT 0
+43 ;
+44 ;***** PUTS THE RULE INTO THE LIST
+45 ;
+46 ; RULENAME Name of the rule
+47 ; MODE "A" (process after subfiles) or
+48 ; "B" (process before subfiles)
+49 ; PARENT Name of the parent rule
+50 ;
+51 ; Return Values:
+52 ; 0 Ok
+53 ; <0 Error code
+54 ;
PUTRULE(RULENAME,MODE,PARENT) ;
+1 NEW CODE,DSTNODE,DEPNAME,HDR,FILE,IR,IC
+2 SET HDR=$GET(@RORUPDPI@(3,RULENAME))
SET FILE=+$PIECE(HDR,U,2)
+3 ;--- If the rule has already been processed, try to remove it from
+4 ; the dependency list of the parent rule
+5 IF $PIECE(HDR,U,3)
DO REMOVE(RULENAME,FILE,MODE,$GET(PARENT))
QUIT 0
+6 ;--- If the rule is in the list of parent rules already, it has been
+7 ; mentioned ; somewhere above in the current processing path.
+8 ; So, we have "cirle refrenece" (the rule directly or inderectly
+9 ; depends on itself)
+10 if $DATA(LSTRUL(RULENAME))
QUIT $$ERROR^RORERR(-5,,RULENAME)
+11 ;--- Put the rule into the list of parent rules
+12 SET LSTRUL(RULENAME)=""
+13 ;--- Process the rules that this one depends on
+14 SET DEPNAME=""
+15 FOR
SET DEPNAME=$ORDER(@RORUPDPI@(3,RULENAME,3,DEPNAME))
if DEPNAME=""
QUIT
Begin DoDot:1
+16 SET RC=$$PUTRULE(DEPNAME,MODE,RULENAME)
End DoDot:1
if RC<0
QUIT
+17 ;--- Remove the rule from the list of parent rules
+18 KILL LSTRUL(RULENAME)
if RC<0
QUIT RC
+19 ;--- Process the rule (put it in the sorted list of rules) if there
+20 ; are no rules left in its dependency list
+21 if $DATA(@RORUPDPI@(3,RULENAME,3))<10
Begin DoDot:1
+22 SET IR=$ORDER(RORUPD("SR",FILE,MODE,""),-1)+1
+23 SET DSTNODE=$NAME(RORUPD("SR",FILE,MODE,IR))
+24 SET @DSTNODE=RULENAME_U_+HDR_U_$PIECE(HDR,U,4)
+25 SET @DSTNODE@(1)=@RORUPDPI@(3,RULENAME,1)
+26 MERGE @DSTNODE@(2)=@RORUPDPI@(3,RULENAME,2)
+27 ;store coding system
SET @DSTNODE@(3)=@RORUPDPI@(3,RULENAME,4)
+28 SET $PIECE(@RORUPDPI@(3,RULENAME),U,3)=1
+29 ;--- Try to remove the rule from the dependency list of
+30 ; the parent rule
+31 DO REMOVE(RULENAME,FILE,MODE,$GET(PARENT))
End DoDot:1
+32 QUIT 0
+33 ;
+34 ;***** REMOVES THE RULE FROM THE DEPENDENCY LIST OF THE PARENT RULE
+35 ;
+36 ; RULENAME Name of the rule
+37 ; FILE File number
+38 ; MODE "A" (process after subfiles) or
+39 ; "B" (process before subfiles)
+40 ; PARENT Name of the parent rule
+41 ;
+42 ; During the first pass of the sort ("before" rules) a rule is
+43 ; removed from the parent's dependency list only if the rule is
+44 ; associated with the same file as its parent.
+45 ;
+46 ; Rules are always removed from the dependency list during
+47 ; the second sort pass ("after" rules").
+48 ;
REMOVE(RULENAME,FILE,MODE,PARENT) ;
+1 if $GET(PARENT)=""
QUIT
+2 if (+$PIECE($GET(@RORUPDPI@(3,PARENT)),U,2)=FILE)!(MODE="A")
KILL @RORUPDPI@(3,PARENT,3,RULENAME)
+3 QUIT
+4 ;
+5 ;***** SORTS SELECTION RULES
+6 ;
+7 ; Return Values:
+8 ; 0 Ok
+9 ; <0 Error code
+10 ;
SORT() ;
+1 ; List of names of the parent rules above in the path
NEW LSTRUL
+2 ;
+3 NEW FILE,MODE,RC,RULENAME
+4 SET RC=0
KILL RORUPD("SR")
+5 ;--- Process "before" selection rules first and then process
+6 ; "after" rules
+7 FOR MODE="B","A"
Begin DoDot:1
+8 ; Loop through affected files
SET FILE=""
+9 FOR
SET FILE=$ORDER(@RORUPDPI@(1,FILE))
if FILE=""
QUIT
Begin DoDot:2
+10 ; Loop through top level rules
SET RULENAME=""
+11 FOR
SET RULENAME=$ORDER(@RORUPDPI@(1,FILE,"S",RULENAME))
if RULENAME=""
QUIT
Begin DoDot:3
+12 SET RC=$$PUTRULE(RULENAME,MODE)
End DoDot:3
if RC<0
QUIT
End DoDot:2
if RC
QUIT
End DoDot:1
if RC
QUIT
+13 ;---
+14 QUIT $SELECT(RC<0:RC,1:0)
