BMCRPC3 ; IHS/CAS/AU - GUI-REFERRED CARE INFO SYSTEM (3/4);
;;4.0;REFERRED CARE INFO SYSTEM;**7,8,12,13**;JAN 09, 2006;Build 101
;
;GDIT/HS/BEE 10/19/17 - p12 CR#8528: Alphabetize the Referral-to-SNOMED terms
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
;GDIT/HS/BEE 05/08/2018 - BMC*4.0*13 - Consult review - Time is now passed in and required
;
; RPC code for RCIS GUI Application
; Routines contains code for Fetching Referral Templates
GTTMPLST(RSLT) ;; Get RCIS Template List from RCIS ROUTINE REFERRAL DEF
N INDEX,OUT
S RSLT="~`"
D LIST^DIC(90001.32,"","@;.01","P","*",,,,,"","OUT")
S INDEX=$O(OUT("DILIST",0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S RSLT=RSLT_$G(OUT("DILIST",INDEX,0))_"~"
.S INDEX=$O(OUT("DILIST",INDEX))
S RSLT=$E(RSLT,1,$L(RSLT)-1)
Q RSLT
GETTMPLT(RSLT,TMPLTIEN) ;; Get Template Detail
; D GETTMPLT^BMCRPC3(.R,8) W R
N INDEX,OUT,TYPE,INOROUT,ICDCAT,CPTCAT,PURPOSE,PRIORITY,TYPEEXT,FCLTYRFT,VISITS,NOTESCHD,HXCMNTS,OTHERTYPE,OTHERTYPETEXT,VREFSNOMED
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
NEW BCMNTS
S TYPEEXT="",HXCMNTS="",FCLTYRFT=""
D GETS^DIQ(90001.32,TMPLTIEN_",","@;.04;.07;.08;.09;.11;.12;.13;.14;.32;1;2;1111;1201;1301;1303","I","OUT")
Q:'$D(OUT)
S TYPE=$G(OUT(90001.32,TMPLTIEN_",",.04,"I"))
;; CHS - Vendor
I TYPE="C" S TYPEEXT=$G(OUT(90001.32,TMPLTIEN_",",.07,"I")) S FCLTYRFT=$$GET1^DIQ(9999999.11,TYPEEXT_",",.01,"") S OTHERTYPE=$G(OUT(90001.32,TMPLTIEN_",",.09,"I")) S OTHERTYPETEXT=$$GET1^DIQ(90001.53,OTHERTYPE_",",.01,"")
;; OTHER - RCIS Specific provider
I TYPE="O" S TYPEEXT=$G(OUT(90001.32,TMPLTIEN_",",.07,"I")) S FCLTYRFT=$$GET1^DIQ(9999999.11,TYPEEXT_",",.01,"") S OTHERTYPE=$G(OUT(90001.32,TMPLTIEN_",",.09,"I")) S OTHERTYPETEXT=$$GET1^DIQ(90001.53,OTHERTYPE_",",.01,"")
I TYPE="N" S TYPEEXT="",FCLTYRFT="" ;; no field available in file (90001.32) for - IN-HOUSE - Clinic Stop
I TYPE="I" S TYPEEXT=$G(OUT(90001.32,TMPLTIEN_",",.08,"I")) S FCLTYRFT=$$GET1^DIQ(9999999.06,TYPEEXT_",",.01,"") ;; IHS (Another facility) - Location (TO IHS FACILITY)
S INOROUT=$G(OUT(90001.32,TMPLTIEN_",",.14,"I"))
S ICDCAT=$G(OUT(90001.32,TMPLTIEN_",",.12,"I"))
S CPTCAT=$G(OUT(90001.32,TMPLTIEN_",",.13,"I"))
S PURPOSE=$G(OUT(90001.32,TMPLTIEN_",",1201,"I"))
S PRIORITY=$G(OUT(90001.32,TMPLTIEN_",",.32,"I"))
S VISITS=$G(OUT(90001.32,TMPLTIEN_",",1111,"I"))
S NOTESCHD=$G(OUT(90001.32,TMPLTIEN_",",1301,"I"))
S HXCMNTS=""
S INDEX=$O(OUT(90001.32,TMPLTIEN_",",1,0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S HXCMNTS=HXCMNTS_$G(OUT(90001.32,TMPLTIEN_",",1,INDEX))_"~"
.S INDEX=$O(OUT(90001.32,TMPLTIEN_",",1,INDEX))
S HXCMNTS=$E(HXCMNTS,1,$L(HXCMNTS)-1)
S BCMNTS=""
S INDEX=$O(OUT(90001.32,TMPLTIEN_",",2,0))
I +INDEX>0 F D Q:(+INDEX'>0)
.S BCMNTS=BCMNTS_$G(OUT(90001.32,TMPLTIEN_",",2,INDEX))_"~"
.S INDEX=$O(OUT(90001.32,TMPLTIEN_",",2,INDEX))
S BCMNTS=$E(BCMNTS,1,$L(BCMNTS)-1)
S VREFSNOMED=$G(OUT(90001.32,TMPLTIEN_",",1303,"I"))
S RSLT="~`"_TYPE_"^"_INOROUT_"^"_ICDCAT_"^"_CPTCAT_"^"_PURPOSE_"^"_PRIORITY_"^"_TYPEEXT_"^"_FCLTYRFT_"^"_VISITS_"^"_NOTESCHD_"^"_HXCMNTS_"^"_$G(BCMNTS)_"^"_$G(OTHERTYPE)_"^"_$G(OTHERTYPETEXT)_"^"_$G(VREFSNOMED)
Q RSLT
ADDC32LG(RSLT,REFIEN,USERIEN,RRINTDT) ;;Add log entry for C32 print in 600 (C32 PRINTED) multiple of 90001(RCIS REFERRAL) file
I '$D(REFIEN) S RSLT="~`0^Referral IEN is not present" Q RSLT
N FDA,FDAIEN,ERR1
I '$D(USERIEN) S USERIEN=DUZ
I USERIEN="" S USERIEN=DUZ
I 'USERIEN S RSLT="~`0^USERIEN(DUZ) is not present" Q RSLT
I $D(RRINTDT) D DT^DILF("RS",RRINTDT,.RRINTDT,,"") I RRINTDT="-1" S RSLT="~`0^Date/Time format is MM/DD/YYYY@HHMM" Q RSLT
D NOW^%DTC
I (('$D(RRINTDT))!(RRINTDT="")!(RRINTDT>%)) S RRINTDT=% ;;if date/time not provided, assume current date/time
S FDA(90001.6,"+1,"_REFIEN_",",.01)=RRINTDT
S FDA(90001.6,"+1,"_REFIEN_",",.02)=USERIEN
D UPDATE^DIE("","FDA","FDAIEN","ERR1")
I $D(ERR1("DIERR")) S RSLT="~`0^Error adding C32 printed log: "_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
S RSLT="~`1^"_FDAIEN(1) Q RSLT
Q
SENDALRT(BMCRIEN) ;;EP-ALERT FOR PHYS
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
NEW BMCRHDR,XQADATA
Q:$G(BMCRIEN)=""
S BMCDFN=$$GET1^DIQ(90001,BMCRIEN_",",.03,"I")
S:$G(BMCDFN) BMCREC("PAT NAME")=$P(^DPT(BMCDFN,0),U)
N XQA
S BMCRHDR="New"
S XQADATA=BMCRIEN
I ($P($G(^BMCPARM(DUZ(2),4100)),U,9)="Y")!($P($G(^BMCPARM(DUZ(2),4100)),U,10)="Y") D PALRT1^BMCALERT
Q
SENDXM(BMCRIEN,BMCMODE) ;;Send mailman message for add/update referral
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
NEW BMCGRP,BMCGRP1,BMCGRPS,I
S BMCDFN=$$GET1^DIQ(90001,BMCRIEN_",",.03,"I"),BMCRDATE=$$GET1^DIQ(90001,BMCRIEN_",",.01,"I")
S:$G(BMCDFN) BMCREC("PAT NAME")=$P(^DPT(BMCDFN,0),U)
S BMCREC("REF DATE")=$$GET1^DIQ(90001,BMCRIEN_",",.01,"E"),BMCRNUMB=$$GET1^DIQ(90001,BMCRIEN_",",.02,"E"),BMCDTYPE=15
I BMCMODE="A" D
.I $D(^BMCMSG("C",BMCRIEN)) K BMCRIEN,BMCDFN,BMCRDATE,BMCMODE,BMCREC,BMCRNUMB,BMCDTYPE Q
.S BMCGRP="BMC",Y=0
.F S BMCGRP=$O(^XMB(3.8,"B",BMCGRP)) Q:$E(BMCGRP,1,3)'="BMC" D
..S BMCGRP1=0 S BMCGRP1=$O(^XMB(3.8,"B",BMCGRP,BMCGRP1))
..S Y=Y+1,BMCGRP(Y)=BMCGRP_U_BMCGRP1
.K XMB,XMY
.F I=1:1 Q:$P(Y,",",I)'?1N.N S XMY("G."_$P(BMCGRP($P(Y,",",I)),U))="",BMCGRPS($P(BMCGRP($P(Y,",",I)),U,2))=""
.D MSGGRP^BMCMM
I BMCMODE="M" D
.D MPER^BMCMM,MSGPRV^BMCMM
D SND^BMCMM
D EXT^BMCMM
K BMCRIEN,BMCDFN,BMCRDATE,BMCMODE,BMCREC,BMCRNUMB,BMCDTYPE
Q
STATIC(PATIEN,REFIEN) ;;EP - STORE STATIC DATA OF REFERRAL
N BMCREC,Y,%
S BMCREC=^BMCREF(REFIEN,0)
S Y=^DPT(PATIEN,0)
S DR="5101///"_$P(Y,U) ; name
S DR=DR_";5103///"_$P(Y,U,3) ;dob
S DR=DR_";5104///"_$P(Y,U,9) ;ssn
S DR=DR_";5107///"_$P(Y,U,2) ;sex
S %=$P(BMCREC,U,5)
I % D
.S DR=DR_";5102///"_$P($G(^AUPNPAT(PATIEN,41,%,0)),U,2) ;chart #
.S DR=DR_";5113///"_$P($G(^DIC(4,%,0)),U) ;facility
.S DR=DR_";5114///"_$P($G(^AUTTLOC(%,0)),U,10) ;asufac
S Y=$G(^AUPNPAT(PATIEN,51))
I $P(Y,U,18)'="" S DR=DR_";5105///"_$P(Y,U,18) ;comm
I $P(Y,U,8) S DR=DR_";5106///"_$P($G(^AUTTTRI($P(Y,U,8),0)),U,2) ;tribe
S %=$P(BMCREC,U,7)
I % D
.S DR=DR_";5108///"_$P($G(^AUTTVNDR(%,0)),U) ;vendor
.S DR=DR_";5109///"_$P($G(^AUTTVNDR(%,51)),U) ;ein
S %=$P(BMCREC,U)
S DR=DR_";5110///"_$$MCR^AUPNPAT(PATIEN,%) ;medicare
S DR=DR_";5111///"_$$MCD^AUPNPAT(PATIEN,%) ;medicaid
S DR=DR_";5112///"_$$PI^AUPNPAT(PATIEN,%) ;private insurance
S DIE="^BMCREF(",DA=REFIEN
D DIE^BMCFMC
K DA,DIE,DR
Q
SETMEDHX(RSLT,CMNTSX,PATIEN,REFIEN,TYPE) ;;Add Medical History comments into RCIS COMMENTS file
;S BMCDFN=PATIEN,BMCRIEN=REFIEN,BMCCTYP=$G(TYPE)
;D COMMENTS^BMCADD1
I (('$D(REFIEN))!('$D(PATIEN))!('$D(CMNTSX))) S RSLT="~`0^Required data not provided" Q RSLT
N INDEX,FDA,FDAIENP,ERR1,WP,ERR2,RET
S INDEX=1
S FDA(90001.03,"+1,",.01)=DT
S FDA(90001.03,"+1,",.02)=PATIEN
S FDA(90001.03,"+1,",.03)=REFIEN
S FDA(90001.03,"+1,",.04)=DUZ
S FDA(90001.03,"+1,",.05)=$G(TYPE)
D UPDATE^DIE("","FDA","FDAIENP","ERR1")
I $D(ERR1("DIERR")) S RSLT="~`0^Error adding Med Hx/Business Comments: "_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
;I $P(CMNTSX,"~",INDEX)'="" F D Q:($P(CMNTSX,"~",INDEX)="")
;.;S WP(INDEX)=$P(CMNTSX,"~",INDEX)
;.;S INDEX=INDEX+1
;I (($D(WP))&(FDAIENP(1)>0)) D WP^DIE(90001.03,FDAIENP(1)_",",1,"","WP","ERR2")
;I $D(ERR2("DIERR")) N FDAK S FDAK(90001.03,FDAIENP(1)_",",.01)="@" D UPDATE^DIE("","FDAK","FDAIENP","ERR1") S RSLT="~`0^Error adding Med Hx/Business Comments text: "_$G(ERR2("DIERR","1","TEXT",1)) Q RSLT
I (($D(CMNTSX))&(FDAIENP(1)>0)) S RET=$$SETWP^BMCRPC5(90001.03,1,FDAIENP(1),CMNTSX,1,0)
I $G(RET)'=1 S RSLT="~`0^Error adding Med Hx/Business Comments text: "_$G(RET) Q RSLT
S RSLT="~`1^"_FDAIENP(1)
Q RSLT
;
GTREFTYP(RSLT) ;;Get Purpose Of Referrals
;BMC GET PURPOSE OF REF API
;D GTREFTYP^BMCRPC3(.R) ZW @R
K ^TMP($J,"REFPURPOSE")
;GDIT/HS/BEE 10/19/17 - p12 CR#8528: Reworked next section of code to sort results
;N OUT,INDEX
;S OUT="VAR"
;D SUBLST^BSTSAPI(OUT,"EHR REFERRAL TYPE^^1")
;S INDEX=$O(VAR(""))
;I +INDEX>0 F D Q:(+INDEX'>0)
;.S ^TMP($J,"REFPURPOSE",1)=$G(^TMP($J,"REFPURPOSE",1))_$G(VAR(INDEX))_"~"
;.S INDEX=$O(VAR(INDEX))
N INDEX,VAR,TMP,ND,TRM
D SUBLST^BSTSAPI("VAR","EHR REFERRAL TYPE^^1")
S INDEX="" F S INDEX=$O(VAR(INDEX)) Q:'INDEX S ND=$G(VAR(INDEX)),TRM=$P(ND,U,3) I TRM]"" S TMP(TRM)=ND
S (INDEX,TMP)="" F S INDEX=$O(TMP(INDEX)) Q:INDEX="" S TMP=TMP_$S(TMP]"":"~",1:"")_TMP(INDEX)
I TMP]"" S ^TMP($J,"REFPURPOSE",1)=TMP
;End of CR#8528 Changes
S ^TMP($J,"REFPURPOSE",2)=""
S RSLT=$NA(^TMP($J,"REFPURPOSE"))
Q
UPDTSTRF(RSLT,REFIEN,STATUS) ;;Update Status Of Referral against Ref IEN return 0 or 1
; Not in Use
;TUS) ADTLINFO=0 ;;ADDITIONAL INFO flag
I '$D(REFIEN) S RSLT="~`0^Referral Ien is not provided" Q RSLT
I '$D(STATUS) S RSLT="~`0^Referral Status is not provided" Q RSLT
I REFIEN'>0 S RSLT="~`0^Referral Ien is not provided" Q RSLT
S FDA(90001,REFIEN_",",.15)=$G(STATUS)
D FILE^DIE("","FDA","ERR1")
I $D(ERR1("DIERR")) S RSLT="~`0^Error updating referral:"_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
;D SENDXM^BMCRPC3(REFIEN,"M") ;;Send mailman message
S RSLT="1"
Q
;
UPCNRINF(RSLT,REFIEN,CONSULTBY,CONSULTDT,CONSULTSTATUS) ;;Updates new Multiple Consulted By
; S REFIEN="113248"
; S CONSULTBY="3039"
; GDIT/HS/BEE 05/08/2018 - BMC*4.0*13 - Time is passed in and required
; OLD: S CONSULTDT="8/12/2013"
; S CONSULTDT="8/12/2013@10:30"
; S CONSULTSTATUS="R"
; D UPCNRINF^BMCRPC3(.R,REFIEN,CONSULTBY,CONSULTDT,CONSULTSTATUS) W R
; S ^TMP("FAR",12)=$G(REFIEN)_"^"_$G(CONSULTBY)_"^"_$G(CONSULTDT)_"^"_$G(CONSULTSTATUS)
N OUT,FDA,ERR1,PATIEN,ADTLINFO,MSG
I '$D(REFIEN) S RSLT="~`0^Referral Ien is not provided" Q RSLT
I REFIEN'>0 S RSLT="~`0^Referral Ien is not provided" Q RSLT
I $$GET1^DIQ(90001,REFIEN_",",1308,"")'="" D
. I $$GET1^DIQ(90001,REFIEN_",",1307,"")'="" D
. . I $$GET1^DIQ(90001,REFIEN_",",1306,"I")=$G(CONSULTSTATUS) D
. . . S MSG=$$GET1^DIQ(90001,REFIEN_",",.03,"")_" has already been reviewed by "_$$GET1^DIQ(90001,REFIEN_",",1308,"")_" on "_$$GET1^DIQ(90001,REFIEN_",",1307,"")_"."
I $G(MSG)'="" S RSLT="~`1^"_$G(MSG) Q RSLT
; GDIT/HS/BEE 05/08/2018 - BMC*4.0*13 - Time is passed in and required
;D DT^DILF("",CONSULTDT,.CONSULTDT) I CONSULTDT="-1" S RSLT="~`0^Review Date is not in mm/dd/yyyy fromat" Q RSLT
D DT^DILF("RT",CONSULTDT,.CONSULTDT) I CONSULTDT="-1" S RSLT="~`0^Review Date is not in mm/dd/yyyy format" Q RSLT
S FDA(90001,REFIEN_",",1308)=$G(CONSULTBY)
S FDA(90001,REFIEN_",",1307)=$G(CONSULTDT)
S FDA(90001,REFIEN_",",1306)=$G(CONSULTSTATUS)
D FILE^DIE("","FDA","ERR1")
I $D(ERR1("DIERR")) S RSLT="~`0^Error updating referral:"_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
D CRENSCCT^BMCRPC3("",REFIEN,"371530004")
S RSLT="~`1^"
Q
;
CRENSCCT(RSLT,RRIEN,TERM) ; Create entry in 2300 (SNOMED CLOSED CLINICAL TERM) multiple of RCIS REFERRAL (90001) file
; D CRENSCCT^BMCRPC3(.R,"113255","371530004") W @R
; RRIEN = RCIS Feferral IEN
; TERM = Free text
; RSLT=IEN of entry created in 2300 (SNOMED CLOSED CLINICAL TERM) multiple
K FDA,FDAMSG,FDAIEN
N FDADA
;
S FDA(42,90001.23,"+1,"_RRIEN_",",.01)=$G(TERM)
D UPDATE^DIE("","FDA(42)","FDAIEN","FDAMSG")
S FDADA=+$G(FDAIEN(1))
I $D(FDAMSG) D
. W !!,"The following error message was returned:",!!
. S FDAMSG="" F S FDAMSG=$O(FDAMSG("DIERR",1,"TEXT",FDAMSG)) Q:FDAMSG="" W FDAMSG("DIERR",1,"TEXT",FDAMSG),!
I $G(FDADA)="" S RSLT=$G(FDAMSG) Q
S RSLT=$G(FDADA)
Q
;
CRENSCT(RSLT,RRIEN,TERM) ; Create entry in 2200 (SNOMED CLINICAL TERM) multiple of RCIS REFERRAL (90001) file
; D CRENSCT^BMCRPC3(.R,"113255","371530004") W @R
; RRIEN = RCIS Feferral IEN
; TERM = Free text
; RSLT=IEN of entry created in 2200 (SNOMED CLINICAL TERM) multiple
K FDA,FDAMSG,FDAIEN
N FDADA
;
S FDA(42,90001.22,"+1,"_RRIEN_",",.01)=$G(TERM)
D UPDATE^DIE("","FDA(42)","FDAIEN","FDAMSG")
S FDADA=+$G(FDAIEN(1))
I $D(FDAMSG) D
. W !!,"The following error message was returned:",!!
. S FDAMSG="" F S FDAMSG=$O(FDAMSG("DIERR",1,"TEXT",FDAMSG)) Q:FDAMSG="" W FDAMSG("DIERR",1,"TEXT",FDAMSG),!
I $G(FDADA)="" S RSLT=$G(FDAMSG) Q
S RSLT=$G(FDADA)
Q
;
BMCRPC3 ; IHS/CAS/AU - GUI-REFERRED CARE INFO SYSTEM (3/4);
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**7,8,12,13**;JAN 09, 2006;Build 101
+2 ;
+3 ;GDIT/HS/BEE 10/19/17 - p12 CR#8528: Alphabetize the Referral-to-SNOMED terms
+4 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+5 ;GDIT/HS/BEE 05/08/2018 - BMC*4.0*13 - Consult review - Time is now passed in and required
+6 ;
+7 ; RPC code for RCIS GUI Application
+8 ; Routines contains code for Fetching Referral Templates
GTTMPLST(RSLT) ;; Get RCIS Template List from RCIS ROUTINE REFERRAL DEF
+1 NEW INDEX,OUT
+2 SET RSLT="~`"
+3 DO LIST^DIC(90001.32,"","@;.01","P","*",,,,,"","OUT")
+4 SET INDEX=$ORDER(OUT("DILIST",0))
+5 IF +INDEX>0
FOR
Begin DoDot:1
+6 SET RSLT=RSLT_$GET(OUT("DILIST",INDEX,0))_"~"
+7 SET INDEX=$ORDER(OUT("DILIST",INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+8 SET RSLT=$EXTRACT(RSLT,1,$LENGTH(RSLT)-1)
+9 QUIT RSLT
GETTMPLT(RSLT,TMPLTIEN) ;; Get Template Detail
+1 ; D GETTMPLT^BMCRPC3(.R,8) W R
+2 NEW INDEX,OUT,TYPE,INOROUT,ICDCAT,CPTCAT,PURPOSE,PRIORITY,TYPEEXT,FCLTYRFT,VISITS,NOTESCHD,HXCMNTS,OTHERTYPE,OTHERTYPETEXT,VREFSNOMED
+3 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+4 NEW BCMNTS
+5 SET TYPEEXT=""
SET HXCMNTS=""
SET FCLTYRFT=""
+6 DO GETS^DIQ(90001.32,TMPLTIEN_",","@;.04;.07;.08;.09;.11;.12;.13;.14;.32;1;2;1111;1201;1301;1303","I","OUT")
+7 IF '$DATA(OUT)
QUIT
+8 SET TYPE=$GET(OUT(90001.32,TMPLTIEN_",",.04,"I"))
+9 ;; CHS - Vendor
+10 IF TYPE="C"
SET TYPEEXT=$GET(OUT(90001.32,TMPLTIEN_",",.07,"I"))
SET FCLTYRFT=$$GET1^DIQ(9999999.11,TYPEEXT_",",.01,"")
SET OTHERTYPE=$GET(OUT(90001.32,TMPLTIEN_",",.09,"I"))
SET OTHERTYPETEXT=$$GET1^DIQ(90001.53,OTHERTYPE_",",.01,"")
+11 ;; OTHER - RCIS Specific provider
+12 IF TYPE="O"
SET TYPEEXT=$GET(OUT(90001.32,TMPLTIEN_",",.07,"I"))
SET FCLTYRFT=$$GET1^DIQ(9999999.11,TYPEEXT_",",.01,"")
SET OTHERTYPE=$GET(OUT(90001.32,TMPLTIEN_",",.09,"I"))
SET OTHERTYPETEXT=$$GET1^DIQ(90001.53,OTHERTYPE_",",.01,"")
+13 ;; no field available in file (90001.32) for - IN-HOUSE - Clinic Stop
IF TYPE="N"
SET TYPEEXT=""
SET FCLTYRFT=""
+14 ;; IHS (Another facility) - Location (TO IHS FACILITY)
IF TYPE="I"
SET TYPEEXT=$GET(OUT(90001.32,TMPLTIEN_",",.08,"I"))
SET FCLTYRFT=$$GET1^DIQ(9999999.06,TYPEEXT_",",.01,"")
+15 SET INOROUT=$GET(OUT(90001.32,TMPLTIEN_",",.14,"I"))
+16 SET ICDCAT=$GET(OUT(90001.32,TMPLTIEN_",",.12,"I"))
+17 SET CPTCAT=$GET(OUT(90001.32,TMPLTIEN_",",.13,"I"))
+18 SET PURPOSE=$GET(OUT(90001.32,TMPLTIEN_",",1201,"I"))
+19 SET PRIORITY=$GET(OUT(90001.32,TMPLTIEN_",",.32,"I"))
+20 SET VISITS=$GET(OUT(90001.32,TMPLTIEN_",",1111,"I"))
+21 SET NOTESCHD=$GET(OUT(90001.32,TMPLTIEN_",",1301,"I"))
+22 SET HXCMNTS=""
+23 SET INDEX=$ORDER(OUT(90001.32,TMPLTIEN_",",1,0))
+24 IF +INDEX>0
FOR
Begin DoDot:1
+25 SET HXCMNTS=HXCMNTS_$GET(OUT(90001.32,TMPLTIEN_",",1,INDEX))_"~"
+26 SET INDEX=$ORDER(OUT(90001.32,TMPLTIEN_",",1,INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+27 SET HXCMNTS=$EXTRACT(HXCMNTS,1,$LENGTH(HXCMNTS)-1)
+28 SET BCMNTS=""
+29 SET INDEX=$ORDER(OUT(90001.32,TMPLTIEN_",",2,0))
+30 IF +INDEX>0
FOR
Begin DoDot:1
+31 SET BCMNTS=BCMNTS_$GET(OUT(90001.32,TMPLTIEN_",",2,INDEX))_"~"
+32 SET INDEX=$ORDER(OUT(90001.32,TMPLTIEN_",",2,INDEX))
End DoDot:1
IF (+INDEX'>0)
QUIT
+33 SET BCMNTS=$EXTRACT(BCMNTS,1,$LENGTH(BCMNTS)-1)
+34 SET VREFSNOMED=$GET(OUT(90001.32,TMPLTIEN_",",1303,"I"))
+35 SET RSLT="~`"_TYPE_"^"_INOROUT_"^"_ICDCAT_"^"_CPTCAT_"^"_PURPOSE_"^"_PRIORITY_"^"_TYPEEXT_"^"_FCLTYRFT_"^"_VISITS_"^"_NOTESCHD_"^"_HXCMNTS_"^"_$GET(BCMNTS)_"^"_$GET(OTHERTYPE)_"^"_$GET(OTHERTYPETEXT)_"^"_$GET(VREFSNOMED)
+36 QUIT RSLT
ADDC32LG(RSLT,REFIEN,USERIEN,RRINTDT) ;;Add log entry for C32 print in 600 (C32 PRINTED) multiple of 90001(RCIS REFERRAL) file
+1 IF '$DATA(REFIEN)
SET RSLT="~`0^Referral IEN is not present"
QUIT RSLT
+2 NEW FDA,FDAIEN,ERR1
+3 IF '$DATA(USERIEN)
SET USERIEN=DUZ
+4 IF USERIEN=""
SET USERIEN=DUZ
+5 IF 'USERIEN
SET RSLT="~`0^USERIEN(DUZ) is not present"
QUIT RSLT
+6 IF $DATA(RRINTDT)
DO DT^DILF("RS",RRINTDT,.RRINTDT,,"")
IF RRINTDT="-1"
SET RSLT="~`0^Date/Time format is MM/DD/YYYY@HHMM"
QUIT RSLT
+7 DO NOW^%DTC
+8 ;;if date/time not provided, assume current date/time
IF (('$DATA(RRINTDT))!(RRINTDT="")!(RRINTDT>%))
SET RRINTDT=%
+9 SET FDA(90001.6,"+1,"_REFIEN_",",.01)=RRINTDT
+10 SET FDA(90001.6,"+1,"_REFIEN_",",.02)=USERIEN
+11 DO UPDATE^DIE("","FDA","FDAIEN","ERR1")
+12 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error adding C32 printed log: "_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+13 SET RSLT="~`1^"_FDAIEN(1)
QUIT RSLT
+14 QUIT
SENDALRT(BMCRIEN) ;;EP-ALERT FOR PHYS
+1 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+2 NEW BMCRHDR,XQADATA
+3 IF $GET(BMCRIEN)=""
QUIT
+4 SET BMCDFN=$$GET1^DIQ(90001,BMCRIEN_",",.03,"I")
+5 IF $GET(BMCDFN)
SET BMCREC("PAT NAME")=$PIECE(^DPT(BMCDFN,0),U)
+6 NEW XQA
+7 SET BMCRHDR="New"
+8 SET XQADATA=BMCRIEN
+9 IF ($PIECE($GET(^BMCPARM(DUZ(2),4100)),U,9)="Y")!($PIECE($GET(^BMCPARM(DUZ(2),4100)),U,10)="Y")
DO PALRT1^BMCALERT
+10 QUIT
SENDXM(BMCRIEN,BMCMODE) ;;Send mailman message for add/update referral
+1 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+2 NEW BMCGRP,BMCGRP1,BMCGRPS,I
+3 SET BMCDFN=$$GET1^DIQ(90001,BMCRIEN_",",.03,"I")
SET BMCRDATE=$$GET1^DIQ(90001,BMCRIEN_",",.01,"I")
+4 IF $GET(BMCDFN)
SET BMCREC("PAT NAME")=$PIECE(^DPT(BMCDFN,0),U)
+5 SET BMCREC("REF DATE")=$$GET1^DIQ(90001,BMCRIEN_",",.01,"E")
SET BMCRNUMB=$$GET1^DIQ(90001,BMCRIEN_",",.02,"E")
SET BMCDTYPE=15
+6 IF BMCMODE="A"
Begin DoDot:1
+7 IF $DATA(^BMCMSG("C",BMCRIEN))
KILL BMCRIEN,BMCDFN,BMCRDATE,BMCMODE,BMCREC,BMCRNUMB,BMCDTYPE
QUIT
+8 SET BMCGRP="BMC"
SET Y=0
+9 FOR
SET BMCGRP=$ORDER(^XMB(3.8,"B",BMCGRP))
IF $EXTRACT(BMCGRP,1,3)'="BMC"
QUIT
Begin DoDot:2
+10 SET BMCGRP1=0
SET BMCGRP1=$ORDER(^XMB(3.8,"B",BMCGRP,BMCGRP1))
+11 SET Y=Y+1
SET BMCGRP(Y)=BMCGRP_U_BMCGRP1
End DoDot:2
+12 KILL XMB,XMY
+13 FOR I=1:1
IF $PIECE(Y,",",I)'?1N.N
QUIT
SET XMY("G."_$PIECE(BMCGRP($PIECE(Y,",",I)),U))=""
SET BMCGRPS($PIECE(BMCGRP($PIECE(Y,",",I)),U,2))=""
+14 DO MSGGRP^BMCMM
End DoDot:1
+15 IF BMCMODE="M"
Begin DoDot:1
+16 DO MPER^BMCMM
DO MSGPRV^BMCMM
End DoDot:1
+17 DO SND^BMCMM
+18 DO EXT^BMCMM
+19 KILL BMCRIEN,BMCDFN,BMCRDATE,BMCMODE,BMCREC,BMCRNUMB,BMCDTYPE
+20 QUIT
STATIC(PATIEN,REFIEN) ;;EP - STORE STATIC DATA OF REFERRAL
+1 NEW BMCREC,Y,%
+2 SET BMCREC=^BMCREF(REFIEN,0)
+3 SET Y=^DPT(PATIEN,0)
+4 ; name
SET DR="5101///"_$PIECE(Y,U)
+5 ;dob
SET DR=DR_";5103///"_$PIECE(Y,U,3)
+6 ;ssn
SET DR=DR_";5104///"_$PIECE(Y,U,9)
+7 ;sex
SET DR=DR_";5107///"_$PIECE(Y,U,2)
+8 SET %=$PIECE(BMCREC,U,5)
+9 IF %
Begin DoDot:1
+10 ;chart #
SET DR=DR_";5102///"_$PIECE($GET(^AUPNPAT(PATIEN,41,%,0)),U,2)
+11 ;facility
SET DR=DR_";5113///"_$PIECE($GET(^DIC(4,%,0)),U)
+12 ;asufac
SET DR=DR_";5114///"_$PIECE($GET(^AUTTLOC(%,0)),U,10)
End DoDot:1
+13 SET Y=$GET(^AUPNPAT(PATIEN,51))
+14 ;comm
IF $PIECE(Y,U,18)'=""
SET DR=DR_";5105///"_$PIECE(Y,U,18)
+15 ;tribe
IF $PIECE(Y,U,8)
SET DR=DR_";5106///"_$PIECE($GET(^AUTTTRI($PIECE(Y,U,8),0)),U,2)
+16 SET %=$PIECE(BMCREC,U,7)
+17 IF %
Begin DoDot:1
+18 ;vendor
SET DR=DR_";5108///"_$PIECE($GET(^AUTTVNDR(%,0)),U)
+19 ;ein
SET DR=DR_";5109///"_$PIECE($GET(^AUTTVNDR(%,51)),U)
End DoDot:1
+20 SET %=$PIECE(BMCREC,U)
+21 ;medicare
SET DR=DR_";5110///"_$$MCR^AUPNPAT(PATIEN,%)
+22 ;medicaid
SET DR=DR_";5111///"_$$MCD^AUPNPAT(PATIEN,%)
+23 ;private insurance
SET DR=DR_";5112///"_$$PI^AUPNPAT(PATIEN,%)
+24 SET DIE="^BMCREF("
SET DA=REFIEN
+25 DO DIE^BMCFMC
+26 KILL DA,DIE,DR
+27 QUIT
SETMEDHX(RSLT,CMNTSX,PATIEN,REFIEN,TYPE) ;;Add Medical History comments into RCIS COMMENTS file
+1 ;S BMCDFN=PATIEN,BMCRIEN=REFIEN,BMCCTYP=$G(TYPE)
+2 ;D COMMENTS^BMCADD1
+3 IF (('$DATA(REFIEN))!('$DATA(PATIEN))!('$DATA(CMNTSX)))
SET RSLT="~`0^Required data not provided"
QUIT RSLT
+4 NEW INDEX,FDA,FDAIENP,ERR1,WP,ERR2,RET
+5 SET INDEX=1
+6 SET FDA(90001.03,"+1,",.01)=DT
+7 SET FDA(90001.03,"+1,",.02)=PATIEN
+8 SET FDA(90001.03,"+1,",.03)=REFIEN
+9 SET FDA(90001.03,"+1,",.04)=DUZ
+10 SET FDA(90001.03,"+1,",.05)=$GET(TYPE)
+11 DO UPDATE^DIE("","FDA","FDAIENP","ERR1")
+12 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error adding Med Hx/Business Comments: "_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+13 ;I $P(CMNTSX,"~",INDEX)'="" F D Q:($P(CMNTSX,"~",INDEX)="")
+14 ;.;S WP(INDEX)=$P(CMNTSX,"~",INDEX)
+15 ;.;S INDEX=INDEX+1
+16 ;I (($D(WP))&(FDAIENP(1)>0)) D WP^DIE(90001.03,FDAIENP(1)_",",1,"","WP","ERR2")
+17 ;I $D(ERR2("DIERR")) N FDAK S FDAK(90001.03,FDAIENP(1)_",",.01)="@" D UPDATE^DIE("","FDAK","FDAIENP","ERR1") S RSLT="~`0^Error adding Med Hx/Business Comments text: "_$G(ERR2("DIERR","1","TEXT",1)) Q RSLT
+18 IF (($DATA(CMNTSX))&(FDAIENP(1)>0))
SET RET=$$SETWP^BMCRPC5(90001.03,1,FDAIENP(1),CMNTSX,1,0)
+19 IF $GET(RET)'=1
SET RSLT="~`0^Error adding Med Hx/Business Comments text: "_$GET(RET)
QUIT RSLT
+20 SET RSLT="~`1^"_FDAIENP(1)
+21 QUIT RSLT
+22 ;
GTREFTYP(RSLT) ;;Get Purpose Of Referrals
+1 ;BMC GET PURPOSE OF REF API
+2 ;D GTREFTYP^BMCRPC3(.R) ZW @R
+3 KILL ^TMP($JOB,"REFPURPOSE")
+4 ;GDIT/HS/BEE 10/19/17 - p12 CR#8528: Reworked next section of code to sort results
+5 ;N OUT,INDEX
+6 ;S OUT="VAR"
+7 ;D SUBLST^BSTSAPI(OUT,"EHR REFERRAL TYPE^^1")
+8 ;S INDEX=$O(VAR(""))
+9 ;I +INDEX>0 F D Q:(+INDEX'>0)
+10 ;.S ^TMP($J,"REFPURPOSE",1)=$G(^TMP($J,"REFPURPOSE",1))_$G(VAR(INDEX))_"~"
+11 ;.S INDEX=$O(VAR(INDEX))
+12 NEW INDEX,VAR,TMP,ND,TRM
+13 DO SUBLST^BSTSAPI("VAR","EHR REFERRAL TYPE^^1")
+14 SET INDEX=""
FOR
SET INDEX=$ORDER(VAR(INDEX))
IF 'INDEX
QUIT
SET ND=$GET(VAR(INDEX))
SET TRM=$PIECE(ND,U,3)
IF TRM]""
SET TMP(TRM)=ND
+15 SET (INDEX,TMP)=""
FOR
SET INDEX=$ORDER(TMP(INDEX))
IF INDEX=""
QUIT
SET TMP=TMP_$SELECT(TMP]"":"~",1:"")_TMP(INDEX)
+16 IF TMP]""
SET ^TMP($JOB,"REFPURPOSE",1)=TMP
+17 ;End of CR#8528 Changes
+18 SET ^TMP($JOB,"REFPURPOSE",2)=""
+19 SET RSLT=$NAME(^TMP($JOB,"REFPURPOSE"))
+20 QUIT
UPDTSTRF(RSLT,REFIEN,STATUS) ;;Update Status Of Referral against Ref IEN return 0 or 1
+1 ; Not in Use
+2 ;TUS) ADTLINFO=0 ;;ADDITIONAL INFO flag
+3 IF '$DATA(REFIEN)
SET RSLT="~`0^Referral Ien is not provided"
QUIT RSLT
+4 IF '$DATA(STATUS)
SET RSLT="~`0^Referral Status is not provided"
QUIT RSLT
+5 IF REFIEN'>0
SET RSLT="~`0^Referral Ien is not provided"
QUIT RSLT
+6 SET FDA(90001,REFIEN_",",.15)=$GET(STATUS)
+7 DO FILE^DIE("","FDA","ERR1")
+8 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error updating referral:"_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+9 ;D SENDXM^BMCRPC3(REFIEN,"M") ;;Send mailman message
+10 SET RSLT="1"
+11 QUIT
+12 ;
UPCNRINF(RSLT,REFIEN,CONSULTBY,CONSULTDT,CONSULTSTATUS) ;;Updates new Multiple Consulted By
+1 ; S REFIEN="113248"
+2 ; S CONSULTBY="3039"
+3 ; GDIT/HS/BEE 05/08/2018 - BMC*4.0*13 - Time is passed in and required
+4 ; OLD: S CONSULTDT="8/12/2013"
+5 ; S CONSULTDT="8/12/2013@10:30"
+6 ; S CONSULTSTATUS="R"
+7 ; D UPCNRINF^BMCRPC3(.R,REFIEN,CONSULTBY,CONSULTDT,CONSULTSTATUS) W R
+8 ; S ^TMP("FAR",12)=$G(REFIEN)_"^"_$G(CONSULTBY)_"^"_$G(CONSULTDT)_"^"_$G(CONSULTSTATUS)
+9 NEW OUT,FDA,ERR1,PATIEN,ADTLINFO,MSG
+10 IF '$DATA(REFIEN)
SET RSLT="~`0^Referral Ien is not provided"
QUIT RSLT
+11 IF REFIEN'>0
SET RSLT="~`0^Referral Ien is not provided"
QUIT RSLT
+12 IF $$GET1^DIQ(90001,REFIEN_",",1308,"")'=""
Begin DoDot:1
+13 IF $$GET1^DIQ(90001,REFIEN_",",1307,"")'=""
Begin DoDot:2
+14 IF $$GET1^DIQ(90001,REFIEN_",",1306,"I")=$GET(CONSULTSTATUS)
Begin DoDot:3
+15 SET MSG=$$GET1^DIQ(90001,REFIEN_",",.03,"")_" has already been reviewed by "_$$GET1^DIQ(90001,REFIEN_",",1308,"")_" on "_$$GET1^DIQ(90001,REFIEN_",",1307,"")_"."
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF $GET(MSG)'=""
SET RSLT="~`1^"_$GET(MSG)
QUIT RSLT
+17 ; GDIT/HS/BEE 05/08/2018 - BMC*4.0*13 - Time is passed in and required
+18 ;D DT^DILF("",CONSULTDT,.CONSULTDT) I CONSULTDT="-1" S RSLT="~`0^Review Date is not in mm/dd/yyyy fromat" Q RSLT
+19 DO DT^DILF("RT",CONSULTDT,.CONSULTDT)
IF CONSULTDT="-1"
SET RSLT="~`0^Review Date is not in mm/dd/yyyy format"
QUIT RSLT
+20 SET FDA(90001,REFIEN_",",1308)=$GET(CONSULTBY)
+21 SET FDA(90001,REFIEN_",",1307)=$GET(CONSULTDT)
+22 SET FDA(90001,REFIEN_",",1306)=$GET(CONSULTSTATUS)
+23 DO FILE^DIE("","FDA","ERR1")
+24 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error updating referral:"_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+25 DO CRENSCCT^BMCRPC3("",REFIEN,"371530004")
+26 SET RSLT="~`1^"
+27 QUIT
+28 ;
CRENSCCT(RSLT,RRIEN,TERM) ; Create entry in 2300 (SNOMED CLOSED CLINICAL TERM) multiple of RCIS REFERRAL (90001) file
+1 ; D CRENSCCT^BMCRPC3(.R,"113255","371530004") W @R
+2 ; RRIEN = RCIS Feferral IEN
+3 ; TERM = Free text
+4 ; RSLT=IEN of entry created in 2300 (SNOMED CLOSED CLINICAL TERM) multiple
+5 KILL FDA,FDAMSG,FDAIEN
+6 NEW FDADA
+7 ;
+8 SET FDA(42,90001.23,"+1,"_RRIEN_",",.01)=$GET(TERM)
+9 DO UPDATE^DIE("","FDA(42)","FDAIEN","FDAMSG")
+10 SET FDADA=+$GET(FDAIEN(1))
+11 IF $DATA(FDAMSG)
Begin DoDot:1
+12 WRITE !!,"The following error message was returned:",!!
+13 SET FDAMSG=""
FOR
SET FDAMSG=$ORDER(FDAMSG("DIERR",1,"TEXT",FDAMSG))
IF FDAMSG=""
QUIT
WRITE FDAMSG("DIERR",1,"TEXT",FDAMSG),!
End DoDot:1
+14 IF $GET(FDADA)=""
SET RSLT=$GET(FDAMSG)
QUIT
+15 SET RSLT=$GET(FDADA)
+16 QUIT
+17 ;
CRENSCT(RSLT,RRIEN,TERM) ; Create entry in 2200 (SNOMED CLINICAL TERM) multiple of RCIS REFERRAL (90001) file
+1 ; D CRENSCT^BMCRPC3(.R,"113255","371530004") W @R
+2 ; RRIEN = RCIS Feferral IEN
+3 ; TERM = Free text
+4 ; RSLT=IEN of entry created in 2200 (SNOMED CLINICAL TERM) multiple
+5 KILL FDA,FDAMSG,FDAIEN
+6 NEW FDADA
+7 ;
+8 SET FDA(42,90001.22,"+1,"_RRIEN_",",.01)=$GET(TERM)
+9 DO UPDATE^DIE("","FDA(42)","FDAIEN","FDAMSG")
+10 SET FDADA=+$GET(FDAIEN(1))
+11 IF $DATA(FDAMSG)
Begin DoDot:1
+12 WRITE !!,"The following error message was returned:",!!
+13 SET FDAMSG=""
FOR
SET FDAMSG=$ORDER(FDAMSG("DIERR",1,"TEXT",FDAMSG))
IF FDAMSG=""
QUIT
WRITE FDAMSG("DIERR",1,"TEXT",FDAMSG),!
End DoDot:1
+14 IF $GET(FDADA)=""
SET RSLT=$GET(FDAMSG)
QUIT
+15 SET RSLT=$GET(FDADA)
+16 QUIT
+17 ;
