- PXRMVCPT ; SLC/PKR - Code to handle V CPT data. ;07/23/2020
- ;;2.0;CLINICAL REMINDERS;**4,26,47,42**;Feb 04, 2005;Build 245
- ;
- ;===============
- FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,FLIST) ;Find data for a patient.
- N CODESYS,CSYST,DATE,DS,EDTT,IND,NFOUND,NNODES,TLIST
- S NNODES=TAXARR("APDS",9000010.18,"NNODES")
- I NNODES=0 Q
- I $G(^PXRMINDX(9000010.18,"DATE BUILT"))="" D Q
- . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000010.18)
- I '$D(^PXRMINDX(9000010.18,"PPI",DFN)) Q
- S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
- S CODESYS=""
- F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
- . S CSYST=$S(CODESYS="CPC":"P81",CODESYS="CPT":"P81",1:"NP81")
- . I (CSYST="P81"),$D(^PXRMINDX(9000010.18,"PPI",DFN)) D FPDP81(DFN,CODESYS,.TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,.TLIST)
- . I (CSYST="NP81"),$D(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN)) D FPDCSYS(DFN,CODESYS,.TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,.TLIST)
- ;Return up to NGET of the most recent entries.
- S DATE="",NFOUND=0
- F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NGET) D
- . S IND=0
- . F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NGET) D
- .. S NFOUND=NFOUND+1
- .. S FLIST(DATE,NFOUND,9000010.18)=TLIST(DATE,IND)
- Q
- ;
- ;===============
- FPDP81(DFN,CODESYS,TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,TLIST) ;Find data for a
- ;patient for pointers to file 81.
- N CODE,CODEP,DAS,DATE,NFOUND,NODE,TDATE,TIND
- S NFOUND=0
- F IND=1:1:NNODES D
- . S NODE=TAXARR("APDS",9000010.18,IND)
- . I '$D(^PXRMINDX(9000010.18,"PPI",DFN,NODE)) Q
- . S CODE=""
- . F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:CODE="" D
- .. S CODEP=$P(TAXARR("AE",CODESYS,CODE),U,1)
- .. I '$D(^PXRMINDX(9000010.18,"PPI",DFN,NODE,CODEP)) Q
- .. S DATE=DS
- .. F S DATE=+$O(^PXRMINDX(9000010.18,"PPI",DFN,NODE,CODEP,DATE),SDIR) Q:$S(DATE=0:1,DATE<BDT:1,DATE>EDTT:1,1:0) D
- ... S DAS=$O(^PXRMINDX(9000010.18,"PPI",DFN,NODE,CODEP,DATE,""))
- ... S NFOUND=NFOUND+1
- ... S TLIST(DATE,NFOUND)=DAS_U_DATE_U_CODESYS_U_CODE_U_NODE
- ... I NFOUND>NGET D
- .... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
- .... K TLIST(TDATE,TIND)
- Q
- ;
- ;===============
- FPDCSYS(DFN,CODESYS,TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,TLIST) ;Find data for
- ;a patient for coding systems not stored as a pointer.
- N CODE,DAS,DATE,NFOUND,NODE,TDATE,TIND
- ;Get the start and end of the taxonomy.
- I '$D(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN)) Q
- S NFOUND=0
- F IND=1:1:NNODES D
- . S NODE=TAXARR("APDS",9000010.18,IND)
- . I '$D(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE)) Q
- . S CODE=""
- . F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:CODE="" D
- .. I '$D(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE,CODE)) Q
- .. S DATE=DS
- .. F S DATE=+$O(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE,CODE,DATE),SDIR) Q:$S(DATE=0:1,DATE<BDT:1,DATE>EDTT:1,1:0) D
- ... S DAS=$O(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE,CODE,DATE,""))
- ... S NFOUND=NFOUND+1
- ... S TLIST(DATE,NFOUND)=DAS_U_DATE_U_CODESYS_U_CODE_U_NODE
- ... I NFOUND>NGET D
- .... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
- .... K TLIST(TDATE,TIND)
- Q
- ;
- ;===============
- GETDATA(DAS,FIEVT) ;Return data for a specified V CPT entry.
- ;DBIA #4250.
- D VCPT^PXPXRM(DAS,.FIEVT)
- Q
- ;
- ;===============
- GPLIST(TAXARR,NOCC,BDT,EDT,PLIST) ;Build patient list for V CPT entries.
- N CODE,CODEP,CODESYS,DAS,DATE,DFN,DS,NFOUND,NODE,NNODES,TEMP,TLIST
- S NNODES=TAXARR("APDS",9000010.18,"NNODES")
- I NNODES=0 Q
- I $G(^PXRMINDX(9000010.18,"DATE BUILT"))="" D Q
- . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000010.18)
- S TLIST="GPLIST_PXRMVCPT"
- K ^TMP($J,TLIST)
- S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S CODESYS=""
- F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
- . S CODE=""
- . F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:(CODE="") D
- .. S CODEP=$P(TAXARR("AE",CODESYS,CODE),U,1)
- .. I $D(^PXRMINDX(9000010.18,"IPP",CODEP)) D GPLCPT4(CODE,CODEP,.TAXARR,NNODES,BDT,DS,TLIST) Q
- ..;This is in case other coding systems are ever added to file #81.
- .. I $D(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE)) D GPLCSYS(CODESYS,CODE,.TAXARR,NNODES,BDT,DS,TLIST)
- ;Return up to NOCC of the most recent entries for each patient.
- S DFN=0
- F S DFN=$O(^TMP($J,TLIST,DFN)) Q:DFN="" D
- . S DATE="",NFOUND=0
- . F S DATE=$O(^TMP($J,TLIST,DFN,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
- .. S DAS=""
- .. F S DAS=$O(^TMP($J,TLIST,DFN,DATE,DAS)) Q:DAS="" D
- ... S NFOUND=NFOUND+1
- ... S TEMP=^TMP($J,TLIST,DFN,DATE,DAS)
- ... S ^TMP($J,PLIST,1,DFN,DATE,9000010.18)=DAS_U_DATE_U_TEMP
- K ^TMP($J,TLIST)
- Q
- ;
- ;===============
- GPLCPT4(CODE,CODEP,TAXARR,NNODES,BDT,DS,TLIST) ;Build patient list for V CPT
- ;for CPT-4 and HCPCS.
- N DAS,DATE,DFN,IND,NODE,TEMP
- F IND=1:1:NNODES D
- . S NODE=TAXARR("APDS",9000010.18,IND)
- . I '$D(^PXRMINDX(9000010.18,"IPP",CODEP,NODE)) Q
- . S DFN=0
- . F S DFN=$O(^PXRMINDX(9000010.18,"IPP",CODEP,NODE,DFN)) Q:DFN="" D
- .. S DATE=DS
- .. F S DATE=+$O(^PXRMINDX(9000010.18,"IPP",CODEP,NODE,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT) D
- ... S DAS=$O(^PXRMINDX(9000010.18,"IPP",CODEP,NODE,DFN,DATE,""))
- ... S ^TMP($J,TLIST,DFN,DATE,DAS)="CPT"_U_CODE_U_NODE
- Q
- ;
- ;===============
- GPLCSYS(CODESYS,CODE,TAXARR,NNODES,BDT,DS,TLIST) ;Build patient list for V CPT
- ;for coding systems other than CPT-4.
- N DAS,DATE,DFN,IND,NODE,TEMP
- F IND=1:1:NNODES D
- . S NODE=TAXARR("APDS",9000010.18,IND)
- . I '$D(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE)) Q
- . S DFN=0
- . F S DFN=$O(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE,DFN)) Q:DFN="" D
- .. S DATE=DS
- .. F S DATE=+$O(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE,DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT) D
- ... S DAS=$O(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE,DFN,DATE,""))
- ... S ^TMP($J,TLIST,DFN,DATE,DAS)=CODESYS_U_CODE_U_NODE
- Q
- ;
- ;===============
- MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
- N CDATA,CODE,CODESYS,IND,JND,NAME,NIN,NOUT
- N PN,PP,RESULT,TEMP,TEXTOUT,VDATE
- S NAME="Encounter Procedure = "
- S IND=0
- F S IND=$O(OCCLIST(IND)) Q:IND="" D
- . S VDATE=IFIEVAL(IND,"DATE")
- . S CODE=IFIEVAL(IND,"CODE")
- . S CODESYS=IFIEVAL(IND,"CODESYS")
- . K CDATA
- .;DBIA #5679
- . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
- . S TEMP=NAME_$P(CDATA("LEX",1),U,2)_" ("_$$EDATE^PXRMDATE(VDATE)_")"
- . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
- . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
- S NLINES=NLINES+1,TEXT(NLINES)=""
- Q
- ;
- ;===============
- OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
- ;maintenance output.
- N CDATA,CODE,CODESYS,CODESYSN,D0,IND,JND,NIN,NOUT
- N PN,PP,RESULT,TEXTIN,TEXTOUT,VDATE
- S NLINES=NLINES+1
- S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Encounter Procedure:"
- ;DBIA #5679
- S IND=0
- F S IND=$O(OCCLIST(IND)) Q:IND="" D
- . S VDATE=IFIEVAL(IND,"DATE")
- . S CODE=IFIEVAL(IND,"CODE")
- . S CODESYS=IFIEVAL(IND,"CODESYS")
- . S CODESYSN=$P($$CSYS^LEXU(CODESYS),U,4)
- . K CDATA
- .;DBIA #5679
- . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
- . S D0=$G(^AUPNVCPT(IFIEVAL(IND,"DAS"),0))
- . S PN=$P(D0,U,4)
- . I PN="" S PN="MISSING"
- . E S PN=$P($G(^AUTNPOV(PN,0)),U,1)
- . S PP=$P(IFIEVAL(IND,"FILE SPECIFIC"),U,1)
- . S PP=$S(PP="Y":"YES",1:"NO")
- . S TEXTIN(1)=$$EDATE^PXRMDATE(VDATE)_" "_CODE_" ("_CODESYSN_")"
- . S TEXTIN(2)=$P(CDATA("LEX",1),U,2)_"\\"
- . S TEXTIN(3)=" Principle Procedure: "_PP_"\\"
- . S TEXTIN(4)=" Prov. Narr. - "_PN
- . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,4,.TEXTIN,.NOUT,.TEXTOUT)
- . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
- . I IFIEVAL(IND,"COMMENTS")'="" D
- .. S TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
- .. D FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
- .. F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
- S NLINES=NLINES+1,TEXT(NLINES)=""
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMVCPT 7838 printed Jan 18, 2025@02:51:06 Page 2
- PXRMVCPT ; SLC/PKR - Code to handle V CPT data. ;07/23/2020
- +1 ;;2.0;CLINICAL REMINDERS;**4,26,47,42**;Feb 04, 2005;Build 245
- +2 ;
- +3 ;===============
- FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,FLIST) ;Find data for a patient.
- +1 NEW CODESYS,CSYST,DATE,DS,EDTT,IND,NFOUND,NNODES,TLIST
- +2 SET NNODES=TAXARR("APDS",9000010.18,"NNODES")
- +3 IF NNODES=0
- QUIT
- +4 IF $GET(^PXRMINDX(9000010.18,"DATE BUILT"))=""
- Begin DoDot:1
- +5 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000010.18)
- End DoDot:1
- QUIT
- +6 IF '$DATA(^PXRMINDX(9000010.18,"PPI",DFN))
- QUIT
- +7 SET EDTT=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
- +8 SET DS=$SELECT(SDIR=+1:BDT-.000001,1:EDTT)
- +9 SET CODESYS=""
- +10 FOR
- SET CODESYS=$ORDER(TAXARR("AE",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +11 SET CSYST=$SELECT(CODESYS="CPC":"P81",CODESYS="CPT":"P81",1:"NP81")
- +12 IF (CSYST="P81")
- IF $DATA(^PXRMINDX(9000010.18,"PPI",DFN))
- DO FPDP81(DFN,CODESYS,.TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,.TLIST)
- +13 IF (CSYST="NP81")
- IF $DATA(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN))
- DO FPDCSYS(DFN,CODESYS,.TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,.TLIST)
- End DoDot:1
- +14 ;Return up to NGET of the most recent entries.
- +15 SET DATE=""
- SET NFOUND=0
- +16 FOR
- SET DATE=$ORDER(TLIST(DATE),SDIR)
- if (DATE="")!(NFOUND=NGET)
- QUIT
- Begin DoDot:1
- +17 SET IND=0
- +18 FOR
- SET IND=$ORDER(TLIST(DATE,IND))
- if (IND="")!(NFOUND=NGET)
- QUIT
- Begin DoDot:2
- +19 SET NFOUND=NFOUND+1
- +20 SET FLIST(DATE,NFOUND,9000010.18)=TLIST(DATE,IND)
- End DoDot:2
- End DoDot:1
- +21 QUIT
- +22 ;
- +23 ;===============
- FPDP81(DFN,CODESYS,TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,TLIST) ;Find data for a
- +1 ;patient for pointers to file 81.
- +2 NEW CODE,CODEP,DAS,DATE,NFOUND,NODE,TDATE,TIND
- +3 SET NFOUND=0
- +4 FOR IND=1:1:NNODES
- Begin DoDot:1
- +5 SET NODE=TAXARR("APDS",9000010.18,IND)
- +6 IF '$DATA(^PXRMINDX(9000010.18,"PPI",DFN,NODE))
- QUIT
- +7 SET CODE=""
- +8 FOR
- SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:2
- +9 SET CODEP=$PIECE(TAXARR("AE",CODESYS,CODE),U,1)
- +10 IF '$DATA(^PXRMINDX(9000010.18,"PPI",DFN,NODE,CODEP))
- QUIT
- +11 SET DATE=DS
- +12 FOR
- SET DATE=+$ORDER(^PXRMINDX(9000010.18,"PPI",DFN,NODE,CODEP,DATE),SDIR)
- if $SELECT(DATE=0
- QUIT
- Begin DoDot:3
- +13 SET DAS=$ORDER(^PXRMINDX(9000010.18,"PPI",DFN,NODE,CODEP,DATE,""))
- +14 SET NFOUND=NFOUND+1
- +15 SET TLIST(DATE,NFOUND)=DAS_U_DATE_U_CODESYS_U_CODE_U_NODE
- +16 IF NFOUND>NGET
- Begin DoDot:4
- +17 SET TDATE=$ORDER(TLIST(""),-SDIR)
- SET TIND=$ORDER(TLIST(TDATE,""))
- +18 KILL TLIST(TDATE,TIND)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- +21 ;===============
- FPDCSYS(DFN,CODESYS,TAXARR,NNODES,NGET,BDT,EDTT,DS,SDIR,TLIST) ;Find data for
- +1 ;a patient for coding systems not stored as a pointer.
- +2 NEW CODE,DAS,DATE,NFOUND,NODE,TDATE,TIND
- +3 ;Get the start and end of the taxonomy.
- +4 IF '$DATA(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN))
- QUIT
- +5 SET NFOUND=0
- +6 FOR IND=1:1:NNODES
- Begin DoDot:1
- +7 SET NODE=TAXARR("APDS",9000010.18,IND)
- +8 IF '$DATA(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE))
- QUIT
- +9 SET CODE=""
- +10 FOR
- SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:2
- +11 IF '$DATA(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE,CODE))
- QUIT
- +12 SET DATE=DS
- +13 FOR
- SET DATE=+$ORDER(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE,CODE,DATE),SDIR)
- if $SELECT(DATE=0
- QUIT
- Begin DoDot:3
- +14 SET DAS=$ORDER(^PXRMINDX(9000010.18,CODESYS,"PPI",DFN,NODE,CODE,DATE,""))
- +15 SET NFOUND=NFOUND+1
- +16 SET TLIST(DATE,NFOUND)=DAS_U_DATE_U_CODESYS_U_CODE_U_NODE
- +17 IF NFOUND>NGET
- Begin DoDot:4
- +18 SET TDATE=$ORDER(TLIST(""),-SDIR)
- SET TIND=$ORDER(TLIST(TDATE,""))
- +19 KILL TLIST(TDATE,TIND)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +20 QUIT
- +21 ;
- +22 ;===============
- GETDATA(DAS,FIEVT) ;Return data for a specified V CPT entry.
- +1 ;DBIA #4250.
- +2 DO VCPT^PXPXRM(DAS,.FIEVT)
- +3 QUIT
- +4 ;
- +5 ;===============
- GPLIST(TAXARR,NOCC,BDT,EDT,PLIST) ;Build patient list for V CPT entries.
- +1 NEW CODE,CODEP,CODESYS,DAS,DATE,DFN,DS,NFOUND,NODE,NNODES,TEMP,TLIST
- +2 SET NNODES=TAXARR("APDS",9000010.18,"NNODES")
- +3 IF NNODES=0
- QUIT
- +4 IF $GET(^PXRMINDX(9000010.18,"DATE BUILT"))=""
- Begin DoDot:1
- +5 DO NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000010.18)
- End DoDot:1
- QUIT
- +6 SET TLIST="GPLIST_PXRMVCPT"
- +7 KILL ^TMP($JOB,TLIST)
- +8 SET DS=$SELECT(EDT[".":EDT+.0000001,1:EDT+.240001)
- +9 SET CODESYS=""
- +10 FOR
- SET CODESYS=$ORDER(TAXARR("AE",CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +11 SET CODE=""
- +12 FOR
- SET CODE=$ORDER(TAXARR("AE",CODESYS,CODE))
- if (CODE="")
- QUIT
- Begin DoDot:2
- +13 SET CODEP=$PIECE(TAXARR("AE",CODESYS,CODE),U,1)
- +14 IF $DATA(^PXRMINDX(9000010.18,"IPP",CODEP))
- DO GPLCPT4(CODE,CODEP,.TAXARR,NNODES,BDT,DS,TLIST)
- QUIT
- +15 ;This is in case other coding systems are ever added to file #81.
- +16 IF $DATA(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE))
- DO GPLCSYS(CODESYS,CODE,.TAXARR,NNODES,BDT,DS,TLIST)
- End DoDot:2
- End DoDot:1
- +17 ;Return up to NOCC of the most recent entries for each patient.
- +18 SET DFN=0
- +19 FOR
- SET DFN=$ORDER(^TMP($JOB,TLIST,DFN))
- if DFN=""
- QUIT
- Begin DoDot:1
- +20 SET DATE=""
- SET NFOUND=0
- +21 FOR
- SET DATE=$ORDER(^TMP($JOB,TLIST,DFN,DATE),-1)
- if (DATE="")!(NFOUND=NOCC)
- QUIT
- Begin DoDot:2
- +22 SET DAS=""
- +23 FOR
- SET DAS=$ORDER(^TMP($JOB,TLIST,DFN,DATE,DAS))
- if DAS=""
- QUIT
- Begin DoDot:3
- +24 SET NFOUND=NFOUND+1
- +25 SET TEMP=^TMP($JOB,TLIST,DFN,DATE,DAS)
- +26 SET ^TMP($JOB,PLIST,1,DFN,DATE,9000010.18)=DAS_U_DATE_U_TEMP
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +27 KILL ^TMP($JOB,TLIST)
- +28 QUIT
- +29 ;
- +30 ;===============
- GPLCPT4(CODE,CODEP,TAXARR,NNODES,BDT,DS,TLIST) ;Build patient list for V CPT
- +1 ;for CPT-4 and HCPCS.
- +2 NEW DAS,DATE,DFN,IND,NODE,TEMP
- +3 FOR IND=1:1:NNODES
- Begin DoDot:1
- +4 SET NODE=TAXARR("APDS",9000010.18,IND)
- +5 IF '$DATA(^PXRMINDX(9000010.18,"IPP",CODEP,NODE))
- QUIT
- +6 SET DFN=0
- +7 FOR
- SET DFN=$ORDER(^PXRMINDX(9000010.18,"IPP",CODEP,NODE,DFN))
- if DFN=""
- QUIT
- Begin DoDot:2
- +8 SET DATE=DS
- +9 FOR
- SET DATE=+$ORDER(^PXRMINDX(9000010.18,"IPP",CODEP,NODE,DFN,DATE),-1)
- if (DATE=0)!(DATE<BDT)
- QUIT
- Begin DoDot:3
- +10 SET DAS=$ORDER(^PXRMINDX(9000010.18,"IPP",CODEP,NODE,DFN,DATE,""))
- +11 SET ^TMP($JOB,TLIST,DFN,DATE,DAS)="CPT"_U_CODE_U_NODE
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- +14 ;===============
- GPLCSYS(CODESYS,CODE,TAXARR,NNODES,BDT,DS,TLIST) ;Build patient list for V CPT
- +1 ;for coding systems other than CPT-4.
- +2 NEW DAS,DATE,DFN,IND,NODE,TEMP
- +3 FOR IND=1:1:NNODES
- Begin DoDot:1
- +4 SET NODE=TAXARR("APDS",9000010.18,IND)
- +5 IF '$DATA(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE))
- QUIT
- +6 SET DFN=0
- +7 FOR
- SET DFN=$ORDER(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE,DFN))
- if DFN=""
- QUIT
- Begin DoDot:2
- +8 SET DATE=DS
- +9 FOR
- SET DATE=+$ORDER(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE,DFN,DATE),-1)
- if (DATE=0)!(DATE<BDT)
- QUIT
- Begin DoDot:3
- +10 SET DAS=$ORDER(^PXRMINDX(9000010.18,CODESYS,"IPP",CODE,NODE,DFN,DATE,""))
- +11 SET ^TMP($JOB,TLIST,DFN,DATE,DAS)=CODESYS_U_CODE_U_NODE
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- +14 ;===============
- MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
- +1 NEW CDATA,CODE,CODESYS,IND,JND,NAME,NIN,NOUT
- +2 NEW PN,PP,RESULT,TEMP,TEXTOUT,VDATE
- +3 SET NAME="Encounter Procedure = "
- +4 SET IND=0
- +5 FOR
- SET IND=$ORDER(OCCLIST(IND))
- if IND=""
- QUIT
- Begin DoDot:1
- +6 SET VDATE=IFIEVAL(IND,"DATE")
- +7 SET CODE=IFIEVAL(IND,"CODE")
- +8 SET CODESYS=IFIEVAL(IND,"CODESYS")
- +9 KILL CDATA
- +10 ;DBIA #5679
- +11 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
- +12 SET TEMP=NAME_$PIECE(CDATA("LEX",1),U,2)_" ("_$$EDATE^PXRMDATE(VDATE)_")"
- +13 DO FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
- +14 FOR JND=1:1:NOUT
- SET NLINES=NLINES+1
- SET TEXT(NLINES)=TEXTOUT(JND)
- End DoDot:1
- +15 SET NLINES=NLINES+1
- SET TEXT(NLINES)=""
- +16 QUIT
- +17 ;
- +18 ;===============
- OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
- +1 ;maintenance output.
- +2 NEW CDATA,CODE,CODESYS,CODESYSN,D0,IND,JND,NIN,NOUT
- +3 NEW PN,PP,RESULT,TEXTIN,TEXTOUT,VDATE
- +4 SET NLINES=NLINES+1
- +5 SET TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Encounter Procedure:"
- +6 ;DBIA #5679
- +7 SET IND=0
- +8 FOR
- SET IND=$ORDER(OCCLIST(IND))
- if IND=""
- QUIT
- Begin DoDot:1
- +9 SET VDATE=IFIEVAL(IND,"DATE")
- +10 SET CODE=IFIEVAL(IND,"CODE")
- +11 SET CODESYS=IFIEVAL(IND,"CODESYS")
- +12 SET CODESYSN=$PIECE($$CSYS^LEXU(CODESYS),U,4)
- +13 KILL CDATA
- +14 ;DBIA #5679
- +15 SET RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
- +16 SET D0=$GET(^AUPNVCPT(IFIEVAL(IND,"DAS"),0))
- +17 SET PN=$PIECE(D0,U,4)
- +18 IF PN=""
- SET PN="MISSING"
- +19 IF '$TEST
- SET PN=$PIECE($GET(^AUTNPOV(PN,0)),U,1)
- +20 SET PP=$PIECE(IFIEVAL(IND,"FILE SPECIFIC"),U,1)
- +21 SET PP=$SELECT(PP="Y":"YES",1:"NO")
- +22 SET TEXTIN(1)=$$EDATE^PXRMDATE(VDATE)_" "_CODE_" ("_CODESYSN_")"
- +23 SET TEXTIN(2)=$PIECE(CDATA("LEX",1),U,2)_"\\"
- +24 SET TEXTIN(3)=" Principle Procedure: "_PP_"\\"
- +25 SET TEXTIN(4)=" Prov. Narr. - "_PN
- +26 DO FORMAT^PXRMTEXT(INDENT+2,PXRMRM,4,.TEXTIN,.NOUT,.TEXTOUT)
- +27 FOR JND=1:1:NOUT
- SET NLINES=NLINES+1
- SET TEXT(NLINES)=TEXTOUT(JND)
- +28 IF IFIEVAL(IND,"COMMENTS")'=""
- Begin DoDot:2
- +29 SET TEMP="Comments: "_IFIEVAL(IND,"COMMENTS")
- +30 DO FORMATS^PXRMTEXT(INDENT+3,PXRMRM,TEMP,.NOUT,.TEXTOUT)
- +31 FOR JND=1:1:NOUT
- SET NLINES=NLINES+1
- SET TEXT(NLINES)=TEXTOUT(JND)
- End DoDot:2
- End DoDot:1
- +32 SET NLINES=NLINES+1
- SET TEXT(NLINES)=""
- +33 QUIT
- +34 ;