RORUPEX ;HCIOFO/SG - SELECTION RULE EXPRESSION PARSER ; 7/21/03 9:47am
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
;
Q
;
;***** GETS THE NEXT CHARACTER FROM THE EXPRESSION
GETCHAR ;
S LOOK=$E(EXPR,EPTR),EPTR=EPTR+1
Q
;
;***** TRANSLATES FIELD OR RULE MACRO TO MUMPS CODE
;
; The function returns a string containing MUMPS expression
; that implements the selection rule macro.
;
GETMACRO() ;
;;AVG,CNT,E,GDF,GDL,I,LS,MAX,MIN,SDF,SDL,SUM
;
Q:'$$MATCH("{") ""
N BI,BUF,DATELMT,NAME,PFX,PFXLST,RC,RORMSG,SFX,TMP,XCODE
S PFXLST=","_$P($T(GETMACRO+1),";;",2)_","
S BI=1,RC=0
F D Q:RC
. I LOOK="}" D GETCHAR S RC=1 Q
. I LOOK=":" D GETCHAR S BI=BI+1 Q
. I LOOK="{" D Q
. . I BI<3 D SNTXERR("GETMACRO^RORUPEX") S RC=1 Q
. . S BUF(BI)=$G(BUF(BI))_$$GETMACRO()
. S BUF(BI)=$G(BUF(BI))_LOOK
. D GETCHAR
Q:ERRCODE<0 ""
;--- Get the parts of the macro
S BI=1,(NAME,PFX,SFX)=""
S TMP=$$UP^XLFSTR($$TRIM^XLFSTR($G(BUF(BI))))
S:PFXLST[(","_TMP_",") PFX=TMP,BI=BI+1
S NAME=$$TRIM^XLFSTR($G(BUF(BI))),BI=BI+1
S SFX=$$TRIM^XLFSTR($G(BUF(BI))),BI=BI+1
;--- Data element value
I (PFX="E")!(PFX="I") S XCODE="" D Q XCODE
. S DATELMT=$S(+NAME=NAME:+NAME,1:$$DATACODE^RORUPDUT(FILE,NAME))
. I DATELMT<0 S ERRCODE=DATELMT Q
. S XCODE="$G(RORVALS(""DV"","_FILE_","_DATELMT_","""_PFX_"""))"
. S RESULT("F",DATELMT,PFX)=""
;--- Lab Search (replace a name of the Lab Search with the IEN)
I PFX="LS" D Q "$$RULE^RORUPD04("_TMP_")"
. I FILE'=63 D SNTXERR("GETMACRO^RORUPEX") S TMP="" Q
. S TMP="I '$P(^(0),U,2)" ; Only Active
. S TMP=+$$FIND1^DIC(798.9,"","X",NAME,"B",TMP,"RORMSG")
. S RC=$$DBS^RORERR("RORMSG",-9,,,798.9)
. S:RC<0 ERRCODE=RC,TMP=0
. S:TMP RESULT("L",TMP)=""
;--- Trigger date macros (set)
I PFX="SDF" Q "$$SDF^RORUPDUT("""_NAME_""","_SFX_")"
I PFX="SDL" Q "$$SDL^RORUPDUT("""_NAME_""","_SFX_")"
;--- Macros processed after this point cannot reference
; the rule that they are part of the expression of
S RESULT("R",NAME)=""
;--- Trigger date macros (get)
I (PFX="GDF")!(PFX="GDL") D Q XCODE
. S XCODE="$$SRDT^RORUPDUT("""_NAME_""","""_PFX_""","_SFX_")"
;--- Value of the selection rule
Q:PFX="" "$G(RORVALS(""SV"","""_NAME_"""))"
Q "$G(RORVALS(""SV"","""_NAME_""","""_PFX_"""))"
;
;***** GETS A STRING CONSTANT FROM THE EXPRESSION
;
; The function returns a string argument from the expression.
;
GETSTR() ;
Q:'$$MATCH("""") ""
N RC,STR
S STR="",RC=0
F D Q:RC
. I LOOK="""" D Q:RC
. . D GETCHAR
. . I LOOK'="""" S RC=1 Q
. . S STR=STR_""""
. S STR=STR_LOOK
. D GETCHAR
Q STR
;
;***** INITIALIZES PARSING PROCESS
INIT ;
S EPTR=1,ERRCODE=0,RESULT=""
D GETCHAR,SKIPWHT
Q
;
;***** COMPARES LOOK-AHEAD CHARACTER TO THE ARGUMENT
MATCH(CH) ;
I LOOK=CH D GETCHAR Q 1
D SNTXERR("MATCH^RORUPEX")
Q 0
;
;***** PARSES THE EXPRESSION
;
; FILE File number
; EXPR Source expression
; .RESULT( Resulting MUMPS code
; "F", List of data elements to load
; DataCode)
; "L",LS#) List of Lab Search IENs
; "R",Rule#) List of rules that this expression depend on
;
; Return values:
; <0 Error code
; 0 Ok
;
PARSER(FILE,EXPR,RESULT) ;
N EPTR ; Current position in the expression
N ERRCODE ; Error code
N LOOK ; Look-ahead character
;
;--- Check if the file exists and supported
Q:'$$VFILE^DILFD(FILE) $$ERROR^RORERR(-58,"PARSER^RORUPEX",,,FILE)
Q:'$D(^ROR(799.2,FILE)) $$ERROR^RORERR(-63,"PARSER^RORUPEX",,,FILE)
;--- Parse the expression
D INIT
F Q:LOOK="" D Q:ERRCODE<0
. I LOOK="""" D Q
. . S RESULT=RESULT_""""_$$GETSTR()_""""
. I LOOK="{" D Q
. . S RESULT=RESULT_$$GETMACRO()
. S RESULT=RESULT_LOOK
. D GETCHAR
;
Q $S(ERRCODE<0:ERRCODE,1:0)
;
;***** PROCESSES A SYNTAX ERROR
SNTXERR(PLACE,MSG) ;
N I,INFO S I=0
S:$G(MSG)'="" I=I+1,INFO(I)=MSG
S I=I+1,INFO(I)="Position: "_EPTR
S:LOOK'="" INFO(I)=INFO(I)_", Character: '"_LOOK_"'"
S ERRCODE=$$ERROR^RORERR(-21,$G(PLACE),.INFO)
Q
;
;***** SKIPS WHITE SPACES IN THE EXPRESSION
SKIPWHT ;
F Q:(" "'[LOOK)!(LOOK="") D GETCHAR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORUPEX 4247 printed Dec 13, 2024@01:43:50 Page 2
RORUPEX ;HCIOFO/SG - SELECTION RULE EXPRESSION PARSER ; 7/21/03 9:47am
+1 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
+2 ;
+3 QUIT
+4 ;
+5 ;***** GETS THE NEXT CHARACTER FROM THE EXPRESSION
GETCHAR ;
+1 SET LOOK=$EXTRACT(EXPR,EPTR)
SET EPTR=EPTR+1
+2 QUIT
+3 ;
+4 ;***** TRANSLATES FIELD OR RULE MACRO TO MUMPS CODE
+5 ;
+6 ; The function returns a string containing MUMPS expression
+7 ; that implements the selection rule macro.
+8 ;
GETMACRO() ;
+1 ;;AVG,CNT,E,GDF,GDL,I,LS,MAX,MIN,SDF,SDL,SUM
+2 ;
+3 if '$$MATCH("{")
QUIT ""
+4 NEW BI,BUF,DATELMT,NAME,PFX,PFXLST,RC,RORMSG,SFX,TMP,XCODE
+5 SET PFXLST=","_$PIECE($TEXT(GETMACRO+1),";;",2)_","
+6 SET BI=1
SET RC=0
+7 FOR
Begin DoDot:1
+8 IF LOOK="}"
DO GETCHAR
SET RC=1
QUIT
+9 IF LOOK=":"
DO GETCHAR
SET BI=BI+1
QUIT
+10 IF LOOK="{"
Begin DoDot:2
+11 IF BI<3
DO SNTXERR("GETMACRO^RORUPEX")
SET RC=1
QUIT
+12 SET BUF(BI)=$GET(BUF(BI))_$$GETMACRO()
End DoDot:2
QUIT
+13 SET BUF(BI)=$GET(BUF(BI))_LOOK
+14 DO GETCHAR
End DoDot:1
if RC
QUIT
+15 if ERRCODE<0
QUIT ""
+16 ;--- Get the parts of the macro
+17 SET BI=1
SET (NAME,PFX,SFX)=""
+18 SET TMP=$$UP^XLFSTR($$TRIM^XLFSTR($GET(BUF(BI))))
+19 if PFXLST[(","_TMP_",")
SET PFX=TMP
SET BI=BI+1
+20 SET NAME=$$TRIM^XLFSTR($GET(BUF(BI)))
SET BI=BI+1
+21 SET SFX=$$TRIM^XLFSTR($GET(BUF(BI)))
SET BI=BI+1
+22 ;--- Data element value
+23 IF (PFX="E")!(PFX="I")
SET XCODE=""
Begin DoDot:1
+24 SET DATELMT=$SELECT(+NAME=NAME:+NAME,1:$$DATACODE^RORUPDUT(FILE,NAME))
+25 IF DATELMT<0
SET ERRCODE=DATELMT
QUIT
+26 SET XCODE="$G(RORVALS(""DV"","_FILE_","_DATELMT_","""_PFX_"""))"
+27 SET RESULT("F",DATELMT,PFX)=""
End DoDot:1
QUIT XCODE
+28 ;--- Lab Search (replace a name of the Lab Search with the IEN)
+29 IF PFX="LS"
Begin DoDot:1
+30 IF FILE'=63
DO SNTXERR("GETMACRO^RORUPEX")
SET TMP=""
QUIT
+31 ; Only Active
SET TMP="I '$P(^(0),U,2)"
+32 SET TMP=+$$FIND1^DIC(798.9,"","X",NAME,"B",TMP,"RORMSG")
+33 SET RC=$$DBS^RORERR("RORMSG",-9,,,798.9)
+34 if RC<0
SET ERRCODE=RC
SET TMP=0
+35 if TMP
SET RESULT("L",TMP)=""
End DoDot:1
QUIT "$$RULE^RORUPD04("_TMP_")"
+36 ;--- Trigger date macros (set)
+37 IF PFX="SDF"
QUIT "$$SDF^RORUPDUT("""_NAME_""","_SFX_")"
+38 IF PFX="SDL"
QUIT "$$SDL^RORUPDUT("""_NAME_""","_SFX_")"
+39 ;--- Macros processed after this point cannot reference
+40 ; the rule that they are part of the expression of
+41 SET RESULT("R",NAME)=""
+42 ;--- Trigger date macros (get)
+43 IF (PFX="GDF")!(PFX="GDL")
Begin DoDot:1
+44 SET XCODE="$$SRDT^RORUPDUT("""_NAME_""","""_PFX_""","_SFX_")"
End DoDot:1
QUIT XCODE
+45 ;--- Value of the selection rule
+46 if PFX=""
QUIT "$G(RORVALS(""SV"","""_NAME_"""))"
+47 QUIT "$G(RORVALS(""SV"","""_NAME_""","""_PFX_"""))"
+48 ;
+49 ;***** GETS A STRING CONSTANT FROM THE EXPRESSION
+50 ;
+51 ; The function returns a string argument from the expression.
+52 ;
GETSTR() ;
+1 if '$$MATCH("""")
QUIT ""
+2 NEW RC,STR
+3 SET STR=""
SET RC=0
+4 FOR
Begin DoDot:1
+5 IF LOOK=""""
Begin DoDot:2
+6 DO GETCHAR
+7 IF LOOK'=""""
SET RC=1
QUIT
+8 SET STR=STR_""""
End DoDot:2
if RC
QUIT
+9 SET STR=STR_LOOK
+10 DO GETCHAR
End DoDot:1
if RC
QUIT
+11 QUIT STR
+12 ;
+13 ;***** INITIALIZES PARSING PROCESS
INIT ;
+1 SET EPTR=1
SET ERRCODE=0
SET RESULT=""
+2 DO GETCHAR
DO SKIPWHT
+3 QUIT
+4 ;
+5 ;***** COMPARES LOOK-AHEAD CHARACTER TO THE ARGUMENT
MATCH(CH) ;
+1 IF LOOK=CH
DO GETCHAR
QUIT 1
+2 DO SNTXERR("MATCH^RORUPEX")
+3 QUIT 0
+4 ;
+5 ;***** PARSES THE EXPRESSION
+6 ;
+7 ; FILE File number
+8 ; EXPR Source expression
+9 ; .RESULT( Resulting MUMPS code
+10 ; "F", List of data elements to load
+11 ; DataCode)
+12 ; "L",LS#) List of Lab Search IENs
+13 ; "R",Rule#) List of rules that this expression depend on
+14 ;
+15 ; Return values:
+16 ; <0 Error code
+17 ; 0 Ok
+18 ;
PARSER(FILE,EXPR,RESULT) ;
+1 ; Current position in the expression
NEW EPTR
+2 ; Error code
NEW ERRCODE
+3 ; Look-ahead character
NEW LOOK
+4 ;
+5 ;--- Check if the file exists and supported
+6 if '$$VFILE^DILFD(FILE)
QUIT $$ERROR^RORERR(-58,"PARSER^RORUPEX",,,FILE)
+7 if '$DATA(^ROR(799.2,FILE))
QUIT $$ERROR^RORERR(-63,"PARSER^RORUPEX",,,FILE)
+8 ;--- Parse the expression
+9 DO INIT
+10 FOR
if LOOK=""
QUIT
Begin DoDot:1
+11 IF LOOK=""""
Begin DoDot:2
+12 SET RESULT=RESULT_""""_$$GETSTR()_""""
End DoDot:2
QUIT
+13 IF LOOK="{"
Begin DoDot:2
+14 SET RESULT=RESULT_$$GETMACRO()
End DoDot:2
QUIT
+15 SET RESULT=RESULT_LOOK
+16 DO GETCHAR
End DoDot:1
if ERRCODE<0
QUIT
+17 ;
+18 QUIT $SELECT(ERRCODE<0:ERRCODE,1:0)
+19 ;
+20 ;***** PROCESSES A SYNTAX ERROR
SNTXERR(PLACE,MSG) ;
+1 NEW I,INFO
SET I=0
+2 if $GET(MSG)'=""
SET I=I+1
SET INFO(I)=MSG
+3 SET I=I+1
SET INFO(I)="Position: "_EPTR
+4 if LOOK'=""
SET INFO(I)=INFO(I)_", Character: '"_LOOK_"'"
+5 SET ERRCODE=$$ERROR^RORERR(-21,$GET(PLACE),.INFO)
+6 QUIT
+7 ;
+8 ;***** SKIPS WHITE SPACES IN THE EXPRESSION
SKIPWHT ;
+1 FOR
if (" "'[LOOK)!(LOOK="")
QUIT
DO GETCHAR
+2 QUIT
