PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;01/28/2015
;;2.0;CLINICAL REMINDERS;**6,47**;Feb 04, 2005;Build 291
;
;============================================================
CASESEN(X,DA,FILENUM) ;
;Called by xref on condition case sensitive field in 811.5 and 811.9.
N COND,GBL
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
S GBL=GBL_DA(1)_",20,"_DA_",3)"
S COND=$P(@GBL,U,1)
D SICOND(COND,.DA,FILENUM)
Q
;
;============================================================
COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
S CONVAL=""
;If there is no condition return true.
I $L($G(ICOND))=0 Q 1
S NSTAR=0
F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D
. I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
S V=$G(VA("VALUE"))
I 'CASESEN S V=$$UP^XLFSTR(V)
;Move all non "*" elements of VA into V.
I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
I NSTAR=0 X ICOND S CONVAL=$T
I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
Q CONVAL
;
;============================================================
KICOND(X,DA,FILENUM) ;
;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
S FILENUM=$G(FILENUM)
I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
Q
;
;============================================================
MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
;into V and uppercase if necessary.
N IND,NE,RV,RVA,SUB
S NE=$L(VSLIST,";")-1
F IND=1:1:NE D
. S SUB=$P(VSLIST,";",IND)
. I SUB["*" Q
. S RV="V("_SUB_")",RVA="VA("_SUB_")"
.;If VA(SUB) does not exist skip it.
. I '$D(@RVA) Q
. S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
Q
;
;============================================================
RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
;first substitutes V array elements with "*" in subscript with a
;replacement value. Once all have been replaced test condition and
;quit if true. If not true continue until all combinations have been
;tested.
N JND,RV,RVA,VSUB,VASUB
F JND=1:1:NM(IND) Q:CONVAL D
. S VASUB=VM(IND,JND)
. S RVA="VA("_VASUB_")"
. S SUB=$P(VSTAR(IND),U,2)
. S RV="V("_SUB_")"
. S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
. I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
. I IND=NSTAR X ICOND S CONVAL=$T
;If there were no substitutions to make, make sure the condition is
;evaluated.
I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
Q
;
;============================================================
SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
N CONDS
S CONDS=$G(FINDPA(3))
S COND=$P(CONDS,U,1)
;Even if there is no condition UCIFS could be used for status search.
S UCIFS=$P(CONDS,U,3)
I COND="" Q
S CASESEN=$P(CONDS,U,2)
I CASESEN="" S CASESEN=1
S ICOND=FINDPA(10),VSLIST=FINDPA(11)
Q
;
;============================================================
SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
;Called by xref on condition field in 811.5 and 811.9.
I X="" Q
;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 CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
S GBL=GBL_DA(1)_",20,"_DA_",3)"
S CASESEN=$P(@GBL,U,2)
I CASESEN="" S CASESEN=1
;Find each V("sub") entry.
S XUP=$$UP^XLFSTR(X)
I 'CASESEN S (ICOND,X)=XUP
I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
S SS=1,VSLIST=""
F S SS=$F(XUP,"V(",SS) Q:SS=0 D
. S SE=$F(X,")",SS)
. S SUB=$E(X,SS,SE-2)
. I $D(SUBLIST(SUB)) Q
. S SUBLIST(SUB)=""
. S VSLIST=VSLIST_SUB_";"
. S VWSUB="V("_SUB_")"
. S TEMP="$G("_VWSUB_")"
. S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
Q
;
;============================================================
STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
;look for any replacements for the * subscripts that will make the
;Condition true.
N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
N VASUB,VSSUB,VM
;Build a list of the subscripts in VA.
S NVA=0,REF="VA"
F S REF=$Q(@REF) Q:REF="" D
. S SUB=$P(REF,"(",2)
. S SUB=$P(SUB,")",1)
. S SUBL=$L(SUB,",")
. S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
;Build a list of replacements for the * subscripts.
F IND=1:1:NSTAR D
. S NM=0
. S VSSUB=$P(VSTAR(IND),U,2)
. S SUBL=+VSTAR(IND)
. F JND=1:1:NVA D
.. I +VASUB(JND)'=SUBL Q
.. S SUB=$P(VASUB(JND),U,2)
.. S MATCH=1
.. F KND=1:1:SUBL D
... S TEMP=$P(VSSUB,",",KND)
... I TEMP["*" Q
... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
.. I MATCH S NM=NM+1,VM(IND,NM)=SUB
. S NM(IND)=NM
S CONVAL=0
F IND=1:1:NSTAR Q:CONVAL D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
Q CONVAL
;
;============================================================
VCOND(X) ;Input transform for Condition field.
;Do not execute as part of exchange.
I $G(PXRMEXCH) Q 1
;The CONDITION must start with "I ".
S X=$$UP^XLFSTR(X)
I $E(X,1,2)'="I " D Q 0
. S X=""
. D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
;The CONDITION cannot contain "^".
I (X["^")!(X["$C(94)") D Q 0
. S X=""
. D EN^DDIOL("CONDITION cannot contain ""^""")
;The CONDITION cannot contain "@".
I (X["@")!(X["$C(64)") D Q 0
. S X=""
. D EN^DDIOL("CONDITION cannot contain ""@""")
;The rest of the condition can only contain spaces if they are in
;a string.
N COND,TEMP,VALID
S COND=$E(X,3,$L(X))
S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
I VALID D
. D ^DIM
. I '$D(X) D
.. D EN^DDIOL("Not a valid MUMPS string")
.. S VALID=0
Q VALID
;
;============================================================
VSPACE(COND) ;Make sure all spaces in the condition that come after
;the beginning I are inside a quoted string.
N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
S VALID=1
S (LQ,NQP,NSP)=0
F IND=1:1:$L(COND) D
. S CHAR=$E(COND,IND)
. I CHAR="""" D
.. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
.. E S LQ=IND
. I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
S NIQ=0
F IND=1:1:NSP D
. S SPACE=SP(NSP)
. S IQ=0
. F JND=1:1:NQP D
.. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
. S NIQ=$S(IQ:0,1:1)
. I NIQ S IND=NSP Q
I NIQ D
. D EN^DDIOL("No spaces are allowed except in quoted strings!")
. S VALID=0
Q VALID
;
;============================================================
VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
;or quoted * strings.
N IND,RP,SS,SUB,SUBL,VALID
S (SS,VALID)=1
F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D
. S RP=$F(COND,")",SS)-2
. I RP=-2 D Q
.. N TEXT
.. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
.. D EN^DDIOL(TEXT)
.. S VALID=0
. S SUBL=$E(COND,SS,RP)
. F IND=1:1:$L(SUBL,",") D
.. S SUB=$P(SUBL,",",IND)
..;Check for a number.
.. I SUB=+SUB Q
..;Check for a wildcard, must be in quotes any number of * allowed.
.. I SUB?1"""1"*"."*"""" Q
.. ;Check for first and last character = to a ".
.. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
Q VALID
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMCOND 7806 printed Dec 13, 2024@01:43:16 Page 2
PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;01/28/2015
+1 ;;2.0;CLINICAL REMINDERS;**6,47**;Feb 04, 2005;Build 291
+2 ;
+3 ;============================================================
CASESEN(X,DA,FILENUM) ;
+1 ;Called by xref on condition case sensitive field in 811.5 and 811.9.
+2 NEW COND,GBL
+3 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+4 SET GBL=GBL_DA(1)_",20,"_DA_",3)"
+5 SET COND=$PIECE(@GBL,U,1)
+6 DO SICOND(COND,.DA,FILENUM)
+7 QUIT
+8 ;
+9 ;============================================================
COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
+1 NEW CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
+2 SET CONVAL=""
+3 ;If there is no condition return true.
+4 IF $LENGTH($GET(ICOND))=0
QUIT 1
+5 SET NSTAR=0
+6 FOR IND=1:1
SET SUB=$PIECE(VSLIST,";",IND)
if SUB=""
QUIT
Begin DoDot:1
+7 IF SUB["*"
SET NSTAR=NSTAR+1
SET VSTAR(NSTAR)=$LENGTH(SUB,",")_U_SUB
End DoDot:1
+8 SET V=$GET(VA("VALUE"))
+9 IF 'CASESEN
SET V=$$UP^XLFSTR(V)
+10 ;Move all non "*" elements of VA into V.
+11 IF VSLIST'=""
DO MV(VSLIST,CASESEN,.V,.VA)
+12 IF NSTAR=0
XECUTE ICOND
SET CONVAL=$TEST
+13 IF NSTAR>0
SET CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
+14 QUIT CONVAL
+15 ;
+16 ;============================================================
KICOND(X,DA,FILENUM) ;
+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 SET FILENUM=$GET(FILENUM)
+6 IF FILENUM=811.5
KILL ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
+7 IF FILENUM=811.9
KILL ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
+8 QUIT
+9 ;
+10 ;============================================================
MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
+1 ;into V and uppercase if necessary.
+2 NEW IND,NE,RV,RVA,SUB
+3 SET NE=$LENGTH(VSLIST,";")-1
+4 FOR IND=1:1:NE
Begin DoDot:1
+5 SET SUB=$PIECE(VSLIST,";",IND)
+6 IF SUB["*"
QUIT
+7 SET RV="V("_SUB_")"
SET RVA="VA("_SUB_")"
+8 ;If VA(SUB) does not exist skip it.
+9 IF '$DATA(@RVA)
QUIT
+10 SET @RV=$SELECT('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
End DoDot:1
+11 QUIT
+12 ;
+13 ;============================================================
RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
+1 ;first substitutes V array elements with "*" in subscript with a
+2 ;replacement value. Once all have been replaced test condition and
+3 ;quit if true. If not true continue until all combinations have been
+4 ;tested.
+5 NEW JND,RV,RVA,VSUB,VASUB
+6 FOR JND=1:1:NM(IND)
if CONVAL
QUIT
Begin DoDot:1
+7 SET VASUB=VM(IND,JND)
+8 SET RVA="VA("_VASUB_")"
+9 SET SUB=$PIECE(VSTAR(IND),U,2)
+10 SET RV="V("_SUB_")"
+11 SET @RV=$SELECT('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
+12 IF IND<NSTAR
DO RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
+13 IF IND=NSTAR
XECUTE ICOND
SET CONVAL=$TEST
End DoDot:1
+14 ;If there were no substitutions to make, make sure the condition is
+15 ;evaluated.
+16 IF 'CONVAL
IF IND=NSTAR
IF NM(IND)=0
XECUTE ICOND
SET CONVAL=$TEST
+17 QUIT
+18 ;
+19 ;============================================================
SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
+1 NEW CONDS
+2 SET CONDS=$GET(FINDPA(3))
+3 SET COND=$PIECE(CONDS,U,1)
+4 ;Even if there is no condition UCIFS could be used for status search.
+5 SET UCIFS=$PIECE(CONDS,U,3)
+6 IF COND=""
QUIT
+7 SET CASESEN=$PIECE(CONDS,U,2)
+8 IF CASESEN=""
SET CASESEN=1
+9 SET ICOND=FINDPA(10)
SET VSLIST=FINDPA(11)
+10 QUIT
+11 ;
+12 ;============================================================
SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
+1 ;Called by xref on condition field in 811.5 and 811.9.
+2 IF X=""
QUIT
+3 ;Do not execute as part of a verify fields.
+4 IF $GET(DIUTIL)="VERIFY FIELDS"
QUIT
+5 ;Do not execute as part of exchange.
+6 IF $GET(PXRMEXCH)
QUIT
+7 NEW CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
+8 SET GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
+9 SET GBL=GBL_DA(1)_",20,"_DA_",3)"
+10 SET CASESEN=$PIECE(@GBL,U,2)
+11 IF CASESEN=""
SET CASESEN=1
+12 ;Find each V("sub") entry.
+13 SET XUP=$$UP^XLFSTR(X)
+14 IF 'CASESEN
SET (ICOND,X)=XUP
+15 IF CASESEN
SET ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
+16 SET SS=1
SET VSLIST=""
+17 FOR
SET SS=$FIND(XUP,"V(",SS)
if SS=0
QUIT
Begin DoDot:1
+18 SET SE=$FIND(X,")",SS)
+19 SET SUB=$EXTRACT(X,SS,SE-2)
+20 IF $DATA(SUBLIST(SUB))
QUIT
+21 SET SUBLIST(SUB)=""
+22 SET VSLIST=VSLIST_SUB_";"
+23 SET VWSUB="V("_SUB_")"
+24 SET TEMP="$G("_VWSUB_")"
+25 SET ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
End DoDot:1
+26 IF FILENUM=811.5
SET ^PXRMD(811.5,DA(1),20,DA,10)=ICOND
SET ^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
+27 IF FILENUM=811.9
SET ^PXD(811.9,DA(1),20,DA,10)=ICOND
SET ^PXD(811.9,DA(1),20,DA,11)=VSLIST
+28 QUIT
+29 ;
+30 ;============================================================
STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
+1 ;look for any replacements for the * subscripts that will make the
+2 ;Condition true.
+3 NEW CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
+4 NEW VASUB,VSSUB,VM
+5 ;Build a list of the subscripts in VA.
+6 SET NVA=0
SET REF="VA"
+7 FOR
SET REF=$QUERY(@REF)
if REF=""
QUIT
Begin DoDot:1
+8 SET SUB=$PIECE(REF,"(",2)
+9 SET SUB=$PIECE(SUB,")",1)
+10 SET SUBL=$LENGTH(SUB,",")
+11 SET NVA=NVA+1
SET VASUB(NVA)=SUBL_U_SUB
End DoDot:1
+12 ;Build a list of replacements for the * subscripts.
+13 FOR IND=1:1:NSTAR
Begin DoDot:1
+14 SET NM=0
+15 SET VSSUB=$PIECE(VSTAR(IND),U,2)
+16 SET SUBL=+VSTAR(IND)
+17 FOR JND=1:1:NVA
Begin DoDot:2
+18 IF +VASUB(JND)'=SUBL
QUIT
+19 SET SUB=$PIECE(VASUB(JND),U,2)
+20 SET MATCH=1
+21 FOR KND=1:1:SUBL
Begin DoDot:3
+22 SET TEMP=$PIECE(VSSUB,",",KND)
+23 IF TEMP["*"
QUIT
+24 IF $PIECE(SUB,",",KND)'=TEMP
SET MATCH=0
SET KND=SUBL
End DoDot:3
+25 IF MATCH
SET NM=NM+1
SET VM(IND,NM)=SUB
End DoDot:2
+26 SET NM(IND)=NM
End DoDot:1
+27 SET CONVAL=0
+28 FOR IND=1:1:NSTAR
if CONVAL
QUIT
DO RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
+29 QUIT CONVAL
+30 ;
+31 ;============================================================
VCOND(X) ;Input transform for Condition field.
+1 ;Do not execute as part of exchange.
+2 IF $GET(PXRMEXCH)
QUIT 1
+3 ;The CONDITION must start with "I ".
+4 SET X=$$UP^XLFSTR(X)
+5 IF $EXTRACT(X,1,2)'="I "
Begin DoDot:1
+6 SET X=""
+7 DO EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
End DoDot:1
QUIT 0
+8 ;The CONDITION cannot contain "^".
+9 IF (X["^")!(X["$C(94)")
Begin DoDot:1
+10 SET X=""
+11 DO EN^DDIOL("CONDITION cannot contain ""^""")
End DoDot:1
QUIT 0
+12 ;The CONDITION cannot contain "@".
+13 IF (X["@")!(X["$C(64)")
Begin DoDot:1
+14 SET X=""
+15 DO EN^DDIOL("CONDITION cannot contain ""@""")
End DoDot:1
QUIT 0
+16 ;The rest of the condition can only contain spaces if they are in
+17 ;a string.
+18 NEW COND,TEMP,VALID
+19 SET COND=$EXTRACT(X,3,$LENGTH(X))
+20 SET VALID=$SELECT(COND[" ":$$VSPACE(COND),1:1)
+21 IF VALID
SET VALID=$SELECT(COND["V(":$$VSUB(COND),1:1)
+22 IF VALID
Begin DoDot:1
+23 DO ^DIM
+24 IF '$DATA(X)
Begin DoDot:2
+25 DO EN^DDIOL("Not a valid MUMPS string")
+26 SET VALID=0
End DoDot:2
End DoDot:1
+27 QUIT VALID
+28 ;
+29 ;============================================================
VSPACE(COND) ;Make sure all spaces in the condition that come after
+1 ;the beginning I are inside a quoted string.
+2 NEW CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
+3 SET VALID=1
+4 SET (LQ,NQP,NSP)=0
+5 FOR IND=1:1:$LENGTH(COND)
Begin DoDot:1
+6 SET CHAR=$EXTRACT(COND,IND)
+7 IF CHAR=""""
Begin DoDot:2
+8 IF LQ
SET NQP=NQP+1
SET QP(NQP)=LQ_U_IND
SET LQ=0
+9 IF '$TEST
SET LQ=IND
End DoDot:2
+10 IF CHAR=" "
SET NSP=NSP+1
SET SP(NSP)=IND
End DoDot:1
+11 SET NIQ=0
+12 FOR IND=1:1:NSP
Begin DoDot:1
+13 SET SPACE=SP(NSP)
+14 SET IQ=0
+15 FOR JND=1:1:NQP
Begin DoDot:2
+16 IF SPACE>$PIECE(QP(JND),U,1)
IF SPACE<$PIECE(QP(JND),U,2)
SET IQ=1
SET JND=NQP
QUIT
End DoDot:2
+17 SET NIQ=$SELECT(IQ:0,1:1)
+18 IF NIQ
SET IND=NSP
QUIT
End DoDot:1
+19 IF NIQ
Begin DoDot:1
+20 DO EN^DDIOL("No spaces are allowed except in quoted strings!")
+21 SET VALID=0
End DoDot:1
+22 QUIT VALID
+23 ;
+24 ;============================================================
VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
+1 ;or quoted * strings.
+2 NEW IND,RP,SS,SUB,SUBL,VALID
+3 SET (SS,VALID)=1
+4 FOR
SET SS=$FIND(COND,"V(",SS)
if ('VALID)!(SS=0)
QUIT
Begin DoDot:1
+5 SET RP=$FIND(COND,")",SS)-2
+6 IF RP=-2
Begin DoDot:2
+7 NEW TEXT
+8 SET TEXT=$EXTRACT(COND,SS-2,$LENGTH(COND))_" is missing a "")"""
+9 DO EN^DDIOL(TEXT)
+10 SET VALID=0
End DoDot:2
QUIT
+11 SET SUBL=$EXTRACT(COND,SS,RP)
+12 FOR IND=1:1:$LENGTH(SUBL,",")
Begin DoDot:2
+13 SET SUB=$PIECE(SUBL,",",IND)
+14 ;Check for a number.
+15 IF SUB=+SUB
QUIT
+16 ;Check for a wildcard, must be in quotes any number of * allowed.
+17 IF SUB?1"""1"*"."*""""
QUIT
+18 ;Check for first and last character = to a ".
+19 IF ($EXTRACT(SUB,1)'="""")!($EXTRACT(SUB,$LENGTH(SUB))'="""")
SET VALID=0
End DoDot:2
End DoDot:1
+20 IF 'VALID
DO EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
+21 QUIT VALID
+22 ;
