PXRMTAX ;SLC/PKR - Handle taxonomy finding. ;19-Jan-2017 14:23;DU
;;2.0;CLINICAL REMINDERS;**4,6,1001,12,18,24,26,1005,1009**;Feb 04, 2005;Build 17
;
;==================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate taxonomy findings.
N FIEVT,FINDPA,FINDING
N TAXIEN
S TAXIEN=""
F S TAXIEN=$O(DEFARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D
. S FINDING=""
. F S FINDING=$O(DEFARR("E",ENODE,TAXIEN,FINDING)) Q:+FINDING=0 D
.. K FINDPA
.. M FINDPA=DEFARR(20,FINDING)
.. K FIEVT
.. D FIEVAL(DFN,TAXIEN,.FINDPA,.FIEVT)
.. M FIEVAL(FINDING)=FIEVT
Q
;
;==================================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate taxonomy terms for
;building patient lists.
N PFIND3,PFIND4,PFINDPA,TAXIEN
N TFINDPA,TFINDING
S TAXIEN=""
F S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D
. S TFINDING=""
. F S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0 D
.. K PFINDPA,TFINDPA
.. M TFINDPA=TERMARR(20,TFINDING)
..;Set the finding parameters.
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
.. D GPLIST(TAXIEN,.PFINDPA,PLIST)
Q
;
;==================================================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate taxonomy
;terms.
N FIEVT,PFINDPA
N TAXIEN,TFINDPA,TFINDING
S TAXIEN=""
F S TAXIEN=$O(TERMARR("E",ENODE,TAXIEN)) Q:+TAXIEN=0 D
. S TFINDING=""
. F S TFINDING=$O(TERMARR("E",ENODE,TAXIEN,TFINDING)) Q:+TFINDING=0 D
.. K FIEVT,PFINDPA,TFINDPA
.. M TFINDPA=TERMARR(20,TFINDING)
..;Set the finding parameters.
.. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
.. D FIEVAL(DFN,TAXIEN,.PFINDPA,.FIEVT)
.. M TFIEVAL(TFINDING)=FIEVT
Q
;
;==================================================
FIEVAL(DFN,TAXIEN,FINDPA,FIEVAL) ;
N BDT,CASESEN,CODE,CODESYS,COND,CONVAL,DAS,DATE,EDT,ENS
N FIEVT,FILENUM,FLIST,ICOND,IND,INS,INVFD
N NFOUND,NGET,NOCC,NP,PLS
N RAS,SAVE,SDIR,STATUSA,TAXARR,TLIST,UCIFS,USEINP,VSLIST
;Set the finding search parameters.
D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
I $G(PXRMDEBG) S FIEVAL("BDTE")=BDT,FIEVAL("EDTE")=EDT
S INVFD=$P(FINDPA(0),U,16)
D TAX^PXRMLDR(TAXIEN,.TAXARR)
D SCPAR^PXRMCOND(.FINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
S SDIR=$S(NOCC<0:+1,1:-1)
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
S NGET=$S(UCIFS:50,1:NOCC)
;
;Each TLIST entry returned by the FPDAT entry points should be:
;DAS^DATE^CODESYS^CODE^NODE
;
;I TAXARR("APDS",45,"NNODES")>0 D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
;
I TAXARR("APDS",9000010.07,"NNODES")>0 D FPDAT^PXRMVPOV(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
;
I TAXARR("APDS",9000011,"NNODES")>0 D
. K STATUSA
.;IHS/MSC/MGH Patch 1009 add in call for inactive problem check
. S IHSIEN=$G(TAXARR("IEN"))
. D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA,IHSIEN)
. D FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST)
;
I (TAXARR("APDS",9000010.18,"NNODES")>0) D FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
;
;IHS/MSC/MGH for V procedure
I (TAXARR("APDS",9000010.08,"NNODES")>0) D FPDAT^BPXRMPRC(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
;
I (TAXARR("APDS",71,"NNODES")>0) D
. K STATUSA
. D GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA)
. D FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST)
;
;Process the found list, returning up to NOCC date ordered results.
S DATE="",NFOUND=0
F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D
. S IND=0
. F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D
.. S FILENUM=0
.. F S FILENUM=$O(TLIST(DATE,IND,FILENUM)) Q:FILENUM="" D
... S NFOUND=NFOUND+1
... S FLIST(NFOUND)=FILENUM_U_TLIST(DATE,IND,FILENUM)
I NFOUND=0 S FIEVAL=0 Q
S NP=0
F IND=1:1:NFOUND Q:NP=NOCC D
. S FILENUM=$P(FLIST(IND),U,1)
. S DAS=$P(FLIST(IND),U,2)
. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
. I $D(FIEVT("VISIT")) D GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0)
. S FIEVT("DATE")=$P(FLIST(IND),U,3)
. S FIEVT("CODESYS")=$P(FLIST(IND),U,4)
. S FIEVT("CODE")=$P(FLIST(IND),U,5)
. S FIEVT("NODE")=$P(FLIST(IND),U,6)
. S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1)
. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
. I SAVE D
.. S NP=NP+1
.. S FIEVAL(NP)=CONVAL
.. I COND'="" S FIEVAL(NP,"CONDITION")=CONVAL
.. S FIEVAL(NP,"DAS")=DAS
.. S FIEVAL(NP,"DATE")=FIEVT("DATE")
.. S FIEVAL(NP,"FILE NUMBER")=FILENUM
.. S FIEVAL(NP,"FILE SPECIFIC")=$P(FLIST(IND),U,6,10)
.. S FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2,"
.. M FIEVAL(NP)=FIEVT
.. I $G(PXRMDEBG) M FIEVAL(NP,"CSUB")=FIEVT
;Save the finding result.
D SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
Q
;
;==================================================
GPLIST(TAXIEN,FINDPA,PLIST) ;Get the list of patients with
;taxonomy TAXIEN. Return the list as:
; ^TMP($J,PLIST,T/F,DFN,TAXIEN,COUNT,FILE NUMBER)
; =DAS^DATE^CODE^TYPE^file specific. TAXIEN is like the item for
;non-taxonomy findings.
N BDT,COND,DATE,DFN,DLIST,EDT,ENS,FILENUM
N ICOND,IND,INS,IPLIST
N NF,NFOUND,NF,NGET,NOCC
N PLS,RAS,STATUSA,UCIFS,USEINP,TAXARR,TF,TLIST,VSLIST
;Set the finding search parameters.
S TLIST="GPLIST_PXRMTAX"
K ^TMP($J,TLIST)
D SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
D TAX^PXRMLDR(TAXIEN,.TAXARR)
D SCPAR^PXRMCOND(.FINDPA,.COND,.UCIFS,.ICOND,.VSLIST)
;
;Each TLIST entry returned by the GPLIST entry points should be:
;DAS^DATE^CODESYS^CODE^NODE
;
I TAXARR("APDS",45,"NNODES")>0 D GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,TLIST)
;
I TAXARR("APDS",9000011,"NNODES")>0 D
. K STATUSA
. D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
. D GPLIST^PXRMPROB(.TAXARR,NOCC,BDT,EDT,.STATUSA,TLIST)
;
I (TAXARR("APDS",9000010.07,"NNODES")>0) D GPLIST^PXRMVPOV(.TAXARR,NOCC,BDT,EDT,TLIST)
;
I (TAXARR("APDS",9000010.18,"NNODES")>0) D GPLIST^PXRMVCPT(.TAXARR,NOCC,BDT,EDT,TLIST)
;
I (TAXARR("APDS",71,"NNODES")>0) D GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST)
;Conditions for taxonomies only apply to radiology findings, this
;is taken care of in PXRMRCPT.
;
;Process the found list, return up to NOCC of the most recent entries.
F TF=0,1 D
. I '$D(^TMP($J,TLIST,TF)) Q
. S DFN=""
. F S DFN=$O(^TMP($J,TLIST,TF,DFN)) Q:DFN="" D
.. K DLIST,IPLIST
.. S NFOUND=0
.. S NF=""
.. F S NF=$O(^TMP($J,TLIST,TF,DFN,NF),-1) Q:NF="" D
... S FILENUM=0
... F S FILENUM=$O(^TMP($J,TLIST,TF,DFN,NF,FILENUM)) Q:FILENUM="" D
.... S NFOUND=NFOUND+1
.... S DATE=$P(^TMP($J,TLIST,TF,DFN,NF,FILENUM),U,2)
.... S DLIST(DATE,NFOUND)=NF_U_FILENUM
..;
.. S DATE="",NFOUND=0
.. F S DATE=$O(DLIST(DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
... S NF=0
... F S NF=$O(DLIST(DATE,NF)) Q:(NF="")!(NFOUND=NOCC) D
.... S NFOUND=NFOUND+1
.... S IND=$P(DLIST(DATE,NF),U,1)
.... S FILENUM=$P(DLIST(DATE,NF),U,2)
.... S IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($J,TLIST,TF,DFN,IND,FILENUM)
.. M ^TMP($J,PLIST)=IPLIST
K ^TMP($J,TLIST)
Q
;
;==================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
N IND,FILENUM,FNA,OCCLIST,TIFIEVAL
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)=""
S FILENUM=""
F S FILENUM=$O(FNA(FILENUM)) Q:FILENUM="" D
. K OCCLIST
. M OCCLIST=FNA(FILENUM)
. ;PTF file is not used in IHS
. ;I FILENUM=45 D MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=70 D MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=9000010.07 D MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=9000010.18 D MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=9000011 D MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
. ;IHS/MSC/MGH Patch 1001 V Procedure file
. I FILENUM=9000010.08 D MHVOUT^BPXRMPRC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
Q
;
;==================================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
;maintenance output.
N IND,FILENUM,FNA,OCCLIST,TIFIEVAL
S IND=0
F S IND=+$O(IFIEVAL(IND)) Q:IND=0 S FILENUM=IFIEVAL(IND,"FILE NUMBER"),FNA(FILENUM,IND)=""
S FILENUM=""
F S FILENUM=$O(FNA(FILENUM)) Q:FILENUM="" D
. K OCCLIST
. M OCCLIST=FNA(FILENUM)
. ;IHS/MSC/MGH Patch 1001 PTF file is not used in IHS
. ;I FILENUM=45 D OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=70 D OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=9000010.07 D OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=9000010.18 D OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
. I FILENUM=9000011 D OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
. ;IHS/MSC/MGH Patch 1001 V Procedure file
. I FILENUM=9000010.08 D OUTPUT^BPXRMPRC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
Q
;
PXRMTAX ;SLC/PKR - Handle taxonomy finding. ;19-Jan-2017 14:23;DU
+1 ;;2.0;CLINICAL REMINDERS;**4,6,1001,12,18,24,26,1005,1009**;Feb 04, 2005;Build 17
+2 ;
+3 ;==================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate taxonomy findings.
+1 NEW FIEVT,FINDPA,FINDING
+2 NEW TAXIEN
+3 SET TAXIEN=""
+4 FOR
SET TAXIEN=$ORDER(DEFARR("E",ENODE,TAXIEN))
IF +TAXIEN=0
QUIT
Begin DoDot:1
+5 SET FINDING=""
+6 FOR
SET FINDING=$ORDER(DEFARR("E",ENODE,TAXIEN,FINDING))
IF +FINDING=0
QUIT
Begin DoDot:2
+7 KILL FINDPA
+8 MERGE FINDPA=DEFARR(20,FINDING)
+9 KILL FIEVT
+10 DO FIEVAL(DFN,TAXIEN,.FINDPA,.FIEVT)
+11 MERGE FIEVAL(FINDING)=FIEVT
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;==================================================
EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate taxonomy terms for
+1 ;building patient lists.
+2 NEW PFIND3,PFIND4,PFINDPA,TAXIEN
+3 NEW TFINDPA,TFINDING
+4 SET TAXIEN=""
+5 FOR
SET TAXIEN=$ORDER(TERMARR("E",ENODE,TAXIEN))
IF +TAXIEN=0
QUIT
Begin DoDot:1
+6 SET TFINDING=""
+7 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,TAXIEN,TFINDING))
IF +TFINDING=0
QUIT
Begin DoDot:2
+8 KILL PFINDPA,TFINDPA
+9 MERGE TFINDPA=TERMARR(20,TFINDING)
+10 ;Set the finding parameters.
+11 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+12 DO GPLIST(TAXIEN,.PFINDPA,PLIST)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;==================================================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate taxonomy
+1 ;terms.
+2 NEW FIEVT,PFINDPA
+3 NEW TAXIEN,TFINDPA,TFINDING
+4 SET TAXIEN=""
+5 FOR
SET TAXIEN=$ORDER(TERMARR("E",ENODE,TAXIEN))
IF +TAXIEN=0
QUIT
Begin DoDot:1
+6 SET TFINDING=""
+7 FOR
SET TFINDING=$ORDER(TERMARR("E",ENODE,TAXIEN,TFINDING))
IF +TFINDING=0
QUIT
Begin DoDot:2
+8 KILL FIEVT,PFINDPA,TFINDPA
+9 MERGE TFINDPA=TERMARR(20,TFINDING)
+10 ;Set the finding parameters.
+11 DO SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+12 DO FIEVAL(DFN,TAXIEN,.PFINDPA,.FIEVT)
+13 MERGE TFIEVAL(TFINDING)=FIEVT
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;==================================================
FIEVAL(DFN,TAXIEN,FINDPA,FIEVAL) ;
+1 NEW BDT,CASESEN,CODE,CODESYS,COND,CONVAL,DAS,DATE,EDT,ENS
+2 NEW FIEVT,FILENUM,FLIST,ICOND,IND,INS,INVFD
+3 NEW NFOUND,NGET,NOCC,NP,PLS
+4 NEW RAS,SAVE,SDIR,STATUSA,TAXARR,TLIST,UCIFS,USEINP,VSLIST
+5 ;Set the finding search parameters.
+6 DO SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
+7 IF $GET(PXRMDEBG)
SET FIEVAL("BDTE")=BDT
SET FIEVAL("EDTE")=EDT
+8 SET INVFD=$PIECE(FINDPA(0),U,16)
+9 DO TAX^PXRMLDR(TAXIEN,.TAXARR)
+10 DO SCPAR^PXRMCOND(.FINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
+11 SET SDIR=$SELECT(NOCC<0:+1,1:-1)
+12 SET NOCC=$SELECT(NOCC<0:-NOCC,1:NOCC)
+13 SET NGET=$SELECT(UCIFS:50,1:NOCC)
+14 ;
+15 ;Each TLIST entry returned by the FPDAT entry points should be:
+16 ;DAS^DATE^CODESYS^CODE^NODE
+17 ;
+18 ;I TAXARR("APDS",45,"NNODES")>0 D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
+19 ;
+20 IF TAXARR("APDS",9000010.07,"NNODES")>0
DO FPDAT^PXRMVPOV(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
+21 ;
+22 IF TAXARR("APDS",9000011,"NNODES")>0
Begin DoDot:1
+23 KILL STATUSA
+24 ;IHS/MSC/MGH Patch 1009 add in call for inactive problem check
+25 SET IHSIEN=$GET(TAXARR("IEN"))
+26 DO GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA,IHSIEN)
+27 DO FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST)
End DoDot:1
+28 ;
+29 IF (TAXARR("APDS",9000010.18,"NNODES")>0)
DO FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
+30 ;
+31 ;IHS/MSC/MGH for V procedure
+32 IF (TAXARR("APDS",9000010.08,"NNODES")>0)
DO FPDAT^BPXRMPRC(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
+33 ;
+34 IF (TAXARR("APDS",71,"NNODES")>0)
Begin DoDot:1
+35 KILL STATUSA
+36 DO GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA)
+37 DO FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST)
End DoDot:1
+38 ;
+39 ;Process the found list, returning up to NOCC date ordered results.
+40 SET DATE=""
SET NFOUND=0
+41 FOR
SET DATE=$ORDER(TLIST(DATE),SDIR)
IF (DATE="")!(NFOUND=NOCC)
QUIT
Begin DoDot:1
+42 SET IND=0
+43 FOR
SET IND=$ORDER(TLIST(DATE,IND))
IF (IND="")!(NFOUND=NOCC)
QUIT
Begin DoDot:2
+44 SET FILENUM=0
+45 FOR
SET FILENUM=$ORDER(TLIST(DATE,IND,FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:3
+46 SET NFOUND=NFOUND+1
+47 SET FLIST(NFOUND)=FILENUM_U_TLIST(DATE,IND,FILENUM)
End DoDot:3
End DoDot:2
End DoDot:1
+48 IF NFOUND=0
SET FIEVAL=0
QUIT
+49 SET NP=0
+50 FOR IND=1:1:NFOUND
IF NP=NOCC
QUIT
Begin DoDot:1
+51 SET FILENUM=$PIECE(FLIST(IND),U,1)
+52 SET DAS=$PIECE(FLIST(IND),U,2)
+53 DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
+54 IF $DATA(FIEVT("VISIT"))
DO GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0)
+55 SET FIEVT("DATE")=$PIECE(FLIST(IND),U,3)
+56 SET FIEVT("CODESYS")=$PIECE(FLIST(IND),U,4)
+57 SET FIEVT("CODE")=$PIECE(FLIST(IND),U,5)
+58 SET FIEVT("NODE")=$PIECE(FLIST(IND),U,6)
+59 SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1)
+60 SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+61 IF SAVE
Begin DoDot:2
+62 SET NP=NP+1
+63 SET FIEVAL(NP)=CONVAL
+64 IF COND'=""
SET FIEVAL(NP,"CONDITION")=CONVAL
+65 SET FIEVAL(NP,"DAS")=DAS
+66 SET FIEVAL(NP,"DATE")=FIEVT("DATE")
+67 SET FIEVAL(NP,"FILE NUMBER")=FILENUM
+68 SET FIEVAL(NP,"FILE SPECIFIC")=$PIECE(FLIST(IND),U,6,10)
+69 SET FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2,"
+70 MERGE FIEVAL(NP)=FIEVT
+71 IF $GET(PXRMDEBG)
MERGE FIEVAL(NP,"CSUB")=FIEVT
End DoDot:2
End DoDot:1
+72 ;Save the finding result.
+73 DO SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
+74 QUIT
+75 ;
+76 ;==================================================
GPLIST(TAXIEN,FINDPA,PLIST) ;Get the list of patients with
+1 ;taxonomy TAXIEN. Return the list as:
+2 ; ^TMP($J,PLIST,T/F,DFN,TAXIEN,COUNT,FILE NUMBER)
+3 ; =DAS^DATE^CODE^TYPE^file specific. TAXIEN is like the item for
+4 ;non-taxonomy findings.
+5 NEW BDT,COND,DATE,DFN,DLIST,EDT,ENS,FILENUM
+6 NEW ICOND,IND,INS,IPLIST
+7 NEW NF,NFOUND,NF,NGET,NOCC
+8 NEW PLS,RAS,STATUSA,UCIFS,USEINP,TAXARR,TF,TLIST,VSLIST
+9 ;Set the finding search parameters.
+10 SET TLIST="GPLIST_PXRMTAX"
+11 KILL ^TMP($JOB,TLIST)
+12 DO SSPAR^PXRMUTIL(FINDPA(0),.NOCC,.BDT,.EDT)
+13 DO TAX^PXRMLDR(TAXIEN,.TAXARR)
+14 DO SCPAR^PXRMCOND(.FINDPA,.COND,.UCIFS,.ICOND,.VSLIST)
+15 ;
+16 ;Each TLIST entry returned by the GPLIST entry points should be:
+17 ;DAS^DATE^CODESYS^CODE^NODE
+18 ;
+19 IF TAXARR("APDS",45,"NNODES")>0
DO GPLIST^PXRMDGPT(.TAXARR,NOCC,BDT,EDT,TLIST)
+20 ;
+21 IF TAXARR("APDS",9000011,"NNODES")>0
Begin DoDot:1
+22 KILL STATUSA
+23 DO GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
+24 DO GPLIST^PXRMPROB(.TAXARR,NOCC,BDT,EDT,.STATUSA,TLIST)
End DoDot:1
+25 ;
+26 IF (TAXARR("APDS",9000010.07,"NNODES")>0)
DO GPLIST^PXRMVPOV(.TAXARR,NOCC,BDT,EDT,TLIST)
+27 ;
+28 IF (TAXARR("APDS",9000010.18,"NNODES")>0)
DO GPLIST^PXRMVCPT(.TAXARR,NOCC,BDT,EDT,TLIST)
+29 ;
+30 IF (TAXARR("APDS",71,"NNODES")>0)
DO GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST)
+31 ;Conditions for taxonomies only apply to radiology findings, this
+32 ;is taken care of in PXRMRCPT.
+33 ;
+34 ;Process the found list, return up to NOCC of the most recent entries.
+35 FOR TF=0,1
Begin DoDot:1
+36 IF '$DATA(^TMP($JOB,TLIST,TF))
QUIT
+37 SET DFN=""
+38 FOR
SET DFN=$ORDER(^TMP($JOB,TLIST,TF,DFN))
IF DFN=""
QUIT
Begin DoDot:2
+39 KILL DLIST,IPLIST
+40 SET NFOUND=0
+41 SET NF=""
+42 FOR
SET NF=$ORDER(^TMP($JOB,TLIST,TF,DFN,NF),-1)
IF NF=""
QUIT
Begin DoDot:3
+43 SET FILENUM=0
+44 FOR
SET FILENUM=$ORDER(^TMP($JOB,TLIST,TF,DFN,NF,FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:4
+45 SET NFOUND=NFOUND+1
+46 SET DATE=$PIECE(^TMP($JOB,TLIST,TF,DFN,NF,FILENUM),U,2)
+47 SET DLIST(DATE,NFOUND)=NF_U_FILENUM
End DoDot:4
End DoDot:3
+48 ;
+49 SET DATE=""
SET NFOUND=0
+50 FOR
SET DATE=$ORDER(DLIST(DATE),-1)
IF (DATE="")!(NFOUND=NOCC)
QUIT
Begin DoDot:3
+51 SET NF=0
+52 FOR
SET NF=$ORDER(DLIST(DATE,NF))
IF (NF="")!(NFOUND=NOCC)
QUIT
Begin DoDot:4
+53 SET NFOUND=NFOUND+1
+54 SET IND=$PIECE(DLIST(DATE,NF),U,1)
+55 SET FILENUM=$PIECE(DLIST(DATE,NF),U,2)
+56 SET IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($JOB,TLIST,TF,DFN,IND,FILENUM)
End DoDot:4
End DoDot:3
+57 MERGE ^TMP($JOB,PLIST)=IPLIST
End DoDot:2
End DoDot:1
+58 KILL ^TMP($JOB,TLIST)
+59 QUIT
+60 ;
+61 ;==================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
+1 NEW IND,FILENUM,FNA,OCCLIST,TIFIEVAL
+2 SET IND=0
+3 FOR
SET IND=+$ORDER(IFIEVAL(IND))
IF IND=0
QUIT
SET FILENUM=IFIEVAL(IND,"FILE NUMBER")
SET FNA(FILENUM,IND)=""
+4 SET FILENUM=""
+5 FOR
SET FILENUM=$ORDER(FNA(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+6 KILL OCCLIST
+7 MERGE OCCLIST=FNA(FILENUM)
+8 ;PTF file is not used in IHS
+9 ;I FILENUM=45 D MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+10 IF FILENUM=70
DO MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
+11 IF FILENUM=9000010.07
DO MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
+12 IF FILENUM=9000010.18
DO MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
+13 IF FILENUM=9000011
DO MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
+14 ;IHS/MSC/MGH Patch 1001 V Procedure file
+15 IF FILENUM=9000010.08
DO MHVOUT^BPXRMPRC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
End DoDot:1
+16 QUIT
+17 ;
+18 ;==================================================
OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
+1 ;maintenance output.
+2 NEW IND,FILENUM,FNA,OCCLIST,TIFIEVAL
+3 SET IND=0
+4 FOR
SET IND=+$ORDER(IFIEVAL(IND))
IF IND=0
QUIT
SET FILENUM=IFIEVAL(IND,"FILE NUMBER")
SET FNA(FILENUM,IND)=""
+5 SET FILENUM=""
+6 FOR
SET FILENUM=$ORDER(FNA(FILENUM))
IF FILENUM=""
QUIT
Begin DoDot:1
+7 KILL OCCLIST
+8 MERGE OCCLIST=FNA(FILENUM)
+9 ;IHS/MSC/MGH Patch 1001 PTF file is not used in IHS
+10 ;I FILENUM=45 D OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
+11 IF FILENUM=70
DO OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
+12 IF FILENUM=9000010.07
DO OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
+13 IF FILENUM=9000010.18
DO OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
+14 IF FILENUM=9000011
DO OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
+15 ;IHS/MSC/MGH Patch 1001 V Procedure file
+16 IF FILENUM=9000010.08
DO OUTPUT^BPXRMPRC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
QUIT
End DoDot:1
+17 QUIT
+18 ;
