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