Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXRMCOND

PXRMCOND.m

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