PXRMFFDB.m

PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;22-Jul-2015 04:23;du

 ;;2.0;CLINICAL REMINDERS;**4,6,12,18,26,1005**;Feb 04, 2005;Build 23

 ;

 ;===========================================

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

 ;Remove call to non-existent routine Patch 1005

 ;D QFIX^PXRMSTAC(X,OPERS,.PFSTACK)

 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,TO,VALID

 S EXPR=$P(VAR,",",1)

 S VALID=$S(EXPR="PXRMAGE":1,EXPR="PXRMDOB":1,EXPR="PXRMLAD":1,EXPR="PXRMSEX":1,1:0)

 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

 ;

 ;===========================================

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)

 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)

 ;

 ;===========================================

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=$$VALISTS(LIST,DAI,TEMP,FUNIEN)

 .. I $G(^PXRMD(802.4,FUNIEN,3))'="" S VALID=$$VALISTM(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)

 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)

 Q VALID

 ;

 ;===========================================

VALISTS(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list

 ;s valid. This check is for functions where a single pattern can

 ;be used.

 N AT,IND,LEN,PATTERN,VALID,X

 S LEN=$L(LIST,",")

 I LEN=0 D  Q 0

 . N TEXT

 . S TEXT="The argument list is not defined!"

 . D EN^DDIOL(TEXT)

 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)

 F IND=1:1:LEN D

 . S X=$P(LIST,",",IND)

 . S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)

 . I AT="U" S VALID=0 Q

 . I AT="F",'$$VFINDING(X,DAI) S VALID=0

 Q VALID

 ;

 ;===========================================

VALISTM(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,IND,LEN,NL,PAT,PATTERNS,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)

 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)

 S NL=0,VALID=1

 F IND=1:1:LEN D

 . S ARG=$P(LIST,",",IND)

 . S PAT=$P(PATTERNS,"~",IND)

 . S VARG=ARG?@PAT

 . 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",'$$VFINDING(ARG,DAI) S VARG=0

 I 'VALID D EN^DDIOL(.TEXT)

 Q VALID

 ;

PXRMFFDB  ;SLC/PKR - Function finding data structure builder. ;22-Jul-2015 04:23;du

 +1       ;;2.0;CLINICAL REMINDERS;**4,6,12,18,26,1005**;Feb 04, 2005;Build 23

 +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      ;Remove call to non-existent routine Patch 1005

 +13      ;D QFIX^PXRMSTAC(X,OPERS,.PFSTACK)

 +14       DO POSTFIX^PXRMSTAC(X,OPERS,.PFSTACK)

 +15       SET (FUNNUM,L2)=0

 +16       FOR IND=1:1:PFSTACK(0)

               Begin DoDot:1

 +17               SET TEMP=PFSTACK(IND)

 +18               IF $DATA(^PXRMD(802.4,"B",TEMP))

                       Begin DoDot:2

 +19                       SET FUNP=$ORDER(^PXRMD(802.4,"B",TEMP,""))

 +20                       SET FUNNUM=FUNNUM+1

                           SET L2=L2+1

 +21                       SET IENS="+"_L2_","_IENB

 +22                       SET FDA(811.9255,IENS,.01)=FUNNUM

 +23                       SET FDA(811.9255,IENS,.02)=FUNP

 +24                       SET IND=IND+1

 +25                       SET LIST=$TRANSLATE(PFSTACK(IND),"~"," ")

 +26                       SET REPL(FUNNUM)=TEMP_"("_LIST_")"_U_"FN("_FUNNUM_")"

 +27                       SET L3=L2

 +28                       SET LEN=$LENGTH(LIST,",")

 +29                       FOR JND=1:1:LEN

                               Begin DoDot:3

 +30                               SET L3=L3+1

 +31                               SET IENS="+"_L3_",+"_L2_","_IENB

 +32                               SET TS=$PIECE(LIST,",",JND)

 +33                               SET TS=$TRANSLATE(TS,"""","")

 +34                               SET FDA(811.9256,IENS,.01)=TS

                               End DoDot:3

 +35                       SET L2=L3

                       End DoDot:2

               End DoDot:1

 +36      ;Build the logic string

 +37       SET LOGIC=X

 +38       FOR IND=1:1:FUNNUM

               Begin DoDot:1

 +39               SET TS=$PIECE(REPL(IND),U,1)

 +40               SET RS=$PIECE(REPL(IND),U,2)

 +41               SET LOGIC=$$STRREP^PXRMUTIL(LOGIC,TS,RS)

               End DoDot:1

 +42       SET FDA(811.925,IENB,10)=LOGIC

 +43       DO UPDATE^DIE("","FDA","IENB","MSG")

 +44       IF $DATA(MSG)

               Begin DoDot:1

 +45               WRITE !,"The update failed, UPDATE^DIE returned the following error message:"

 +46               DO AWRITE^PXRMUTIL("MSG")

               End DoDot:1

 +47       QUIT 

 +48      ;

 +49      ;===========================================

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,TO,VALID

 +3        SET EXPR=$PIECE(VAR,",",1)

 +4        SET VALID=$SELECT(EXPR="PXRMAGE":1,EXPR="PXRMDOB":1,EXPR="PXRMLAD":1,EXPR="PXRMSEX":1,1:0)

 +5        IF 'VALID

               QUIT 0

 +6        SET DELIM=$PIECE(VAR,",",2)

 +7        SET VALID=$SELECT(DELIM="":1,1:$$ISSTR(DELIM))

 +8        IF 'VALID

               QUIT 0

 +9        SET FROM=$PIECE(VAR,",",3)

 +10       SET VALID=$SELECT(FROM="":1,FROM=+FROM:1,1:0)

 +11       IF 'VALID

               QUIT 0

 +12       SET TO=$PIECE(VAR,",",4)

 +13       SET VALID=$SELECT(TO="":1,TO=+TO:1,1:0)

 +14       QUIT VALID

 +15      ;

 +16      ;===========================================

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      ;===========================================

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)

               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)

               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=$$VALISTS(LIST,DAI,TEMP,FUNIEN)

 +23                       IF $GET(^PXRMD(802.4,FUNIEN,3))'=""

                               SET VALID=$$VALISTM(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)

               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)

               End DoDot:1

 +45       QUIT VALID

 +46      ;

 +47      ;===========================================

VALISTS(LIST,DAI,FUNCTION,FUNIEN) ;Make sure the function argument list

 +1       ;s valid. This check is for functions where a single pattern can

 +2       ;be used.

 +3        NEW AT,IND,LEN,PATTERN,VALID,X

 +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)

               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)

               End DoDot:1

               QUIT 0

 +15       FOR IND=1:1:LEN

               Begin DoDot:1

 +16               SET X=$PIECE(LIST,",",IND)

 +17               SET AT=$$ARGTYPE^PXRMFFAT(FUNCTION,IND)

 +18               IF AT="U"

                       SET VALID=0

                       QUIT 

 +19               IF AT="F"

                       IF '$$VFINDING(X,DAI)

                           SET VALID=0

               End DoDot:1

 +20       QUIT VALID

 +21      ;

 +22      ;===========================================

VALISTM(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,IND,LEN,NL,PAT,PATTERNS,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)

               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)

               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 PAT=$PIECE(PATTERNS,"~",IND)

 +19               SET VARG=ARG?@PAT

 +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"

                       IF '$$VFINDING(ARG,DAI)

                           SET VARG=0

               End DoDot:1

 +25       IF 'VALID

               DO EN^DDIOL(.TEXT)

 +26       QUIT VALID

 +27      ;