PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;03/12/2013
;;2.0;CLINICAL REMINDERS;**4,6,11,18,22,24,26**;Feb 04, 2005;Build 404
;===========================================
EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
N ARGLIST,FFIND,FFN,FN,FUN,FUNIND,FUNN,FVALUE,JND
N LOGIC,LOGVAL,NL,ROUTINE,TEMP
I '$D(DEFARR(25)) Q
S FFN="FF"
F S FFN=$O(DEFARR(25,FFN)) Q:FFN'["FF" D
. K FN
. S FUNIND=0
. F S FUNIND=+$O(DEFARR(25,FFN,5,FUNIND)) Q:FUNIND=0 D
.. S FUNN=$P(DEFARR(25,FFN,5,FUNIND,0),U,1)
.. S FUN=$P(DEFARR(25,FFN,5,FUNIND,0),U,2)
.. S TEMP=^PXRMD(802.4,FUN,0)
.. S ROUTINE=$P(TEMP,U,2,3)_"(.ARGLIST,.FIEVAL,.FVALUE)"
.. K ARGLIST
.. S (JND,NL)=0
.. F S JND=+$O(DEFARR(25,FFN,5,FUNIND,20,JND)) Q:JND=0 D
... S NL=NL+1
... S ARGLIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0)
.. S ARGLIST(0)=NL
.. D @ROUTINE
.. S FN(FUNIND)=FVALUE
. S LOGIC=$G(DEFARR(25,FFN,10))
. S LOGIC=$S(LOGIC'="":LOGIC,1:0)
. S LOGVAL=$$EVALLOG(LOGIC,.FN)
. S FIEVAL(FFN)=LOGVAL
. S FIEVAL(FFN,"NUMBER")=$P(FFN,"FF",2)
. S FIEVAL(FFN,"FINDING")=$G(FUN)_";PXRMD(802.4,"
. I $G(PXRMDEBG) D
.. S ^TMP(PXRMPID,$J,"FFDEB",FFN,"DETAIL")=FIEVAL(FFN)_U_DEFARR(25,FFN,3)_U_$$NLOGIC(LOGIC,.FN)
.. I $G(PXRMFFSS) D SBSDISP(LOGIC,FFN,.FN)
Q
;
;===========================================
EVALLOG(LOGIC,FN) ;Evaluate the logic string.
N DIVBY0,DIVOP,IND,NLOGIC,NODIV,NULL,NUMSTACK,OP1,OP2,OPER,OPERS
N PFSTACK,RES,TEMP,UNARY
I LOGIC="" Q 0
S NULL="" ;REMOVE THIS WHEN DONE FIXING.
S NODIV=$S(LOGIC["/":0,LOGIC["\":0,LOGIC["#":0,1:1)
I NODIV Q @LOGIC
S NULL=""
S DIVBY0=0,DIVOP="/\#"
S OPERS=$$GETOPERS^PXRMFFDB
S NLOGIC=$$NLOGIC(LOGIC,.FN)
D POSTFIX^PXRMSTAC(NLOGIC,OPERS,.PFSTACK)
F IND=1:1:PFSTACK(0) D
. S TEMP=PFSTACK(IND)
.;Check for a unary operator.
. S UNARY=$S(TEMP="+U":1,TEMP="-U":1,TEMP="'U":1,1:0)
. S OPER=$S(UNARY:$E(TEMP,1),1:TEMP)
. I OPERS'[OPER D PUSH^PXRMSTAC(.NUMSTACK,TEMP) Q
.;If control gets to here we have an operator.
. S OP2=$$POP^PXRMSTAC(.NUMSTACK)
. S OP2=$$STRCLEAN(OP2)
. I UNARY S TEMP="S RES="_OPER_"OP2"
. I 'UNARY D
.. S OP1=$$POP^PXRMSTAC(.NUMSTACK)
.. S OP1=$$STRCLEAN(OP1)
..;Flag division by 0 with ~
.. I DIVOP[OPER,+OP2=0 S DIVBY0=1,TEMP="S RES=""~"""
.. E S TEMP="S RES=OP1"_OPER_"OP2"
.;Do the math and put the result on the stack. The result of division
.;by 0 with any operator is 0.
. I ($G(OP1)="~")!(OP2="~") S RES=0
. E X TEMP
. D PUSH^PXRMSTAC(.NUMSTACK,RES)
S RES=$$POP^PXRMSTAC(.NUMSTACK)
I PFSTACK(0)=1 D
. I @NLOGIC S RES=1
. E S RES=0
Q RES
;
;===========================================
EVALPL(DEFARR,FFIND,PLIST) ;Build a list of patients based on a function
;finding.
N ARGL,ARGLIST,AT,COUNT,DAS,DATE,DFN
N FI,FIEVAL,FIEVT,FILIST,FILENUM,FINDPA,FN
N FUN,FUNCTION,FUNNM,FUNN,FUNNUM,FVALUE
N IND,ITEM,JND,LOGIC,LNAME,NARG,NFI,NFUN
N ROUTINE,TEMP,TERMARR,UNIQFIL
S LOGIC=DEFARR(25,FFIND,10)
I LOGIC="" Q
;Build the list of functions and findings used by the function finding.
S (FUNNUM,NFUN)=0
F S FUNNUM=+$O(DEFARR(25,FFIND,5,FUNNUM)) Q:FUNNUM=0 D
. S NFUN=NFUN+1
. S FUNN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,1)
. S FUN=$P(DEFARR(25,FFIND,5,FUNNUM,0),U,2)
. S TEMP=^PXRMD(802.4,FUN,0)
. S FUN=$P(TEMP,U,1)
. S FUNCTION(NFUN)=$TR(FUN,"_","")
. S ROUTINE(NFUN)=$P(TEMP,U,2,3)_"(.ARGL,.FIEVAL,.FVALUE)"
. S (FI,NARG,NFI)=0
. F S FI=+$O(DEFARR(25,FFIND,5,FUNNUM,20,FI)) Q:FI=0 D
.. S NARG=NARG+1,ARGLIST(NFUN,NARG)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0)
.. S AT=$$ARGTYPE^PXRMFFAT(FUNCTION(NFUN),FI)
.. I AT="F" S NFI=NFI+1,FILIST(NFUN,NFI)=ARGLIST(NFUN,NARG)
. S ARGLIST(NFUN,0)=NARG
. S FILIST(NFUN,0)=NFI
;A finding may be used in more than one function in the function
;finding so build a list of the unique findings.
F IND=1:1:NFUN D
. F JND=1:1:FILIST(IND,0) D
.. S TEMP=$P(DEFARR(20,FILIST(IND,JND),0),U,1)
.. S ITEM=$P(TEMP,";",1)
.. S FILENUM=$$GETFNUM^PXRMDATA($P(TEMP,";",2))
.. S UNIQFIL(FILIST(IND,JND))=""
K ^TMP($J,"PXRMFFDFN")
S IND=0
F S IND=$O(UNIQFIL(IND)) Q:IND="" D
. S FINDPA(0)=DEFARR(20,IND,0)
. S FINDPA(3)=DEFARR(20,IND,3)
. S FINDPA(10)=DEFARR(20,IND,10)
. S FINDPA(11)=DEFARR(20,IND,11)
. D GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR)
. S LNAME(IND)="PXRMFF"_IND
. K ^TMP($J,LNAME(IND))
. D EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND))
.;Get rid of the false part of the list.
. K ^TMP($J,LNAME(IND),0)
.;Build a complete list of patients.
. S DFN=0
. F S DFN=$O(^TMP($J,LNAME(IND),1,DFN)) Q:DFN="" S ^TMP($J,"PXRMFFDFN",DFN)=""
;Evaluate the function finding for each patient. If the function
;finding is true then add the patient to PLIST.
S DFN=0
F S DFN=$O(^TMP($J,"PXRMFFDFN",DFN)) Q:DFN="" D
. K FIEVAL
. S IND=""
. F S IND=$O(UNIQFIL(IND)) Q:IND="" D
.. S FIEVAL(IND)=0
.. S ITEM=""
.. F S ITEM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM)) Q:ITEM="" D
... S COUNT=0
... F S COUNT=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT)) Q:COUNT="" D
.... S FILENUM=$O(^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,""))
.... S TEMP=^TMP($J,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM)
.... S DAS=$P(TEMP,U,1)
.... S DATE=$P(TEMP,U,2)
.... K FIEVT
.... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
.... M FIEVAL(IND,COUNT)=FIEVT
.... S FIEVAL(IND,COUNT,"DATE")=DATE,FIEVAL(IND,COUNT)=1
.;Save the top level results for each finding.
. S IND=0
. F S IND=$O(FIEVAL(IND)) Q:IND="" D
.. K FIEVT M FIEVT=FIEVAL(IND)
.. S NFI=+$O(FIEVT(""),-1)
.. D SFRES^PXRMUTIL(-1,NFI,.FIEVT)
.. K FIEVAL(IND) M FIEVAL(IND)=FIEVT
.;Evaluate the function finding for this patient.
. K FN
. F IND=1:1:NFUN D
.. K ARGL M ARGL=ARGLIST(IND)
.. D @ROUTINE(IND)
.. S FN(IND)=FVALUE
. I @LOGIC S ^TMP($J,PLIST,1,DFN,1,FFIND)=""
;Clean up.
K ^TMP($J,"PXRMFFDFN")
S IND=""
F S IND=$O(UNIQFIL(IND)) Q:IND="" K ^TMP($J,LNAME(IND))
Q
;
;===========================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
;None currently defined.
Q
;
;===========================================
NLOGIC(LOGIC,FN) ;Replace the symbols in the logic string with their values.
N IND,NLOGIC,TEMP
I LOGIC="" Q 0
S NLOGIC=LOGIC
I NLOGIC["$P" S NLOGIC=$$PRP(NLOGIC)
I $D(PXRMAGE) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMAGE",PXRMAGE)
I $D(PXRMDOB) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMDOB",PXRMDOB)
I $D(PXRMDOD) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMDOD",PXRMDOD)
I $D(PXRMLAD) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMLAD",PXRMLAD)
I $D(PXRMSEX) S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMSEX",""""_PXRMSEX_"""")
S IND=""
F S IND=$O(FN(IND)) Q:IND="" D
. S TEMP=$S(FN(IND)="":"NULL",1:FN(IND))
. S NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"FN("_IND_")",TEMP)
Q NLOGIC
;
;===========================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
;maintenance output. None currently defined.
Q
;
;===========================================
PRP(LOGIC) ;Process $P in logic.
N IND,PFSTACK,RES,T1,TEMP
D POSTFIX^PXRMSTAC(LOGIC,"",.PFSTACK)
F IND=1:1:PFSTACK(0) D
. I PFSTACK(IND)'="$P" Q
. S IND=IND+1,T1=PFSTACK(IND)
. I T1="FN" S IND=IND+1,T1=T1_"("_PFSTACK(IND)_")",IND=IND+1,T1=T1_PFSTACK(IND)
. S TEMP="$P("_T1_")"
. S T1="S RES="_TEMP
. X T1
. I RES="" S RES="NULL"
. S LOGIC=$$STRREP^PXRMUTIL(LOGIC,TEMP,RES)
Q LOGIC
;
;===========================================
SBSDISP(LOGIC,FFN,FN) ;Create a step-by-step display of the function finding
;evaluation for reminder test.
N DIVOP,IND,NLOGIC,NUMSTACK,OP1,OP2,OPER,OPERS,PFSTACK
N RES,TEMP,TEXT,UNARY
N NSTEPS,REPL
I LOGIC="" Q 0
S NSTEPS=0
S DIVOP="/\#"
S OPERS=$$GETOPERS^PXRMFFDB
S NLOGIC=$$NLOGIC(LOGIC,.FN)
K ^TMP("PXRMFFSS",$J,FFN)
S ^TMP("PXRMFFSS",$J,FFN,0)=NLOGIC
D POSTFIX^PXRMSTAC(NLOGIC,OPERS,.PFSTACK)
F IND=1:1:PFSTACK(0) D
. S TEMP=PFSTACK(IND)
.;Check for a unary operator.
. S UNARY=$S(TEMP="+U":1,TEMP="-U":1,TEMP="'U":1,1:0)
. S OPER=$S(UNARY:$E(TEMP,1),1:TEMP)
. I OPERS'[OPER D PUSH^PXRMSTAC(.NUMSTACK,TEMP) Q
.;If control gets to here we have an operator.
. S OP2=$$POP^PXRMSTAC(.NUMSTACK)
. S OP2=$$STRCLEAN(OP2)
. I UNARY S TEMP="S RES="_OPER_"OP2",TEXT=OPER_OP2
. I 'UNARY D
.. S OP1=$$POP^PXRMSTAC(.NUMSTACK)
.. S OP1=$$STRCLEAN(OP1)
..;Flag division by 0 with ~
.. I DIVOP[OPER,+OP2=0 S TEMP="S RES=""~""",TEXT="0/0"
.. E S TEMP="S RES=OP1"_OPER_"OP2",TEXT=OP1_OPER_OP2
.;Do the math and put the result on the stack. The result of division
.;by 0 with any operator is 0.
. I ($G(OP1)="~")!(OP2="~") S RES=0
. E X TEMP
. S NSTEPS=NSTEPS+1
. S ^TMP("PXRMFFSS",$J,FFN,NSTEPS)=TEXT_"="_RES
. D PUSH^PXRMSTAC(.NUMSTACK,RES)
S RES=$$POP^PXRMSTAC(.NUMSTACK)
I PFSTACK(0)=1 D
. S RES=$S(NLOGIC:1,1:0)
. S ^TMP("PXRMFFSS",$J,FFN,1)=PFSTACK(1)_"="_RES
Q
;
;===========================================
STRCLEAN(STRING) ;Remove extra quotes from strings.
I +STRING=STRING Q STRING
N LEN,QUOTE
S QUOTE=$C(34)
S LEN=$L(STRING)
I ($E(STRING,1)=QUOTE),($E(STRING,LEN)=QUOTE) Q $E(STRING,2,LEN-1)
Q STRING
;
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
+2 ;===========================================
EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
+1 NEW ARGLIST,FFIND,FFN,FN,FUN,FUNIND,FUNN,FVALUE,JND
+2 NEW LOGIC,LOGVAL,NL,ROUTINE,TEMP
+3 IF '$DATA(DEFARR(25))
QUIT
+4 SET FFN="FF"
+5 FOR
SET FFN=$ORDER(DEFARR(25,FFN))
IF FFN'["FF"
QUIT
Begin DoDot:1
+6 KILL FN
+7 SET FUNIND=0
+8 FOR
SET FUNIND=+$ORDER(DEFARR(25,FFN,5,FUNIND))
IF FUNIND=0
QUIT
Begin DoDot:2
+9 SET FUNN=$PIECE(DEFARR(25,FFN,5,FUNIND,0),U,1)
+10 SET FUN=$PIECE(DEFARR(25,FFN,5,FUNIND,0),U,2)
+11 SET TEMP=^PXRMD(802.4,FUN,0)
+12 SET ROUTINE=$PIECE(TEMP,U,2,3)_"(.ARGLIST,.FIEVAL,.FVALUE)"
+13 KILL ARGLIST
+14 SET (JND,NL)=0
+15 FOR
SET JND=+$ORDER(DEFARR(25,FFN,5,FUNIND,20,JND))
IF JND=0
QUIT
Begin DoDot:3
+16 SET NL=NL+1
+17 SET ARGLIST(NL)=DEFARR(25,FFN,5,FUNIND,20,JND,0)
End DoDot:3
+18 SET ARGLIST(0)=NL
+19 DO @ROUTINE
+20 SET FN(FUNIND)=FVALUE
End DoDot:2
+21 SET LOGIC=$GET(DEFARR(25,FFN,10))
+22 SET LOGIC=$SELECT(LOGIC'="":LOGIC,1:0)
+23 SET LOGVAL=$$EVALLOG(LOGIC,.FN)
+24 SET FIEVAL(FFN)=LOGVAL
+25 SET FIEVAL(FFN,"NUMBER")=$PIECE(FFN,"FF",2)
+26 SET FIEVAL(FFN,"FINDING")=$GET(FUN)_";PXRMD(802.4,"
+27 IF $GET(PXRMDEBG)
Begin DoDot:2
+28 SET ^TMP(PXRMPID,$JOB,"FFDEB",FFN,"DETAIL")=FIEVAL(FFN)_U_DEFARR(25,FFN,3)_U_$$NLOGIC(LOGIC,.FN)
+29 IF $GET(PXRMFFSS)
DO SBSDISP(LOGIC,FFN,.FN)
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
+32 ;===========================================
EVALLOG(LOGIC,FN) ;Evaluate the logic string.
+1 NEW DIVBY0,DIVOP,IND,NLOGIC,NODIV,NULL,NUMSTACK,OP1,OP2,OPER,OPERS
+2 NEW PFSTACK,RES,TEMP,UNARY
+3 IF LOGIC=""
QUIT 0
+4 ;REMOVE THIS WHEN DONE FIXING.
SET NULL=""
+5 SET NODIV=$SELECT(LOGIC["/":0,LOGIC["\":0,LOGIC["#":0,1:1)
+6 IF NODIV
QUIT @LOGIC
+7 SET NULL=""
+8 SET DIVBY0=0
SET DIVOP="/\#"
+9 SET OPERS=$$GETOPERS^PXRMFFDB
+10 SET NLOGIC=$$NLOGIC(LOGIC,.FN)
+11 DO POSTFIX^PXRMSTAC(NLOGIC,OPERS,.PFSTACK)
+12 FOR IND=1:1:PFSTACK(0)
Begin DoDot:1
+13 SET TEMP=PFSTACK(IND)
+14 ;Check for a unary operator.
+15 SET UNARY=$SELECT(TEMP="+U":1,TEMP="-U":1,TEMP="'U":1,1:0)
+16 SET OPER=$SELECT(UNARY:$EXTRACT(TEMP,1),1:TEMP)
+17 IF OPERS'[OPER
DO PUSH^PXRMSTAC(.NUMSTACK,TEMP)
QUIT
+18 ;If control gets to here we have an operator.
+19 SET OP2=$$POP^PXRMSTAC(.NUMSTACK)
+20 SET OP2=$$STRCLEAN(OP2)
+21 IF UNARY
SET TEMP="S RES="_OPER_"OP2"
+22 IF 'UNARY
Begin DoDot:2
+23 SET OP1=$$POP^PXRMSTAC(.NUMSTACK)
+24 SET OP1=$$STRCLEAN(OP1)
+25 ;Flag division by 0 with ~
+26 IF DIVOP[OPER
IF +OP2=0
SET DIVBY0=1
SET TEMP="S RES=""~"""
+27 IF '$TEST
SET TEMP="S RES=OP1"_OPER_"OP2"
End DoDot:2
+28 ;Do the math and put the result on the stack. The result of division
+29 ;by 0 with any operator is 0.
+30 IF ($GET(OP1)="~")!(OP2="~")
SET RES=0
+31 IF '$TEST
XECUTE TEMP
+32 DO PUSH^PXRMSTAC(.NUMSTACK,RES)
End DoDot:1
+33 SET RES=$$POP^PXRMSTAC(.NUMSTACK)
+34 IF PFSTACK(0)=1
Begin DoDot:1
+35 IF @NLOGIC
SET RES=1
+36 IF '$TEST
SET RES=0
End DoDot:1
+37 QUIT RES
+38 ;
+39 ;===========================================
EVALPL(DEFARR,FFIND,PLIST) ;Build a list of patients based on a function
+1 ;finding.
+2 NEW ARGL,ARGLIST,AT,COUNT,DAS,DATE,DFN
+3 NEW FI,FIEVAL,FIEVT,FILIST,FILENUM,FINDPA,FN
+4 NEW FUN,FUNCTION,FUNNM,FUNN,FUNNUM,FVALUE
+5 NEW IND,ITEM,JND,LOGIC,LNAME,NARG,NFI,NFUN
+6 NEW ROUTINE,TEMP,TERMARR,UNIQFIL
+7 SET LOGIC=DEFARR(25,FFIND,10)
+8 IF LOGIC=""
QUIT
+9 ;Build the list of functions and findings used by the function finding.
+10 SET (FUNNUM,NFUN)=0
+11 FOR
SET FUNNUM=+$ORDER(DEFARR(25,FFIND,5,FUNNUM))
IF FUNNUM=0
QUIT
Begin DoDot:1
+12 SET NFUN=NFUN+1
+13 SET FUNN=$PIECE(DEFARR(25,FFIND,5,FUNNUM,0),U,1)
+14 SET FUN=$PIECE(DEFARR(25,FFIND,5,FUNNUM,0),U,2)
+15 SET TEMP=^PXRMD(802.4,FUN,0)
+16 SET FUN=$PIECE(TEMP,U,1)
+17 SET FUNCTION(NFUN)=$TRANSLATE(FUN,"_","")
+18 SET ROUTINE(NFUN)=$PIECE(TEMP,U,2,3)_"(.ARGL,.FIEVAL,.FVALUE)"
+19 SET (FI,NARG,NFI)=0
+20 FOR
SET FI=+$ORDER(DEFARR(25,FFIND,5,FUNNUM,20,FI))
IF FI=0
QUIT
Begin DoDot:2
+21 SET NARG=NARG+1
SET ARGLIST(NFUN,NARG)=DEFARR(25,FFIND,5,FUNNUM,20,FI,0)
+22 SET AT=$$ARGTYPE^PXRMFFAT(FUNCTION(NFUN),FI)
+23 IF AT="F"
SET NFI=NFI+1
SET FILIST(NFUN,NFI)=ARGLIST(NFUN,NARG)
End DoDot:2
+24 SET ARGLIST(NFUN,0)=NARG
+25 SET FILIST(NFUN,0)=NFI
End DoDot:1
+26 ;A finding may be used in more than one function in the function
+27 ;finding so build a list of the unique findings.
+28 FOR IND=1:1:NFUN
Begin DoDot:1
+29 FOR JND=1:1:FILIST(IND,0)
Begin DoDot:2
+30 SET TEMP=$PIECE(DEFARR(20,FILIST(IND,JND),0),U,1)
+31 SET ITEM=$PIECE(TEMP,";",1)
+32 SET FILENUM=$$GETFNUM^PXRMDATA($PIECE(TEMP,";",2))
+33 SET UNIQFIL(FILIST(IND,JND))=""
End DoDot:2
End DoDot:1
+34 KILL ^TMP($JOB,"PXRMFFDFN")
+35 SET IND=0
+36 FOR
SET IND=$ORDER(UNIQFIL(IND))
IF IND=""
QUIT
Begin DoDot:1
+37 SET FINDPA(0)=DEFARR(20,IND,0)
+38 SET FINDPA(3)=DEFARR(20,IND,3)
+39 SET FINDPA(10)=DEFARR(20,IND,10)
+40 SET FINDPA(11)=DEFARR(20,IND,11)
+41 DO GENTERM^PXRMPLST(FINDPA(0),IND,.TERMARR)
+42 SET LNAME(IND)="PXRMFF"_IND
+43 KILL ^TMP($JOB,LNAME(IND))
+44 DO EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND))
+45 ;Get rid of the false part of the list.
+46 KILL ^TMP($JOB,LNAME(IND),0)
+47 ;Build a complete list of patients.
+48 SET DFN=0
+49 FOR
SET DFN=$ORDER(^TMP($JOB,LNAME(IND),1,DFN))
IF DFN=""
QUIT
SET ^TMP($JOB,"PXRMFFDFN",DFN)=""
End DoDot:1
+50 ;Evaluate the function finding for each patient. If the function
+51 ;finding is true then add the patient to PLIST.
+52 SET DFN=0
+53 FOR
SET DFN=$ORDER(^TMP($JOB,"PXRMFFDFN",DFN))
IF DFN=""
QUIT
Begin DoDot:1
+54 KILL FIEVAL
+55 SET IND=""
+56 FOR
SET IND=$ORDER(UNIQFIL(IND))
IF IND=""
QUIT
Begin DoDot:2
+57 SET FIEVAL(IND)=0
+58 SET ITEM=""
+59 FOR
SET ITEM=$ORDER(^TMP($JOB,LNAME(IND),1,DFN,ITEM))
IF ITEM=""
QUIT
Begin DoDot:3
+60 SET COUNT=0
+61 FOR
SET COUNT=$ORDER(^TMP($JOB,LNAME(IND),1,DFN,ITEM,COUNT))
IF COUNT=""
QUIT
Begin DoDot:4
+62 SET FILENUM=$ORDER(^TMP($JOB,LNAME(IND),1,DFN,ITEM,COUNT,""))
+63 SET TEMP=^TMP($JOB,LNAME(IND),1,DFN,ITEM,COUNT,FILENUM)
+64 SET DAS=$PIECE(TEMP,U,1)
+65 SET DATE=$PIECE(TEMP,U,2)
+66 KILL FIEVT
+67 DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
+68 MERGE FIEVAL(IND,COUNT)=FIEVT
+69 SET FIEVAL(IND,COUNT,"DATE")=DATE
SET FIEVAL(IND,COUNT)=1
End DoDot:4
End DoDot:3
End DoDot:2
+70 ;Save the top level results for each finding.
+71 SET IND=0
+72 FOR
SET IND=$ORDER(FIEVAL(IND))
IF IND=""
QUIT
Begin DoDot:2
+73 KILL FIEVT
MERGE FIEVT=FIEVAL(IND)
+74 SET NFI=+$ORDER(FIEVT(""),-1)
+75 DO SFRES^PXRMUTIL(-1,NFI,.FIEVT)
+76 KILL FIEVAL(IND)
MERGE FIEVAL(IND)=FIEVT
End DoDot:2
+77 ;Evaluate the function finding for this patient.
+78 KILL FN
+79 FOR IND=1:1:NFUN
Begin DoDot:2
+80 KILL ARGL
MERGE ARGL=ARGLIST(IND)
+81 DO @ROUTINE(IND)
+82 SET FN(IND)=FVALUE
End DoDot:2
+83 IF @LOGIC
SET ^TMP($JOB,PLIST,1,DFN,1,FFIND)=""
End DoDot:1
+84 ;Clean up.
+85 KILL ^TMP($JOB,"PXRMFFDFN")
+86 SET IND=""
+87 FOR
SET IND=$ORDER(UNIQFIL(IND))
IF IND=""
QUIT
KILL ^TMP($JOB,LNAME(IND))
+88 QUIT
+89 ;
+90 ;===========================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 ;None currently defined.
+2 QUIT
+3 ;
+4 ;===========================================
NLOGIC(LOGIC,FN) ;Replace the symbols in the logic string with their values.
+1 NEW IND,NLOGIC,TEMP
+2 IF LOGIC=""
QUIT 0
+3 SET NLOGIC=LOGIC
+4 IF NLOGIC["$P"
SET NLOGIC=$$PRP(NLOGIC)
+5 IF $DATA(PXRMAGE)
SET NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMAGE",PXRMAGE)
+6 IF $DATA(PXRMDOB)
SET NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMDOB",PXRMDOB)
+7 IF $DATA(PXRMDOD)
SET NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMDOD",PXRMDOD)
+8 IF $DATA(PXRMLAD)
SET NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMLAD",PXRMLAD)
+9 IF $DATA(PXRMSEX)
SET NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"PXRMSEX",""""_PXRMSEX_"""")
+10 SET IND=""
+11 FOR
SET IND=$ORDER(FN(IND))
IF IND=""
QUIT
Begin DoDot:1
+12 SET TEMP=$SELECT(FN(IND)="":"NULL",1:FN(IND))
+13 SET NLOGIC=$$STRREP^PXRMUTIL(NLOGIC,"FN("_IND_")",TEMP)
End DoDot:1
+14 QUIT NLOGIC
+15 ;
+16 ;===========================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output. None currently defined.
+2 QUIT
+3 ;
+4 ;===========================================
PRP(LOGIC) ;Process $P in logic.
+1 NEW IND,PFSTACK,RES,T1,TEMP
+2 DO POSTFIX^PXRMSTAC(LOGIC,"",.PFSTACK)
+3 FOR IND=1:1:PFSTACK(0)
Begin DoDot:1
+4 IF PFSTACK(IND)'="$P"
QUIT
+5 SET IND=IND+1
SET T1=PFSTACK(IND)
+6 IF T1="FN"
SET IND=IND+1
SET T1=T1_"("_PFSTACK(IND)_")"
SET IND=IND+1
SET T1=T1_PFSTACK(IND)
+7 SET TEMP="$P("_T1_")"
+8 SET T1="S RES="_TEMP
+9 XECUTE T1
+10 IF RES=""
SET RES="NULL"
+11 SET LOGIC=$$STRREP^PXRMUTIL(LOGIC,TEMP,RES)
End DoDot:1
+12 QUIT LOGIC
+13 ;
+14 ;===========================================
SBSDISP(LOGIC,FFN,FN) ;Create a step-by-step display of the function finding
+1 ;evaluation for reminder test.
+2 NEW DIVOP,IND,NLOGIC,NUMSTACK,OP1,OP2,OPER,OPERS,PFSTACK
+3 NEW RES,TEMP,TEXT,UNARY
+4 NEW NSTEPS,REPL
+5 IF LOGIC=""
QUIT 0
+6 SET NSTEPS=0
+7 SET DIVOP="/\#"
+8 SET OPERS=$$GETOPERS^PXRMFFDB
+9 SET NLOGIC=$$NLOGIC(LOGIC,.FN)
+10 KILL ^TMP("PXRMFFSS",$JOB,FFN)
+11 SET ^TMP("PXRMFFSS",$JOB,FFN,0)=NLOGIC
+12 DO POSTFIX^PXRMSTAC(NLOGIC,OPERS,.PFSTACK)
+13 FOR IND=1:1:PFSTACK(0)
Begin DoDot:1
+14 SET TEMP=PFSTACK(IND)
+15 ;Check for a unary operator.
+16 SET UNARY=$SELECT(TEMP="+U":1,TEMP="-U":1,TEMP="'U":1,1:0)
+17 SET OPER=$SELECT(UNARY:$EXTRACT(TEMP,1),1:TEMP)
+18 IF OPERS'[OPER
DO PUSH^PXRMSTAC(.NUMSTACK,TEMP)
QUIT
+19 ;If control gets to here we have an operator.
+20 SET OP2=$$POP^PXRMSTAC(.NUMSTACK)
+21 SET OP2=$$STRCLEAN(OP2)
+22 IF UNARY
SET TEMP="S RES="_OPER_"OP2"
SET TEXT=OPER_OP2
+23 IF 'UNARY
Begin DoDot:2
+24 SET OP1=$$POP^PXRMSTAC(.NUMSTACK)
+25 SET OP1=$$STRCLEAN(OP1)
+26 ;Flag division by 0 with ~
+27 IF DIVOP[OPER
IF +OP2=0
SET TEMP="S RES=""~"""
SET TEXT="0/0"
+28 IF '$TEST
SET TEMP="S RES=OP1"_OPER_"OP2"
SET TEXT=OP1_OPER_OP2
End DoDot:2
+29 ;Do the math and put the result on the stack. The result of division
+30 ;by 0 with any operator is 0.
+31 IF ($GET(OP1)="~")!(OP2="~")
SET RES=0
+32 IF '$TEST
XECUTE TEMP
+33 SET NSTEPS=NSTEPS+1
+34 SET ^TMP("PXRMFFSS",$JOB,FFN,NSTEPS)=TEXT_"="_RES
+35 DO PUSH^PXRMSTAC(.NUMSTACK,RES)
End DoDot:1
+36 SET RES=$$POP^PXRMSTAC(.NUMSTACK)
+37 IF PFSTACK(0)=1
Begin DoDot:1
+38 SET RES=$SELECT(NLOGIC:1,1:0)
+39 SET ^TMP("PXRMFFSS",$JOB,FFN,1)=PFSTACK(1)_"="_RES
End DoDot:1
+40 QUIT
+41 ;
+42 ;===========================================
STRCLEAN(STRING) ;Remove extra quotes from strings.
+1 IF +STRING=STRING
QUIT STRING
+2 NEW LEN,QUOTE
+3 SET QUOTE=$CHAR(34)
+4 SET LEN=$LENGTH(STRING)
+5 IF ($EXTRACT(STRING,1)=QUOTE)
IF ($EXTRACT(STRING,LEN)=QUOTE)
QUIT $EXTRACT(STRING,2,LEN-1)
+6 QUIT STRING
+7 ;
