BMCRPC1.m

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