| [613] | 1 | PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
|
|---|
| 2 | ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
|
|---|
| 3 | ;
|
|---|
| 4 | ;============================================================
|
|---|
| 5 | CASESEN(X,DA,FILENUM) ;
|
|---|
| 6 | ;Called by xref on condition case sensitive field in 811.5 and 811.9.
|
|---|
| 7 | N COND,GBL
|
|---|
| 8 | S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
|---|
| 9 | S GBL=GBL_DA(1)_",20,"_DA_",3)"
|
|---|
| 10 | S COND=$P(@GBL,U,1)
|
|---|
| 11 | D SICOND(COND,.DA,FILENUM)
|
|---|
| 12 | Q
|
|---|
| 13 | ;
|
|---|
| 14 | ;============================================================
|
|---|
| 15 | COND(CASESEN,ICOND,VSLIST,VA) ;Evaluate the condition.
|
|---|
| 16 | N CONVAL,IND,JND,NSTAR,SUB,TEMP,V,VSTAR
|
|---|
| 17 | S CONVAL=""
|
|---|
| 18 | ;If there is no condition return true.
|
|---|
| 19 | I $L($G(ICOND))=0 Q 1
|
|---|
| 20 | S NSTAR=0
|
|---|
| 21 | F IND=1:1 S SUB=$P(VSLIST,";",IND) Q:SUB="" D
|
|---|
| 22 | . I SUB["*" S NSTAR=NSTAR+1,VSTAR(NSTAR)=$L(SUB,",")_U_SUB
|
|---|
| 23 | S V=$G(VA("VALUE"))
|
|---|
| 24 | I 'CASESEN S V=$$UP^XLFSTR(V)
|
|---|
| 25 | ;Move all non "*" elements of VA into V.
|
|---|
| 26 | I VSLIST'="" D MV(VSLIST,CASESEN,.V,.VA)
|
|---|
| 27 | I NSTAR=0 X ICOND S CONVAL=$T
|
|---|
| 28 | I NSTAR>0 S CONVAL=$$STARCOND(CASESEN,ICOND,.V,.VA,NSTAR,.VSTAR)
|
|---|
| 29 | Q CONVAL
|
|---|
| 30 | ;
|
|---|
| 31 | ;============================================================
|
|---|
| 32 | KICOND(X,DA,FILENUM) ;
|
|---|
| 33 | ;Do not execute as part of a verify fields.
|
|---|
| 34 | I $G(DIUTIL)="VERIFY FIELDS" Q
|
|---|
| 35 | ;Do not execute as part of exchange.
|
|---|
| 36 | I $G(PXRMEXCH) Q
|
|---|
| 37 | S FILENUM=$G(FILENUM)
|
|---|
| 38 | I FILENUM=811.5 K ^PXRMD(811.5,DA(1),20,DA,10),^PXRMD(811.5,DA(1),20,DA,11)
|
|---|
| 39 | I FILENUM=811.9 K ^PXD(811.9,DA(1),20,DA,10),^PXD(811.9,DA(1),20,DA,11)
|
|---|
| 40 | Q
|
|---|
| 41 | ;
|
|---|
| 42 | ;============================================================
|
|---|
| 43 | MV(VSLIST,CASESEN,V,VA) ;Move the elements of VA included in VSLIST
|
|---|
| 44 | ;into V and uppercase if necessary.
|
|---|
| 45 | N IND,NE,RV,RVA,SUB
|
|---|
| 46 | S NE=$L(VSLIST,";")-1
|
|---|
| 47 | F IND=1:1:NE D
|
|---|
| 48 | . S SUB=$P(VSLIST,";",IND)
|
|---|
| 49 | . I SUB["*" Q
|
|---|
| 50 | . S RV="V("_SUB_")",RVA="VA("_SUB_")"
|
|---|
| 51 | .;If VA(SUB) does not exist skip it.
|
|---|
| 52 | . I '$D(@RVA) Q
|
|---|
| 53 | . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
|
|---|
| 54 | Q
|
|---|
| 55 | ;
|
|---|
| 56 | ;============================================================
|
|---|
| 57 | RECSUB(IND,V,VA,NSTAR,VSTAR,NM,VM,CASESEN,ICOND,CONVAL) ;Called recursively,
|
|---|
| 58 | ;first substitutes V array elements with "*" in subscript with a
|
|---|
| 59 | ;replacement value. Once all have been replaced test condition and
|
|---|
| 60 | ;quit if true. If not true continue until all combinations have been
|
|---|
| 61 | ;tested.
|
|---|
| 62 | N JND,RV,RVA,VSUB,VASUB
|
|---|
| 63 | F JND=1:1:NM(IND) Q:CONVAL D
|
|---|
| 64 | . S VASUB=VM(IND,JND)
|
|---|
| 65 | . S RVA="VA("_VASUB_")"
|
|---|
| 66 | . S SUB=$P(VSTAR(IND),U,2)
|
|---|
| 67 | . S RV="V("_SUB_")"
|
|---|
| 68 | . S @RV=$S('CASESEN:$$UP^XLFSTR(@RVA),1:@RVA)
|
|---|
| 69 | . I IND<NSTAR D RECSUB(IND+1,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
|
|---|
| 70 | . I IND=NSTAR X ICOND S CONVAL=$T
|
|---|
| 71 | ;If there were no substitutions to make, make sure the condition is
|
|---|
| 72 | ;evaluated.
|
|---|
| 73 | I 'CONVAL,IND=NSTAR,NM(IND)=0 X ICOND S CONVAL=$T
|
|---|
| 74 | Q
|
|---|
| 75 | ;
|
|---|
| 76 | ;============================================================
|
|---|
| 77 | SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
|
|---|
| 78 | N CONDS
|
|---|
| 79 | S CONDS=$G(FINDPA(3))
|
|---|
| 80 | S COND=$P(CONDS,U,1)
|
|---|
| 81 | ;Even if there is no condition UCIFS could be used for status search.
|
|---|
| 82 | S UCIFS=$P(CONDS,U,3)
|
|---|
| 83 | I COND="" Q
|
|---|
| 84 | S CASESEN=$P(CONDS,U,2)
|
|---|
| 85 | I CASESEN="" S CASESEN=1
|
|---|
| 86 | S ICOND=FINDPA(10),VSLIST=FINDPA(11)
|
|---|
| 87 | Q
|
|---|
| 88 | ;
|
|---|
| 89 | ;============================================================
|
|---|
| 90 | SICOND(X,DA,FILENUM) ;Set the internal condition field. Wrap all V() in $G.
|
|---|
| 91 | ;Called by xref on condition field in 811.5 and 811.9.
|
|---|
| 92 | I X="" Q
|
|---|
| 93 | ;Do not execute as part of a verify fields.
|
|---|
| 94 | I $G(DIUTIL)="VERIFY FIELDS" Q
|
|---|
| 95 | ;Do not execute as part of exchange.
|
|---|
| 96 | I $G(PXRMEXCH) Q
|
|---|
| 97 | N CASESEN,GBL,ICOND,IND,SE,SS,SUB,SUBLIST,TEMP,VSLIST,VWSUB,XUP
|
|---|
| 98 | S GBL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
|
|---|
| 99 | S GBL=GBL_DA(1)_",20,"_DA_",3)"
|
|---|
| 100 | S CASESEN=$P(@GBL,U,2)
|
|---|
| 101 | I CASESEN="" S CASESEN=1
|
|---|
| 102 | ;Find each V("sub") entry.
|
|---|
| 103 | S XUP=$$UP^XLFSTR(X)
|
|---|
| 104 | I 'CASESEN S (ICOND,X)=XUP
|
|---|
| 105 | I CASESEN S ICOND=$$STRREP^PXRMUTIL(X,"v(","V(")
|
|---|
| 106 | S SS=1,VSLIST=""
|
|---|
| 107 | F S SS=$F(XUP,"V(",SS) Q:SS=0 D
|
|---|
| 108 | . S SE=$F(X,")",SS)
|
|---|
| 109 | . S SUB=$E(X,SS,SE-2)
|
|---|
| 110 | . I $D(SUBLIST(SUB)) Q
|
|---|
| 111 | . S SUBLIST(SUB)=""
|
|---|
| 112 | . S VSLIST=VSLIST_SUB_";"
|
|---|
| 113 | . S VWSUB="V("_SUB_")"
|
|---|
| 114 | . S TEMP="$G("_VWSUB_")"
|
|---|
| 115 | . S ICOND=$$STRREP^PXRMUTIL(ICOND,VWSUB,TEMP)
|
|---|
| 116 | I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,DA,10)=ICOND,^PXRMD(811.5,DA(1),20,DA,11)=VSLIST
|
|---|
| 117 | I FILENUM=811.9 S ^PXD(811.9,DA(1),20,DA,10)=ICOND,^PXD(811.9,DA(1),20,DA,11)=VSLIST
|
|---|
| 118 | Q
|
|---|
| 119 | ;
|
|---|
| 120 | ;============================================================
|
|---|
| 121 | STARCOND(CASESEN,ICOND,V,VA,NSTAR,VSTAR) ;Execute a star condition,
|
|---|
| 122 | ;look for any replacements for the * subscripts that will make the
|
|---|
| 123 | ;Condition true.
|
|---|
| 124 | N CONVAL,IND,JND,KND,MATCH,NEWV,NM,NVA,ORV,REF,SUB,SUBL,TCOND,TEMP
|
|---|
| 125 | N VASUB,VSSUB,VM
|
|---|
| 126 | ;Build a list of the subscripts in VA.
|
|---|
| 127 | S NVA=0,REF="VA"
|
|---|
| 128 | F S REF=$Q(@REF) Q:REF="" D
|
|---|
| 129 | . S SUB=$P(REF,"(",2)
|
|---|
| 130 | . S SUB=$P(SUB,")",1)
|
|---|
| 131 | . S SUBL=$L(SUB,",")
|
|---|
| 132 | . S NVA=NVA+1,VASUB(NVA)=SUBL_U_SUB
|
|---|
| 133 | ;Build a list of replacements for the * subscripts.
|
|---|
| 134 | F IND=1:1:NSTAR D
|
|---|
| 135 | . S NM=0
|
|---|
| 136 | . S VSSUB=$P(VSTAR(IND),U,2)
|
|---|
| 137 | . S SUBL=+VSTAR(IND)
|
|---|
| 138 | . F JND=1:1:NVA D
|
|---|
| 139 | .. I +VASUB(JND)'=SUBL Q
|
|---|
| 140 | .. S SUB=$P(VASUB(JND),U,2)
|
|---|
| 141 | .. S MATCH=1
|
|---|
| 142 | .. F KND=1:1:SUBL D
|
|---|
| 143 | ... S TEMP=$P(VSSUB,",",KND)
|
|---|
| 144 | ... I TEMP["*" Q
|
|---|
| 145 | ... I $P(SUB,",",KND)'=TEMP S MATCH=0,KND=SUBL
|
|---|
| 146 | .. I MATCH S NM=NM+1,VM(IND,NM)=SUB
|
|---|
| 147 | . S NM(IND)=NM
|
|---|
| 148 | S CONVAL=0
|
|---|
| 149 | F IND=1:1:NSTAR Q:CONVAL D RECSUB(IND,.V,.VA,NSTAR,.VSTAR,.NM,.VM,CASESEN,ICOND,.CONVAL)
|
|---|
| 150 | Q CONVAL
|
|---|
| 151 | ;
|
|---|
| 152 | ;============================================================
|
|---|
| 153 | VCOND(X) ;
|
|---|
| 154 | ;Input transform on Condition field.
|
|---|
| 155 | ;Do not execute as part of exchange.
|
|---|
| 156 | I $G(PXRMEXCH) Q 1
|
|---|
| 157 | ;The CONDITION must start with "I ".
|
|---|
| 158 | S X=$$UP^XLFSTR(X)
|
|---|
| 159 | I $E(X,1,2)'="I " D Q 0
|
|---|
| 160 | . S X=""
|
|---|
| 161 | . D EN^DDIOL("CONDITION must start with ""I"" followed by a single space")
|
|---|
| 162 | ;The CONDITION cannot contain "^".
|
|---|
| 163 | I X["^" D Q 0
|
|---|
| 164 | . S X=""
|
|---|
| 165 | . D EN^DDIOL("CONDITION cannot contain ""^""")
|
|---|
| 166 | ;The CONDITION cannot contain "@".
|
|---|
| 167 | I X["@" D Q 0
|
|---|
| 168 | . S X=""
|
|---|
| 169 | . D EN^DDIOL("CONDITION cannot contain ""@""")
|
|---|
| 170 | ;The rest of the condition can only contain spaces if they are in
|
|---|
| 171 | ;a string.
|
|---|
| 172 | N COND,TEMP,VALID
|
|---|
| 173 | S COND=$E(X,3,$L(X))
|
|---|
| 174 | S VALID=$S(COND[" ":$$VSPACE(COND),1:1)
|
|---|
| 175 | I VALID S VALID=$S(COND["V(":$$VSUB(COND),1:1)
|
|---|
| 176 | I VALID D
|
|---|
| 177 | . D ^DIM
|
|---|
| 178 | . I '$D(X) D
|
|---|
| 179 | .. D EN^DDIOL("Not a valid MUMPS string")
|
|---|
| 180 | .. S VALID=0
|
|---|
| 181 | Q VALID
|
|---|
| 182 | ;
|
|---|
| 183 | ;============================================================
|
|---|
| 184 | VSPACE(COND) ;Make sure all spaces in the condition that come after
|
|---|
| 185 | ;the beginning I are inside a quoted string.
|
|---|
| 186 | N CHAR,IND,IQ,JND,LQ,NIQ,NQP,NSP,QP,SP,SPACE,VALID
|
|---|
| 187 | S VALID=1
|
|---|
| 188 | S (LQ,NQP,NSP)=0
|
|---|
| 189 | F IND=1:1:$L(COND) D
|
|---|
| 190 | . S CHAR=$E(COND,IND)
|
|---|
| 191 | . I CHAR="""" D
|
|---|
| 192 | .. I LQ S NQP=NQP+1,QP(NQP)=LQ_U_IND,LQ=0
|
|---|
| 193 | .. E S LQ=IND
|
|---|
| 194 | . I CHAR=" " S NSP=NSP+1,SP(NSP)=IND
|
|---|
| 195 | S NIQ=0
|
|---|
| 196 | F IND=1:1:NSP D
|
|---|
| 197 | . S SPACE=SP(NSP)
|
|---|
| 198 | . S IQ=0
|
|---|
| 199 | . F JND=1:1:NQP D
|
|---|
| 200 | .. I SPACE>$P(QP(JND),U,1),SPACE<$P(QP(JND),U,2) S IQ=1,JND=NQP Q
|
|---|
| 201 | . S NIQ=$S(IQ:0,1:1)
|
|---|
| 202 | . I NIQ S IND=NSP Q
|
|---|
| 203 | I NIQ D
|
|---|
| 204 | . D EN^DDIOL("No spaces are allowed except in quoted strings!")
|
|---|
| 205 | . S VALID=0
|
|---|
| 206 | Q VALID
|
|---|
| 207 | ;
|
|---|
| 208 | ;============================================================
|
|---|
| 209 | VSUB(COND) ;Make sure all V subscripts are quoted strings, numbers
|
|---|
| 210 | ;or quoted * strings.
|
|---|
| 211 | N IND,RP,SS,SUB,SUBL,VALID
|
|---|
| 212 | S (SS,VALID)=1
|
|---|
| 213 | F S SS=$F(COND,"V(",SS) Q:('VALID)!(SS=0) D
|
|---|
| 214 | . S RP=$F(COND,")",SS)-2
|
|---|
| 215 | . I RP=-2 D Q
|
|---|
| 216 | .. N TEXT
|
|---|
| 217 | .. S TEXT=$E(COND,SS-2,$L(COND))_" is missing a "")"""
|
|---|
| 218 | .. D EN^DDIOL(TEXT)
|
|---|
| 219 | .. S VALID=0
|
|---|
| 220 | . S SUBL=$E(COND,SS,RP)
|
|---|
| 221 | . F IND=1:1:$L(SUBL,",") D
|
|---|
| 222 | .. S SUB=$P(SUBL,",",IND)
|
|---|
| 223 | ..;Check for a number.
|
|---|
| 224 | .. I SUB=+SUB Q
|
|---|
| 225 | ..;Check for a wildcard, must be in quotes any number of * allowed.
|
|---|
| 226 | .. I SUB?1"""1"*"."*"""" Q
|
|---|
| 227 | .. ;Check for first and last character = to a ".
|
|---|
| 228 | .. I ($E(SUB,1)'="""")!($E(SUB,$L(SUB))'="""") S VALID=0
|
|---|
| 229 | I 'VALID D EN^DDIOL("All V subscripts must be quoted strings, numbers or *!")
|
|---|
| 230 | Q VALID
|
|---|
| 231 | ;
|
|---|
