PXRMDEV ;SLC/PKR - This is a driver for testing Clinical Reminders. ;06/23/2020
;;2.0;CLINICAL REMINDERS;**4,6,11,16,18,24,26,47,45,46,42**;Feb 04, 2005;Build 245
;
;===============
DEB ;Prompt for patient and reminder by name input component.
N DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,HASFF,HASTERM,IND
N PXRHM,PXRMFFSS,PXRMITEM,PXRMTDEB,X,Y
S DIC=2,DIC("A")="Select Patient: "
S DIC(0)="AEQMZ"
GPAT1 D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S DFN=+$P(Y,U,1)
I DFN=-1 G GPAT1
S DIC=811.9,DIC("A")="Select Reminder: "
GREM1 D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S PXRMITEM=+$P(Y,U,1)
I PXRMITEM=-1 G GREM1
S DIR(0)="LA"_U_"0"
S DIR("A")="Enter component number 0, 1, 5, 10, 11, 12, 55: "
D ^DIR
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
I X="" S X=5
S PXRHM=X
S DIR(0)="DA^"_0_"::ETX"
S DIR("A")="Enter date for reminder evaluation: "
S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
W !
D ^DIR K DIR
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S DATE=Y
S (HASFF,HASTERM,PXRMFFSS,PXRMTDEB)=0
I $D(^PXD(811.9,PXRMITEM,25,"B")) S HASFF=1
I HASFF S PXRMFFSS=$$ASKYN^PXRMEUT("N","Display step-by-step function finding evaluation","","")
I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S HASTERM=1
I 'HASTERM D
. S IND=0
. F S IND=+$O(^PXD(811.9,PXRMITEM,20,"EDEP",IND)) Q:IND=0 D
.. I $D(^PXD(811.9,PXRMITEM,20,"EDEP",IND,"PXRMD(811.5,")) S HASTERM=1
I HASTERM S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
D DOREM(DFN,PXRMITEM,PXRHM,DATE)
Q
;
;===============
DEV ;Prompt for patient and reminder by name and evaluation date.
N DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,HASFF,HASTERM,IND
N PXRHM,PXRMFFSS,PXRMITEM,PXRMTDEB,REF,X,Y
S DIC=2,DIC("A")="Select Patient: "
S DIC(0)="AEQMZ"
GPAT2 D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S DFN=+$P(Y,U,1)
I DFN=-1 G GPAT2
S DIC=811.9,DIC("A")="Select Reminder: "
GREM2 D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S PXRMITEM=+$P(Y,U,1)
I PXRMITEM=-1 G GREM2
S PXRHM=5
S DIR(0)="DA^"_0_"::ET"
S DIR("A")="Enter date for reminder evaluation: "
S DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
S DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
W !
D ^DIR K DIR
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S DATE=Y
S (HASFF,HASTERM,PXRMFFSS,PXRMTDEB)=0
I $D(^PXD(811.9,PXRMITEM,25,"B")) S HASFF=1
I HASFF S PXRMFFSS=$$ASKYN^PXRMEUT("N","Display step-by-step function finding evaluation","","")
I $D(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,")) S HASTERM=1
I 'HASTERM D
. S IND=0
. F S IND=+$O(^PXD(811.9,PXRMITEM,20,"EDEP",IND)) Q:IND=0 D
.. I $D(^PXD(811.9,PXRMITEM,20,"EDEP",IND,"PXRMD(811.5,")) S HASTERM=1
I HASTERM S PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
D DOREM(DFN,PXRMITEM,PXRHM,DATE)
Q
;
;===============
DISP01(FIEVAL) ;For Education Topics, Exams, and Health Factors the Print Name
;is displayed in the Clinical Maintenance Output. Since Print Names
;are not unique it can be difficult to determine what the actual
;finding is so display the .01.
N IEN,IND
S IND=0
F S IND=+$O(FIEVAL(IND)) Q:IND=0 D
. I FIEVAL(IND)=0 Q
. S IEN=$P(FIEVAL(IND,"FINDING"),";",1)
. I FIEVAL(IND,"FILE NUMBER")=9000010.16 S FIEVAL(IND,"NAME")=$P(^AUTTEDT(IEN,0),U,1)
. I FIEVAL(IND,"FILE NUMBER")=9000010.13 S FIEVAL(IND,"NAME")=$P(^AUTTEXAM(IEN,0),U,1)
. I FIEVAL(IND,"FILE NUMBER")=9000010.23 S FIEVAL(IND,"FACTOR")=$P(^AUTTHF(IEN,0),U,1)
Q
;
;===============
DOREM(DFN,PXRMITEM,PXRHM,DATE) ;Do the reminder
;Reference to XLFSHAN ICR #6157
N BOP,DEFARR,END,FFN,FFNUMBER,FIEVAL,FINDING,IND,JND,NL,NOUT,OUTPUT
N PNAME,PXRMDEBG,PXRMID,REF,RIEN,RNAME,START,STATUS
N TEXT,TEXTOUT,TFIEVAL,TTEXT,WSTART,WEND,X
;This is a debugging run so set PXRMDEBG.
S NL=0,PXRMDEBG=1
S WSTART=$H
S START=$$CPUTIME^XLFSHAN
D DEF^PXRMLDR(PXRMITEM,.DEFARR)
I +$G(DATE)=0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL)
I +$G(DATE)>0 D EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE)
S END=$$CPUTIME^XLFSHAN
S WEND=$H
;
I $D(^TMP(PXRMID,$J,"FFDEB")) M FIEVAL=^TMP(PXRMID,$J,"FFDEB") K ^TMP(PXRMID,$J,"FFDEB")
;
S TTEXT=^PXD(811.9,PXRMITEM,0)
S PNAME=$P(TTEXT,U,2)
I PNAME="" S PNAME=$P(TTEXT,U,1)
S NL=NL+1,OUTPUT(NL)="Reminder: "_PNAME
S NL=NL+1,OUTPUT(NL)="Patient: "_$$GET1^DIQ(2,DFN,.01)
S NL=NL+1,OUTPUT(NL)="Reminder evaluation cpu time: "_$$ETIMEMS^XLFSHAN(START,END)
S NL=NL+1,OUTPUT(NL)="Reminder evaluation clock time: "_$$HDIFF^XLFDT(WEND,WSTART,2)_" seconds"
S NL=NL+1,OUTPUT(NL)=" "
S NL=NL+1,OUTPUT(NL)="The elements of the FIEVAL array are:"
S FFN="FF"
F S FFN=$O(FIEVAL(FFN)) Q:FFN'["FF" D
. S FFNUMBER=$P(FFN,"FF",2)
. M FIEVAL("FF",FFNUMBER)=FIEVAL(FFN)
. K FIEVAL(FFN)
D DISP01(.FIEVAL)
S REF="FIEVAL"
D ACOPY^PXRMUTIL(REF,"TTEXT()")
S IND=0
F S IND=$O(TTEXT(IND)) Q:IND="" D
. I $L(TTEXT(IND))<79 S NL=NL+1,OUTPUT(NL)=TTEXT(IND) Q
. D FORMATS^PXRMTEXT(1,79,TTEXT(IND),.NOUT,.TEXTOUT)
. F JND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(JND)
;
I $G(PXRMFFSS) D
. N FFN,STEP
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="Step-by-step function finding evaluation:"
. S FFNUMBER=0
. F S FFNUMBER=+$O(FIEVAL("FF",FFNUMBER)) Q:FFNUMBER=0 D
.. S NL=NL+1,OUTPUT(NL)=""
.. S NL=NL+1,OUTPUT(NL)=" Function finding "_FFNUMBER_"="_FIEVAL("FF",FFNUMBER)
.. D FORMATS^PXRMTEXT(1,79,$P(FIEVAL("FF",FFNUMBER,"DETAIL"),U,2),.NOUT,.TEXTOUT)
.. S FFN="FF"_FFNUMBER
.. F JND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(JND)
.. S NL=NL+1,OUTPUT(NL)=" = "_^TMP("PXRMFFSS",$J,FFN,0)
.. S NL=NL+1,OUTPUT(NL)="Step Result"
.. S STEP=0
.. F S STEP=$O(^TMP("PXRMFFSS",$J,FFN,STEP)) Q:STEP="" D
... S NL=NL+1,OUTPUT(NL)=$$RJ^XLFSTR(STEP_".",4," ")_" "_^TMP("PXRMFFSS",$J,FFN,STEP)
. K ^TMP("PXRMFFSS",$J)
.;
I $G(PXRMTDEB) D
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="Term findings:"
. S REF="TFIEVAL"
. S FINDING=0
. F S FINDING=$O(^TMP("PXRMTDEB",$J,FINDING)) Q:FINDING="" D
.. K TFIEVAL M TFIEVAL(FINDING)=^TMP("PXRMTDEB",$J,FINDING)
.. S NL=NL+1,OUTPUT(NL)="Finding "_FINDING_":"
.. K TTEXT
.. D ACOPY^PXRMUTIL(REF,"TTEXT()")
.. S IND=0
.. F S IND=$O(TTEXT(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=TTEXT(IND)
. K ^TMP("PXRMTDEB",$J)
;
;If CF.VA-ELIGIBILITY has been used as a finding display the VAEL array.
I $D(^TMP("PXRMELIG",$J)) D
. N VAEL
. M VAEL=^TMP("PXRMELIG",$J)
. K ^TMP("PXRMELIG",$J),TTEXT
. D ACOPY^PXRMUTIL("VAEL","TTEXT()")
. S NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="VAEL array returned by ELIG^VADPT:"
. S IND=0
. F S IND=$O(TTEXT(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=TTEXT(IND)
;
;Display the demographic variables.
S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
S NL=NL+1,OUTPUT(NL)="The demographic variables are:"
S IND=""
F S IND=$O(^TMP("PXRMDEM",$J,IND)) Q:IND="" D
. S TEXT=^TMP("PXRMDEM",$J,IND)
. I (IND="DOB")!(IND="DOD")!(IND="LAD") S TEXT=$$FMTE^XLFDT(TEXT,"5Z")
. S NL=NL+1,OUTPUT(NL)=IND_"="_TEXT
K ^TMP("PXRMDEM",$J)
;
I $D(^TMP(PXRMID,$J)) D
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="The elements of the ^TMP(PXRMID,$J) array are:"
. S REF="^TMP(PXRMID,$J)"
. K TTEXT
. D ACOPY^PXRMUTIL(REF,"TTEXT()")
. S IND=0
. F S IND=$O(TTEXT(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=TTEXT(IND)
. K ^TMP(PXRMID,$J)
;
I $D(^TMP("PXRHM",$J)) D
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="The elements of the ^TMP(""PXRHM"",$J) array are:"
. S REF="^TMP(""PXRHM"",$J)"
. K TTEXT
. D ACOPY^PXRMUTIL(REF,"TTEXT()")
. S IND=0
. F S IND=$O(TTEXT(IND)) Q:IND="" S NL=NL+1,OUTPUT(NL)=TTEXT(IND)
;
I (PXRHM=0)!(PXRHM=1)!(PXRHM=5)!(PXRHM=55) D
. S TEXT=$S(PXRHM=0:"Due Now ",PXRHM=1:"Summary ",PXRHM=5:"Clinical Maintenance ",PXRHM=55:"Order Check ",1:"")
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)=TEXT_"Output:"
. D FMTOUT^PXRMFMTO("PXRHM",.NL,.OUTPUT)
I (PXRHM=10)!(PXRHM=11) D
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="MHV "_$S(PXRHM=10:"Summary",PXRHM=11:"Detailed")_" Output:"
. S RIEN=$O(^TMP("PXRHM",$J,""))
. S RNAME=$O(^TMP("PXRHM",$J,RIEN,""))
. S STATUS=$P($G(^TMP("PXRHM",$J,RIEN,RNAME)),U,1)
. I STATUS="" S STATUS="UNKNOWN"
. M ^TMP("PXRMMHV",$J,STATUS,RNAME,RIEN)=^TMP("PXRHM",$J,RIEN,RNAME)
. D MHVOUT^PXRMFMTO("PXRMMHV",STATUS,RNAME,RIEN,.NL,.OUTPUT)
I PXRHM=12 D
. S NL=NL+1,OUTPUT(NL)="",NL=NL+1,OUTPUT(NL)=""
. S NL=NL+1,OUTPUT(NL)="MHV Combined Output:"
. D MHVCOUT^PXRMFMTO("PXRMMHVC",.NL,.OUTPUT)
K ^TMP("PXRM",$J),^TMP("PXRHM",$J),^TMP("PXRMMHV",$J),^TMP("PXRMMHVC",$J)
S BOP=$$BORP^PXRMUTIL("P")
I BOP="B" D
. S X="IORESET"
. D ENDR^%ZISS
. D BROWSE^DDBR("OUTPUT","NR","Reminder Test")
. W IORESET
. D KILL^%ZISS
I BOP="P" D GPRINT^PXRMUTIL("OUTPUT")
Q
;
;===============
TERM ;
N DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT
N FIEVAL,FINDPA,IND,MAXOCC,OCC,TERMIEN,TERMARR
S DIC=2,DIC("A")="Select Patient: "
S DIC(0)="AEQMZ"
TPAT D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S DFN=+$P(Y,U,1)
I DFN=-1 G TPAT
S DIC=811.5,DIC("A")="Select Reminder Term: "
TTERM D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
S TERMIEN=+$P(Y,U,1)
I TERMIEN=-1 G TTERM
D TERM^PXRMLDR(TERMIEN,.TERMARR)
S IND=0,MAXOCC=1
F S IND=+$O(TERMARR(20,IND)) Q:IND=0 D
. I $P(TERMARR(20,IND,3),U,3)=1 S MAXOCC=50 Q
. S OCC=+$P(TERMARR(20,IND,0),U,14)
. I OCC>MAXOCC S MAXOCC=OCC
S $P(FINDPA(0),U,14)=MAXOCC
D IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.FIEVAL)
D DISP01(.FIEVAL)
W !,"The term is "_$S($G(FIEVAL(1))=1:"True",1:"False")
W !,"FIEVAL:"
D AWRITE^PXRMUTIL("FIEVAL")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDEV 9949 printed Dec 13, 2024@01:43:41 Page 2
PXRMDEV ;SLC/PKR - This is a driver for testing Clinical Reminders. ;06/23/2020
+1 ;;2.0;CLINICAL REMINDERS;**4,6,11,16,18,24,26,47,45,46,42**;Feb 04, 2005;Build 245
+2 ;
+3 ;===============
DEB ;Prompt for patient and reminder by name input component.
+1 NEW DATE,DFN,DIC,DIR,DIROUT,DTOUT,DUOUT,HASFF,HASTERM,IND
+2 NEW PXRHM,PXRMFFSS,PXRMITEM,PXRMTDEB,X,Y
+3 SET DIC=2
SET DIC("A")="Select Patient: "
+4 SET DIC(0)="AEQMZ"
GPAT1 DO ^DIC
+1 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET DFN=+$PIECE(Y,U,1)
+4 IF DFN=-1
GOTO GPAT1
+5 SET DIC=811.9
SET DIC("A")="Select Reminder: "
GREM1 DO ^DIC
+1 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET PXRMITEM=+$PIECE(Y,U,1)
+4 IF PXRMITEM=-1
GOTO GREM1
+5 SET DIR(0)="LA"_U_"0"
+6 SET DIR("A")="Enter component number 0, 1, 5, 10, 11, 12, 55: "
+7 DO ^DIR
+8 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+9 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+10 IF X=""
SET X=5
+11 SET PXRHM=X
+12 SET DIR(0)="DA^"_0_"::ETX"
+13 SET DIR("A")="Enter date for reminder evaluation: "
+14 SET DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
+15 SET DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
+16 WRITE !
+17 DO ^DIR
KILL DIR
+18 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+19 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+20 SET DATE=Y
+21 SET (HASFF,HASTERM,PXRMFFSS,PXRMTDEB)=0
+22 IF $DATA(^PXD(811.9,PXRMITEM,25,"B"))
SET HASFF=1
+23 IF HASFF
SET PXRMFFSS=$$ASKYN^PXRMEUT("N","Display step-by-step function finding evaluation","","")
+24 IF $DATA(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,"))
SET HASTERM=1
+25 IF 'HASTERM
Begin DoDot:1
+26 SET IND=0
+27 FOR
SET IND=+$ORDER(^PXD(811.9,PXRMITEM,20,"EDEP",IND))
if IND=0
QUIT
Begin DoDot:2
+28 IF $DATA(^PXD(811.9,PXRMITEM,20,"EDEP",IND,"PXRMD(811.5,"))
SET HASTERM=1
End DoDot:2
End DoDot:1
+29 IF HASTERM
SET PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
+30 DO DOREM(DFN,PXRMITEM,PXRHM,DATE)
+31 QUIT
+32 ;
+33 ;===============
DEV ;Prompt for patient and reminder by name and evaluation date.
+1 NEW DATE,DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT,HASFF,HASTERM,IND
+2 NEW PXRHM,PXRMFFSS,PXRMITEM,PXRMTDEB,REF,X,Y
+3 SET DIC=2
SET DIC("A")="Select Patient: "
+4 SET DIC(0)="AEQMZ"
GPAT2 DO ^DIC
+1 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET DFN=+$PIECE(Y,U,1)
+4 IF DFN=-1
GOTO GPAT2
+5 SET DIC=811.9
SET DIC("A")="Select Reminder: "
GREM2 DO ^DIC
+1 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET PXRMITEM=+$PIECE(Y,U,1)
+4 IF PXRMITEM=-1
GOTO GREM2
+5 SET PXRHM=5
+6 SET DIR(0)="DA^"_0_"::ET"
+7 SET DIR("A")="Enter date for reminder evaluation: "
+8 SET DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,"D")
+9 SET DIR("PRE")="S X=$$DCHECK^PXRMDATE(X) K:X=-1 X"
+10 WRITE !
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+13 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+14 SET DATE=Y
+15 SET (HASFF,HASTERM,PXRMFFSS,PXRMTDEB)=0
+16 IF $DATA(^PXD(811.9,PXRMITEM,25,"B"))
SET HASFF=1
+17 IF HASFF
SET PXRMFFSS=$$ASKYN^PXRMEUT("N","Display step-by-step function finding evaluation","","")
+18 IF $DATA(^PXD(811.9,PXRMITEM,20,"E","PXRMD(811.5,"))
SET HASTERM=1
+19 IF 'HASTERM
Begin DoDot:1
+20 SET IND=0
+21 FOR
SET IND=+$ORDER(^PXD(811.9,PXRMITEM,20,"EDEP",IND))
if IND=0
QUIT
Begin DoDot:2
+22 IF $DATA(^PXD(811.9,PXRMITEM,20,"EDEP",IND,"PXRMD(811.5,"))
SET HASTERM=1
End DoDot:2
End DoDot:1
+23 IF HASTERM
SET PXRMTDEB=$$ASKYN^PXRMEUT("N","Display all term findings","","")
+24 DO DOREM(DFN,PXRMITEM,PXRHM,DATE)
+25 QUIT
+26 ;
+27 ;===============
DISP01(FIEVAL) ;For Education Topics, Exams, and Health Factors the Print Name
+1 ;is displayed in the Clinical Maintenance Output. Since Print Names
+2 ;are not unique it can be difficult to determine what the actual
+3 ;finding is so display the .01.
+4 NEW IEN,IND
+5 SET IND=0
+6 FOR
SET IND=+$ORDER(FIEVAL(IND))
if IND=0
QUIT
Begin DoDot:1
+7 IF FIEVAL(IND)=0
QUIT
+8 SET IEN=$PIECE(FIEVAL(IND,"FINDING"),";",1)
+9 IF FIEVAL(IND,"FILE NUMBER")=9000010.16
SET FIEVAL(IND,"NAME")=$PIECE(^AUTTEDT(IEN,0),U,1)
+10 IF FIEVAL(IND,"FILE NUMBER")=9000010.13
SET FIEVAL(IND,"NAME")=$PIECE(^AUTTEXAM(IEN,0),U,1)
+11 IF FIEVAL(IND,"FILE NUMBER")=9000010.23
SET FIEVAL(IND,"FACTOR")=$PIECE(^AUTTHF(IEN,0),U,1)
End DoDot:1
+12 QUIT
+13 ;
+14 ;===============
DOREM(DFN,PXRMITEM,PXRHM,DATE) ;Do the reminder
+1 ;Reference to XLFSHAN ICR #6157
+2 NEW BOP,DEFARR,END,FFN,FFNUMBER,FIEVAL,FINDING,IND,JND,NL,NOUT,OUTPUT
+3 NEW PNAME,PXRMDEBG,PXRMID,REF,RIEN,RNAME,START,STATUS
+4 NEW TEXT,TEXTOUT,TFIEVAL,TTEXT,WSTART,WEND,X
+5 ;This is a debugging run so set PXRMDEBG.
+6 SET NL=0
SET PXRMDEBG=1
+7 SET WSTART=$HOROLOG
+8 SET START=$$CPUTIME^XLFSHAN
+9 DO DEF^PXRMLDR(PXRMITEM,.DEFARR)
+10 IF +$GET(DATE)=0
DO EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL)
+11 IF +$GET(DATE)>0
DO EVAL^PXRM(DFN,.DEFARR,PXRHM,1,.FIEVAL,DATE)
+12 SET END=$$CPUTIME^XLFSHAN
+13 SET WEND=$HOROLOG
+14 ;
+15 IF $DATA(^TMP(PXRMID,$JOB,"FFDEB"))
MERGE FIEVAL=^TMP(PXRMID,$JOB,"FFDEB")
KILL ^TMP(PXRMID,$JOB,"FFDEB")
+16 ;
+17 SET TTEXT=^PXD(811.9,PXRMITEM,0)
+18 SET PNAME=$PIECE(TTEXT,U,2)
+19 IF PNAME=""
SET PNAME=$PIECE(TTEXT,U,1)
+20 SET NL=NL+1
SET OUTPUT(NL)="Reminder: "_PNAME
+21 SET NL=NL+1
SET OUTPUT(NL)="Patient: "_$$GET1^DIQ(2,DFN,.01)
+22 SET NL=NL+1
SET OUTPUT(NL)="Reminder evaluation cpu time: "_$$ETIMEMS^XLFSHAN(START,END)
+23 SET NL=NL+1
SET OUTPUT(NL)="Reminder evaluation clock time: "_$$HDIFF^XLFDT(WEND,WSTART,2)_" seconds"
+24 SET NL=NL+1
SET OUTPUT(NL)=" "
+25 SET NL=NL+1
SET OUTPUT(NL)="The elements of the FIEVAL array are:"
+26 SET FFN="FF"
+27 FOR
SET FFN=$ORDER(FIEVAL(FFN))
if FFN'["FF"
QUIT
Begin DoDot:1
+28 SET FFNUMBER=$PIECE(FFN,"FF",2)
+29 MERGE FIEVAL("FF",FFNUMBER)=FIEVAL(FFN)
+30 KILL FIEVAL(FFN)
End DoDot:1
+31 DO DISP01(.FIEVAL)
+32 SET REF="FIEVAL"
+33 DO ACOPY^PXRMUTIL(REF,"TTEXT()")
+34 SET IND=0
+35 FOR
SET IND=$ORDER(TTEXT(IND))
if IND=""
QUIT
Begin DoDot:1
+36 IF $LENGTH(TTEXT(IND))<79
SET NL=NL+1
SET OUTPUT(NL)=TTEXT(IND)
QUIT
+37 DO FORMATS^PXRMTEXT(1,79,TTEXT(IND),.NOUT,.TEXTOUT)
+38 FOR JND=1:1:NOUT
SET NL=NL+1
SET OUTPUT(NL)=TEXTOUT(JND)
End DoDot:1
+39 ;
+40 IF $GET(PXRMFFSS)
Begin DoDot:1
+41 NEW FFN,STEP
+42 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+43 SET NL=NL+1
SET OUTPUT(NL)="Step-by-step function finding evaluation:"
+44 SET FFNUMBER=0
+45 FOR
SET FFNUMBER=+$ORDER(FIEVAL("FF",FFNUMBER))
if FFNUMBER=0
QUIT
Begin DoDot:2
+46 SET NL=NL+1
SET OUTPUT(NL)=""
+47 SET NL=NL+1
SET OUTPUT(NL)=" Function finding "_FFNUMBER_"="_FIEVAL("FF",FFNUMBER)
+48 DO FORMATS^PXRMTEXT(1,79,$PIECE(FIEVAL("FF",FFNUMBER,"DETAIL"),U,2),.NOUT,.TEXTOUT)
+49 SET FFN="FF"_FFNUMBER
+50 FOR JND=1:1:NOUT
SET NL=NL+1
SET OUTPUT(NL)=TEXTOUT(JND)
+51 SET NL=NL+1
SET OUTPUT(NL)=" = "_^TMP("PXRMFFSS",$JOB,FFN,0)
+52 SET NL=NL+1
SET OUTPUT(NL)="Step Result"
+53 SET STEP=0
+54 FOR
SET STEP=$ORDER(^TMP("PXRMFFSS",$JOB,FFN,STEP))
if STEP=""
QUIT
Begin DoDot:3
+55 SET NL=NL+1
SET OUTPUT(NL)=$$RJ^XLFSTR(STEP_".",4," ")_" "_^TMP("PXRMFFSS",$JOB,FFN,STEP)
End DoDot:3
End DoDot:2
+56 KILL ^TMP("PXRMFFSS",$JOB)
+57 ;
End DoDot:1
+58 IF $GET(PXRMTDEB)
Begin DoDot:1
+59 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+60 SET NL=NL+1
SET OUTPUT(NL)="Term findings:"
+61 SET REF="TFIEVAL"
+62 SET FINDING=0
+63 FOR
SET FINDING=$ORDER(^TMP("PXRMTDEB",$JOB,FINDING))
if FINDING=""
QUIT
Begin DoDot:2
+64 KILL TFIEVAL
MERGE TFIEVAL(FINDING)=^TMP("PXRMTDEB",$JOB,FINDING)
+65 SET NL=NL+1
SET OUTPUT(NL)="Finding "_FINDING_":"
+66 KILL TTEXT
+67 DO ACOPY^PXRMUTIL(REF,"TTEXT()")
+68 SET IND=0
+69 FOR
SET IND=$ORDER(TTEXT(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=TTEXT(IND)
End DoDot:2
+70 KILL ^TMP("PXRMTDEB",$JOB)
End DoDot:1
+71 ;
+72 ;If CF.VA-ELIGIBILITY has been used as a finding display the VAEL array.
+73 IF $DATA(^TMP("PXRMELIG",$JOB))
Begin DoDot:1
+74 NEW VAEL
+75 MERGE VAEL=^TMP("PXRMELIG",$JOB)
+76 KILL ^TMP("PXRMELIG",$JOB),TTEXT
+77 DO ACOPY^PXRMUTIL("VAEL","TTEXT()")
+78 SET NL=NL+1
SET OUTPUT(NL)=""
+79 SET NL=NL+1
SET OUTPUT(NL)="VAEL array returned by ELIG^VADPT:"
+80 SET IND=0
+81 FOR
SET IND=$ORDER(TTEXT(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=TTEXT(IND)
End DoDot:1
+82 ;
+83 ;Display the demographic variables.
+84 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+85 SET NL=NL+1
SET OUTPUT(NL)="The demographic variables are:"
+86 SET IND=""
+87 FOR
SET IND=$ORDER(^TMP("PXRMDEM",$JOB,IND))
if IND=""
QUIT
Begin DoDot:1
+88 SET TEXT=^TMP("PXRMDEM",$JOB,IND)
+89 IF (IND="DOB")!(IND="DOD")!(IND="LAD")
SET TEXT=$$FMTE^XLFDT(TEXT,"5Z")
+90 SET NL=NL+1
SET OUTPUT(NL)=IND_"="_TEXT
End DoDot:1
+91 KILL ^TMP("PXRMDEM",$JOB)
+92 ;
+93 IF $DATA(^TMP(PXRMID,$JOB))
Begin DoDot:1
+94 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+95 SET NL=NL+1
SET OUTPUT(NL)="The elements of the ^TMP(PXRMID,$J) array are:"
+96 SET REF="^TMP(PXRMID,$J)"
+97 KILL TTEXT
+98 DO ACOPY^PXRMUTIL(REF,"TTEXT()")
+99 SET IND=0
+100 FOR
SET IND=$ORDER(TTEXT(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=TTEXT(IND)
+101 KILL ^TMP(PXRMID,$JOB)
End DoDot:1
+102 ;
+103 IF $DATA(^TMP("PXRHM",$JOB))
Begin DoDot:1
+104 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+105 SET NL=NL+1
SET OUTPUT(NL)="The elements of the ^TMP(""PXRHM"",$J) array are:"
+106 SET REF="^TMP(""PXRHM"",$J)"
+107 KILL TTEXT
+108 DO ACOPY^PXRMUTIL(REF,"TTEXT()")
+109 SET IND=0
+110 FOR
SET IND=$ORDER(TTEXT(IND))
if IND=""
QUIT
SET NL=NL+1
SET OUTPUT(NL)=TTEXT(IND)
End DoDot:1
+111 ;
+112 IF (PXRHM=0)!(PXRHM=1)!(PXRHM=5)!(PXRHM=55)
Begin DoDot:1
+113 SET TEXT=$SELECT(PXRHM=0:"Due Now ",PXRHM=1:"Summary ",PXRHM=5:"Clinical Maintenance ",PXRHM=55:"Order Check ",1:"")
+114 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+115 SET NL=NL+1
SET OUTPUT(NL)=TEXT_"Output:"
+116 DO FMTOUT^PXRMFMTO("PXRHM",.NL,.OUTPUT)
End DoDot:1
+117 IF (PXRHM=10)!(PXRHM=11)
Begin DoDot:1
+118 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+119 SET NL=NL+1
SET OUTPUT(NL)="MHV "_$SELECT(PXRHM=10:"Summary",PXRHM=11:"Detailed")_" Output:"
+120 SET RIEN=$ORDER(^TMP("PXRHM",$JOB,""))
+121 SET RNAME=$ORDER(^TMP("PXRHM",$JOB,RIEN,""))
+122 SET STATUS=$PIECE($GET(^TMP("PXRHM",$JOB,RIEN,RNAME)),U,1)
+123 IF STATUS=""
SET STATUS="UNKNOWN"
+124 MERGE ^TMP("PXRMMHV",$JOB,STATUS,RNAME,RIEN)=^TMP("PXRHM",$JOB,RIEN,RNAME)
+125 DO MHVOUT^PXRMFMTO("PXRMMHV",STATUS,RNAME,RIEN,.NL,.OUTPUT)
End DoDot:1
+126 IF PXRHM=12
Begin DoDot:1
+127 SET NL=NL+1
SET OUTPUT(NL)=""
SET NL=NL+1
SET OUTPUT(NL)=""
+128 SET NL=NL+1
SET OUTPUT(NL)="MHV Combined Output:"
+129 DO MHVCOUT^PXRMFMTO("PXRMMHVC",.NL,.OUTPUT)
End DoDot:1
+130 KILL ^TMP("PXRM",$JOB),^TMP("PXRHM",$JOB),^TMP("PXRMMHV",$JOB),^TMP("PXRMMHVC",$JOB)
+131 SET BOP=$$BORP^PXRMUTIL("P")
+132 IF BOP="B"
Begin DoDot:1
+133 SET X="IORESET"
+134 DO ENDR^%ZISS
+135 DO BROWSE^DDBR("OUTPUT","NR","Reminder Test")
+136 WRITE IORESET
+137 DO KILL^%ZISS
End DoDot:1
+138 IF BOP="P"
DO GPRINT^PXRMUTIL("OUTPUT")
+139 QUIT
+140 ;
+141 ;===============
TERM ;
+1 NEW DFN,DIC,DIROUT,DIRUT,DTOUT,DUOUT
+2 NEW FIEVAL,FINDPA,IND,MAXOCC,OCC,TERMIEN,TERMARR
+3 SET DIC=2
SET DIC("A")="Select Patient: "
+4 SET DIC(0)="AEQMZ"
TPAT DO ^DIC
+1 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET DFN=+$PIECE(Y,U,1)
+4 IF DFN=-1
GOTO TPAT
+5 SET DIC=811.5
SET DIC("A")="Select Reminder Term: "
TTERM DO ^DIC
+1 IF $DATA(DIROUT)!$DATA(DIRUT)
QUIT
+2 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+3 SET TERMIEN=+$PIECE(Y,U,1)
+4 IF TERMIEN=-1
GOTO TTERM
+5 DO TERM^PXRMLDR(TERMIEN,.TERMARR)
+6 SET IND=0
SET MAXOCC=1
+7 FOR
SET IND=+$ORDER(TERMARR(20,IND))
if IND=0
QUIT
Begin DoDot:1
+8 IF $PIECE(TERMARR(20,IND,3),U,3)=1
SET MAXOCC=50
QUIT
+9 SET OCC=+$PIECE(TERMARR(20,IND,0),U,14)
+10 IF OCC>MAXOCC
SET MAXOCC=OCC
End DoDot:1
+11 SET $PIECE(FINDPA(0),U,14)=MAXOCC
+12 DO IEVALTER^PXRMTERM(DFN,.FINDPA,.TERMARR,1,.FIEVAL)
+13 DO DISP01(.FIEVAL)
+14 WRITE !,"The term is "_$SELECT($GET(FIEVAL(1))=1:"True",1:"False")
+15 WRITE !,"FIEVAL:"
+16 DO AWRITE^PXRMUTIL("FIEVAL")
+17 QUIT
+18 ;
