PXRMTERM ;SLC/PKR - Handle reminder terms. ;03/31/2022
;;2.0;CLINICAL REMINDERS;**4,6,11,18,26,47,42,65**;Feb 04, 2005;Build 438
;
;=============================================
COPY(NOCC,SDIR,TFIEVAL,DATEORDR,FINDING,FIEVAL,STF) ;Copy the NOCC date ordered
;findings from TFIEVAL to FIEVAL(FINDING).
N DATE,IND,JND,MRS,NFOUND,TFI
;Start with most recent and go to oldest finding.
S MRS=1
S NFOUND=0
S DATE=""
F S DATE=$O(DATEORDR(DATE),SDIR) Q:(NFOUND=NOCC)!(DATE="") D
. S TFI=0
. F S TFI=$O(DATEORDR(DATE,TFI)) Q:(NFOUND=NOCC)!(TFI="") D
.. I MRS D
...;Save the main result node.
... S FIEVAL(FINDING)=TFIEVAL(TFI)
... S MRS=0
... I 'FIEVAL(FINDING) Q
... S JND="@"
... F S JND=$O(TFIEVAL(TFI,JND)) Q:JND="" M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
.. I 'FIEVAL(FINDING) Q
.. S IND=0
.. F S IND=$O(DATEORDR(DATE,TFI,IND)) Q:(NFOUND=NOCC)!(IND="") D
...;Only save true sub-results.
... I 'TFIEVAL(TFI,IND) Q
... S NFOUND=NFOUND+1
... M FIEVAL(FINDING,NFOUND)=TFIEVAL(TFI,IND)
... S FIEVAL(FINDING,NFOUND,"FILE NUMBER")=TFIEVAL(TFI,"FILE NUMBER")
... S FIEVAL(FINDING,NFOUND,"FINDING")=TFIEVAL(TFI,"FINDING")
... I STF S FIEVAL(FINDING,NFOUND,"TERM FINDING")=TFI
... S JND=0
... F S JND=$O(TFIEVAL(TFI,IND,JND)) Q:JND="" M FIEVAL(FINDING,NFOUND,JND)=TFIEVAL(TFI,IND,JND)
Q
;
;=============================================
DORDER(TFIEVAL,DATEORDR) ;Order term findings by date, term finding,
;and term finding occurrence.
N DATE,FI,IND
K DATEORDR
S FI=0
F S FI=+$O(TFIEVAL(FI)) Q:FI=0 D
. S IND=0
. F S IND=+$O(TFIEVAL(FI,IND)) Q:IND=0 D
.. S DATE=$G(TFIEVAL(FI,IND,"DATE"))
.. I DATE'="" S DATEORDR(DATE,FI,IND)=""
Q
;
;=============================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate all reminder terms in a
;definition.
N CASESEN,CONVAL,DATE,DATEORDR
N FIEVT,FINDING,FINDPA,IND,NOCC
N SDIR,TFIND3,TFIND4,TERMARR,TERMIEN,TFI,TFIEVAL,UCIFS
S TERMIEN=""
F S TERMIEN=$O(DEFARR("E",ENODE,TERMIEN)) Q:+TERMIEN=0 D
.;If the term does not exist, create a warning and set all the
.;definition findings using the term to false.
. I '$D(^PXRMD(811.5,TERMIEN)) D Q
.. S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOTERM"_TERMIEN)="Warning: Reminder term IEN="_TERMIEN_" does not exist."
.. S FINDING=0
.. F S FINDING=+$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING=0 S FIEVAL(FINDING)=0
.;If the term does not have any mapped findings set all the
.;definition findings using the term to false.
. I '$D(^PXRMD(811.5,TERMIEN,20,"E")) D Q
.. S FINDING=0
.. F S FINDING=+$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING=0 S FIEVAL(FINDING)=0
. D TERM^PXRMLDR(TERMIEN,.TERMARR)
. S FINDING=0
. F S FINDING=+$O(DEFARR("E",ENODE,TERMIEN,FINDING)) Q:FINDING=0 D
.. S FIEVAL(FINDING)=0
.. S FIEVAL(FINDING,"TERM")=TERMARR(0)
.. S FIEVAL(FINDING,"TERM IEN")=TERMIEN
.. K FINDPA,TFIEVAL
.. M FINDPA=DEFARR(20,FINDING)
.. D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
.. I $G(PXRMTDEB) D
... N CFPARAM,COND,TFINDING
... S TFINDING=0
... F S TFINDING=+$O(TERMARR(20,TFINDING)) Q:TFINDING=0 D
.... S COND=$P($G(TERMARR(20,TFINDING,3)),U,1)
.... I COND'="" S TFIEVAL(TFINDING,"CONDITION TEXT")=COND
.... S CFPARAM=$G(TERMARR(20,TFINDING,15))
.... I CFPARAM'="" S TFIEVAL(TFINDING,"CFP TEXT")=CFPARAM
... M ^TMP("PXRMTDEB",$J,FINDING)=TFIEVAL
..;Set NOCC and SDIR.
.. S NOCC=$P(FINDPA(0),U,14)
.. I NOCC="" S NOCC=1
.. S SDIR=$S(NOCC<0:+1,1:-1)
.. S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
..;Order the term findings by date.
.. D DORDER(.TFIEVAL,.DATEORDR)
.. D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL,1)
.. ;If the term contains immunizations, check for contraindications
.. ;precautions and refusals and set the C/R value of the term.
.. I $D(TERMARR("E","AUTTIMM(")),$D(TFIEVAL("C/R STATUS")) D TERMCRFINDING^PXRMIMM(.TFIEVAL,FINDING,.FIEVAL)
.. I FIEVAL(FINDING)=0 Q
.. I $G(PXRMDEBG)'=1 Q
.. S IND=0
.. F S IND=+$O(FIEVAL(FINDING,IND)) Q:IND=0 D
... I '$D(FIEVAL(FINDING,IND,"TERM FINDING")) Q
... S FIEVAL(FINDING,IND,"TERM FINDING")=$P(TERMARR(20,FIEVAL(FINDING,IND,"TERM FINDING"),0),U,1)
Q
;
;=============================================
EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL) ;Evaluate all the findings in
;a term. Use the "E" cross-reference just like the finding evaluation.
N ENODE
S ENODE=""
F S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE="" D
. I ENODE="AUTTEDT(" D EVALTERM^PXRMEDU(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="AUTTEXAM(" D EVALTERM^PXRMEXAM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="AUTTHF(" D EVALTERM^PXRMHF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="AUTTIMM(" D EVALTERM^PXRMIMM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="AUTTSK(" D EVALTERM^PXRMSKIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="GMRD(120.51," D EVALTERM^PXRMVITL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="LAB(60," D EVALTERM^PXRMLAB(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="ORD(101.43," D EVALTERM^PXRMORDR(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PXD(811.2," D EVALTERM^PXRMTAX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PXRMD(810.9," D EVALTERM^PXRMLOCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PXRMD(811.4," D EVALTERM^PXRMCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PS(50.605," D EVALTERM^PXRMDRCL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PS(55," D EVALTERM^PXRMDIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PS(55NVA," D EVALTERM^PXRMDNVA(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PSDRUG(" D EVALTERM^PXRMDRUG(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PSRX(" D EVALTERM^PXRMDOUT(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="PSNDF(50.6," D EVALTERM^PXRMDGEN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="RAMIS(71," D EVALTERM^PXRMRAD(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
. I ENODE="YTT(601.71," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
Q
;
;=============================================
IEVALTER(DFN,FINDPA,TERMARR,FINDING,FIEVAL) ;Evaluate an individual
;term, put the result in FIEVAL(FINDING).
N DATEORDR,NOCC,SDIR,TFIEVAL
I '$D(PXRMDATE) N PXRMDATE S PXRMDATE=DT
I $D(PXRMPDEM) G DEMOK
N PXRMPDEM D DEM^PXRMPINF(DFN,DT,.PXRMPDEM)
;Create the local demographic variables for use in Condition.
N PXRMAGE,PXRMDOB,PXRMDOD,PXRMLAD,PXRMSEX,PXRMSIG
S PXRMAGE=PXRMPDEM("AGE"),PXRMDOB=PXRMPDEM("DOB"),PXRMDOD=PXRMPDEM("DOD")
S PXRMLAD=PXRMPDEM("LAD"),PXRMSEX=PXRMPDEM("SEX"),PXRMSIG=PXRMPDEM("SIG")
DEMOK S FIEVAL(FINDING)=0
D EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
;Set NOCC and SDIR.
S NOCC=$P(FINDPA(0),U,14)
I NOCC="" S NOCC=1
S SDIR=$S(NOCC<0:+1,1:-1)
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
;Order the term findings by date.
D DORDER(.TFIEVAL,.DATEORDR)
D COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL,0)
I FIEVAL(FINDING)=0 Q
I $G(PXRMDEBG)'=1 Q
S IND=0
F S IND=+$O(FIEVAL(FINDING,IND)) Q:IND=0 D
. I '$D(FIEVAL(FINDING,IND,"TERM FINDING")) Q
. S FIEVAL(FINDING,IND,"TERM FINDING")=$P(TERMARR(20,FIEVAL(FINDING,IND,"TERM FINDING"),0),U,1)
K ^TMP($J,"SVC",DFN)
Q
;
;=============================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"MHV")
Q
;
;=============================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
;maintenance output.
D OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"CM")
Q
;
;=============================================
OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output.
N DG,DGL,DGN,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
;Build the display grouping, where all findings of the same type
;are grouped together. DGN is the number of mapped findings and
;DGL is the list of groups, DGL(M)=FILE NUMBER^IEN of the finding.
;DGL(M,N)="", N is the term finding number.
S FILENUM=IFIEVAL("FILE NUMBER")
S IEN=$P(IFIEVAL("FINDING"),";",1)
S DG(FILENUM,IEN)=1,DGL(1)=FILENUM_U_IEN,DGL(1,1)=""
S (DGN,IND)=1
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 D
. S FILENUM=IFIEVAL(IND,"FILE NUMBER")
. S IEN=$P(IFIEVAL(IND,"FINDING"),";",1)
. I '$D(DG(FILENUM,IEN)) D
.. S DGN=DGN+1,DG(FILENUM,IEN)=DGN
.. S DGL(DGN)=FILENUM_U_IEN,DGL(DGN,IND)=""
. I $D(DG(FILENUM,IEN)) D
.. S TEMP=DG(FILENUM,IEN),DGL(TEMP,IND)=""
S INDENTT=INDENT+1
S TEMP=$$INSCHR^PXRMEXLC(INDENT," ")_"Reminder Term: "_$P(FIEVAL(FINDING,"TERM"),U,1)
S NLINES=NLINES+1,TEXT(NLINES)=TEMP
F IND=1:1:DGN D
. K TIFIEVAL
. S (JND,KND)=0
. F S JND=$O(DGL(IND,JND)) Q:JND="" D
..;For immunizations, it is possible only the contra/refusal portion of
..;the finding exists so check before incrementing KND.
.. I $D(IFIEVAL(JND)) S KND=KND+1
.. I KND=1 M TIFIEVAL=IFIEVAL(JND)
.. M TIFIEVAL(KND)=IFIEVAL(JND)
. I TYPE="CM" D FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
. I TYPE="MHV" D FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
Q
;
;=============================================
SPFINDPA(FINDPA,TFINDPA,PFINDPA) ;Set the finding parameter array
;for terms.
N FIND0,PIECE,PFIND0,TFIND0,VAL
S FIND0=$G(FINDPA(0))
S (PFIND0,TFIND0)=TFINDPA(0)
;Set the 0 node.
F PIECE=9,10,12,13,14,15,16 D
. S VAL=$P(TFIND0,U,PIECE)
. I VAL="" S VAL=$P(FIND0,U,PIECE)
. S $P(PFIND0,U,PIECE)=VAL
;BDT and EDT are treated as a pair.
I $P(TFIND0,U,8)="",$P(TFIND0,U,11)="" F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(FIND0,U,PIECE)
E F PIECE=8,11 S $P(PFIND0,U,PIECE)=$P(TFIND0,U,PIECE)
S PFINDPA(0)=PFIND0
I $P($G(TFINDPA(3)),U,1)'="" S PFINDPA(3)=TFINDPA(3),PFINDPA(10)=TFINDPA(10),PFINDPA(11)=TFINDPA(11)
E S PFINDPA(3)=$G(FINDPA(3)),PFINDPA(10)=$G(FINDPA(10)),PFINDPA(11)=$G(FINDPA(11))
;Get the status list.
I $D(TFINDPA(5)) M PFINDPA(5)=TFINDPA(5)
E M PFINDPA(5)=FINDPA(5)
I $D(TFINDPA(15)) S PFINDPA(15)=TFINDPA(15)
E S PFINDPA(15)=$G(FINDPA(15))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTERM 10012 printed Oct 16, 2024@17:50:15 Page 2
PXRMTERM ;SLC/PKR - Handle reminder terms. ;03/31/2022
+1 ;;2.0;CLINICAL REMINDERS;**4,6,11,18,26,47,42,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;=============================================
COPY(NOCC,SDIR,TFIEVAL,DATEORDR,FINDING,FIEVAL,STF) ;Copy the NOCC date ordered
+1 ;findings from TFIEVAL to FIEVAL(FINDING).
+2 NEW DATE,IND,JND,MRS,NFOUND,TFI
+3 ;Start with most recent and go to oldest finding.
+4 SET MRS=1
+5 SET NFOUND=0
+6 SET DATE=""
+7 FOR
SET DATE=$ORDER(DATEORDR(DATE),SDIR)
if (NFOUND=NOCC)!(DATE="")
QUIT
Begin DoDot:1
+8 SET TFI=0
+9 FOR
SET TFI=$ORDER(DATEORDR(DATE,TFI))
if (NFOUND=NOCC)!(TFI="")
QUIT
Begin DoDot:2
+10 IF MRS
Begin DoDot:3
+11 ;Save the main result node.
+12 SET FIEVAL(FINDING)=TFIEVAL(TFI)
+13 SET MRS=0
+14 IF 'FIEVAL(FINDING)
QUIT
+15 SET JND="@"
+16 FOR
SET JND=$ORDER(TFIEVAL(TFI,JND))
if JND=""
QUIT
MERGE FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
End DoDot:3
+17 IF 'FIEVAL(FINDING)
QUIT
+18 SET IND=0
+19 FOR
SET IND=$ORDER(DATEORDR(DATE,TFI,IND))
if (NFOUND=NOCC)!(IND="")
QUIT
Begin DoDot:3
+20 ;Only save true sub-results.
+21 IF 'TFIEVAL(TFI,IND)
QUIT
+22 SET NFOUND=NFOUND+1
+23 MERGE FIEVAL(FINDING,NFOUND)=TFIEVAL(TFI,IND)
+24 SET FIEVAL(FINDING,NFOUND,"FILE NUMBER")=TFIEVAL(TFI,"FILE NUMBER")
+25 SET FIEVAL(FINDING,NFOUND,"FINDING")=TFIEVAL(TFI,"FINDING")
+26 IF STF
SET FIEVAL(FINDING,NFOUND,"TERM FINDING")=TFI
+27 SET JND=0
+28 FOR
SET JND=$ORDER(TFIEVAL(TFI,IND,JND))
if JND=""
QUIT
MERGE FIEVAL(FINDING,NFOUND,JND)=TFIEVAL(TFI,IND,JND)
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
+31 ;=============================================
DORDER(TFIEVAL,DATEORDR) ;Order term findings by date, term finding,
+1 ;and term finding occurrence.
+2 NEW DATE,FI,IND
+3 KILL DATEORDR
+4 SET FI=0
+5 FOR
SET FI=+$ORDER(TFIEVAL(FI))
if FI=0
QUIT
Begin DoDot:1
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(TFIEVAL(FI,IND))
if IND=0
QUIT
Begin DoDot:2
+8 SET DATE=$GET(TFIEVAL(FI,IND,"DATE"))
+9 IF DATE'=""
SET DATEORDR(DATE,FI,IND)=""
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
+12 ;=============================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate all reminder terms in a
+1 ;definition.
+2 NEW CASESEN,CONVAL,DATE,DATEORDR
+3 NEW FIEVT,FINDING,FINDPA,IND,NOCC
+4 NEW SDIR,TFIND3,TFIND4,TERMARR,TERMIEN,TFI,TFIEVAL,UCIFS
+5 SET TERMIEN=""
+6 FOR
SET TERMIEN=$ORDER(DEFARR("E",ENODE,TERMIEN))
if +TERMIEN=0
QUIT
Begin DoDot:1
+7 ;If the term does not exist, create a warning and set all the
+8 ;definition findings using the term to false.
+9 IF '$DATA(^PXRMD(811.5,TERMIEN))
Begin DoDot:2
+10 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"WARNING","NOTERM"_TERMIEN)="Warning: Reminder term IEN="_TERMIEN_" does not exist."
+11 SET FINDING=0
+12 FOR
SET FINDING=+$ORDER(DEFARR("E",ENODE,TERMIEN,FINDING))
if FINDING=0
QUIT
SET FIEVAL(FINDING)=0
End DoDot:2
QUIT
+13 ;If the term does not have any mapped findings set all the
+14 ;definition findings using the term to false.
+15 IF '$DATA(^PXRMD(811.5,TERMIEN,20,"E"))
Begin DoDot:2
+16 SET FINDING=0
+17 FOR
SET FINDING=+$ORDER(DEFARR("E",ENODE,TERMIEN,FINDING))
if FINDING=0
QUIT
SET FIEVAL(FINDING)=0
End DoDot:2
QUIT
+18 DO TERM^PXRMLDR(TERMIEN,.TERMARR)
+19 SET FINDING=0
+20 FOR
SET FINDING=+$ORDER(DEFARR("E",ENODE,TERMIEN,FINDING))
if FINDING=0
QUIT
Begin DoDot:2
+21 SET FIEVAL(FINDING)=0
+22 SET FIEVAL(FINDING,"TERM")=TERMARR(0)
+23 SET FIEVAL(FINDING,"TERM IEN")=TERMIEN
+24 KILL FINDPA,TFIEVAL
+25 MERGE FINDPA=DEFARR(20,FINDING)
+26 DO EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
+27 IF $GET(PXRMTDEB)
Begin DoDot:3
+28 NEW CFPARAM,COND,TFINDING
+29 SET TFINDING=0
+30 FOR
SET TFINDING=+$ORDER(TERMARR(20,TFINDING))
if TFINDING=0
QUIT
Begin DoDot:4
+31 SET COND=$PIECE($GET(TERMARR(20,TFINDING,3)),U,1)
+32 IF COND'=""
SET TFIEVAL(TFINDING,"CONDITION TEXT")=COND
+33 SET CFPARAM=$GET(TERMARR(20,TFINDING,15))
+34 IF CFPARAM'=""
SET TFIEVAL(TFINDING,"CFP TEXT")=CFPARAM
End DoDot:4
+35 MERGE ^TMP("PXRMTDEB",$JOB,FINDING)=TFIEVAL
End DoDot:3
+36 ;Set NOCC and SDIR.
+37 SET NOCC=$PIECE(FINDPA(0),U,14)
+38 IF NOCC=""
SET NOCC=1
+39 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
+40 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+41 ;Order the term findings by date.
+42 DO DORDER(.TFIEVAL,.DATEORDR)
+43 DO COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL,1)
+44 ;If the term contains immunizations, check for contraindications
+45 ;precautions and refusals and set the C/R value of the term.
+46 IF $DATA(TERMARR("E","AUTTIMM("))
IF $DATA(TFIEVAL("C/R STATUS"))
DO TERMCRFINDING^PXRMIMM(.TFIEVAL,FINDING,.FIEVAL)
+47 IF FIEVAL(FINDING)=0
QUIT
+48 IF $GET(PXRMDEBG)'=1
QUIT
+49 SET IND=0
+50 FOR
SET IND=+$ORDER(FIEVAL(FINDING,IND))
if IND=0
QUIT
Begin DoDot:3
+51 IF '$DATA(FIEVAL(FINDING,IND,"TERM FINDING"))
QUIT
+52 SET FIEVAL(FINDING,IND,"TERM FINDING")=$PIECE(TERMARR(20,FIEVAL(FINDING,IND,"TERM FINDING"),0),U,1)
End DoDot:3
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
+55 ;=============================================
EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL) ;Evaluate all the findings in
+1 ;a term. Use the "E" cross-reference just like the finding evaluation.
+2 NEW ENODE
+3 SET ENODE=""
+4 FOR
SET ENODE=$ORDER(TERMARR("E",ENODE))
if ENODE=""
QUIT
Begin DoDot:1
+5 IF ENODE="AUTTEDT("
DO EVALTERM^PXRMEDU(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+6 IF ENODE="AUTTEXAM("
DO EVALTERM^PXRMEXAM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+7 IF ENODE="AUTTHF("
DO EVALTERM^PXRMHF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+8 IF ENODE="AUTTIMM("
DO EVALTERM^PXRMIMM(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+9 IF ENODE="AUTTSK("
DO EVALTERM^PXRMSKIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+10 IF ENODE="GMRD(120.51,"
DO EVALTERM^PXRMVITL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+11 IF ENODE="LAB(60,"
DO EVALTERM^PXRMLAB(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+12 IF ENODE="ORD(101.43,"
DO EVALTERM^PXRMORDR(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+13 IF ENODE="PXD(811.2,"
DO EVALTERM^PXRMTAX(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+14 IF ENODE="PXRMD(810.9,"
DO EVALTERM^PXRMLOCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+15 IF ENODE="PXRMD(811.4,"
DO EVALTERM^PXRMCF(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+16 IF ENODE="PS(50.605,"
DO EVALTERM^PXRMDRCL(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+17 IF ENODE="PS(55,"
DO EVALTERM^PXRMDIN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+18 IF ENODE="PS(55NVA,"
DO EVALTERM^PXRMDNVA(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+19 IF ENODE="PSDRUG("
DO EVALTERM^PXRMDRUG(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+20 IF ENODE="PSRX("
DO EVALTERM^PXRMDOUT(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+21 IF ENODE="PSNDF(50.6,"
DO EVALTERM^PXRMDGEN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+22 IF ENODE="RAMIS(71,"
DO EVALTERM^PXRMRAD(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
+23 IF ENODE="YTT(601.71,"
DO EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL)
QUIT
End DoDot:1
+24 QUIT
+25 ;
+26 ;=============================================
IEVALTER(DFN,FINDPA,TERMARR,FINDING,FIEVAL) ;Evaluate an individual
+1 ;term, put the result in FIEVAL(FINDING).
+2 NEW DATEORDR,NOCC,SDIR,TFIEVAL
+3 IF '$DATA(PXRMDATE)
NEW PXRMDATE
SET PXRMDATE=DT
+4 IF $DATA(PXRMPDEM)
GOTO DEMOK
+5 NEW PXRMPDEM
DO DEM^PXRMPINF(DFN,DT,.PXRMPDEM)
+6 ;Create the local demographic variables for use in Condition.
+7 NEW PXRMAGE,PXRMDOB,PXRMDOD,PXRMLAD,PXRMSEX,PXRMSIG
+8 SET PXRMAGE=PXRMPDEM("AGE")
SET PXRMDOB=PXRMPDEM("DOB")
SET PXRMDOD=PXRMPDEM("DOD")
+9 SET PXRMLAD=PXRMPDEM("LAD")
SET PXRMSEX=PXRMPDEM("SEX")
SET PXRMSIG=PXRMPDEM("SIG")
DEMOK SET FIEVAL(FINDING)=0
+1 DO EVALTERM(DFN,.FINDPA,.TERMARR,.TFIEVAL)
+2 ;Set NOCC and SDIR.
+3 SET NOCC=$PIECE(FINDPA(0),U,14)
+4 IF NOCC=""
SET NOCC=1
+5 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
+6 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+7 ;Order the term findings by date.
+8 DO DORDER(.TFIEVAL,.DATEORDR)
+9 DO COPY(NOCC,SDIR,.TFIEVAL,.DATEORDR,FINDING,.FIEVAL,0)
+10 IF FIEVAL(FINDING)=0
QUIT
+11 IF $GET(PXRMDEBG)'=1
QUIT
+12 SET IND=0
+13 FOR
SET IND=+$ORDER(FIEVAL(FINDING,IND))
if IND=0
QUIT
Begin DoDot:1
+14 IF '$DATA(FIEVAL(FINDING,IND,"TERM FINDING"))
QUIT
+15 SET FIEVAL(FINDING,IND,"TERM FINDING")=$PIECE(TERMARR(20,FIEVAL(FINDING,IND,"TERM FINDING"),0),U,1)
End DoDot:1
+16 KILL ^TMP($JOB,"SVC",DFN)
+17 QUIT
+18 ;
+19 ;=============================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 DO OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"MHV")
+2 QUIT
+3 ;
+4 ;=============================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 DO OPT(INDENT,.IFIEVAL,.NLINES,.TEXT,"CM")
+3 QUIT
+4 ;
+5 ;=============================================
OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output.
+1 NEW DG,DGL,DGN,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
+2 ;Build the display grouping, where all findings of the same type
+3 ;are grouped together. DGN is the number of mapped findings and
+4 ;DGL is the list of groups, DGL(M)=FILE NUMBER^IEN of the finding.
+5 ;DGL(M,N)="", N is the term finding number.
+6 SET FILENUM=IFIEVAL("FILE NUMBER")
+7 SET IEN=$PIECE(IFIEVAL("FINDING"),";",1)
+8 SET DG(FILENUM,IEN)=1
SET DGL(1)=FILENUM_U_IEN
SET DGL(1,1)=""
+9 SET (DGN,IND)=1
+10 FOR
SET IND=+$ORDER(IFIEVAL(IND))
if IND=0
QUIT
Begin DoDot:1
+11 SET FILENUM=IFIEVAL(IND,"FILE NUMBER")
+12 SET IEN=$PIECE(IFIEVAL(IND,"FINDING"),";",1)
+13 IF '$DATA(DG(FILENUM,IEN))
Begin DoDot:2
+14 SET DGN=DGN+1
SET DG(FILENUM,IEN)=DGN
+15 SET DGL(DGN)=FILENUM_U_IEN
SET DGL(DGN,IND)=""
End DoDot:2
+16 IF $DATA(DG(FILENUM,IEN))
Begin DoDot:2
+17 SET TEMP=DG(FILENUM,IEN)
SET DGL(TEMP,IND)=""
End DoDot:2
End DoDot:1
+18 SET INDENTT=INDENT+1
+19 SET TEMP=$$INSCHR^PXRMEXLC(INDENT," ")_"Reminder Term: "_$PIECE(FIEVAL(FINDING,"TERM"),U,1)
+20 SET NLINES=NLINES+1
SET TEXT(NLINES)=TEMP
+21 FOR IND=1:1:DGN
Begin DoDot:1
+22 KILL TIFIEVAL
+23 SET (JND,KND)=0
+24 FOR
SET JND=$ORDER(DGL(IND,JND))
if JND=""
QUIT
Begin DoDot:2
+25 ;For immunizations, it is possible only the contra/refusal portion of
+26 ;the finding exists so check before incrementing KND.
+27 IF $DATA(IFIEVAL(JND))
SET KND=KND+1
+28 IF KND=1
MERGE TIFIEVAL=IFIEVAL(JND)
+29 MERGE TIFIEVAL(KND)=IFIEVAL(JND)
End DoDot:2
+30 IF TYPE="CM"
DO FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
+31 IF TYPE="MHV"
DO FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
End DoDot:1
+32 QUIT
+33 ;
+34 ;=============================================
SPFINDPA(FINDPA,TFINDPA,PFINDPA) ;Set the finding parameter array
+1 ;for terms.
+2 NEW FIND0,PIECE,PFIND0,TFIND0,VAL
+3 SET FIND0=$GET(FINDPA(0))
+4 SET (PFIND0,TFIND0)=TFINDPA(0)
+5 ;Set the 0 node.
+6 FOR PIECE=9,10,12,13,14,15,16
Begin DoDot:1
+7 SET VAL=$PIECE(TFIND0,U,PIECE)
+8 IF VAL=""
SET VAL=$PIECE(FIND0,U,PIECE)
+9 SET $PIECE(PFIND0,U,PIECE)=VAL
End DoDot:1
+10 ;BDT and EDT are treated as a pair.
+11 IF $PIECE(TFIND0,U,8)=""
IF $PIECE(TFIND0,U,11)=""
FOR PIECE=8,11
SET $PIECE(PFIND0,U,PIECE)=$PIECE(FIND0,U,PIECE)
+12 IF '$TEST
FOR PIECE=8,11
SET $PIECE(PFIND0,U,PIECE)=$PIECE(TFIND0,U,PIECE)
+13 SET PFINDPA(0)=PFIND0
+14 IF $PIECE($GET(TFINDPA(3)),U,1)'=""
SET PFINDPA(3)=TFINDPA(3)
SET PFINDPA(10)=TFINDPA(10)
SET PFINDPA(11)=TFINDPA(11)
+15 IF '$TEST
SET PFINDPA(3)=$GET(FINDPA(3))
SET PFINDPA(10)=$GET(FINDPA(10))
SET PFINDPA(11)=$GET(FINDPA(11))
+16 ;Get the status list.
+17 IF $DATA(TFINDPA(5))
MERGE PFINDPA(5)=TFINDPA(5)
+18 IF '$TEST
MERGE PFINDPA(5)=FINDPA(5)
+19 IF $DATA(TFINDPA(15))
SET PFINDPA(15)=TFINDPA(15)
+20 IF '$TEST
SET PFINDPA(15)=$GET(FINDPA(15))
+21 QUIT
+22 ;
