- PXRMTAX ;SLC/PKR - Handle taxonomy finding. ;12/09/2020
- ;;2.0;CLINICAL REMINDERS;**4,6,12,18,24,26,42**;Feb 04, 2005;Build 245
- ;
- ;==================================================
- 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,INCVD,IND,INS
- 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 INCVD=$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
- . D GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
- . 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)
- ;
- I (TAXARR("APDS",9000010.71,"NNODES")>0) D FPDAT^PXRMVSC(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 INCVD,$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",9000010.71,"NNODES")>0) D GPLIST^PXRMVSC(.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)
- . 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=9000010.71 D MHVOUT^PXRMVSC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
- . I FILENUM=9000011 D MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- 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)
- . 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=9000010.71 D OUTPUT^PXRMVSC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT) Q
- . I FILENUM=9000011 D OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTAX 8664 printed Feb 18, 2025@23:15:42 Page 2
- PXRMTAX ;SLC/PKR - Handle taxonomy finding. ;12/09/2020
- +1 ;;2.0;CLINICAL REMINDERS;**4,6,12,18,24,26,42**;Feb 04, 2005;Build 245
- +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,INCVD,IND,INS
- +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 INCVD=$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 IF TAXARR("APDS",45,"NNODES")>0
- DO 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 DO GETSTATI^PXRMSTAT(9000011,.FINDPA,.STATUSA)
- +25 DO FPDAT^PXRMPROB(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.STATUSA,.TLIST)
- End DoDot:1
- +26 ;
- +27 IF (TAXARR("APDS",9000010.18,"NNODES")>0)
- DO FPDAT^PXRMVCPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
- +28 ;
- +29 IF (TAXARR("APDS",9000010.71,"NNODES")>0)
- DO FPDAT^PXRMVSC(DFN,.TAXARR,NGET,SDIR,BDT,EDT,.TLIST)
- +30 ;
- +31 IF (TAXARR("APDS",71,"NNODES")>0)
- Begin DoDot:1
- +32 KILL STATUSA
- +33 DO GETSTATI^PXRMSTAT(70,.FINDPA,.STATUSA)
- +34 DO FPDAT^PXRMRCPT(DFN,.TAXARR,NOCC,BDT,EDT,.STATUSA,.TLIST)
- End DoDot:1
- +35 ;
- +36 ;Process the found list, returning up to NOCC date ordered results.
- +37 SET DATE=""
- SET NFOUND=0
- +38 FOR
- SET DATE=$ORDER(TLIST(DATE),SDIR)
- if (DATE="")!(NFOUND=NOCC)
- QUIT
- Begin DoDot:1
- +39 SET IND=0
- +40 FOR
- SET IND=$ORDER(TLIST(DATE,IND))
- if (IND="")!(NFOUND=NOCC)
- QUIT
- Begin DoDot:2
- +41 SET FILENUM=0
- +42 FOR
- SET FILENUM=$ORDER(TLIST(DATE,IND,FILENUM))
- if FILENUM=""
- QUIT
- Begin DoDot:3
- +43 SET NFOUND=NFOUND+1
- +44 SET FLIST(NFOUND)=FILENUM_U_TLIST(DATE,IND,FILENUM)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +45 IF NFOUND=0
- SET FIEVAL=0
- QUIT
- +46 SET NP=0
- +47 FOR IND=1:1:NFOUND
- if NP=NOCC
- QUIT
- Begin DoDot:1
- +48 SET FILENUM=$PIECE(FLIST(IND),U,1)
- +49 SET DAS=$PIECE(FLIST(IND),U,2)
- +50 DO GETDATA^PXRMDATA(FILENUM,DAS,.FIEVT)
- +51 IF INCVD
- IF $DATA(FIEVT("VISIT"))
- DO GETDATA^PXRMVSIT(FIEVT("VISIT"),.FIEVT,0)
- +52 SET FIEVT("DATE")=$PIECE(FLIST(IND),U,3)
- +53 SET FIEVT("CODESYS")=$PIECE(FLIST(IND),U,4)
- +54 SET FIEVT("CODE")=$PIECE(FLIST(IND),U,5)
- +55 SET FIEVT("NODE")=$PIECE(FLIST(IND),U,6)
- +56 SET CONVAL=$SELECT(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVT),1:1)
- +57 SET SAVE=$SELECT('UCIFS:1,(UCIFS&CONVAL):1,1:0)
- +58 IF SAVE
- Begin DoDot:2
- +59 SET NP=NP+1
- +60 SET FIEVAL(NP)=CONVAL
- +61 IF COND'=""
- SET FIEVAL(NP,"CONDITION")=CONVAL
- +62 SET FIEVAL(NP,"DAS")=DAS
- +63 SET FIEVAL(NP,"DATE")=FIEVT("DATE")
- +64 SET FIEVAL(NP,"FILE NUMBER")=FILENUM
- +65 SET FIEVAL(NP,"FILE SPECIFIC")=$PIECE(FLIST(IND),U,6,10)
- +66 SET FIEVAL(NP,"FINDING")=TAXIEN_";PXD(811.2,"
- +67 MERGE FIEVAL(NP)=FIEVT
- +68 IF $GET(PXRMDEBG)
- MERGE FIEVAL(NP,"CSUB")=FIEVT
- End DoDot:2
- End DoDot:1
- +69 ;Save the finding result.
- +70 DO SFRES^PXRMUTIL(SDIR,NP,.FIEVAL)
- +71 QUIT
- +72 ;
- +73 ;==================================================
- 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",9000010.71,"NNODES")>0)
- DO GPLIST^PXRMVSC(.TAXARR,NOCC,BDT,EDT,TLIST)
- +31 ;
- +32 IF (TAXARR("APDS",71,"NNODES")>0)
- DO GPLIST^PXRMRCPT(.TAXARR,.FINDPA,TLIST)
- +33 ;Conditions for taxonomies only apply to radiology findings, this
- +34 ;is taken care of in PXRMRCPT.
- +35 ;
- +36 ;Process the found list, return up to NOCC of the most recent entries.
- +37 FOR TF=0,1
- Begin DoDot:1
- +38 IF '$DATA(^TMP($JOB,TLIST,TF))
- QUIT
- +39 SET DFN=""
- +40 FOR
- SET DFN=$ORDER(^TMP($JOB,TLIST,TF,DFN))
- if DFN=""
- QUIT
- Begin DoDot:2
- +41 KILL DLIST,IPLIST
- +42 SET NFOUND=0
- +43 SET NF=""
- +44 FOR
- SET NF=$ORDER(^TMP($JOB,TLIST,TF,DFN,NF),-1)
- if NF=""
- QUIT
- Begin DoDot:3
- +45 SET FILENUM=0
- +46 FOR
- SET FILENUM=$ORDER(^TMP($JOB,TLIST,TF,DFN,NF,FILENUM))
- if FILENUM=""
- QUIT
- Begin DoDot:4
- +47 SET NFOUND=NFOUND+1
- +48 SET DATE=$PIECE(^TMP($JOB,TLIST,TF,DFN,NF,FILENUM),U,2)
- +49 SET DLIST(DATE,NFOUND)=NF_U_FILENUM
- End DoDot:4
- End DoDot:3
- +50 ;
- +51 SET DATE=""
- SET NFOUND=0
- +52 FOR
- SET DATE=$ORDER(DLIST(DATE),-1)
- if (DATE="")!(NFOUND=NOCC)
- QUIT
- Begin DoDot:3
- +53 SET NF=0
- +54 FOR
- SET NF=$ORDER(DLIST(DATE,NF))
- if (NF="")!(NFOUND=NOCC)
- QUIT
- Begin DoDot:4
- +55 SET NFOUND=NFOUND+1
- +56 SET IND=$PIECE(DLIST(DATE,NF),U,1)
- +57 SET FILENUM=$PIECE(DLIST(DATE,NF),U,2)
- +58 SET IPLIST(TF,DFN,TAXIEN,NFOUND,FILENUM)=^TMP($JOB,TLIST,TF,DFN,IND,FILENUM)
- End DoDot:4
- End DoDot:3
- +59 MERGE ^TMP($JOB,PLIST)=IPLIST
- End DoDot:2
- End DoDot:1
- +60 KILL ^TMP($JOB,TLIST)
- +61 QUIT
- +62 ;
- +63 ;==================================================
- 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 IF FILENUM=45
- DO MHVOUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +9 IF FILENUM=70
- DO MHVOUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +10 IF FILENUM=9000010.07
- DO MHVOUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +11 IF FILENUM=9000010.18
- DO MHVOUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +12 IF FILENUM=9000010.71
- DO MHVOUT^PXRMVSC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +13 IF FILENUM=9000011
- DO MHVOUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- End DoDot:1
- +14 QUIT
- +15 ;
- +16 ;==================================================
- 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 IF FILENUM=45
- DO OUTPUT^PXRMDGPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +10 IF FILENUM=70
- DO OUTPUT^PXRMRCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +11 IF FILENUM=9000010.07
- DO OUTPUT^PXRMVPOV(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +12 IF FILENUM=9000010.18
- DO OUTPUT^PXRMVCPT(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +13 IF FILENUM=9000010.71
- DO OUTPUT^PXRMVSC(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- QUIT
- +14 IF FILENUM=9000011
- DO OUTPUT^PXRMPROB(INDENT,.OCCLIST,.IFIEVAL,.NLINES,.TEXT)
- End DoDot:1
- +15 QUIT
- +16 ;