PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;05/31/2022
;;2.0;CLINICAL REMINDERS;**4,6,12,18,26,46,65**;Feb 04, 2005;Build 438
;
;===========================================
BASE2(NUM) ;Convert a base 10 integer to base 2.
N BD,BIN
S BIN=""
F Q:NUM=0 D
. S BD=$S((NUM\2)=(NUM/2):0,1:1)
. S BIN=BD_BIN,NUM=NUM\2
Q BIN
;
;===========================================
CRESLOG(NUM,FLIST,RESLOG) ;Check the resolution logic to see if
;it can be made true solely by function findings. If that is the case
;warn the user. Called by BLDRESLS^PXRMLOGX
N AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE
S (AGEFI,SEXFI)=0
S NFF=0
F IND=1:1:NUM D
. S JND=$P(FLIST,";",IND)
. I +JND=JND S FI(JND)=0 Q
. I JND["FF" S NFF=NFF+1,FF=$P(JND,"FF",2),FFL(NFF)=FF
I NFF=0 Q
;Generate and test all combinations of true and false FFs.
S VALUE=0
S NTC=$$PWR^XLFMTH(2,NFF)-1
F IND=1:1:NTC Q:VALUE D
. S BIN=$$BASE2(IND)
. S LEN=$L(BIN)
. S LE=NFF-LEN
.;Fill in the values for the implied preceding 0s.
. F JND=1:1:LE S KND=FFL(JND),FF(KND)=0
. S LND=0
. F JND=LE+1:1:NFF D
.. S KND=FFL(JND),LND=LND+1
.. S FF(KND)=$E(BIN,LND)
. I @RESLOG
. S VALUE=$T
I VALUE D
. N RESLSTR
. S RESLSTR=RESLOG
. F IND=1:1:NUM D
.. S JND=$P(FLIST,";",IND)
.. S TEMP=$S(JND["FF":"FF("_$P(JND,"FF",2)_")",1:"FI("_JND_")")
.. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP)
. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI)
. S RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI)
. W !!,"Warning - your resolution logic can be satisfied by function findings only."
. W !,"If this happens it will not be possible to calculate a resolution date and"
. W !,"the reminder will not be resolved. Here is a case where the logic evaluates"
. W !,"to true:"
. W !,RESLSTR
. W !,RESLOG
. W !
Q
;
;===========================================
FFBUILD(X,DA) ;Given a function finding logical string build the data
;structure. This is called by a new-style cross-reference after
;the function string has passed the input transform so we don't need
;to validate the elements.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
N FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPERS,MSG
N PFSTACK,REPL,RS,TEMP,TS
S IENB=DA_","_DA(1)_","
S OPERS=$$GETOPERS
D POSTFIX^PXRMSTAC(X,OPERS,.PFSTACK)
S (FUNNUM,L2)=0
F IND=1:1:PFSTACK(0) D
. S TEMP=PFSTACK(IND)
. I $D(^PXRMD(802.4,"B",TEMP)) D
.. S FUNP=$O(^PXRMD(802.4,"B",TEMP,""))
.. S FUNNUM=FUNNUM+1,L2=L2+1
.. S IENS="+"_L2_","_IENB
.. S FDA(811.9255,IENS,.01)=FUNNUM
.. S FDA(811.9255,IENS,.02)=FUNP
.. S IND=IND+1
.. S LIST=$TR(PFSTACK(IND),"~"," ")
.. S REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")"
.. S L3=L2
.. S LEN=$L(LIST,",")
.. F JND=1:1:LEN D
... S L3=L3+1
... S IENS="+"_L3_",+"_L2_","_IENB
... S TS=$P(LIST,",",JND)
... S TS=$TR(TS,"""","")
... S FDA(811.9256,IENS,.01)=TS
.. S L2=L3
;Build the logic string
S LOGIC=X
F IND=1:1:FUNNUM D
. S TS=$P(REPL(IND),U,1)
. S RS=$P(REPL(IND),U,2)
. S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS)
S FDA(811.925,IENB,10)=LOGIC
D UPDATE^DIE("","FDA","IENB","MSG")
I $D(MSG) D
. W !,"The update failed, UPDATE^DIE returned the following error message:"
. D AWRITE^PXRMUTIL("MSG")
Q
;
;===========================================
FFKILL(X,DA) ;This is the kill logic for the function string.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q
K ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10)
Q
;
;===========================================
GETOPERS() ;Return the list of operators that can be used in a function string.
Q "!&-+*/\#<>=']['='<'>'[']"
;
;===========================================
ISGRV(VAR) ;VAR can be a global reminder variable by itself or used in a
;$P.
N DELIM,EXPR,FROM,GBLREMVAR,TO,VALID
S GBLREMVAR("PXRMAGE")="",GBLREMVAR("PXRMDATE")="",GBLREMVAR("PXRMDOB")=""
S GBLREMVAR("PXRMDOD")="",GBLREMVAR("PXRMLAD")="",GBLREMVAR("PXRMSEX")=""
S GBLREMVAR("PXRMSIG")=""
S EXPR=$P(VAR,",",1)
S VALID=$D(GBLREMVAR(EXPR))
I 'VALID Q 0
S DELIM=$P(VAR,",",2)
S VALID=$S(DELIM="":1,1:$$ISSTR(DELIM))
I 'VALID Q 0
S FROM=$P(VAR,",",3)
S VALID=$S(FROM="":1,FROM=+FROM:1,1:0)
I 'VALID Q 0
S TO=$P(VAR,",",4)
S VALID=$S(TO="":1,TO=+TO:1,1:0)
Q VALID
;
;===========================================
ISSTR(STRING) ;Return true if STRING really is a string and it is not
;executable MUMPS code.
N VALID,X
S VALID=0
;First and last character is a quote and there are an even number of
;quotes in the string.
I ($E(STRING,1)=""""),($E(STRING,$L(STRING))=""""),($L(STRING,"""")#2=1) S VALID=1
;Check for ,DELIMITER,FROM,TO associated with $P.
I 'VALID D
. I STRING?1","1""""1.E1""""0.1(1","1.N)0.1(1","1.N) S VALID=1
. I STRING?1",U"0.1(1","1.N)0.1(1","1.N) S VALID=1
I 'VALID Q VALID
S X=STRING
D ^DIM
S VALID=$S($D(X)=0:1,1:0)
Q VALID
;
;===========================================
VARGLISTM(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
;is valid. This check is for functions where a different pattern is
;required for each argument.
N ARG,AT,C1,IND,LEN,NL,PATTERN,PATTERNS,TARG,TEXT,VARG,VALID
S LEN=$L(LIST,",")
I LEN=0 D Q 0
. N TEXT
. S TEXT="The argument list is not defined!"
. D EN^DDIOL(TEXT) H 2
S PATTERNS=^PXRMD(802.4,FUNIEN,3)
S LEN=$L(PATTERNS,"~")
I LEN=0 D Q 0
. N TEXT
. S TEXT="The pattern list is not defined!"
. D EN^DDIOL(TEXT) H 2
S NL=0,VALID=1
F IND=1:1:LEN D
. S ARG=$P(LIST,",",IND)
. S PATTERN=$P(PATTERNS,"~",IND)
. S VARG=ARG?@PATTERN
. I 'VARG S VALID=0,NL=NL+1,TEXT(NL)="Function argument number "_IND_" is incorrect." Q
. S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
. I AT="U" S VARG=0
. I 'VARG S VALID=0,NL=NL+1,TEXT(NL)="Function argument number "_IND_" is the wrong type." Q
. I AT="F" D
..;Check for an argument starting with C or R.
.. S C1=$E(ARG,1)
.. I (C1="C")!(C1="R") S TARG=$E(ARG,2,15),VARG=$$VFINDING(TARG,DAI)
.. E S VARG=$$VFINDING(ARG,DAI)
. I 'VARG S VALID=0,NL=NL+1,TEXT(NL)="Function argument number "_IND_" is not a valid finding."
I 'VALID D EN^DDIOL(.TEXT) H 2
Q VALID
;
;===========================================
VARGLISTS(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
;is valid. This check is for functions where a single pattern can
;be used.
N ARG,AT,C1,IND,LEN,PATTERN,TARG,TEXT,VALID
S LEN=$L(LIST,",")
I LEN=0 D Q 0
. N TEXT
. S TEXT="The argument list is not defined!"
. D EN^DDIOL(TEXT) H 2
S PATTERN=^PXRMD(802.4,FUNIEN,2)
S VALID=$S(LIST?@PATTERN:1,1:0)
I 'VALID D Q 0
. N TEXT
. S TEXT="Argument list: "_LIST_" is not correct for function "_$P(^PXRMD(802.4,FUNIEN,0),U,1)
. D EN^DDIOL(TEXT) H 2
F IND=1:1:LEN D
. S ARG=$P(LIST,",",IND)
. S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
. I AT="U" S VALID=0 Q
. I AT="F" D
..;Check for an argument starting with C or R.
.. S C1=$E(ARG,1)
.. I (C1="C")!(C1="R") S TARG=$E(ARG,2,15),VALID=$$VFINDING(TARG,DAI)
.. E S VALID=$$VFINDING(ARG,DAI)
.. I 'VALID D
... S TEXT=ARG_" is not a valid finding."
... D EN^DDIOL(TEXT) H 2
Q VALID
;
;===========================================
VFFORM(FUN,ARGLIST,FSTRING) ;Make sure the function is followed by an argument
;list i.e., FUN(...).
N TSTRING,VALID
S TSTRING=FUN_"("_ARGLIST_")"
S VALID=$S(FSTRING[TSTRING:1,1:0)
I 'VALID D
. N TEXT
. S TEXT="Function "_FUN_" must be followed by an argument list!"
. D EN^DDIOL(.TEXT) H 2
Q VALID
;
;===========================================
VFINDING(X,DAI) ;Make sure a finding number is a valid member of the
;definition finding multiple. Input transform for function
;finding finding number.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q 1
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q 1
I '$D(DAI) Q 1
;If X is not numeric it is not a finding number.
I +X'=X Q 0
I $D(^PXD(811.9,DAI,20,X,0)) Q 1
E D Q 0
. N TEXT
. S TEXT="Finding number "_X_" does not exist!"
. D EN^DDIOL(TEXT) H 2
;
;===========================================
VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid.
;The elements can be functions, operators, and numbers.
;Do not execute as part of a verify fields.
;I $G(DIUTIL)="VERIFY FIELDS" Q 1
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q 1
I '$D(DA) Q 1
N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPERS,PFSTACK,TEMP,TEXT,VALID
S DAI=DA(1)
S OPERS=$$GETOPERS
;Define the allowed M functions.
S MFUN("$P")=""
D POSTFIX^PXRMSTAC(FFSTRING,OPERS,.PFSTACK)
S VALID=1
F IND=1:1:PFSTACK(0) Q:'VALID D
. S TEMP=PFSTACK(IND)
. I $D(^PXRMD(802.4,"B",TEMP)) D Q
.. S FUNIEN=$O(^PXRMD(802.4,"B",TEMP,""))
.. S IND=IND+1
.. S LIST=$G(PFSTACK(IND))
.. S VALID=$$VFFORM(TEMP,LIST,X)
.. I 'VALID Q
.. I $G(^PXRMD(802.4,FUNIEN,2))'="" S VALID=$$VARGLISTS(LIST,DAI,TEMP,FUNIEN)
.. I $G(^PXRMD(802.4,FUNIEN,3))'="" S VALID=$$VARGLISTM(LIST,DAI,TEMP,FUNIEN)
.;Check for an operator. Unary operators have a "U" appended.
. I OPERS[$P(TEMP,"U",1) Q
.;Check for number
. I TEMP=+TEMP Q
.;Check for allowed M function.
. I $D(MFUN(TEMP)) Q
.;Check for a global reminder variable
. I $$ISGRV(TEMP) Q
.;Check for a non-executable string.
. I $$ISSTR(TEMP) Q
. S VALID=0
. S TEXT=TEMP_" is not a valid function finding element!"
. D EN^DDIOL(TEXT) H 2
I VALID D
. N X
. S X="I "_FFSTRING
. D ^DIM
. I $D(X)=0 S VALID=0
I 'VALID D
. S TEMP=FFSTRING_" is not a valid function string!"
. D EN^DDIOL(TEMP) H 2
Q VALID
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMFFDB 9910 printed Nov 22, 2024@16:55:37 Page 2
PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;05/31/2022
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,18,26,46,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;===========================================
BASE2(NUM) ;Convert a base 10 integer to base 2.
+1 NEW BD,BIN
+2 SET BIN=""
+3 FOR
if NUM=0
QUIT
Begin DoDot:1
+4 SET BD=$SELECT((NUM\2)=(NUM/2):0,1:1)
+5 SET BIN=BD_BIN
SET NUM=NUM\2
End DoDot:1
+6 QUIT BIN
+7 ;
+8 ;===========================================
CRESLOG(NUM,FLIST,RESLOG) ;Check the resolution logic to see if
+1 ;it can be made true solely by function findings. If that is the case
+2 ;warn the user. Called by BLDRESLS^PXRMLOGX
+3 NEW AGEFI,BP,FI,FF,FFL,IND,JND,KND,LE,LEN,LND,NFF,NTC,SEXFI,TEMP,VALUE
+4 SET (AGEFI,SEXFI)=0
+5 SET NFF=0
+6 FOR IND=1:1:NUM
Begin DoDot:1
+7 SET JND=$PIECE(FLIST,";",IND)
+8 IF +JND=JND
SET FI(JND)=0
QUIT
+9 IF JND["FF"
SET NFF=NFF+1
SET FF=$PIECE(JND,"FF",2)
SET FFL(NFF)=FF
End DoDot:1
+10 IF NFF=0
QUIT
+11 ;Generate and test all combinations of true and false FFs.
+12 SET VALUE=0
+13 SET NTC=$$PWR^XLFMTH(2,NFF)-1
+14 FOR IND=1:1:NTC
if VALUE
QUIT
Begin DoDot:1
+15 SET BIN=$$BASE2(IND)
+16 SET LEN=$LENGTH(BIN)
+17 SET LE=NFF-LEN
+18 ;Fill in the values for the implied preceding 0s.
+19 FOR JND=1:1:LE
SET KND=FFL(JND)
SET FF(KND)=0
+20 SET LND=0
+21 FOR JND=LE+1:1:NFF
Begin DoDot:2
+22 SET KND=FFL(JND)
SET LND=LND+1
+23 SET FF(KND)=$EXTRACT(BIN,LND)
End DoDot:2
+24 IF @RESLOG
+25 SET VALUE=$TEST
End DoDot:1
+26 IF VALUE
Begin DoDot:1
+27 NEW RESLSTR
+28 SET RESLSTR=RESLOG
+29 FOR IND=1:1:NUM
Begin DoDot:2
+30 SET JND=$PIECE(FLIST,";",IND)
+31 SET TEMP=$SELECT(JND["FF":"FF("_$PIECE(JND,"FF",2)_")",1:"FI("_JND_")")
+32 SET RESLOG=$$STRREP^PXRMUTIL(RESLOG,TEMP,@TEMP)
End DoDot:2
+33 SET RESLOG=$$STRREP^PXRMUTIL(RESLOG,"AGE",AGEFI)
+34 SET RESLOG=$$STRREP^PXRMUTIL(RESLOG,"SEX",SEXFI)
+35 WRITE !!,"Warning - your resolution logic can be satisfied by function findings only."
+36 WRITE !,"If this happens it will not be possible to calculate a resolution date and"
+37 WRITE !,"the reminder will not be resolved. Here is a case where the logic evaluates"
+38 WRITE !,"to true:"
+39 WRITE !,RESLSTR
+40 WRITE !,RESLOG
+41 WRITE !
End DoDot:1
+42 QUIT
+43 ;
+44 ;===========================================
FFBUILD(X,DA) ;Given a function finding logical string build the data
+1 ;structure. This is called by a new-style cross-reference after
+2 ;the function string has passed the input transform so we don't need
+3 ;to validate the elements.
+4 ;Do not execute as part of a verify fields.
+5 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+6 ;Do not execute as part of exchange.
+7 IF $GET(PXRMEXCH)
QUIT
+8 NEW FDA,FUNNUM,FUNP,IENB,IENS,IND,JND,L2,L3,LEN,LIST,LOGIC,OPERS,MSG
+9 NEW PFSTACK,REPL,RS,TEMP,TS
+10 SET IENB=DA_","_DA(1)_","
+11 SET OPERS=$$GETOPERS
+12 DO POSTFIX^PXRMSTAC(X,OPERS,.PFSTACK)
+13 SET (FUNNUM,L2)=0
+14 FOR IND=1:1:PFSTACK(0)
Begin DoDot:1
+15 SET TEMP=PFSTACK(IND)
+16 IF $DATA(^PXRMD(802.4,"B",TEMP))
Begin DoDot:2
+17 SET FUNP=$ORDER(^PXRMD(802.4,"B",TEMP,""))
+18 SET FUNNUM=FUNNUM+1
SET L2=L2+1
+19 SET IENS="+"_L2_","_IENB
+20 SET FDA(811.9255,IENS,.01)=FUNNUM
+21 SET FDA(811.9255,IENS,.02)=FUNP
+22 SET IND=IND+1
+23 SET LIST=$TRANSLATE(PFSTACK(IND),"~"," ")
+24 SET REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")"
+25 SET L3=L2
+26 SET LEN=$LENGTH(LIST,",")
+27 FOR JND=1:1:LEN
Begin DoDot:3
+28 SET L3=L3+1
+29 SET IENS="+"_L3_",+"_L2_","_IENB
+30 SET TS=$PIECE(LIST,",",JND)
+31 SET TS=$TRANSLATE(TS,"""","")
+32 SET FDA(811.9256,IENS,.01)=TS
End DoDot:3
+33 SET L2=L3
End DoDot:2
End DoDot:1
+34 ;Build the logic string
+35 SET LOGIC=X
+36 FOR IND=1:1:FUNNUM
Begin DoDot:1
+37 SET TS=$PIECE(REPL(IND),U,1)
+38 SET RS=$PIECE(REPL(IND),U,2)
+39 SET LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS)
End DoDot:1
+40 SET FDA(811.925,IENB,10)=LOGIC
+41 DO UPDATE^DIE("","FDA","IENB","MSG")
+42 IF $DATA(MSG)
Begin DoDot:1
+43 WRITE !,"The update failed, UPDATE^DIE returned the following error message:"
+44 DO AWRITE^PXRMUTIL("MSG")
End DoDot:1
+45 QUIT
+46 ;
+47 ;===========================================
FFKILL(X,DA) ;This is the kill logic for the function string.
+1 ;Do not execute as part of a verify fields.
+2 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT
+5 KILL ^PXD(811.9,DA(1),25,DA,5),^PXD(811.9,DA(1),25,DA,10)
+6 QUIT
+7 ;
+8 ;===========================================
GETOPERS() ;Return the list of operators that can be used in a function string.
+1 QUIT "!&-+*/\#<>=']['='<'>'[']"
+2 ;
+3 ;===========================================
ISGRV(VAR) ;VAR can be a global reminder variable by itself or used in a
+1 ;$P.
+2 NEW DELIM,EXPR,FROM,GBLREMVAR,TO,VALID
+3 SET GBLREMVAR("PXRMAGE")=""
SET GBLREMVAR("PXRMDATE")=""
SET GBLREMVAR("PXRMDOB")=""
+4 SET GBLREMVAR("PXRMDOD")=""
SET GBLREMVAR("PXRMLAD")=""
SET GBLREMVAR("PXRMSEX")=""
+5 SET GBLREMVAR("PXRMSIG")=""
+6 SET EXPR=$PIECE(VAR,",",1)
+7 SET VALID=$DATA(GBLREMVAR(EXPR))
+8 IF 'VALID
QUIT 0
+9 SET DELIM=$PIECE(VAR,",",2)
+10 SET VALID=$SELECT(DELIM="":1,1:$$ISSTR(DELIM))
+11 IF 'VALID
QUIT 0
+12 SET FROM=$PIECE(VAR,",",3)
+13 SET VALID=$SELECT(FROM="":1,FROM=+FROM:1,1:0)
+14 IF 'VALID
QUIT 0
+15 SET TO=$PIECE(VAR,",",4)
+16 SET VALID=$SELECT(TO="":1,TO=+TO:1,1:0)
+17 QUIT VALID
+18 ;
+19 ;===========================================
ISSTR(STRING) ;Return true if STRING really is a string and it is not
+1 ;executable MUMPS code.
+2 NEW VALID,X
+3 SET VALID=0
+4 ;First and last character is a quote and there are an even number of
+5 ;quotes in the string.
+6 IF ($EXTRACT(STRING,1)="""")
IF ($EXTRACT(STRING,$LENGTH(STRING))="""")
IF ($LENGTH(STRING,"""")#2=1)
SET VALID=1
+7 ;Check for ,DELIMITER,FROM,TO associated with $P.
+8 IF 'VALID
Begin DoDot:1
+9 IF STRING?1","1""""1.E1""""0.1(1","1.N)0.1(1","1.N)
SET VALID=1
+10 IF STRING?1",U"0.1(1","1.N)0.1(1","1.N)
SET VALID=1
End DoDot:1
+11 IF 'VALID
QUIT VALID
+12 SET X=STRING
+13 DO ^DIM
+14 SET VALID=$SELECT($DATA(X)=0:1,1:0)
+15 QUIT VALID
+16 ;
+17 ;===========================================
VARGLISTM(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
+1 ;is valid. This check is for functions where a different pattern is
+2 ;required for each argument.
+3 NEW ARG,AT,C1,IND,LEN,NL,PATTERN,PATTERNS,TARG,TEXT,VARG,VALID
+4 SET LEN=$LENGTH(LIST,",")
+5 IF LEN=0
Begin DoDot:1
+6 NEW TEXT
+7 SET TEXT="The argument list is not defined!"
+8 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:1
QUIT 0
+9 SET PATTERNS=^PXRMD(802.4,FUNIEN,3)
+10 SET LEN=$LENGTH(PATTERNS,"~")
+11 IF LEN=0
Begin DoDot:1
+12 NEW TEXT
+13 SET TEXT="The pattern list is not defined!"
+14 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:1
QUIT 0
+15 SET NL=0
SET VALID=1
+16 FOR IND=1:1:LEN
Begin DoDot:1
+17 SET ARG=$PIECE(LIST,",",IND)
+18 SET PATTERN=$PIECE(PATTERNS,"~",IND)
+19 SET VARG=ARG?@PATTERN
+20 IF 'VARG
SET VALID=0
SET NL=NL+1
SET TEXT(NL)="Function argument number "_IND_" is incorrect."
QUIT
+21 SET AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
+22 IF AT="U"
SET VARG=0
+23 IF 'VARG
SET VALID=0
SET NL=NL+1
SET TEXT(NL)="Function argument number "_IND_" is the wrong type."
QUIT
+24 IF AT="F"
Begin DoDot:2
+25 ;Check for an argument starting with C or R.
+26 SET C1=$EXTRACT(ARG,1)
+27 IF (C1="C")!(C1="R")
SET TARG=$EXTRACT(ARG,2,15)
SET VARG=$$VFINDING(TARG,DAI)
+28 IF '$TEST
SET VARG=$$VFINDING(ARG,DAI)
End DoDot:2
+29 IF 'VARG
SET VALID=0
SET NL=NL+1
SET TEXT(NL)="Function argument number "_IND_" is not a valid finding."
End DoDot:1
+30 IF 'VALID
DO EN^DDIOL(.TEXT)
HANG 2
+31 QUIT VALID
+32 ;
+33 ;===========================================
VARGLISTS(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list
+1 ;is valid. This check is for functions where a single pattern can
+2 ;be used.
+3 NEW ARG,AT,C1,IND,LEN,PATTERN,TARG,TEXT,VALID
+4 SET LEN=$LENGTH(LIST,",")
+5 IF LEN=0
Begin DoDot:1
+6 NEW TEXT
+7 SET TEXT="The argument list is not defined!"
+8 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:1
QUIT 0
+9 SET PATTERN=^PXRMD(802.4,FUNIEN,2)
+10 SET VALID=$SELECT(LIST?@PATTERN:1,1:0)
+11 IF 'VALID
Begin DoDot:1
+12 NEW TEXT
+13 SET TEXT="Argument list: "_LIST_" is not correct for function "_$PIECE(^PXRMD(802.4,FUNIEN,0),U,1)
+14 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:1
QUIT 0
+15 FOR IND=1:1:LEN
Begin DoDot:1
+16 SET ARG=$PIECE(LIST,",",IND)
+17 SET AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)
+18 IF AT="U"
SET VALID=0
QUIT
+19 IF AT="F"
Begin DoDot:2
+20 ;Check for an argument starting with C or R.
+21 SET C1=$EXTRACT(ARG,1)
+22 IF (C1="C")!(C1="R")
SET TARG=$EXTRACT(ARG,2,15)
SET VALID=$$VFINDING(TARG,DAI)
+23 IF '$TEST
SET VALID=$$VFINDING(ARG,DAI)
+24 IF 'VALID
Begin DoDot:3
+25 SET TEXT=ARG_" is not a valid finding."
+26 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT VALID
+28 ;
+29 ;===========================================
VFFORM(FUN,ARGLIST,FSTRING) ;Make sure the function is followed by an argument
+1 ;list i.e., FUN(...).
+2 NEW TSTRING,VALID
+3 SET TSTRING=FUN_"("_ARGLIST_")"
+4 SET VALID=$SELECT(FSTRING[TSTRING:1,1:0)
+5 IF 'VALID
Begin DoDot:1
+6 NEW TEXT
+7 SET TEXT="Function "_FUN_" must be followed by an argument list!"
+8 DO EN^DDIOL(.TEXT)
HANG 2
End DoDot:1
+9 QUIT VALID
+10 ;
+11 ;===========================================
VFINDING(X,DAI) ;Make sure a finding number is a valid member of the
+1 ;definition finding multiple. Input transform for function
+2 ;finding finding number.
+3 ;Do not execute as part of a verify fields.
+4 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT 1
+5 ;Do not execute as part of exchange.
+6 IF $GET(PXRMEXCH)
QUIT 1
+7 IF '$DATA(DAI)
QUIT 1
+8 ;If X is not numeric it is not a finding number.
+9 IF +X'=X
QUIT 0
+10 IF $DATA(^PXD(811.9,DAI,20,X,0))
QUIT 1
+11 IF '$TEST
Begin DoDot:1
+12 NEW TEXT
+13 SET TEXT="Finding number "_X_" does not exist!"
+14 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:1
QUIT 0
+15 ;
+16 ;===========================================
VFSTRING(FFSTRING,DA) ;Make sure a function finding string is valid.
+1 ;The elements can be functions, operators, and numbers.
+2 ;Do not execute as part of a verify fields.
+3 ;I $G(DIUTIL)="VERIFY FIELDS" Q 1
+4 ;Do not execute as part of exchange.
+5 IF $GET(PXRMEXCH)
QUIT 1
+6 IF '$DATA(DA)
QUIT 1
+7 NEW DAI,DATE,FUNIEN,IND,LIST,MFUN,OPERS,PFSTACK,TEMP,TEXT,VALID
+8 SET DAI=DA(1)
+9 SET OPERS=$$GETOPERS
+10 ;Define the allowed M functions.
+11 SET MFUN("$P")=""
+12 DO POSTFIX^PXRMSTAC(FFSTRING,OPERS,.PFSTACK)
+13 SET VALID=1
+14 FOR IND=1:1:PFSTACK(0)
if 'VALID
QUIT
Begin DoDot:1
+15 SET TEMP=PFSTACK(IND)
+16 IF $DATA(^PXRMD(802.4,"B",TEMP))
Begin DoDot:2
+17 SET FUNIEN=$ORDER(^PXRMD(802.4,"B",TEMP,""))
+18 SET IND=IND+1
+19 SET LIST=$GET(PFSTACK(IND))
+20 SET VALID=$$VFFORM(TEMP,LIST,X)
+21 IF 'VALID
QUIT
+22 IF $GET(^PXRMD(802.4,FUNIEN,2))'=""
SET VALID=$$VARGLISTS(LIST,DAI,TEMP,FUNIEN)
+23 IF $GET(^PXRMD(802.4,FUNIEN,3))'=""
SET VALID=$$VARGLISTM(LIST,DAI,TEMP,FUNIEN)
End DoDot:2
QUIT
+24 ;Check for an operator. Unary operators have a "U" appended.
+25 IF OPERS[$PIECE(TEMP,"U",1)
QUIT
+26 ;Check for number
+27 IF TEMP=+TEMP
QUIT
+28 ;Check for allowed M function.
+29 IF $DATA(MFUN(TEMP))
QUIT
+30 ;Check for a global reminder variable
+31 IF $$ISGRV(TEMP)
QUIT
+32 ;Check for a non-executable string.
+33 IF $$ISSTR(TEMP)
QUIT
+34 SET VALID=0
+35 SET TEXT=TEMP_" is not a valid function finding element!"
+36 DO EN^DDIOL(TEXT)
HANG 2
End DoDot:1
+37 IF VALID
Begin DoDot:1
+38 NEW X
+39 SET X="I "_FFSTRING
+40 DO ^DIM
+41 IF $DATA(X)=0
SET VALID=0
End DoDot:1
+42 IF 'VALID
Begin DoDot:1
+43 SET TEMP=FFSTRING_" is not a valid function string!"
+44 DO EN^DDIOL(TEMP)
HANG 2
End DoDot:1
+45 QUIT VALID
+46 ;
