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