BMCRPC1 ; IHS/CAS/AU - GUI REFERRED CARE INFO SYSTEM (1/4);
;;4.0;REFERRED CARE INFO SYSTEM;**7,8,12**;JAN 09, 2006;Build 101
;
;GDIT/HS/BEE 10/19/17 - p12 CR#7796:Filter out inactive vendors
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
;
; RPC code for RCIS GUI Application
; Routines contains code for Reading data from RCIS files
SRCHREF(RSLT,PATIENT,REFPRVDR,STRTDATE,ENDDATE,RECNMBR,STATUS) ; search referral w.r.t patient, referring provider and date range
;; PATIENT = DFN
; REFPRVDR = Provider Ien
; STRTDATE = start date , ENDDATE = end date , search referrels between start and end date
; NMBRREC = Number of recrods to return
;S RSLT="Test Referaal Data" Q
;S ^TMP("FAR234")=$G(PATIENT)_"^"_$G(REFPRVDR)_"^"_$G(STRTDATE)_"^"_$G(ENDDATE)_"^"_$G(RECNMBR)_"^"_$G(STATUS)
;S PATIENT=""
;S STRTDATE="8/14/2012"
;S ENDDATE="8/14/2013"
;S REFPRVDR="3043"
;S STATUS="Active"
;D SRCHREF^BMCRPC1(.R,PATIENT,REFPRVDR,STRTDATE,ENDDATE,"",STATUS) ZW @R
;S DI="S X=$P($G("_"^"_"(0)),U,2) D LIST^DIC(8992.5,,""@;.01;.02IE;.03IE;.04;.05;.06;.09;1"",""IP"",1,X-1,X,""#"",,,""OUT1""_@X) D EN^DDIOL($G(OUT1_@X(""DILIST"",1,0)))"
N OUT,ERR,SCR
S SCR="I 1"
I ($D(STATUS)&($G(STATUS)'="")) D
. I $G(STATUS)="Active" S STATUS="A"
. I $G(STATUS)="Approved" S STATUS="A1"
. I $G(STATUS)="Closed-Completed" S STATUS="C1"
. I $G(STATUS)="Closed-Not Completed" S STATUS="X"
K ^TMP($J,"PRNRCTMP")
I +RECNMBR'>0 S RECNMBR="*"
I ($D(PATIENT)&(PATIENT'="")) S SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",3))="_PATIENT_")" ;D EN^DDIOL($G(OUT1("DILIST",1,0)))
I ($D(REFPRVDR)&(REFPRVDR'="")) S SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",6))="_REFPRVDR_")"
I ($D(STATUS)&($G(STATUS)'="")) D
. I $G(STATUS)'="Active/Approved" D
. . S SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",15))="""_$G(STATUS)_""")"
. I $G(STATUS)="Active/Approved" D
. . S SCR=SCR_" & ((($P($G("_"^"_"(0)),""^"",15))=""A"") ! (($P($G("_"^"_"(0)),""^"",15))=""A1""))"
I ($D(STRTDATE)&(STRTDATE'="")) D DT^DILF("TS",STRTDATE,.STRTDATE,,"") S SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",1))>="_STRTDATE_")"
I ($D(ENDDATE)&(ENDDATE'="")) D DT^DILF("TS",ENDDATE,.ENDDATE,,"") S SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",1))<="_ENDDATE_")"
I ($D(PATIENT)&(PATIENT'="")) D LIST^DIC(90001,"","@;.01;.02;101;.03IE;.05I;.06;.0999;1105;1112;1201;1114;1301;.15;1306;1307;1308","BQ",RECNMBR,,PATIENT,"D",SCR,"","^TMP($J,""PRNRCTMP"")") D CRTMSG^BMCRPC4(.RSLT,0) Q RSLT
I ($D(REFPRVDR)&(REFPRVDR'="")) D LIST^DIC(90001,"","@;.01;.02;101;.03IE;.05I;.06;.0999;1105;1112;1201;1114;1301;.15;1306;1307;1308","BQ",RECNMBR,,REFPRVDR,"E",SCR,"","^TMP($J,""PRNRCTMP"")") D CRTMSG^BMCRPC4(.RSLT,0) Q RSLT
I ($D(STRTDATE)&(STRTDATE'="")) D
.I ($D(ENDDATE)&(ENDDATE'="")) D LIST^DIC(90001,"","@;.01;.02;101;.03IE;.05I;.06;.0999;1105;1112;1201;1114;1301;.15;1306;1307;1308","",RECNMBR,,,"B",SCR,"","^TMP($J,""PRNRCTMP"")") D CRTMSG^BMCRPC4(.RSLT,0) Q
Q RSLT
GTRFBYID(RSLT,REFIEN) ;; get referral
;; D GTRFBYID^BMCRPC1(.R,"113251") ZW @R
;; RSLT = result set returned as golbal array
;; REFIEN = referral ien of RCIS REFERRAL file
;; D GTRFBYID^BMCRPC1(.R,"113252") ZW @R
N SCR,REFNUM,CMNTSX,CMNTSB,PRIMREF,FIELDS,CMNTSBB,CMNTSXX
I '$D(REFIEN) Q
I REFIEN="" Q
I $$GET1^DIQ(90001,REFIEN_",",.01,"")="" S RSLT="Not a valid Referral Ien" Q RSLT
LOCK +^BMCREF(REFIEN):0.2 ;;check if record is being locked else where
ELSE S RSLT="The referral record cannot be opened becuase it is locked. Please try again later." Q RSLT
S SCR="I Y="_REFIEN
K ^TMP($J,"PRNRCTMP"),^TMP($J,"PRNRC")
S REFNUM=$$GET1^DIQ(90001,REFIEN_",",.02,"") ;;get Ref Number... to use index in search... fast fetch
S PRIMREF=$$GET1^DIQ(90001,REFIEN_",",102,"") ;;get primary referral - if exsits; fetch Med Hx for primary ref too
S FIELDS="@;.01;.02;.06;.0999;.15;101;1105;1111;1112;1201;1114;1301;1302;401;402;403;404;405;406;407;408;409;410;411;412;.03IE;.04I;.05I;.12I;.13I;.14I;.07I;.08I;.09I;.23I;.32;1306;1307;1308"
D LIST^DIC(90001,"",FIELDS,"Q","1",,REFNUM,"C",SCR,"","^TMP($J,""PRNRCTMP"")")
LOCK -^BMCREF(REFIEN) ;; unlock the record
D CRTMSG^BMCRPC4(.RSLT,1) ;;package data to be returned
;; fetch MED HX comments for the Referral
;S CMNTSX=$$GETMEDHX("",REFIEN,"M")
;S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSX,1,$L(CMNTSX)-4)
;; fetch Business Office/CHS comments for the Referral
;S CMNTSB=$$GETMEDHX("",REFIEN,"B")
;S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSB,1,$L(CMNTSB)-4)
;; fetch MED HX comments for the Primary referral too, if this is a secondary referral
;I PRIMREF>0 S CMNTSX=$$GETMEDHX("",PRIMREF,"M") S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSX,1,$L(CMNTSX)-4)
;; fetch Business Office/CHS comments for the Primary referral too, if this is a secondary referral
;I PRIMREF>0 S CMNTSB=$$GETMEDHX("",PRIMREF,"B") S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSB,1,$L(CMNTSB)-4)
;; fetch MED HX comments for the Primary referral too, if this is a secondary referral
I PRIMREF>0 D
. S CMNTSX=$$GETMEDHX("",PRIMREF,"M")
. I $G(CMNTSX)="~`M'~M" S CMNTSX=""
. I $G(CMNTSX)'="~`M'~M" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSX,1,$L(CMNTSX)-4)
;; fetch MED HX comments for the Referral
I $G(CMNTSX)'="" D
. S CMNTSXX=$$GETMEDHX("",REFIEN,"M")
. I $G(CMNTSXX)="~`M'~M" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)
. I $G(CMNTSXX)'="~`M'~M" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSXX,3,$L(CMNTSXX)-4)
;; fetch Business Office/CHS comments for the Primary referral too, if this is a secondary referral
I $G(CMNTSX)="" D
. S CMNTSXX=$$GETMEDHX("",REFIEN,"M")
. I $G(CMNTSXX)="~`M'~M" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$G(CMNTSXX)
. I $G(CMNTSXX)'="~`M'~M" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSXX,1,$L(CMNTSXX)-4)
I PRIMREF>0 D
. S CMNTSB=$$GETMEDHX("",PRIMREF,"B")
. I $G(CMNTSB)="~`B'~B" S CMNTSB=""
. I $G(CMNTSB)'="~`B'~B" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSB,1,$L(CMNTSB)-4)
;; fetch Business Office/CHS comments for the Referral
I $G(CMNTSB)'="" D
. S CMNTSBB=$$GETMEDHX("",REFIEN,"B")
. I $G(CMNTSBB)="~`B'~B" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)
. I $G(CMNTSBB)'="~`B'~B" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSBB,3,$L(CMNTSBB)-4)
I $G(CMNTSB)="" D
. S CMNTSBB=$$GETMEDHX("",REFIEN,"B")
. I $G(CMNTSBB)="~`B'~B" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$G(CMNTSBB)
. I $G(CMNTSBB)'="~`B'~B" S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSBB,1,$L(CMNTSBB)-4)
;
S RSLT=$NA(^TMP($J,"PRNRC"))
Q RSLT
GETMEDHX(RSLT,REFIEN,TYPE) ;; Get Medical History or Business Office/CHS notes for a referral
; D GETMEDHX^BMCRPC1(.R,"113251","M") W R
N CMNTS,IND,ERR,INDEX,CMDATE,RFCMTIEN,REVIEWER,OUT,SCR,CMNTSX
S RFCMTIEN="",REVIEWER="",CMDATE="",IND="",INDEX="",CMNTS="",CMNTSX="~`"_TYPE_"'~"_TYPE,ERR=""
S SCR="I ((($P($G("_"^"_"(0)),""^"",5))="""_TYPE_""") & (($P($G(^(0)),""^"",3))="_REFIEN_"))" ;;fetch only MED HX comments, for the Primary Referral
D LIST^DIC(90001.03,"","@;.01;.04","BQ","*",,REFIEN,"AD",SCR,"","OUT")
;S RFCMTIEN=$$FIND1^DIC(90001.03,"","BQX",REFIEN,"AD")
S INDEX=$O(OUT("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S RFCMTIEN=$G(OUT("DILIST",2,INDEX))
.S CMDATE=$G(OUT("DILIST","ID",INDEX,".01"))
.S REVIEWER=$G(OUT("DILIST","ID",INDEX,".04"))
.K WP N WP
.I RFCMTIEN>0 D GET1^DIQ(90001.03,RFCMTIEN_",",1,,"WP")
.S IND=$O(WP(IND))
.I +IND>0 F D Q:(+IND'>0)
..S CMNTS=CMNTS_WP(IND)_"~"
..S IND=$O(WP(IND))
.I CMNTS'="" S CMNTSX=CMNTSX_RFCMTIEN_"^"_CMDATE_"^"_REVIEWER_"^"_$E(CMNTS,1,$L(CMNTS)-1)_TYPE_"'~"_TYPE
.S INDEX=$O(OUT("DILIST","ID",INDEX)),CMNTS=""
S RSLT=CMNTSX
Q RSLT
;
GETREFDT(RSLT) ;; get Reference data for Refferal i-e ICD/CPT Categories
; D GETREFDT^BMCRPC1(.R) ZW R
K ^TMP($J)
N OUT,OUT1,OUT2,OUT3,ICDIEN,ICDCAT,ICDACTDT,ICDINADT,CPTIEN,CPTCAT,PRPIEN,PRPTXT,I,PIECE,RSCODE,RSDESC
S ^TMP($J,"PRNRCRF",1)="~`" ;; RCIS ICD DIAGNOSTIC CATEGORY
S ^TMP($J,"PRNRCRF",2)="~`" ;; RCIS CPT PROCEDURE CATEGORY
S ^TMP($J,"PRNRCRF",3)="~`" ;; RCIS PURPOSE TEXT LIST
S ^TMP($J,"PRNRCRF",4)="~`" ;; RCIS STATUS OF REFERRAL LIST
D LIST^DIC(90001.51,"","@;.01","","*",,,"",,"","OUT")
S INDEX=$O(OUT("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S ICDIEN=$G(OUT("DILIST",2,INDEX))
.S ICDCAT=$G(OUT("DILIST","ID",INDEX,".01"))
.S ICDACTDT=$$GET1^DIQ(90001.51,$G(ICDIEN)_",",.02,"")
.S ICDINADT=$$GET1^DIQ(90001.51,$G(ICDIEN)_",",.03,"")
.S ^TMP($J,"PRNRCRF",1)=$G(^TMP($J,"PRNRCRF",1))_ICDIEN_"^"_ICDCAT_"^"_ICDACTDT_"^"_ICDINADT_"~"
.S INDEX=$O(OUT("DILIST","ID",INDEX))
D LIST^DIC(90001.52,"","@;.01","","*",,,"",,"","OUT1")
S INDEX=$O(OUT1("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S CPTIEN=$G(OUT1("DILIST",2,INDEX))
.S CPTCAT=$G(OUT1("DILIST","ID",INDEX,".01"))
.S ^TMP($J,"PRNRCRF",2)=$G(^TMP($J,"PRNRCRF",2))_CPTIEN_"^"_CPTCAT_"~"
.S INDEX=$O(OUT1("DILIST","ID",INDEX))
D LIST^DIC(90001.58,"","@;.01","","*",,,"",,"","OUT2")
S INDEX=$O(OUT2("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S PRPIEN=$G(OUT2("DILIST",2,INDEX))
.S PRPTXT=$G(OUT2("DILIST","ID",INDEX,".01"))
.S ^TMP($J,"PRNRCRF",3)=$G(^TMP($J,"PRNRCRF",3))_PRPIEN_"^"_PRPTXT_"~"
.S INDEX=$O(OUT2("DILIST","ID",INDEX))
S OUT3=$P($G(^DD(90001,.15,0)),"^",3)
S PIECE=$P($G(OUT3),";"),I=1
I PIECE'="" F D Q:(PIECE="")
.S RSCODE=$P($G(PIECE),":",1)
.S RSDESC=$P($G(PIECE),":",2)
.S ^TMP($J,"PRNRCRF",4)=$G(^TMP($J,"PRNRCRF",4))_RSCODE_"^"_RSDESC_"~"
.S I=I+1,PIECE=$P($G(OUT3),";",I)
S RSLT=$NA(^TMP($J,"PRNRCRF"))
Q RSLT
SRRFRDTO(RSLT,SRHSTRNG,REFTYPE) ;; Search Vendor ; Specific Provider ; Clinic Stop ; Location
; search varies on Refferal type
K ^TMP($J)
I (('$D(REFTYPE))!('$D(SRHSTRNG))) S RSLT="Either search string or Referral Type is not present" Q RSLT
I REFTYPE="C" D SRVNDR(.RSLT,SRHSTRNG) Q RSLT ;CHS
I REFTYPE="I" D SRIHSFC(.RSLT,SRHSTRNG) Q RSLT ;IHS (ANOTHER FACILITY)
I REFTYPE="O" D SROTPRV(.RSLT,SRHSTRNG) Q RSLT ;OTHER
I REFTYPE="N" D SRCLNCST(.RSLT,SRHSTRNG) Q RSLT ;IN-HOUSE
Q
SRVNDR(RSLT,VNRSTRNG) ;; search vendor from VENDOR file for type 'CHS' referrel
N OUT,SCR,INDEX,VNDRIEN,VNDRNM,VNDRDUN,VNDREIN,EINSFX,MAILTO,REMITTO
S SCR="I (($P($G("_"^"_"(0)),""^"",5)="""") ! ($P($G("_"^"_"(0)),""^"",5)>"_DT_"))"
D LIST^DIC(9999999.11,"","@;.01;.05;.07;1101;1102;1301;1302;1401;1402;1403","","*",,VNRSTRNG,"B",SCR,"","OUT")
S INDEX=$O(OUT("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.;GDIT/HS/BEE 10/19/17 - p12 CR#7796 - added next two lines
.NEW IDT
.S IDT=$G(OUT("DILIST","ID",INDEX,".05")) I IDT]"",IDT<DT Q
.;End of CR#7796 changes
.S VNDRIEN=$G(OUT("DILIST",2,INDEX))
.S VNDRNM=$G(OUT("DILIST","ID",INDEX,".01"))
.S VNDRDUN=$G(OUT("DILIST","ID",INDEX,".07"))
.S VNDREIN=$G(OUT("DILIST","ID",INDEX,"1101"))
.S EINSFX=$G(OUT("DILIST","ID",INDEX,"1102"))
.S MAILTO=$G(OUT("DILIST","ID",INDEX,"1301"))_","_$G(OUT("DILIST","ID",INDEX,"1302"))
.S REMITTO=$G(OUT("DILIST","ID",INDEX,"1401"))_","_$G(OUT("DILIST","ID",INDEX,"1402"))_","_$G(OUT("DILIST","ID",INDEX,"1403"))
.S ^TMP($J,"PRNRCRVND",INDEX)="~`"_VNDRIEN_"^"_VNDRNM_"^"_VNDRDUN_"^"_VNDREIN_"^"_EINSFX_"^"_MAILTO_"^"_REMITTO
.S INDEX=$O(OUT("DILIST","ID",INDEX))
S RSLT=$NA(^TMP($J,"PRNRCRVND"))
Q RSLT
SRIHSFC(RSLT,FCSTRNG) ;; search falicity from Location file for type 'IHS (ANOTHER FACILITY)' refferel
N OUT,INDEX,FACIEN,NAME,AREA,SVCUNIT,CODE,INACTIVE,INACTDT
D LIST^DIC(9999999.06,"","@;.01;.04;.05;.07;.27","","*",,FCSTRNG,"B",,"","OUT")
S INDEX=$O(OUT("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S FACIEN=$G(OUT("DILIST",2,INDEX))
.S NAME=$G(OUT("DILIST","ID",INDEX,".01"))
.S AREA=$G(OUT("DILIST","ID",INDEX,".04"))
.S SVCUNIT=$G(OUT("DILIST","ID",INDEX,".05"))
.S CODE=$G(OUT("DILIST","ID",INDEX,".07"))
.S INACTIVE="" I ($G(OUT("DILIST","ID",INDEX,".27"))'="") S INACTDT=$G(OUT("DILIST","ID",INDEX,".27")) D DT^DILF("TS",INACTDT,.INACTDT,,"") I INACTDT<=DT S INACTIVE=1
.S ^TMP($J,"PRNRCRVND",INDEX)="~`"_FACIEN_"^"_NAME_"^"_AREA_"^"_SVCUNIT_"^"_CODE_"^"_INACTIVE_"^"_"" ;; extra empty field to keep inline with return paramaters of RPC
.S INDEX=$O(OUT("DILIST","ID",INDEX))
S RSLT=$NA(^TMP($J,"PRNRCRVND"))
Q RSLT
SROTPRV(RSLT,PRVSTRNG) ;; search provider from RCIS SPECIFIC PROVIDER file for type 'OTHER' referrels
N OUT,INDEX,PRVIEN,NAME
D LIST^DIC(90001.53,"","@;.01","","*",,PRVSTRNG,"B",,"","OUT")
S INDEX=$O(OUT("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S PRVIEN=$G(OUT("DILIST",2,INDEX))
.S NAME=$G(OUT("DILIST","ID",INDEX,".01"))
.S ^TMP($J,"PRNRCRVND",INDEX)="~`"_PRVIEN_"^"_NAME_"^"_""_"^"_""_"^"_""_"^"_""_"^"_"" ;; extra empty field to keep inline with return paramaters of RPC
.S INDEX=$O(OUT("DILIST","ID",INDEX))
S RSLT=$NA(^TMP($J,"PRNRCRVND"))
Q RSLT
SRCLNCST(RSLT,CLNSTRNG) ;; search from CLINIC STOP file for IN-HOUSE referrals
N OUT,INDEX,CLNIEN,NAME,CODE
D LIST^DIC(40.7,"","@;.01;1","","*",,CLNSTRNG,"B",,"","OUT")
S INDEX=$O(OUT("DILIST","ID",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S CLNIEN=$G(OUT("DILIST",2,INDEX))
.S NAME=$G(OUT("DILIST","ID",INDEX,".01"))
.S CODE=$G(OUT("DILIST","ID",INDEX,"1"))
.S ^TMP($J,"PRNRCRVND",INDEX)="~`"_CLNIEN_"^"_NAME_"^"_CODE_"^"_""_"^"_""_"^"_""_"^"_"" ;; extra empty field to keep inline with return paramaters of RPC
.S INDEX=$O(OUT("DILIST","ID",INDEX))
S RSLT=$NA(^TMP($J,"PRNRCRVND"))
Q RSLT
;
BMCRPC1 ; IHS/CAS/AU - GUI REFERRED CARE INFO SYSTEM (1/4);
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**7,8,12**;JAN 09, 2006;Build 101
+2 ;
+3 ;GDIT/HS/BEE 10/19/17 - p12 CR#7796:Filter out inactive vendors
+4 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+5 ;
+6 ; RPC code for RCIS GUI Application
+7 ; Routines contains code for Reading data from RCIS files
SRCHREF(RSLT,PATIENT,REFPRVDR,STRTDATE,ENDDATE,RECNMBR,STATUS) ; search referral w.r.t patient, referring provider and date range
+1 ;; PATIENT = DFN
+2 ; REFPRVDR = Provider Ien
+3 ; STRTDATE = start date , ENDDATE = end date , search referrels between start and end date
+4 ; NMBRREC = Number of recrods to return
+5 ;S RSLT="Test Referaal Data" Q
+6 ;S ^TMP("FAR234")=$G(PATIENT)_"^"_$G(REFPRVDR)_"^"_$G(STRTDATE)_"^"_$G(ENDDATE)_"^"_$G(RECNMBR)_"^"_$G(STATUS)
+7 ;S PATIENT=""
+8 ;S STRTDATE="8/14/2012"
+9 ;S ENDDATE="8/14/2013"
+10 ;S REFPRVDR="3043"
+11 ;S STATUS="Active"
+12 ;D SRCHREF^BMCRPC1(.R,PATIENT,REFPRVDR,STRTDATE,ENDDATE,"",STATUS) ZW @R
+13 ;S DI="S X=$P($G("_"^"_"(0)),U,2) D LIST^DIC(8992.5,,""@;.01;.02IE;.03IE;.04;.05;.06;.09;1"",""IP"",1,X-1,X,""#"",,,""OUT1""_@X) D EN^DDIOL($G(OUT1_@X(""DILIST"",1,0)))"
+14 NEW OUT,ERR,SCR
+15 SET SCR="I 1"
+16 IF ($DATA(STATUS)&($GET(STATUS)'=""))
Begin DoDot:1
+17 IF $GET(STATUS)="Active"
SET STATUS="A"
+18 IF $GET(STATUS)="Approved"
SET STATUS="A1"
+19 IF $GET(STATUS)="Closed-Completed"
SET STATUS="C1"
+20 IF $GET(STATUS)="Closed-Not Completed"
SET STATUS="X"
End DoDot:1
+21 KILL ^TMP($JOB,"PRNRCTMP")
+22 IF +RECNMBR'>0
SET RECNMBR="*"
+23 ;D EN^DDIOL($G(OUT1("DILIST",1,0)))
IF ($DATA(PATIENT)&(PATIENT'=""))
SET SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",3))="_PATIENT_")"
+24 IF ($DATA(REFPRVDR)&(REFPRVDR'=""))
SET SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",6))="_REFPRVDR_")"
+25 IF ($DATA(STATUS)&($GET(STATUS)'=""))
Begin DoDot:1
+26 IF $GET(STATUS)'="Active/Approved"
Begin DoDot:2
+27 SET SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",15))="""_$GET(STATUS)_""")"
End DoDot:2
+28 IF $GET(STATUS)="Active/Approved"
Begin DoDot:2
+29 SET SCR=SCR_" & ((($P($G("_"^"_"(0)),""^"",15))=""A"") ! (($P($G("_"^"_"(0)),""^"",15))=""A1""))"
End DoDot:2
End DoDot:1
+30 IF ($DATA(STRTDATE)&(STRTDATE'=""))
DO DT^DILF("TS",STRTDATE,.STRTDATE,,"")
SET SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",1))>="_STRTDATE_")"
+31 IF ($DATA(ENDDATE)&(ENDDATE'=""))
DO DT^DILF("TS",ENDDATE,.ENDDATE,,"")
SET SCR=SCR_" & (($P($G("_"^"_"(0)),""^"",1))<="_ENDDATE_")"
+32 IF ($DATA(PATIENT)&(PATIENT'=""))
DO LIST^DIC(90001,"","@;.01;.02;101;.03IE;.05I;.06;.0999;1105;1112;1201;1114;1301;.15;1306;1307;1308","BQ",RECNMBR,,PATIENT,"D",SCR,"","^TMP($J,""PRNRCTMP"")")
DO CRTMSG^BMCRPC4(.RSLT,0)
QUIT RSLT
+33 IF ($DATA(REFPRVDR)&(REFPRVDR'=""))
DO LIST^DIC(90001,"","@;.01;.02;101;.03IE;.05I;.06;.0999;1105;1112;1201;1114;1301;.15;1306;1307;1308","BQ",RECNMBR,,REFPRVDR,"E",SCR,"","^TMP($J,""PRNRCTMP"")")
DO CRTMSG^BMCRPC4(.RSLT,0)
QUIT RSLT
+34 IF ($DATA(STRTDATE)&(STRTDATE'=""))
Begin DoDot:1
+35 IF ($DATA(ENDDATE)&(ENDDATE'=""))
DO LIST^DIC(90001,"","@;.01;.02;101;.03IE;.05I;.06;.0999;1105;1112;1201;1114;1301;.15;1306;1307;1308","",RECNMBR,,,"B",SCR,"","^TMP($J,""PRNRCTMP"")")
DO CRTMSG^BMCRPC4(.RSLT,0)
QUIT
End DoDot:1
+36 QUIT RSLT
GTRFBYID(RSLT,REFIEN) ;; get referral
+1 ;; D GTRFBYID^BMCRPC1(.R,"113251") ZW @R
+2 ;; RSLT = result set returned as golbal array
+3 ;; REFIEN = referral ien of RCIS REFERRAL file
+4 ;; D GTRFBYID^BMCRPC1(.R,"113252") ZW @R
+5 NEW SCR,REFNUM,CMNTSX,CMNTSB,PRIMREF,FIELDS,CMNTSBB,CMNTSXX
+6 IF '$DATA(REFIEN)
QUIT
+7 IF REFIEN=""
QUIT
+8 IF $$GET1^DIQ(90001,REFIEN_",",.01,"")=""
SET RSLT="Not a valid Referral Ien"
QUIT RSLT
+9 ;;check if record is being locked else where
LOCK +^BMCREF(REFIEN):0.2
+10 IF '$TEST
SET RSLT="The referral record cannot be opened becuase it is locked. Please try again later."
QUIT RSLT
+11 SET SCR="I Y="_REFIEN
+12 KILL ^TMP($JOB,"PRNRCTMP"),^TMP($JOB,"PRNRC")
+13 ;;get Ref Number... to use index in search... fast fetch
SET REFNUM=$$GET1^DIQ(90001,REFIEN_",",.02,"")
+14 ;;get primary referral - if exsits; fetch Med Hx for primary ref too
SET PRIMREF=$$GET1^DIQ(90001,REFIEN_",",102,"")
+15 SET FIELDS="@;.01;.02;.06;.0999;.15;101;1105;1111;1112;1201;1114;1301;1302;401;402;403;404;405;406;407;408;409;410;411;412;.03IE;.04I;.05I;.12I;.13I;.14I;.07I;.08I;.09I;.23I;.32;1306;1307;1308"
+16 DO LIST^DIC(90001,"",FIELDS,"Q","1",,REFNUM,"C",SCR,"","^TMP($J,""PRNRCTMP"")")
+17 ;; unlock the record
LOCK -^BMCREF(REFIEN)
+18 ;;package data to be returned
DO CRTMSG^BMCRPC4(.RSLT,1)
+19 ;; fetch MED HX comments for the Referral
+20 ;S CMNTSX=$$GETMEDHX("",REFIEN,"M")
+21 ;S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSX,1,$L(CMNTSX)-4)
+22 ;; fetch Business Office/CHS comments for the Referral
+23 ;S CMNTSB=$$GETMEDHX("",REFIEN,"B")
+24 ;S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSB,1,$L(CMNTSB)-4)
+25 ;; fetch MED HX comments for the Primary referral too, if this is a secondary referral
+26 ;I PRIMREF>0 S CMNTSX=$$GETMEDHX("",PRIMREF,"M") S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSX,1,$L(CMNTSX)-4)
+27 ;; fetch Business Office/CHS comments for the Primary referral too, if this is a secondary referral
+28 ;I PRIMREF>0 S CMNTSB=$$GETMEDHX("",PRIMREF,"B") S ^TMP($J,"PRNRC",1)=^TMP($J,"PRNRC",1)_$E(CMNTSB,1,$L(CMNTSB)-4)
+29 ;; fetch MED HX comments for the Primary referral too, if this is a secondary referral
+30 IF PRIMREF>0
Begin DoDot:1
+31 SET CMNTSX=$$GETMEDHX("",PRIMREF,"M")
+32 IF $GET(CMNTSX)="~`M'~M"
SET CMNTSX=""
+33 IF $GET(CMNTSX)'="~`M'~M"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$EXTRACT(CMNTSX,1,$LENGTH(CMNTSX)-4)
End DoDot:1
+34 ;; fetch MED HX comments for the Referral
+35 IF $GET(CMNTSX)'=""
Begin DoDot:1
+36 SET CMNTSXX=$$GETMEDHX("",REFIEN,"M")
+37 IF $GET(CMNTSXX)="~`M'~M"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)
+38 IF $GET(CMNTSXX)'="~`M'~M"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$EXTRACT(CMNTSXX,3,$LENGTH(CMNTSXX)-4)
End DoDot:1
+39 ;; fetch Business Office/CHS comments for the Primary referral too, if this is a secondary referral
+40 IF $GET(CMNTSX)=""
Begin DoDot:1
+41 SET CMNTSXX=$$GETMEDHX("",REFIEN,"M")
+42 IF $GET(CMNTSXX)="~`M'~M"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$GET(CMNTSXX)
+43 IF $GET(CMNTSXX)'="~`M'~M"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$EXTRACT(CMNTSXX,1,$LENGTH(CMNTSXX)-4)
End DoDot:1
+44 IF PRIMREF>0
Begin DoDot:1
+45 SET CMNTSB=$$GETMEDHX("",PRIMREF,"B")
+46 IF $GET(CMNTSB)="~`B'~B"
SET CMNTSB=""
+47 IF $GET(CMNTSB)'="~`B'~B"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$EXTRACT(CMNTSB,1,$LENGTH(CMNTSB)-4)
End DoDot:1
+48 ;; fetch Business Office/CHS comments for the Referral
+49 IF $GET(CMNTSB)'=""
Begin DoDot:1
+50 SET CMNTSBB=$$GETMEDHX("",REFIEN,"B")
+51 IF $GET(CMNTSBB)="~`B'~B"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)
+52 IF $GET(CMNTSBB)'="~`B'~B"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$EXTRACT(CMNTSBB,3,$LENGTH(CMNTSBB)-4)
End DoDot:1
+53 IF $GET(CMNTSB)=""
Begin DoDot:1
+54 SET CMNTSBB=$$GETMEDHX("",REFIEN,"B")
+55 IF $GET(CMNTSBB)="~`B'~B"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$GET(CMNTSBB)
+56 IF $GET(CMNTSBB)'="~`B'~B"
SET ^TMP($JOB,"PRNRC",1)=^TMP($JOB,"PRNRC",1)_$EXTRACT(CMNTSBB,1,$LENGTH(CMNTSBB)-4)
End DoDot:1
+57 ;
+58 SET RSLT=$NAME(^TMP($JOB,"PRNRC"))
+59 QUIT RSLT
GETMEDHX(RSLT,REFIEN,TYPE) ;; Get Medical History or Business Office/CHS notes for a referral
+1 ; D GETMEDHX^BMCRPC1(.R,"113251","M") W R
+2 NEW CMNTS,IND,ERR,INDEX,CMDATE,RFCMTIEN,REVIEWER,OUT,SCR,CMNTSX
+3 SET RFCMTIEN=""
SET REVIEWER=""
SET CMDATE=""
SET IND=""
SET INDEX=""
SET CMNTS=""
SET CMNTSX="~`"_TYPE_"'~"_TYPE
SET ERR=""
+4 ;;fetch only MED HX comments, for the Primary Referral
SET SCR="I ((($P($G("_"^"_"(0)),""^"",5))="""_TYPE_""") & (($P($G(^(0)),""^"",3))="_REFIEN_"))"
+5 DO LIST^DIC(90001.03,"","@;.01;.04","BQ","*",,REFIEN,"AD",SCR,"","OUT")
+6 ;S RFCMTIEN=$$FIND1^DIC(90001.03,"","BQX",REFIEN,"AD")
+7 SET INDEX=$ORDER(OUT("DILIST","ID",0))
+8 IF +INDEX>0
FOR
Begin DoDot:1
+9 SET RFCMTIEN=$GET(OUT("DILIST",2,INDEX))
+10 SET CMDATE=$GET(OUT("DILIST","ID",INDEX,".01"))
+11 SET REVIEWER=$GET(OUT("DILIST","ID",INDEX,".04"))
+12 KILL WP
NEW WP
+13 IF RFCMTIEN>0
DO GET1^DIQ(90001.03,RFCMTIEN_",",1,,"WP")
+14 SET IND=$ORDER(WP(IND))
+15 IF +IND>0
FOR
Begin DoDot:2
+16 SET CMNTS=CMNTS_WP(IND)_"~"
+17 SET IND=$ORDER(WP(IND))
End DoDot:2
IF (+IND'>0)
QUIT
+18 IF CMNTS'=""
SET CMNTSX=CMNTSX_RFCMTIEN_"^"_CMDATE_"^"_REVIEWER_"^"_$EXTRACT(CMNTS,1,$LENGTH(CMNTS)-1)_TYPE_"'~"_TYPE
+19 SET INDEX=$ORDER(OUT("DILIST","ID",INDEX))
SET CMNTS=""
End DoDot:1
IF (+INDEX'>0)
QUIT
+20 SET RSLT=CMNTSX
+21 QUIT RSLT
+22 ;
GETREFDT(RSLT) ;; get Reference data for Refferal i-e ICD/CPT Categories
+1 ; D GETREFDT^BMCRPC1(.R) ZW R
+2 KILL ^TMP($JOB)
+3 NEW OUT,OUT1,OUT2,OUT3,ICDIEN,ICDCAT,ICDACTDT,ICDINADT,CPTIEN,CPTCAT,PRPIEN,PRPTXT,I,PIECE,RSCODE,RSDESC
+4 ;; RCIS ICD DIAGNOSTIC CATEGORY
SET ^TMP($JOB,"PRNRCRF",1)="~`"
+5 ;; RCIS CPT PROCEDURE CATEGORY
SET ^TMP($JOB,"PRNRCRF",2)="~`"
+6 ;; RCIS PURPOSE TEXT LIST
SET ^TMP($JOB,"PRNRCRF",3)="~`"
+7 ;; RCIS STATUS OF REFERRAL LIST
SET ^TMP($JOB,"PRNRCRF",4)="~`"
+8 DO LIST^DIC(90001.51,"","@;.01","","*",,,"",,"","OUT")
+9 SET INDEX=$ORDER(OUT("DILIST","ID",0))
+10 IF +INDEX>0
FOR
Begin DoDot:1
+11 SET ICDIEN=$GET(OUT("DILIST",2,INDEX))
+12 SET ICDCAT=$GET(OUT("DILIST","ID",INDEX,".01"))
+13 SET ICDACTDT=$$GET1^DIQ(90001.51,$GET(ICDIEN)_",",.02,"")
+14 SET ICDINADT=$$GET1^DIQ(90001.51,$GET(ICDIEN)_",",.03,"")
+15 SET ^TMP($JOB,"PRNRCRF",1)=$GET(^TMP($JOB,"PRNRCRF",1))_ICDIEN_"^"_ICDCAT_"^"_ICDACTDT_"^"_ICDINADT_"~"
+16 SET INDEX=$ORDER(OUT("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+17 DO LIST^DIC(90001.52,"","@;.01","","*",,,"",,"","OUT1")
+18 SET INDEX=$ORDER(OUT1("DILIST","ID",0))
+19 IF +INDEX>0
FOR
Begin DoDot:1
+20 SET CPTIEN=$GET(OUT1("DILIST",2,INDEX))
+21 SET CPTCAT=$GET(OUT1("DILIST","ID",INDEX,".01"))
+22 SET ^TMP($JOB,"PRNRCRF",2)=$GET(^TMP($JOB,"PRNRCRF",2))_CPTIEN_"^"_CPTCAT_"~"
+23 SET INDEX=$ORDER(OUT1("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+24 DO LIST^DIC(90001.58,"","@;.01","","*",,,"",,"","OUT2")
+25 SET INDEX=$ORDER(OUT2("DILIST","ID",0))
+26 IF +INDEX>0
FOR
Begin DoDot:1
+27 SET PRPIEN=$GET(OUT2("DILIST",2,INDEX))
+28 SET PRPTXT=$GET(OUT2("DILIST","ID",INDEX,".01"))
+29 SET ^TMP($JOB,"PRNRCRF",3)=$GET(^TMP($JOB,"PRNRCRF",3))_PRPIEN_"^"_PRPTXT_"~"
+30 SET INDEX=$ORDER(OUT2("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+31 SET OUT3=$PIECE($GET(^DD(90001,.15,0)),"^",3)
+32 SET PIECE=$PIECE($GET(OUT3),";")
SET I=1
+33 IF PIECE'=""
FOR
Begin DoDot:1
+34 SET RSCODE=$PIECE($GET(PIECE),":",1)
+35 SET RSDESC=$PIECE($GET(PIECE),":",2)
+36 SET ^TMP($JOB,"PRNRCRF",4)=$GET(^TMP($JOB,"PRNRCRF",4))_RSCODE_"^"_RSDESC_"~"
+37 SET I=I+1
SET PIECE=$PIECE($GET(OUT3),";",I)
End DoDot:1
IF (PIECE="")
QUIT
+38 SET RSLT=$NAME(^TMP($JOB,"PRNRCRF"))
+39 QUIT RSLT
SRRFRDTO(RSLT,SRHSTRNG,REFTYPE) ;; Search Vendor ; Specific Provider ; Clinic Stop ; Location
+1 ; search varies on Refferal type
+2 KILL ^TMP($JOB)
+3 IF (('$DATA(REFTYPE))!('$DATA(SRHSTRNG)))
SET RSLT="Either search string or Referral Type is not present"
QUIT RSLT
+4 ;CHS
IF REFTYPE="C"
DO SRVNDR(.RSLT,SRHSTRNG)
QUIT RSLT
+5 ;IHS (ANOTHER FACILITY)
IF REFTYPE="I"
DO SRIHSFC(.RSLT,SRHSTRNG)
QUIT RSLT
+6 ;OTHER
IF REFTYPE="O"
DO SROTPRV(.RSLT,SRHSTRNG)
QUIT RSLT
+7 ;IN-HOUSE
IF REFTYPE="N"
DO SRCLNCST(.RSLT,SRHSTRNG)
QUIT RSLT
+8 QUIT
SRVNDR(RSLT,VNRSTRNG) ;; search vendor from VENDOR file for type 'CHS' referrel
+1 NEW OUT,SCR,INDEX,VNDRIEN,VNDRNM,VNDRDUN,VNDREIN,EINSFX,MAILTO,REMITTO
+2 SET SCR="I (($P($G("_"^"_"(0)),""^"",5)="""") ! ($P($G("_"^"_"(0)),""^"",5)>"_DT_"))"
+3 DO LIST^DIC(9999999.11,"","@;.01;.05;.07;1101;1102;1301;1302;1401;1402;1403","","*",,VNRSTRNG,"B",SCR,"","OUT")
+4 SET INDEX=$ORDER(OUT("DILIST","ID",0))
+5 IF +INDEX>0
FOR
Begin DoDot:1
+6 ;GDIT/HS/BEE 10/19/17 - p12 CR#7796 - added next two lines
+7 NEW IDT
+8 SET IDT=$GET(OUT("DILIST","ID",INDEX,".05"))
IF IDT]""
IF IDT<DT
QUIT
+9 ;End of CR#7796 changes
+10 SET VNDRIEN=$GET(OUT("DILIST",2,INDEX))
+11 SET VNDRNM=$GET(OUT("DILIST","ID",INDEX,".01"))
+12 SET VNDRDUN=$GET(OUT("DILIST","ID",INDEX,".07"))
+13 SET VNDREIN=$GET(OUT("DILIST","ID",INDEX,"1101"))
+14 SET EINSFX=$GET(OUT("DILIST","ID",INDEX,"1102"))
+15 SET MAILTO=$GET(OUT("DILIST","ID",INDEX,"1301"))_","_$GET(OUT("DILIST","ID",INDEX,"1302"))
+16 SET REMITTO=$GET(OUT("DILIST","ID",INDEX,"1401"))_","_$GET(OUT("DILIST","ID",INDEX,"1402"))_","_$GET(OUT("DILIST","ID",INDEX,"1403"))
+17 SET ^TMP($JOB,"PRNRCRVND",INDEX)="~`"_VNDRIEN_"^"_VNDRNM_"^"_VNDRDUN_"^"_VNDREIN_"^"_EINSFX_"^"_MAILTO_"^"_REMITTO
+18 SET INDEX=$ORDER(OUT("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+19 SET RSLT=$NAME(^TMP($JOB,"PRNRCRVND"))
+20 QUIT RSLT
SRIHSFC(RSLT,FCSTRNG) ;; search falicity from Location file for type 'IHS (ANOTHER FACILITY)' refferel
+1 NEW OUT,INDEX,FACIEN,NAME,AREA,SVCUNIT,CODE,INACTIVE,INACTDT
+2 DO LIST^DIC(9999999.06,"","@;.01;.04;.05;.07;.27","","*",,FCSTRNG,"B",,"","OUT")
+3 SET INDEX=$ORDER(OUT("DILIST","ID",0))
+4 IF +INDEX>0
FOR
Begin DoDot:1
+5 SET FACIEN=$GET(OUT("DILIST",2,INDEX))
+6 SET NAME=$GET(OUT("DILIST","ID",INDEX,".01"))
+7 SET AREA=$GET(OUT("DILIST","ID",INDEX,".04"))
+8 SET SVCUNIT=$GET(OUT("DILIST","ID",INDEX,".05"))
+9 SET CODE=$GET(OUT("DILIST","ID",INDEX,".07"))
+10 SET INACTIVE=""
IF ($GET(OUT("DILIST","ID",INDEX,".27"))'="")
SET INACTDT=$GET(OUT("DILIST","ID",INDEX,".27"))
DO DT^DILF("TS",INACTDT,.INACTDT,,"")
IF INACTDT<=DT
SET INACTIVE=1
+11 ;; extra empty field to keep inline with return paramaters of RPC
SET ^TMP($JOB,"PRNRCRVND",INDEX)="~`"_FACIEN_"^"_NAME_"^"_AREA_"^"_SVCUNIT_"^"_CODE_"^"_INACTIVE_"^"_""
+12 SET INDEX=$ORDER(OUT("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+13 SET RSLT=$NAME(^TMP($JOB,"PRNRCRVND"))
+14 QUIT RSLT
SROTPRV(RSLT,PRVSTRNG) ;; search provider from RCIS SPECIFIC PROVIDER file for type 'OTHER' referrels
+1 NEW OUT,INDEX,PRVIEN,NAME
+2 DO LIST^DIC(90001.53,"","@;.01","","*",,PRVSTRNG,"B",,"","OUT")
+3 SET INDEX=$ORDER(OUT("DILIST","ID",0))
+4 IF +INDEX>0
FOR
Begin DoDot:1
+5 SET PRVIEN=$GET(OUT("DILIST",2,INDEX))
+6 SET NAME=$GET(OUT("DILIST","ID",INDEX,".01"))
+7 ;; extra empty field to keep inline with return paramaters of RPC
SET ^TMP($JOB,"PRNRCRVND",INDEX)="~`"_PRVIEN_"^"_NAME_"^"_""_"^"_""_"^"_""_"^"_""_"^"_""
+8 SET INDEX=$ORDER(OUT("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+9 SET RSLT=$NAME(^TMP($JOB,"PRNRCRVND"))
+10 QUIT RSLT
SRCLNCST(RSLT,CLNSTRNG) ;; search from CLINIC STOP file for IN-HOUSE referrals
+1 NEW OUT,INDEX,CLNIEN,NAME,CODE
+2 DO LIST^DIC(40.7,"","@;.01;1","","*",,CLNSTRNG,"B",,"","OUT")
+3 SET INDEX=$ORDER(OUT("DILIST","ID",0))
+4 IF +INDEX>0
FOR
Begin DoDot:1
+5 SET CLNIEN=$GET(OUT("DILIST",2,INDEX))
+6 SET NAME=$GET(OUT("DILIST","ID",INDEX,".01"))
+7 SET CODE=$GET(OUT("DILIST","ID",INDEX,"1"))
+8 ;; extra empty field to keep inline with return paramaters of RPC
SET ^TMP($JOB,"PRNRCRVND",INDEX)="~`"_CLNIEN_"^"_NAME_"^"_CODE_"^"_""_"^"_""_"^"_""_"^"_""
+9 SET INDEX=$ORDER(OUT("DILIST","ID",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+10 SET RSLT=$NAME(^TMP($JOB,"PRNRCRVND"))
+11 QUIT RSLT
+12 ;
