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

PXRMFF.m

Go to the documentation of this file. 
  1. PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;03/12/2013
  1.  ;;2.0;CLINICAL REMINDERS;**4,6,11,18,22,24,26**;Feb 04, 2005;Build 404
  1.  ;===========================================
  1. EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
  1.  N ARGLIST,FFIND,FFN,FN,FUN,FUNIND,FUNN,FVALUE,JND
  1.  N LOGIC,LOGVAL,NL,ROUTINE,TEMP
  1.  I '$D(DEFARR(25)) Q
  1.  S FFN="FF"
  1.  F  S FFN=$O(DEFARR(25,FFN)) Q:FFN'["FF"  D
  1.  . K FN
  1.  . S FUNIND=0
  1.  . F  S FUNIND=+$O(DEFARR(25,FFN,5,FUNIND)) Q:FUNIND=0  D
  1.  .. S FUNN=$P(DEFARR(25,FFN,5,FUNIND,0),U,1)
  1.  .. S FUN=$P(DEFARR(25,FFN,5,FUNIND,0),U,2)
  1.  .. S TEMP=^PXRMD(802.4,FUN,0)
  1.  .. S ROUTINE=$P(TEMP,U,2,3)_"(.ARGLIST,.FIEVAL,.FVALUE)"
  1.  .. K ARGLIST
  1.  .. S (JND,NL)=0
  1.  .. F  S JND=+$O(DEFARR(25,FFN,5,FUNIND,20,JND)) Q:JND=0  D
  1.  ... S NL=NL+1
  1.  ... S ARGLIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0)
  1.  .. S ARGLIST(0)=NL
  1.  .. D @ROUTINE
  1.  .. S FN(FUNIND)=FVALUE
  1.  . S LOGIC=$G(DEFARR(25,FFN,10))
  1.  . S LOGIC=$S(LOGIC'="":LOGIC,1:0)
  1.  . S LOGVAL=$$EVALLOG(LOGIC,.FN)
  1.  . S FIEVAL(FFN)=LOGVAL
  1.  . S FIEVAL(FFN,"NUMBER")=$P(FFN,"FF",2)
  1.  . S FIEVAL(FFN,"FINDING")=$G(FUN)_";PXRMD(802.4,"
  1.  . I $G(PXRMDEBG) D
  1.  .. S ^TMP(PXRMPID,$J,"FFDEB",FFN,"DETAIL")=FIEVAL(FFN)_U_DEFARR(25,FFN,3)_U_$$NLOGIC(LOGIC,.FN)
  1.  .. I $G(PXRMFFSS) D SBSDISP(LOGIC,FFN,.FN)
  1.  Q
  1.  ;
  1.  ;===========================================
  1. EVALLOG(LOGIC,FN) ;Evaluate the logic string.
  1.  N DIVBY0,DIVOP,IND,NLOGIC,NODIV,NULL,NUMSTACK,OP1,OP2,OPER,OPERS
  1.  N PFSTACK,RES,TEMP,UNARY
  1.  I LOGIC="" Q 0
  1.  S NULL="" ;REMOVE THIS WHEN DONE FIXING.
  1.  S NODIV=$S(LOGIC["/":0,LOGIC["\":0,LOGIC["#":0,1:1)
  1.  I NODIV Q @LOGIC
  1.  S NULL=""
  1.  S DIVBY0=0,DIVOP="/\#"
  1.  S OPERS=$$GETOPERS^PXRMFFDB
  1.  S NLOGIC=$$NLOGIC(LOGIC,.FN)
  1.  D POSTFIX^PXRMSTAC(NLOGIC,OPERS,.PFSTACK)
  1.  F IND=1:1:PFSTACK(0) D
  1.  . S TEMP=PFSTACK(IND)
  1.  .;Check for a unary operator.
  1.  . S UNARY=$S(TEMP="+U":1,TEMP="-U":1,TEMP="'U":1,1:0)
  1.  . S OPER=$S(UNARY:$E(TEMP,1),1:TEMP)
  1.  . I OPERS'[OPER D PUSH^PXRMSTAC(.NUMSTACK,TEMP) Q
  1.  .;If control gets to here we have an operator.
  1.  . S OP2=$$POP^PXRMSTAC(.NUMSTACK)
  1.  . S OP2=$$STRCLEAN(OP2)
  1.  . I UNARY S TEMP="S RES="_OPER_"OP2"
  1.  . I 'UNARY D
  1.  .. S OP1=$$POP^PXRMSTAC(.NUMSTACK)
  1.  .. S OP1=$$STRCLEAN(OP1)
  1.  ..;Flag division by 0 with ~
  1.  .. I DIVOP[OPER,+OP2=0 S DIVBY0=1,TEMP="S RES=""~"""
  1.  .. E  S TEMP="S RES=OP1"_OPER_"OP2"
  1.  .;Do the math and put the result on the stack. The result of division
  1.  .;by 0 with any operator is 0.
  1.  . I ($G(OP1)="~")!(OP2="~") S RES=0
  1.  . E  X TEMP
  1.  . D PUSH^PXRMSTAC(.NUMSTACK,RES)
  1.  S RES=$$POP^PXRMSTAC(.NUMSTACK)
  1.  I PFSTACK(0)=1 D
  1.  . I @NLOGIC S RES=1
  1.  . E  S RES=0
  1.  Q RES
  1.  ;
  1.  ;===========================================
  1. EVALPL(DEFARR,FFIND,PLIST) ;Build a list of patients based on a function
  1.  ;finding.
  1.  N ARGL,ARGLIST,AT,COUNT,DAS,DATE,DFN
  1.  N FI,FIEVAL,FIEVT,FILIST,FILENUM,FINDPA,FN
  1.  N FUN,FUNCTION,FUNNM,FUNN,FUNNUM,FVALUE
  1.  N IND,ITEM,JND,LOGIC,LNAME,NARG,NFI,NFUN
  1.  N ROUTINE,TEMP,TERMARR,UNIQFIL
  1.  S LOGIC=DEFARR(25,FFIND,10)
  1.  I LOGIC="" Q
  1.  ;Build the list of functions and findings used by the function finding.
  1.  S (FUNNUM,NFUN)=0
  1.  F  S FUNNUM=+$O(DEFARR(25,FFIND,5,FUNNUM)) Q:FUNNUM=0  D
  1.  . S NFUN=NFUN+1
  1.  . S FUNN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,1)
  1.  . S FUN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,2)
  1.  . S TEMP=^PXRMD(802.4,FUN,0)
  1.  . S FUN=$P(TEMP,U,1)
  1.  . S FUNCTION(NFUN)=$TR(FUN,"_","")
  1.  . S ROUTINE(NFUN)=$P(TEMP,U,2,3)_"(.ARGL,.FIEVAL,.FVALUE)"
  1.  . S (FI,NARG,NFI)=0
  1.  . F  S FI=+$O(DEFARR(25,FFIND,5,FUNNUM,20,FI)) Q:FI=0  D
  1.  .. S NARG=NARG+1,ARGLIST(NFUN,NARG)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0)
  1.  .. S AT=$$ARGTYPE^PXRMFFAT(FUNCTION(NFUN),FI)
  1.  .. I AT="F" S NFI=NFI+1,FILIST(NFUN,NFI)=ARGLIST(NFUN,NARG)
  1.  . S ARGLIST(NFUN,0)=NARG
  1.  . S FILIST(NFUN,0)=NFI
  1.  ;A finding may be used in more than one function in the function
  1.  ;finding so build a list of the unique findings.
  1.  F IND=1:1:NFUN D
  1.  . F JND=1:1:FILIST(IND,0) D
  1.  .. S TEMP=$P(DEFARR(20,FILIST(IND,JND),0),U,1)
  1.  .. S ITEM=$P(TEMP,";",1)
  1.  .. S FILENUM=$$GETFNUM^PXRMDATA($P(TEMP,";",2))
  1.  .. S UNIQFIL(FILIST(IND,JND))=""
  1.  K ^TMP($J,"PXRMFFDFN")
  1.  S IND=0
  1.  F  S IND=$O(UNIQFIL(IND)) Q:IND=""  D
  1.  . S FINDPA(0)=DEFARR(20,IND,0)
  1.  . S FINDPA(3)=DEFARR(20,IND,3)
  1.  . S FINDPA(10)=DEFARR(20,IND,10)
  1.  . S FINDPA(11)=DEFARR(20,IND,11)
  1.  . D GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR)
  1.  . S LNAME(IND)="PXRMFF"_IND
  1.  . K ^TMP($J,LNAME(IND))
  1.  . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND))
  1.  .;Get rid of the false part of the list.
  1.  . K ^TMP($J,LNAME(IND),0)
  1.  .;Build a complete list of patients.
  1.  . S DFN=0
  1.  . F  S DFN=$O(^TMP($J,LNAME(IND),1,DFN)) Q:DFN=""  S ^TMP($J,"PXRMFFDFN",DFN)=""
  1.  ;Evaluate the function finding for each patient. If the function
  1.  ;finding is true then add the patient to PLIST.
  1.  S DFN=0
  1.  F  S DFN=$O(^TMP($J,"PXRMFFDFN",DFN)) Q:DFN=""  D
  1.  . K FIEVAL
  1.  . S IND=""
  1.  . F  S IND=$O(UNIQFIL(IND)) Q:IND=""  D
  1.  .. S FIEVAL(IND)=0
  1.  .. S ITEM=""
  1.  .. F  S ITEM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM)) Q:ITEM=""  D
  1.  ... S COUNT=0
  1.  ... F  S COUNT=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT)) Q:COUNT=""  D
  1.  .... S FILENUM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,""))
  1.  .... S TEMP=^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM)
  1.  .... S DAS=$P(TEMP,U,1)
  1.  .... S DATE=$P(TEMP,U,2)
  1.  .... K FIEVT
  1.  .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
  1.  .... M FIEVAL(IND,COUNT)=FIEVT
  1.  .... S FIEVAL(IND,COUNT,"DATE")=DATE,FIEVAL(IND,COUNT)=1
  1.  .;Save the top level results for each finding.
  1.  . S IND=0
  1.  . F  S IND=$O(FIEVAL(IND)) Q:IND=""  D
  1.  .. K FIEVT M FIEVT=FIEVAL(IND)
  1.  .. S NFI=+$O(FIEVT(""),-1)
  1.  .. D SFRES^PXRMUTIL(-1,NFI,.FIEVT)
  1.  .. K FIEVAL(IND) M FIEVAL(IND)=FIEVT
  1.  .;Evaluate the function finding for this patient.
  1.  . K FN
  1.  . F IND=1:1:NFUN D
  1.  .. K ARGL M ARGL=ARGLIST(IND)
  1.  .. D @ROUTINE(IND)
  1.  .. S FN(IND)=FVALUE
  1.  . I @LOGIC S ^TMP($J,PLIST,1,DFN,1,FFIND)=""
  1.  ;Clean up.
  1.  K ^TMP($J,"PXRMFFDFN")
  1.  S IND=""
  1.  F  S IND=$O(UNIQFIL(IND)) Q:IND=""  K ^TMP($J,LNAME(IND))
  1.  Q
  1.  ;
  1.  ;===========================================
  1. MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
  1.  ;None currently defined.
  1.  Q
  1.  ;
  1.  ;===========================================
  1. NLOGIC(LOGIC,FN) ;Replace the symbols in the logic string with their values.
  1.  N IND,NLOGIC,TEMP
  1.  I LOGIC="" Q 0
  1.  S NLOGIC=LOGIC
  1.  I NLOGIC["$P" S NLOGIC=$$PRP(NLOGIC)
  1.  I $D(PXRMAGE) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMAGE",PXRMAGE)
  1.  I $D(PXRMDOB) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMDOB",PXRMDOB)
  1.  I $D(PXRMDOD) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMDOD",PXRMDOD)
  1.  I $D(PXRMLAD) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMLAD",PXRMLAD)
  1.  I $D(PXRMSEX) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMSEX",""""_PXRMSEX_"""")
  1.  S IND=""
  1.  F  S IND=$O(FN(IND)) Q:IND=""  D
  1.  . S TEMP=$S(FN(IND)="":"NULL",1:FN(IND))
  1.  . S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"FN("_IND_")",TEMP)
  1.  Q NLOGIC
  1.  ;
  1.  ;===========================================
  1. OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
  1.  ;maintenance output. None currently defined.
  1.  Q
  1.  ;
  1.  ;===========================================
  1. PRP(LOGIC) ;Process $P in logic.
  1.  N IND,PFSTACK,RES,T1,TEMP
  1.  D POSTFIX^PXRMSTAC(LOGIC,"",.PFSTACK)
  1.  F IND=1:1:PFSTACK(0) D
  1.  . I PFSTACK(IND)'="$P" Q
  1.  . S IND=IND+1,T1=PFSTACK(IND)
  1.  . I T1="FN" S IND=IND+1,T1=T1_"("_PFSTACK(IND)_")",IND=IND+1,T1=T1_PFSTACK(IND)
  1.  . S TEMP="$P("_T1_")"
  1.  . S T1="S RES="_TEMP
  1.  . X T1
  1.  . I RES="" S RES="NULL"
  1.  . S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TEMP,RES)
  1.  Q LOGIC
  1.  ;
  1.  ;===========================================
  1. SBSDISP(LOGIC,FFN,FN) ;Create a step-by-step display of the function finding
  1.  ;evaluation for reminder test.
  1.  N DIVOP,IND,NLOGIC,NUMSTACK,OP1,OP2,OPER,OPERS,PFSTACK
  1.  N RES,TEMP,TEXT,UNARY
  1.  N NSTEPS,REPL
  1.  I LOGIC="" Q 0
  1.  S NSTEPS=0
  1.  S DIVOP="/\#"
  1.  S OPERS=$$GETOPERS^PXRMFFDB
  1.  S NLOGIC=$$NLOGIC(LOGIC,.FN)
  1.  K ^TMP("PXRMFFSS",$J,FFN)
  1.  S ^TMP("PXRMFFSS",$J,FFN,0)=NLOGIC
  1.  D POSTFIX^PXRMSTAC(NLOGIC,OPERS,.PFSTACK)
  1.  F IND=1:1:PFSTACK(0) D
  1.  . S TEMP=PFSTACK(IND)
  1.  .;Check for a unary operator.
  1.  . S UNARY=$S(TEMP="+U":1,TEMP="-U":1,TEMP="'U":1,1:0)
  1.  . S OPER=$S(UNARY:$E(TEMP,1),1:TEMP)
  1.  . I OPERS'[OPER D PUSH^PXRMSTAC(.NUMSTACK,TEMP) Q
  1.  .;If control gets to here we have an operator.
  1.  . S OP2=$$POP^PXRMSTAC(.NUMSTACK)
  1.  . S OP2=$$STRCLEAN(OP2)
  1.  . I UNARY S TEMP="S RES="_OPER_"OP2",TEXT=OPER_OP2
  1.  . I 'UNARY D
  1.  .. S OP1=$$POP^PXRMSTAC(.NUMSTACK)
  1.  .. S OP1=$$STRCLEAN(OP1)
  1.  ..;Flag division by 0 with ~
  1.  .. I DIVOP[OPER,+OP2=0 S TEMP="S RES=""~""",TEXT="0/0"
  1.  .. E  S TEMP="S RES=OP1"_OPER_"OP2",TEXT=OP1_OPER_OP2
  1.  .;Do the math and put the result on the stack. The result of division
  1.  .;by 0 with any operator is 0.
  1.  . I ($G(OP1)="~")!(OP2="~") S RES=0
  1.  . E  X TEMP
  1.  . S NSTEPS=NSTEPS+1
  1.  . S ^TMP("PXRMFFSS",$J,FFN,NSTEPS)=TEXT_"="_RES
  1.  . D PUSH^PXRMSTAC(.NUMSTACK,RES)
  1.  S RES=$$POP^PXRMSTAC(.NUMSTACK)
  1.  I PFSTACK(0)=1 D
  1.  . S RES=$S(NLOGIC:1,1:0)
  1.  . S ^TMP("PXRMFFSS",$J,FFN,1)=PFSTACK(1)_"="_RES
  1.  Q
  1.  ;
  1.  ;===========================================
  1. STRCLEAN(STRING) ;Remove extra quotes from strings.
  1.  I +STRING=STRING Q STRING
  1.  N LEN,QUOTE
  1.  S QUOTE=$C(34)
  1.  S LEN=$L(STRING)
  1.  I ($E(STRING,1)=QUOTE),($E(STRING,LEN)=QUOTE) Q $E(STRING,2,LEN-1)
  1.  Q STRING
  1.  ;