Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCRPC4

BMCRPC4.m

Go to the documentation of this file. 
  1. BMCRPC4 ; IHS/CAS/AU - GUI REFERRED CARE INFO SYSTEM (4/4);     
  1.  ;;4.0;REFERRED CARE INFO SYSTEM;**7,8**;JAN 09, 2006;Build 101
  1.  ;
  1.  ; RPC code for RCIS GUI Application
  1.  ; Routines contains code for Creating Entry in V Referral and creating message for GUI
  1. CRTMSG(RSLT,DETAIL) ;; build result ;; DETAIL=0 ; search list , DETAIL=1 - get by Id
  1.  N INDEX,REFIEN,REFNMBR,REFDATE,PATIEN,INSURNCE,PATNAME,RQSTFAC,RQSTPRV,FCLTYRFT,APPTDT,CHSSTATS,REFPRPS,PATHRN,DENLRSN,CHSELIG,VAELIG
  1.  N SCHNOTES,REFTYPE,VSTTYPE,VSTNMBR,ICDCATID,CPTCATID,TYPEEXT,SUFFIX,PRIORITY,OTHERTYPE,OTHERTYPETEXT,SCR,SNOMEDCT,VREFIEN
  1.  N REFCNST,REFCNDT,REFCNBY,REFSTATUS,PROBLEM,VISIT
  1.  Q:'$D(^TMP($J,"PRNRCTMP","DILIST"))
  1.  K ^TMP($J,"PRNRC")
  1.  S PATHRN="",CHSELIG="",VAELIG="",INSURNCE="",PATIEN=""
  1.  S INDEX=$O(^TMP($J,"PRNRCTMP","DILIST","ID",0))
  1.  I +INDEX>0 F  D  Q:(+INDEX'>0)
  1.  .S REFIEN=$G(^TMP($J,"PRNRCTMP","DILIST",2,INDEX))
  1.  .S REFDATE=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".01"))
  1.  .S REFNMBR=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".02"))
  1.  .S PATNAME=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".03","E"))
  1.  .S PATIEN=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".03","I"))
  1.  .S CHSELIG=$$GET1^DIQ(9000001,PATIEN_",",1112,"")
  1.  .S SCR="I (($P($G("_"^"_"(0)),""^"",6))="""_REFIEN_""")"
  1.  .S VREFIEN=$$FIND1^DIC(9000010.59,"","Q",$G(PATIEN),"AC",SCR,"REFERR")
  1.  .I $G(VREFIEN)'="" D
  1.  ..S SNOMEDCT=$$GET1^DIQ(9000010.59,VREFIEN_",",.01,"")
  1.  ..S PROBLEM=$$GET1^DIQ(9000010.59,VREFIEN_",",.04,"I")
  1.  ..S SNOMEDPT=$$GET1^DIQ(9000010.59,VREFIEN_",",.019,"")
  1.  ..S VISIT=$$GET1^DIQ(9000010.59,VREFIEN_",",.03,"I")
  1.  .S RQSTFAC=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".05"))
  1.  .S RQSTPRV=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".06"))
  1.  .S FCLTYRFT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".0999"))
  1.  .S APPTDT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1105"))
  1.  .S CHSSTATS=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1112"))
  1.  .S REFSTATUS=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".15"))
  1.  .S REFPRPS=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1201"))
  1.  .S REFCNST=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1306"))
  1.  .S REFCNDT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1307"))
  1.  .S REFCNBY=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1308"))
  1.  .S DENLRSN=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1114"))
  1.  .S SCHNOTES=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1301"))
  1.  .S SUFFIX=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"101"))
  1.  .S PRIORITY=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".32"))
  1.  .I PATIEN'=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".03","I")) D
  1.  ..S PATIEN=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".03","I"))
  1.  ..I $D(^AUPNPAT(PATIEN,41,RQSTFAC)) S PATHRN=$P($G(^AUPNPAT(PATIEN,41,RQSTFAC,0)),"^",2)
  1.  ..S CHSELIG=$$GET1^DIQ(9000001,PATIEN_",",1112,"")
  1.  ..S VAELIG=$$GET1^DIQ(2,PATIEN_",",1901,"")
  1.  .I DETAIL=0 D
  1.  ..N C32IEN,C32DATA S C32DATA="^^",C32IEN=""
  1.  ..I $O(^BMCREF(REFIEN,6,"B","")) S C32IEN=$O(^BMCREF(REFIEN,6,"B",$O(^BMCREF(REFIEN,6,"B",""),-1),""))
  1.  ..I C32IEN>0 S C32DATA=$$GET1^DIQ(90001.6,C32IEN_","_REFIEN,.02,"")_"^"_$$GET1^DIQ(90001.6,C32IEN_","_REFIEN,.01,"")_"^"_$$GET1^DIQ(90001.6,C32IEN_","_REFIEN,.04)
  1.  ..S ^TMP($J,"PRNRC",INDEX)="~`"_REFIEN_"^"_REFDATE_"^"_REFNMBR_"^"_PATIEN_"^"_PATNAME_"^"_PATHRN_"^"_RQSTPRV_"^"_FCLTYRFT_"^"_APPTDT_"^"_REFSTATUS_"^"_REFPRPS_"^"_DENLRSN_"^"_CHSELIG_"^"_VAELIG_"^"_SCHNOTES_"^"_SUFFIX_"^"_C32DATA
  1.  ..S ^TMP($J,"PRNRC",INDEX)=^TMP($J,"PRNRC",INDEX)_"^"_$G(REFCNST)_"^"_$G(REFCNDT)_"^"_$G(REFCNBY)
  1.  .I DETAIL=1  D
  1.  ..N SCHWIDAY,INCLCSRP,INCLFSHT,INCLHLSM,INCLHSPH,INCLEKG,INCLLBRP,INCLPCC,INCLPRNL,INCLTUBL,INCLCLNT,INCLXRYR,INCLXRYF
  1.  ..S REFTYPE=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".04"))
  1.  ..S VSTTYPE=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".14"))
  1.  ..S VSTNMBR=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1111"))
  1.  ..S ICDCATID=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".12"))
  1.  ..S CPTCATID=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".13"))
  1.  ..S RQSTPRV=$$GET1^DIQ(90001,REFIEN_",",.06,"I")
  1.  ..I (REFTYPE="C") S TYPEEXT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".07")) ;; CHS - Vendor
  1.  ..I (REFTYPE="C") S OTHERTYPE=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".09")) ;; OTHER New Rule
  1.  ..I (REFTYPE="I") S TYPEEXT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".08")) ;; IHS (ANOTHER FACILITY) - Location IEn
  1.  ..I (REFTYPE="O") S OTHERTYPE=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".09")) ;; OTHER - RCIS Specific provider
  1.  ..I (REFTYPE="O") S TYPEEXT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".07")) ;; CHS Vendor
  1.  ..I (REFTYPE="N") S TYPEEXT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".23")) ;; IN-HOUSE - Clinic Stop
  1.  ..I ($G(OTHERTYPE)'="") S OTHERTYPETEXT=$$GET1^DIQ(90001.53,OTHERTYPE_",",.01,"")
  1.  ..I ($G(OTHERTYPE)="") S OTHERTYPETEXT="<UNKNOWN>"
  1.  ..I ($G(TYPEEXT)="") S FCLTYRFT="<UNKNOWN>"
  1.  ..S SCHWIDAY=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"1302")) ;; Schedule With In days
  1.  ..S INCLPCC=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"401")) ;; INCLUDE PCC VISIT FORM
  1.  ..S INCLCLNT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"402")) ;; INCLUDE SPECIALTY CLINIC NOTES
  1.  ..S INCLPRNL=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"403")) ;;INCLUDE PRENATAL RECORD(S)
  1.  ..S INCLTUBL=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"404")) ;;INCLUDE SIGNED TUBAL CONSENT
  1.  ..S INCLFSHT=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"405")) ;;INCLUDE FACE SHEET
  1.  ..S INCLHLSM=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"406")) ;;INCLUDE HEALTH SUMMARY
  1.  ..S INCLEKG=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"407")) ;; INCLUDE MOST RECENT EKG
  1.  ..S INCLHSPH=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"408")) ;; INCLUDE HISTORY AND PHYSICAL
  1.  ..S INCLXRYR=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"409")) ;;INCLUDE X-RAY / REPORT
  1.  ..S INCLXRYF=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"410")) ;; INCLUDE X-RAY FILM
  1.  ..S INCLCSRP=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"411")) ;;INCLUDE CONSULTATION REPORT
  1.  ..S INCLLBRP=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,"412")) ;;INCLUDE MOST RECENT LAB REPORT
  1.  ..S REFSTATUS=$G(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX,".15"))
  1.  ..S ^TMP($J,"PRNRC",INDEX)="~`"_REFIEN_"^"_REFDATE_"^"_REFNMBR_"^"_PATIEN_"^"_PATNAME_"^"_PATHRN_"^"_RQSTPRV_"^"_FCLTYRFT_"^"_APPTDT_"^"_CHSSTATS_"^"_REFPRPS_"^"_DENLRSN_"^"_CHSELIG_"^"_VAELIG_"^"_SCHNOTES_"^"_REFTYPE_"^"_VSTTYPE_"^"_VSTNMBR
  1.  ..S ^TMP($J,"PRNRC",INDEX)=$G(^TMP($J,"PRNRC",INDEX))_"^"_ICDCATID_"^"_CPTCATID_"^"_TYPEEXT_"^"_SUFFIX_"^"_SCHWIDAY_"^"_INCLCSRP_"^"_INCLFSHT_"^"_INCLHLSM_"^"_INCLHSPH_"^"_INCLEKG_"^"_INCLLBRP_"^"_INCLPCC_"^"_INCLPRNL_"^"_INCLTUBL
  1.  ..S ^TMP($J,"PRNRC",INDEX)=$G(^TMP($J,"PRNRC",INDEX))_"^"_INCLCLNT_"^"_INCLXRYR_"^"_INCLXRYF_"^"_$G(PRIORITY)_"^"_$G(PROBLEM)_"^"_$G(OTHERTYPE)_"^"_$G(OTHERTYPETEXT)_"^"_$G(SNOMEDCT)_"^"_$G(SNOMEDPT)
  1.  ..S ^TMP($J,"PRNRC",INDEX)=$G(^TMP($J,"PRNRC",INDEX))_"^"_$G(REFCNST)_"^"_$G(REFCNDT)_"^"_$G(REFCNBY)_"^"_$G(REFSTATUS)_"^"_$G(^BMCREF(REFIEN,22,1,0))_"^"_$G(VISIT)
  1.  .S INDEX=$O(^TMP($J,"PRNRCTMP","DILIST","ID",INDEX))
  1.  S RSLT=$NA(^TMP($J,"PRNRC"))
  1.  K ^TMP($J,"PRNRCTMP")
  1.  Q RSLT
  1.  ;
  1. CRENVREF(RTN,SNMDCT,SNMDPT,PATIENT,VISIT,PROBLEM,RREFIEN,EVENTDT,OPROVIDER,CLINIC,ENCPROVIDER,PARENT,OUTSIDEPROV,ORDERINGLOC,DTENTERED,ENTEREDBY) ;;Create Entry in V_Referral
  1.  ; S PROVIDER="2117"
  1.  ; S LOCATION="644"
  1.  ; D CRENVREF^BMCRPC4(.R,"980","","541","3CCDC-CIX","","113245",DT_"."_$REPLACE($ZT($H),":",""),PROVIDER,LOCATION,PROVIDER,"","COLE,WENDY E",LOCATION,DT_"."_$REPLACE($ZT($H),":",""),"1") W @R
  1.  ; RRIEN = RCIS Feferral IEN
  1.  ; PRTXDATE = DATE TIME PRINTED OR TRANSMITTED FILE for example May 16, 2013
  1.  ; PRTXBY = PRINTED-TRANSMITTED BY (IEN of NEW PERSON (200) File)
  1.  ; DOCTYPE = Accept Set Of Code Internal Format only C32, CP or CT
  1.  ; CCDADOCID = Free text
  1.  ; RSLT=IEN of entry created in 600 (TRANSITION OF CARE DOCUMENT) multiple
  1.  K FDA,FDAMSG1,FDAIEN1
  1.  N FDADA1
  1.  ;S RRIEN=4
  1.  S FDA(9000010.59,"+1,",.01)=$G(SNMDCT)
  1.  S FDA(9000010.59,"+1,",.02)=$G(PATIENT)
  1.  S FDA(9000010.59,"+1,",.03)=$G(VISIT) ;$$FIND1^DIC(9000010,"","MX",$G(VISIT),"","","REFERR")
  1.  S FDA(9000010.59,"+1,",.04)=$G(PROBLEM)
  1.  S FDA(9000010.59,"+1,",.06)=$G(RREFIEN)
  1.  S FDA(9000010.59,"+1,",1201)=$G(EVENTDT)
  1.  S FDA(9000010.59,"+1,",1202)=$G(OPROVIDER)
  1.  ;S FDA(9000010.59,"+1,",1203)=$G(CLINIC)
  1.  S FDA(9000010.59,"+1,",1204)=$G(ENCPROVIDER)
  1.  S FDA(9000010.59,"+1,",1208)=$G(PARENT)
  1.  ;S FDA(9000010.59,"+1,",1209)=$G(?EXT KEY)
  1.  S FDA(9000010.59,"+1,",1210)=$G(OUTSIDEPROV)
  1.  S FDA(9000010.59,"+1,",1215)=$G(ORDERINGLOC)
  1.  S FDA(9000010.59,"+1,",1216)=DTENTERED
  1.  S FDA(9000010.59,"+1,",1217)=$G(ENTEREDBY)
  1.  S FDA(9000010.59,"+1,",1218)=DTENTERED
  1.  S FDA(9000010.59,"+1,",1219)=$G(ENTEREDBY)
  1.  D UPDATE^DIE("","FDA","FDAIEN1","FDAMSG1")
  1.  S FDADA1=+$G(FDAIEN1(1))
  1.  I $D(FDAMSG1) D
  1.  . W !!,"The following error message was returned:",!!
  1.  . S FDAMSG1="" F  S FDAMSG1=$O(FDAMSG1("DIERR",1,"TEXT",FDAMSG1)) Q:FDAMSG1=""  W FDAMSG1("DIERR",1,"TEXT",FDAMSG1),!
  1.  I $G(FDADA1)=""  S RTN=$G(FDAMSG1) Q
  1.  S RTN=$G(FDADA1)
  1.  Q RTN
  1.  ;
  1. UPENVREF(VREFIEN,SNMDCT,ENTEREDBY,PROBLEM) ;Updating V_Referral file
  1.  N OUT,FDA,ERR1,RSLT
  1.  I '$D(VREFIEN) S RSLT="~`0^V Referral Ien is not provided" Q RSLT
  1.  I VREFIEN'>0 S RSLT="~`0^V Referral Ien is not provided" Q RSLT
  1.  I '$D(SNMDCT) S RSLT="~`0^SNOMED CT is not provided" Q RSLT
  1.  I SNMDCT'>0 S RSLT="~`0^SNOMED CT is not provided" Q RSLT
  1.  I ($$GET1^DIQ(9000010.59,VREFIEN_",",.01,"")=$G(SNMDCT))&($$GET1^DIQ(9000010.59,VREFIEN_",",.04,"I")=$G(PROBLEM)) S RSLT="~`1^" Q RSLT
  1.  S FDA(9000010.59,VREFIEN_",",.01)=$G(SNMDCT)
  1.  I $G(PROBLEM)'="" S FDA(9000010.59,VREFIEN_",",.04)=$G(PROBLEM)
  1.  I $G(PROBLEM)="" S FDA(9000010.59,VREFIEN_",",.04)="@"
  1.  S FDA(9000010.59,VREFIEN_",",1218)=$$NOW^XLFDT
  1.  S FDA(9000010.59,VREFIEN_",",1219)=$G(ENTEREDBY)
  1.  D FILE^DIE("","FDA","ERR1")
  1.  I $D(ERR1("DIERR")) S RSLT="~`0^Error updating referral:"_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
  1.  S RSLT="~`1^"
  1.  Q RSLT
  1.  ;
  1. GTPTELST(RSLT,PATIEN) ;BMC PATIENT ELIGIBILITY STATUS 
  1.  ; Takes Patient IEN and return Its Eligibility Status
  1.  ; D GTPTELST^BMCRPC4(.RSLT,"5") W RSLT
  1.  S RSLT=$$GET1^DIQ(9000001,PATIEN_",",1112,"")
  1.  Q
  1.  ;
  1. PROV(Y,ISPROV) ; RETURN LIST OF PROVIDERS
  1.  ; D PROV^BMCRPC4(.Y,0 or 1) ZW @Y 
  1.  I $G(ISPROV)="" S ISPROV="1"
  1.  N I,IEN,NAME,TDATE
  1.  K ^TMP($J,"PROVUSERS")
  1.  S I=1,NAME=""
  1.  F  S NAME=$O(^VA(200,"B",NAME)) Q:NAME=""  S IEN=0,IEN=$O(^(NAME,IEN))  D
  1.  .Q:$E(NAME)="*"
  1.  .I $G(ISPROV),$D(^XUSEC("PROVIDER",IEN)),$$ACTIVE^XUSER(IEN) S ^TMP($J,"PROVUSERS",1)=$G(^TMP($J,"PROVUSERS",1))_IEN_"^"_NAME_"~",I=I+1
  1.  .I '$G(ISPROV),$$ACTIVE^XUSER(IEN) S ^TMP($J,"PROVUSERS",1)=$G(^TMP($J,"PROVUSERS",1))_IEN_"^"_NAME_"~",I=I+1
  1.  S Y=$NA(^TMP($J,"PROVUSERS"))
  1.  Q
  1.  ;
  1. SETSCNRF(RSLT,PRIMREF,CALLIN,REFDATE,PATIEN,TYPE,INOROUT,ICDCAT,CPTCAT,PURPOSE,PRIORITY,TYPEEXT,HXCMNTS,BCMNTS,SCHWIDAY,ICSRP,IFSHT,IHLSM,IHSPH,IEKG,ILBRP,IPCC,IPRNL,ITUBL,ICLNT,IXRYR,IXRYFSNMDCT,SNMDPT,SNMDST,OTHRTYP) ;;insert sec. ref. data
  1.  K ^TMP($J)
  1.  N OUT,FDA,ERR1,REFNMBR,REFSTATS,RQSTFAC,RQSTPRDR,PRIMPYR,CHSSTATS,CASEMGR,SECNSFX,VISITS,ADTLINFO,NREFIEN
  1.  S ADTLINFO=0 ;;ADDITIONAL INFO flag
  1.  S REFSTATS="A" ;; Setting status to ACTIVE
  1.  S PRIMPYR="1"  ;; Setting Primary Payor to 'IHS'
  1.  S RQSTPRDR=DUZ   ;; default to logged in user ien
  1.  S RQSTFAC=DUZ(2) ;;default to facility where user is logged onto
  1.  S CHSSTATS="P"  ;; Setting CHS APPROVAL STATUS to 'PENDING'
  1.  S CASEMGR=$$GET1^DIQ(90001.31,RQSTFAC_",",.12,"I") ;;set default case manager if not provided
  1.  S REFNMBR=$$GET1^DIQ(90001,PRIMREF_",",.02,"") ;;
  1.  I PATIEN="" S PATIEN=$$GET1^DIQ(90001,PRIMREF_",",.03,"I")
  1.  N Y1,Y2,Y3
  1.  ;; Copied from BMCADDS routine - Begin  - to calculate suffix and visits
  1.  S (Y1,Y2,Y3)=0
  1.  I '$D(^BMCREF("S",REFNMBR)) S Y1=0
  1.  E  S Y="" F  S Y=$O(^BMCREF("S",REFNMBR,Y)) Q:Y=""  D
  1.  .S Y3=$E(Y,2,$L(Y)),Y2=Y2+1
  1.  .S:Y3>Y1 Y1=Y3
  1.  S Y1=Y1+1,Y2=Y2+1,SECNSFX="A"_Y1
  1.  ;VISTS REMAINING
  1.  S VISITS=($P(^BMCREF(PRIMREF,11),U,11)-Y2)
  1.  S:VISITS<0 VISITS=0
  1.  ;; Copied code from BMCADDS routine - End
  1.  K Y1,Y2,Y3
  1.  I ((REFDATE="")!(PATIEN="")!(RQSTFAC="")!(INOROUT="")!(PURPOSE="")!(PRIORITY="")!(VISITS="")) S RSLT="~`0^Required field missing" Q RSLT
  1.  D DT^DILF("",REFDATE,.REFDATE) S:REFDATE'="-1" FDA(90001,"+1,",.01)=REFDATE
  1.  S:'$D(TYPE) TYPE=""
  1.  S:'$D(TYPEEXT) TYPEEXT=""
  1.  S:'$D(ICDCAT) ICDCAT=""
  1.  S:'$D(CPTCAT) CPTCAT=""
  1.  S FDA(90001,"+1,",.02)=REFNMBR
  1.  S FDA(90001,"+1,",101)=SECNSFX
  1.  S FDA(90001,"+1,",102)=PRIMREF
  1.  S FDA(90001,"+1,",.03)=PATIEN
  1.  S:TYPE'="" FDA(90001,"+1,",.04)=TYPE
  1.  S FDA(90001,"+1,",.05)=RQSTFAC
  1.  S FDA(90001,"+1,",.14)=INOROUT
  1.  S:CALLIN="N" FDA(90001,"+1,",.06)=RQSTPRDR
  1.  S FDA(90001,"+1,",.11)=PRIMPYR
  1.  S:ICDCAT'="" FDA(90001,"+1,",.12)=ICDCAT
  1.  S:CPTCAT'="" FDA(90001,"+1,",.13)=CPTCAT
  1.  S FDA(90001,"+1,",1201)=PURPOSE
  1.  S FDA(90001,"+1,",.32)=PRIORITY
  1.  I ((TYPE="C")&(TYPEEXT'="")) S FDA(90001,"+1,",.07)=TYPEEXT ;;CHS - Vendor
  1.  I ((TYPE="O")&(TYPEEXT'="")) S FDA(90001,"+1,",.09)=TYPEEXT ;;OTHER - RCIS Specific provider
  1.  I ((TYPE="N")&(TYPEEXT'="")) S FDA(90001,"+1,",.23)=TYPEEXT ;;IN-HOUSE - Clinic Stop
  1.  I ((TYPE="I")&(TYPEEXT'="")) S FDA(90001,"+1,",.08)=TYPEEXT ;;IHS (Another facility) - Location (TO IHS FACILITY)
  1.  I VISITS'="" S FDA(90001,"+1,",1111)=VISITS
  1.  I CHSSTATS'="" S FDA(90001,"+1,",1112)=CHSSTATS
  1.  I CASEMGR'="" S FDA(90001,"+1,",.19)=CASEMGR
  1.  I SCHWIDAY'="" S FDA(90001,"+1,",1302)=SCHWIDAY ;;Schedule With In days
  1.  I "YN"[IPCC S FDA(90001,"+1,",401)=IPCC ;;INCLUDE PCC VISIT FORM
  1.  I "YN"[ICLNT S FDA(90001,"+1,",402)=ICLNT ;;INCLUDE SPECIALTY CLINIC NOTES
  1.  I "YN"[IPRNL S FDA(90001,"+1,",403)=IPRNL ;;INCLUDE PRENATAL RECORD(S)
  1.  I "YN"[ITUBL S FDA(90001,"+1,",404)=ITUBL ;;INCLUDE SIGNED TUBAL CONSENT
  1.  I "YN"[IFSHT S FDA(90001,"+1,",405)=IFSHT ;;INCLUDE FACE SHEET
  1.  I "YN"[IHLSM S FDA(90001,"+1,",406)=IHLSM ;;INCLUDE HEALTH SUMMARY
  1.  I "YN"[IEKG S FDA(90001,"+1,",407)=IEKG ;;INCLUDE MOST RECENT EKG
  1.  I "YN"[IHSPH S FDA(90001,"+1,",408)=IHSPH ;;INCLUDE HISTORY AND PHYSICAL
  1.  I "YN"[IXRYR S FDA(90001,"+1,",409)=IXRYR ;;INCLUDE X-RAY / REPORT
  1.  I "YN"[IXRYF S FDA(90001,"+1,",410)=IXRYF ;;INCLUDE X-RAY FILM
  1.  I "YN"[ICSRP S FDA(90001,"+1,",411)=ICSRP ;;INCLUDE CONSULTATION REPORT
  1.  I "YN"[ILBRP S FDA(90001,"+1,",412)=ILBRP ;;INCLUDE MOST RECENT LAB REPORT
  1.  S:IPCC_ICLNT_IPRNL_ITUBL_IFSHT_IHLSM_IEKG_IHSPH_IXRYR_IXRYF_ICSRP_ILBRP["Y" ADTLINFO=1
  1.  S FDA(90001,"+1,",.34)=ADTLINFO
  1.  S FDA(90001,"+1,",.15)=REFSTATS
  1.  S FDA(90001,"+1,",.25)=DUZ
  1.  S FDA(90001,"+1,",.26)=DT
  1.  S FDA(90001,"+1,",.27)=DT
  1.  N FDAIEN S FDAIEN=""
  1.  D UPDATE^DIE("","FDA","FDAIEN","ERR1")
  1.  I $D(ERR1("DIERR")) S RSLT="~`0^Error adding Secondary Referral: "_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
  1.  D SENDXM^BMCRPC3(FDAIEN(1),"A") ;;Send mailman message
  1.  S NREFIEN=$G(FDAIEN(1))
  1.  I $D(HXCMNTS) D
  1.  .I HXCMNTS'="" D SETMEDHX^BMCRPC3(.RS,HXCMNTS,PATIEN,NREFIEN,"M")
  1.  I $D(BCMNTS) D
  1.  .I BCMNTS'="" D SETMEDHX^BMCRPC3(.RS,BCMNTS,PATIEN,NREFIEN,"B")
  1.  I $P($G(RS),"^")="~`0" S RSLT=RS Q RSLT
  1.  S RSLT="~`1^"_FDAIEN(1)
  1.  Q RSLT
  1.  ;