- 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 Jan 18, 2025@02:44:29 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 ;