BMCRPC2 ;IHS/CAS/AU - GUI REFERRED CARE INFO SYSTEM (2/4) ;
;;4.0;REFERRED CARE INFO SYSTEM;**7,8,12**;JAN 09, 2006;Build 101
;
;GDIT/HS/BEE 10/19/17 - p12 CR#8106: Put in code to set up correct OPTION USED
;GDIT/HS/BEE 10/19/17 - p12 CR#8779: Send correct provider to V REFERRAL
;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
;
; RPC code for RCIS GUI Application
; Routines contains code for adding/updating data into RCIS files
SETREFRL(RSLT,RFDT,PTIEN,TYPE,IORO,ICDCAT,CPTCAT,PURPOS,PRORTY,TYPEX,VSTS,NOTESCHD,HXCMT,RQPR,SCHWIDAY,ICSRP,IFSHT,IHLSM,IHSPH,IEKG,ILBRP,IPCC,IPRNL,ITUBL,ICLNT,IXRYR,IXRYF,TMIEN,SITE,BCMT,PRVDR,LOC,VST,RPNM,SNMDCT,SNMDPT,PROB,SNMDST,OTHRTYP) ;
K ^TMP($J)
;GDIT/HS/BEE 10/19/17 - p12 CR#8106:Added OXQY0
;GDIT/HS/BEE 10/19/17 - p12 - XINDEX finding:Added SECNSFX,Y
;N OUT,FDA,ERR1,X,REFNMBR,REFSTATS,RQSTFAC,PRIMPYR,CHSSTATS,CASEMGR,RS,BMCPDRG,BMCECOST,BMCIHSCT,BMCINLOS,ADTLINFO,YEAR,NREFIEN,PRIMREF,EXPSCHDT,VREFIEN
N OUT,FDA,ERR1,X,REFNMBR,REFSTATS,RQSTFAC,PRIMPYR,CHSSTATS,CASEMGR,RS,BMCPDRG,BMCECOST,BMCIHSCT,BMCINLOS,ADTLINFO,YEAR,NREFIEN,PRIMREF,EXPSCHDT,VREFIEN,OXQY0,SECNSFX,Y
S ADTLINFO=0 ;;ADDITIONAL INFO flag
;; convert date to internal fileman format
I $G(DUZ(2))="" S RSLT="~`0^Site selection is Mandatory" Q RSLT
S YEAR=$$GET1^DIQ(90001.31,$G(DUZ(2))_",",.02)
;I ($E(DT,2,3)'=$G(YEAR)) S RSLT="~`0^RCIS SITE PARAMETER file REFERRAL YEAR does not match current FISCAL YEAR" Q RSLT
I $G(YEAR)="" S RSLT="~`0^RCIS SITE PARAMETER file REFERRAL YEAR field missing or invalid." Q RSLT
I $P(RFDT,"^",2)'="" D
. S PRIMREF=$P(RFDT,"^",2)
. S RFDT=$P(RFDT,"^",1)
. I $G(PTIEN)="" S PTIEN=$$GET1^DIQ(90001,PRIMREF_",",.03,"I")
I $P($G(SCHWIDAY),"^",2)'="" D
. S EXPSCHDT=$P($P($G(SCHWIDAY),"^",2),"@",1)
. D DT^DILF("",EXPSCHDT,.EXPSCHDT) I EXPSCHDT="-1" S EXPSCHDT=""
. ;GDIT/HS/BEE 10/19/17 - p12 - Fixed SAC issue - changed $REPLACE to $TR()
. ;I $G(EXPSCHDT)'="" S EXPSCHDT=$G(EXPSCHDT)_"."_$REPLACE($P($P($G(SCHWIDAY),"^",2),"@",2),":","")
. I $G(EXPSCHDT)'="" S EXPSCHDT=$G(EXPSCHDT)_"."_$TR($P($P($G(SCHWIDAY),"^",2),"@",2),":","")
;;. . S SCHWIDAY=$P($G(SCHWIDAY),"^",1)
S SCHWIDAY=$P($G(SCHWIDAY),"^",1)
D DT^DILF("",RFDT,.RFDT) I RFDT="-1" S RSLT="~`0^Referral Date is not in mm/dd/yyyy fromat" Q RSLT
;; check for duplication of record
I PTIEN'>0 S RSLT="~`0^Patient Ien not provided" Q RSLT
;I $D(^BMCREF("AA",PTIEN,RFDT)) S RSLT="~`0^A referral already exists for this patient on this date" Q RSLT
S REFSTATS="A" ;; Setting status to ACTIVE
S PRIMPYR="1" ;; Setting Primary Payor to 'IHS'
S:'$G(RQPR) RQPR=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 X=$$REFN^BMC ;;generate Referral Number - will return 13 digit number in variable X
Q:'X
X $P(^DD(90001,.02,0),U,5,99) ;; Perform input transport check
S REFNMBR=$G(X)
I $G(PRIMREF)'="" D
. S REFNMBR=$$GET1^DIQ(90001,PRIMREF_",",.02,"") ;;
. I PTIEN="" S PTIEN=$$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 VSTS=($P(^BMCREF(PRIMREF,11),U,11)-Y2)
. S:VSTS<0 VSTS=0
. ;; Copied code from BMCADDS routine - End
. K Y1,Y2,Y3
I ((RFDT="")!(PTIEN="")!(RQSTFAC="")!(IORO="")!(PURPOS="")!(PRORTY="")!(VSTS="")!($G(SNMDCT)="")!(SNMDPT="")) S RSLT="~`0^Required field missing" Q RSLT
S:$D(TMIEN) TMIEN=""
S:'$D(TYPE) TYPE=""
S:'$D(TYPEX) TYPEX=""
S:'$D(OTHRTYP) OTHRTYP=""
S:'$D(ICDCAT) ICDCAT=""
S:'$D(CPTCAT) CPTCAT=""
I $G(PRIMREF)'="" D
. S FDA(90001,"+1,",101)=SECNSFX
. S FDA(90001,"+1,",102)=PRIMREF
S FDA(90001,"+1,",.01)=RFDT
S FDA(90001,"+1,",.02)=REFNMBR
S FDA(90001,"+1,",.03)=PTIEN
S FDA(90001,"+1,",.04)=TYPE
S FDA(90001,"+1,",.05)=RQSTFAC
S FDA(90001,"+1,",.14)=IORO
S FDA(90001,"+1,",.06)=RQPR
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)=PURPOS
S FDA(90001,"+1,",.32)=PRORTY
I ((TYPE="C")) S FDA(90001,"+1,",.07)=$S(TYPEX'="":TYPEX,TYPEX="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"") ;;CHS - Vendor
I ((TYPE="C")&(OTHRTYP'="")) S FDA(90001,"+1,",.09)=OTHRTYP ;;CHS - Vendor and Other can be set at the same time
I ((TYPE="O")&(OTHRTYP'="")) S FDA(90001,"+1,",.09)=OTHRTYP ;;OTHER - RCIS Specific provider
I ((TYPE="O")) S FDA(90001,"+1,",.07)=$S(TYPEX'="":TYPEX,TYPEX="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"") ;;CHS - Vendor and Other can be set at the same time
I ((TYPE="N")&(TYPEX'="")) S FDA(90001,"+1,",.23)=TYPEX ;;IN-HOUSE - Clinic Stop
I ((TYPE="I")&(TYPEX'="")) S FDA(90001,"+1,",.08)=TYPEX ;;IHS (Another facility) - Location (TO IHS FACILITY)
S:VSTS'="" FDA(90001,"+1,",1111)=VSTS
S:CHSSTATS'="" FDA(90001,"+1,",1112)=CHSSTATS
S:NOTESCHD'="" FDA(90001,"+1,",1301)=NOTESCHD
S:CASEMGR'="" FDA(90001,"+1,",.19)=CASEMGR
S:SCHWIDAY'="" FDA(90001,"+1,",1302)=SCHWIDAY ;;Schedule With In days
S:$G(EXPSCHDT)'="" FDA(90001,"+1,",1105)=$G(EXPSCHDT) ;;Expected Schedule DOS
S:"YN"[IPCC FDA(90001,"+1,",401)=IPCC ;;INCLUDE PCC VISIT FORM
S:"YN"[ICLNT FDA(90001,"+1,",402)=ICLNT ;;INCLUDE SPECIALTY CLINIC NOTES
S:"YN"[IPRNL FDA(90001,"+1,",403)=IPRNL ;;INCLUDE PRENATAL RECORD(S)
S:"YN"[ITUBL FDA(90001,"+1,",404)=ITUBL ;;INCLUDE SIGNED TUBAL CONSENT
S:"YN"[IFSHT FDA(90001,"+1,",405)=IFSHT ;;INCLUDE FACE SHEET
S:"YN"[IHLSM FDA(90001,"+1,",406)=IHLSM ;;INCLUDE HEALTH SUMMARY
S:"YN"[IEKG FDA(90001,"+1,",407)=IEKG ;;INCLUDE MOST RECENT EKG
S:"YN"[IHSPH FDA(90001,"+1,",408)=IHSPH ;;INCLUDE HISTORY AND PHYSICAL
S:"YN"[IXRYR FDA(90001,"+1,",409)=IXRYR ;;INCLUDE X-RAY / REPORT
S:"YN"[IXRYF FDA(90001,"+1,",410)=IXRYF ;;INCLUDE X-RAY FILM
S:"YN"[ICSRP FDA(90001,"+1,",411)=ICSRP ;;INCLUDE CONSULTATION REPORT
S:"YN"[ILBRP 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
S FDA(90001,"+1,",1304)="P"
S:$G(VST)'="" FDA(90001,"+1,",1309)=$G(VST)
I TMIEN>0 D ;;If Template was used for this 'Add Referral'; fetch extra info for that template
.S BMCPDRG=$$GET1^DIQ(90001.32,TMIEN_",",.21,"I") S:BMCPDRG'="" FDA(90001,"+1,",.21)=BMCPDRG
.S BMCECOST=$$GET1^DIQ(90001.32,TMIEN_",",1101,"") S:BMCECOST'="" FDA(90001,"+1,",1101)=BMCECOST
.S BMCIHSCT=$$GET1^DIQ(90001.32,TMIEN_",",1103,"") S:BMCIHSCT'="" FDA(90001,"+1,",1103)=BMCIHSCT
.S BMCINLOS=$$GET1^DIQ(90001.32,TMIEN_",",1109,"") S:BMCINLOS'="" FDA(90001,"+1,",1109)=BMCINLOS
N FDAIEN S FDAIEN=""
;GDIT/HS/BEE 10/19/17 - p12 CR#8106;Replace next line with three lines, XQY0 is already defined
;D UPDATE^DIE("","FDA","FDAIEN","ERR1")
S OXQY0=$G(XQY0),XQY0="CIAV VUECENTRIC"
D UPDATE^DIE("","FDA","FDAIEN","ERR1")
S XQY0=OXQY0 ;Return to original value
;End of CR#8106 changes
I $D(ERR1("DIERR")) S RSLT="~`0^Error adding referral: "_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
;S ^TMP("FAR4",1)="SNOW 980"_"^PAT "_$G(PTIEN)_"^VST "_$G(VST)_"^REF IEN "_$G(FDAIEN(1))_"^DATE "_DT_"."_$REPLACE($ZT($H),":","")_"^PROV "
;_$G(PRVDR)_"^LOC "_$G(LOC)_"^ PROV"_$G(PRVDR)_"^ REF PROV "_$G(RPNM)_"^LOC "_$G(LOC)_"^DUZ "_$G(DUZ)_"^B COmments"_$G(BCMT)
;S ^TMP("FAR4",1)="980"_"^"_$G(PTIEN)_"^"_$G(VST)_"^"_$G(FDAIEN(1))_"^"_DT_"."_$REPLACE($ZT($H),":","")_"^"_$G(PRVDR)_"^"_$G(LOC)_"^"_$G(PRVDR)_"^"_$G(RQPR)_"^"_$G(LOC)_"^"_$G(DUZ)
S NREFIEN=$G(FDAIEN(1))
;GDIT/HS/BEE 10/19/17 - p12 CR#8779: Change to pass requesting provider into call, set outside provider to null
;S VREFIEN=$$CRENVREF^BMCRPC4(.OUT,SNMDCT,SNMDPT,PTIEN,$G(VST),$G(PROB),NREFIEN,$$NOW^XLFDT,PRVDR,LOC,PRVDR,"",RPNM,LOC,$$NOW^XLFDT,DUZ)
S VREFIEN=$$CRENVREF^BMCRPC4(.OUT,SNMDCT,SNMDPT,PTIEN,$G(VST),$G(PROB),NREFIEN,$$NOW^XLFDT,RPNM,LOC,PRVDR,"","",LOC,$$NOW^XLFDT,DUZ) ;GDIT/HS/BEE 10/19/17 - p12 CR#8779
I $G(SNMDST)'="" D CRENSCT^BMCRPC3("",NREFIEN,$G(SNMDST))
I ($G(NREFIEN)'="")&($G(VREFIEN)'="")&('$D(ERR1("DIERR"))) D
.K FDA,ERR1
.N FDA,ERR1
.S FDA(90001,NREFIEN_",",1303)=$G(VREFIEN)
.D FILE^DIE("","FDA","ERR1")
I $D(ERR1("DIERR")) S RSLT="~`0^Error updating V Referral IEN:"_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
;
;
D SENDALRT^BMCRPC3(NREFIEN) ;; EP-ALERT FOR PHYS
D SENDXM^BMCRPC3(NREFIEN,"A") ;; Send mailman message
D STATIC^BMCRPC3(PTIEN,NREFIEN) ;; fill in EXP (5101 - 5114) fields in RCIS REF file...
I $D(HXCMT) D
.I HXCMT'="" D SETMEDHX^BMCRPC3(.RS,HXCMT,PTIEN,NREFIEN,"M")
I $D(BCMT) D
.I BCMT'="" D SETMEDHX^BMCRPC3(.RS,BCMT,PTIEN,NREFIEN,"B")
I $P($G(RS),"^")="~`0" S RSLT=RS Q RSLT
S RSLT="~`1^"_NREFIEN
Q RSLT
;
UPDREFRL(RSLT,REFIEN,TYPE,INOROUT,ICDCAT,CPTCAT,PURPOSE,PRIORITY,TYPEEXT,VISITS,NOTESCHD,HXCMNTS,SCHWIDAY,ICSRP,IFSHT,IHLSM,IHSPH,IEKG,ILBRP,IPCC,IPRNL,ITUBL,ICLNT,IXRYR,IXRYF,BCMNTS,OTHRTYP,SNMDCT,PROB,SNMDST) ;;update referral data
K ^TMP($J)
N OUT,FDA,ERR1,PATIEN,ADTLINFO,EXPSCHDT,VREFIEN
;S ^TMP("FAR12",2)=REFIEN_"~"_SCHWIDAY
S ADTLINFO=0 ;;ADDITIONAL INFO flag
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
S:'$D(TYPE) TYPE=""
S:'$D(TYPEEXT) TYPEEXT=""
S:'$D(OTHRTYP) OTHRTYP=""
S:'$D(ICDCAT) ICDCAT=""
S:'$D(CPTCAT) CPTCAT=""
I $P($G(SCHWIDAY),"^",2)'="" D
. S EXPSCHDT=$P($P($G(SCHWIDAY),"^",2),"@",1)
. D DT^DILF("",EXPSCHDT,.EXPSCHDT) I EXPSCHDT="-1" S EXPSCHDT=""
. ;GDIT/HS/BEE 10/19/17 - p12 - Fixed SAC issue - changed $REPLACE to $TR()
. ;I $G(EXPSCHDT)'="" S EXPSCHDT=$G(EXPSCHDT)_"."_$REPLACE($P($P($G(SCHWIDAY),"^",2),"@",2),":","")
. I $G(EXPSCHDT)'="" S EXPSCHDT=$G(EXPSCHDT)_"."_$TR($P($P($G(SCHWIDAY),"^",2),"@",2),":","")
. S SCHWIDAY=$P($G(SCHWIDAY),"^",1)
S SCHWIDAY=$P($G(SCHWIDAY),"^",1)
S:TYPE'="" FDA(90001,REFIEN_",",.04)=TYPE
S:INOROUT'="" FDA(90001,REFIEN_",",.14)=INOROUT
S:ICDCAT'="" FDA(90001,REFIEN_",",.12)=ICDCAT
S:CPTCAT'="" FDA(90001,REFIEN_",",.13)=CPTCAT
S:PURPOSE'="" FDA(90001,REFIEN_",",1201)=PURPOSE
S:PRIORITY'="" FDA(90001,REFIEN_",",.32)=PRIORITY
I (TYPE="C") D ;; CHS - Set Vendor - leave specific provider as is - delete To IHS FAC and Clinic Stop
.S FDA(90001,REFIEN_",",.23)="@",FDA(90001,REFIEN_",",.08)="@",FDA(90001,REFIEN_",",.07)="@",FDA(90001,REFIEN_",",.09)="@"
.S FDA(90001,REFIEN_",",.07)=$S(TYPEEXT'="":TYPEEXT,TYPEEXT="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"")
.S:(OTHRTYP'="") FDA(90001,REFIEN_",",.09)=OTHRTYP
I (TYPE="O") D ;; OTHER - set Specific provider - leave Vendor as is - delete To IHS FAC and Clinic Stop
.S FDA(90001,REFIEN_",",.23)="@",FDA(90001,REFIEN_",",.08)="@",FDA(90001,REFIEN_",",.07)="@",FDA(90001,REFIEN_",",.09)="@"
.S FDA(90001,REFIEN_",",.07)=$S(TYPEEXT'="":TYPEEXT,TYPEEXT="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"")
.S:(OTHRTYP'="") FDA(90001,REFIEN_",",.09)=OTHRTYP
I (TYPE="N") D ;; IN-HOUSE - set Clinic Stop - delete Specific provider - Vendor - To IHS FAC
.S FDA(90001,REFIEN_",",.07)="@",FDA(90001,REFIEN_",",.09)="@",FDA(90001,REFIEN_",",.08)="@",FDA(90001,REFIEN_",",.23)="@"
.S:(TYPEEXT'="") FDA(90001,REFIEN_",",.23)=TYPEEXT
I (TYPE="I") D ;IHS(Another facility)-Set Location(FACILITY)-delete SpecificProvider-Vendor-ClinicStop
.S FDA(90001,REFIEN_",",.07)="@",FDA(90001,REFIEN_",",.09)="@",FDA(90001,REFIEN_",",.23)="@",FDA(90001,REFIEN_",",.08)="@"
.S:(TYPEEXT'="") FDA(90001,REFIEN_",",.08)=TYPEEXT
S:VISITS'="" FDA(90001,REFIEN_",",1111)=VISITS
S:NOTESCHD'="" FDA(90001,REFIEN_",",1301)=NOTESCHD
S:SCHWIDAY'="" FDA(90001,REFIEN_",",1302)=SCHWIDAY ;; Schedule With In days
S:$G(EXPSCHDT)'="" FDA(90001,REFIEN_",",1105)=$G(EXPSCHDT) ;;Expected Schedule DOS
S:$G(EXPSCHDT)="" FDA(90001,REFIEN_",",1105)="@" ;;Expected Schedule DOS
S:"YN"[IPCC FDA(90001,REFIEN_",",401)=IPCC ;; INCLUDE PCC VISIT FORM
S:"YN"[ICLNT FDA(90001,REFIEN_",",402)=ICLNT ;; INCLUDE SPECIALTY CLINIC NOTES
S:"YN"[IPRNL FDA(90001,REFIEN_",",403)=IPRNL ;;INCLUDE PRENATAL RECORD(S)
S:"YN"[ITUBL FDA(90001,REFIEN_",",404)=ITUBL ;;INCLUDE SIGNED TUBAL CONSENT
S:"YN"[IFSHT FDA(90001,REFIEN_",",405)=IFSHT ;;INCLUDE FACE SHEET
S:"YN"[IHLSM FDA(90001,REFIEN_",",406)=IHLSM ;;INCLUDE HEALTH SUMMARY
S:"YN"[IEKG FDA(90001,REFIEN_",",407)=IEKG ;; INCLUDE MOST RECENT EKG
S:"YN"[IHSPH FDA(90001,REFIEN_",",408)=IHSPH ;; INCLUDE HISTORY AND PHYSICAL
S:"YN"[IXRYR FDA(90001,REFIEN_",",409)=IXRYR ;;INCLUDE X-RAY / REPORT
S:"YN"[IXRYF FDA(90001,REFIEN_",",410)=IXRYF ;; INCLUDE X-RAY FILM
S:"YN"[ICSRP FDA(90001,REFIEN_",",411)=ICSRP ;;INCLUDE CONSULTATION REPORT
S:"YN"[ILBRP FDA(90001,REFIEN_",",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,REFIEN_",",.34)=ADTLINFO
S FDA(90001,REFIEN_",",.27)=DT ;; Date last updated - set to current system date
D FILE^DIE("","FDA","ERR1")
I $D(ERR1("DIERR")) S RSLT="~`0^Error updating referral:"_$G(ERR1("DIERR","1","TEXT",1)) Q RSLT
K ^BMCREF(REFIEN,22)
I $G(SNMDST)'="" D CRENSCT^BMCRPC3("",REFIEN,$G(SNMDST))
S VREFIEN=$$GET1^DIQ(90001,REFIEN_",",1303,"I") ;
;S ^TMP("1221")=$G(VREFIEN)_"^"_$G(SNMDCT)_"^"_$G(DUZ)_"^"_$G(PROB)
I $G(VREFIEN)'="" S RSLT=$$UPENVREF^BMCRPC4(VREFIEN,$G(SNMDCT),$G(DUZ),$G(PROB))
I $G(VREFIEN)="" S RSLT="~`1^"
I $G(RSLT)'="~`1^" Q RSLT
D SENDXM^BMCRPC3(REFIEN,"M") ;;Send mailman message
I $D(HXCMNTS) D
.I HXCMNTS'="" S PATIEN=$$GET1^DIQ(90001,REFIEN_",",.03,"I") D SETMEDHX^BMCRPC3(.RS,HXCMNTS,PATIEN,REFIEN,"M")
I $D(BCMNTS) D
.I BCMNTS'="" S PATIEN=$$GET1^DIQ(90001,REFIEN_",",.03,"I") D SETMEDHX^BMCRPC3(.RS,BCMNTS,PATIEN,REFIEN,"B")
I $P($G(RS),"^")="~`0" S RSLT=RS Q RSLT
S RSLT="~`1"
Q RSLT
;
CHKYEAR(RSLT,SITE) ;BMC CHK YEAR SITE PARAM
;S SITE="2011 DEMO HOSPITAL"
I $G(DUZ(2))="" S RSLT="0" Q RSLT
S YEAR=$$GET1^DIQ(90001.31,$G(DUZ(2))_",",.02)
I $G(YEAR)="" S RSLT="0" Q RSLT
S RSLT=$G(YEAR)
Q RSLT
;
BMCRPC2 ;IHS/CAS/AU - GUI REFERRED CARE INFO SYSTEM (2/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#8106: Put in code to set up correct OPTION USED
+4 ;GDIT/HS/BEE 10/19/17 - p12 CR#8779: Send correct provider to V REFERRAL
+5 ;GDIT/HS/BEE 10/19/17 - p12 - Address XINDEX/SAC issues
+6 ;
+7 ; RPC code for RCIS GUI Application
+8 ; Routines contains code for adding/updating data into RCIS files
SETREFRL(RSLT,RFDT,PTIEN,TYPE,IORO,ICDCAT,CPTCAT,PURPOS,PRORTY,TYPEX,VSTS,NOTESCHD,HXCMT,RQPR,SCHWIDAY,ICSRP,IFSHT,IHLSM,IHSPH,IEKG,ILBRP,IPCC,IPRNL,ITUBL,ICLNT,IXRYR,IXRYF,TMIEN,SITE,BCMT,PRVDR,LOC,VST,RPNM,SNMDCT,SNMDPT,PROB,SNMDST,OTHRTYP) ;
+1 KILL ^TMP($JOB)
+2 ;GDIT/HS/BEE 10/19/17 - p12 CR#8106:Added OXQY0
+3 ;GDIT/HS/BEE 10/19/17 - p12 - XINDEX finding:Added SECNSFX,Y
+4 ;N OUT,FDA,ERR1,X,REFNMBR,REFSTATS,RQSTFAC,PRIMPYR,CHSSTATS,CASEMGR,RS,BMCPDRG,BMCECOST,BMCIHSCT,BMCINLOS,ADTLINFO,YEAR,NREFIEN,PRIMREF,EXPSCHDT,VREFIEN
+5 NEW OUT,FDA,ERR1,X,REFNMBR,REFSTATS,RQSTFAC,PRIMPYR,CHSSTATS,CASEMGR,RS,BMCPDRG,BMCECOST,BMCIHSCT,BMCINLOS,ADTLINFO,YEAR,NREFIEN,PRIMREF,EXPSCHDT,VREFIEN,OXQY0,SECNSFX,Y
+6 ;;ADDITIONAL INFO flag
SET ADTLINFO=0
+7 ;; convert date to internal fileman format
+8 IF $GET(DUZ(2))=""
SET RSLT="~`0^Site selection is Mandatory"
QUIT RSLT
+9 SET YEAR=$$GET1^DIQ(90001.31,$GET(DUZ(2))_",",.02)
+10 ;I ($E(DT,2,3)'=$G(YEAR)) S RSLT="~`0^RCIS SITE PARAMETER file REFERRAL YEAR does not match current FISCAL YEAR" Q RSLT
+11 IF $GET(YEAR)=""
SET RSLT="~`0^RCIS SITE PARAMETER file REFERRAL YEAR field missing or invalid."
QUIT RSLT
+12 IF $PIECE(RFDT,"^",2)'=""
Begin DoDot:1
+13 SET PRIMREF=$PIECE(RFDT,"^",2)
+14 SET RFDT=$PIECE(RFDT,"^",1)
+15 IF $GET(PTIEN)=""
SET PTIEN=$$GET1^DIQ(90001,PRIMREF_",",.03,"I")
End DoDot:1
+16 IF $PIECE($GET(SCHWIDAY),"^",2)'=""
Begin DoDot:1
+17 SET EXPSCHDT=$PIECE($PIECE($GET(SCHWIDAY),"^",2),"@",1)
+18 DO DT^DILF("",EXPSCHDT,.EXPSCHDT)
IF EXPSCHDT="-1"
SET EXPSCHDT=""
+19 ;GDIT/HS/BEE 10/19/17 - p12 - Fixed SAC issue - changed $REPLACE to $TR()
+20 ;I $G(EXPSCHDT)'="" S EXPSCHDT=$G(EXPSCHDT)_"."_$REPLACE($P($P($G(SCHWIDAY),"^",2),"@",2),":","")
+21 IF $GET(EXPSCHDT)'=""
SET EXPSCHDT=$GET(EXPSCHDT)_"."_$TRANSLATE($PIECE($PIECE($GET(SCHWIDAY),"^",2),"@",2),":","")
End DoDot:1
+22 ;;. . S SCHWIDAY=$P($G(SCHWIDAY),"^",1)
+23 SET SCHWIDAY=$PIECE($GET(SCHWIDAY),"^",1)
+24 DO DT^DILF("",RFDT,.RFDT)
IF RFDT="-1"
SET RSLT="~`0^Referral Date is not in mm/dd/yyyy fromat"
QUIT RSLT
+25 ;; check for duplication of record
+26 IF PTIEN'>0
SET RSLT="~`0^Patient Ien not provided"
QUIT RSLT
+27 ;I $D(^BMCREF("AA",PTIEN,RFDT)) S RSLT="~`0^A referral already exists for this patient on this date" Q RSLT
+28 ;; Setting status to ACTIVE
SET REFSTATS="A"
+29 ;; Setting Primary Payor to 'IHS'
SET PRIMPYR="1"
+30 ;; default to logged in user ien
IF '$GET(RQPR)
SET RQPR=DUZ
+31 ;;default to facility where user is logged onto
SET RQSTFAC=DUZ(2)
+32 ;; Setting CHS APPROVAL STATUS to 'PENDING'
SET CHSSTATS="P"
+33 ;;set default case manager if not provided
SET CASEMGR=$$GET1^DIQ(90001.31,RQSTFAC_",",.12,"I")
+34 ;;generate Referral Number - will return 13 digit number in variable X
SET X=$$REFN^BMC
+35 IF 'X
QUIT
+36 ;; Perform input transport check
XECUTE $PIECE(^DD(90001,.02,0),U,5,99)
+37 SET REFNMBR=$GET(X)
+38 IF $GET(PRIMREF)'=""
Begin DoDot:1
+39 ;;
SET REFNMBR=$$GET1^DIQ(90001,PRIMREF_",",.02,"")
+40 IF PTIEN=""
SET PTIEN=$$GET1^DIQ(90001,PRIMREF_",",.03,"I")
+41 NEW Y1,Y2,Y3
+42 ;; Copied from BMCADDS routine - Begin - to calculate suffix and visits
+43 SET (Y1,Y2,Y3)=0
+44 IF '$DATA(^BMCREF("S",REFNMBR))
SET Y1=0
+45 IF '$TEST
SET Y=""
FOR
SET Y=$ORDER(^BMCREF("S",REFNMBR,Y))
IF Y=""
QUIT
Begin DoDot:2
+46 SET Y3=$EXTRACT(Y,2,$LENGTH(Y))
SET Y2=Y2+1
+47 IF Y3>Y1
SET Y1=Y3
End DoDot:2
+48 SET Y1=Y1+1
SET Y2=Y2+1
SET SECNSFX="A"_Y1
+49 ;VISTS REMAINING
+50 SET VSTS=($PIECE(^BMCREF(PRIMREF,11),U,11)-Y2)
+51 IF VSTS<0
SET VSTS=0
+52 ;; Copied code from BMCADDS routine - End
+53 KILL Y1,Y2,Y3
End DoDot:1
+54 IF ((RFDT="")!(PTIEN="")!(RQSTFAC="")!(IORO="")!(PURPOS="")!(PRORTY="")!(VSTS="")!($GET(SNMDCT)="")!(SNMDPT=""))
SET RSLT="~`0^Required field missing"
QUIT RSLT
+55 IF $DATA(TMIEN)
SET TMIEN=""
+56 IF '$DATA(TYPE)
SET TYPE=""
+57 IF '$DATA(TYPEX)
SET TYPEX=""
+58 IF '$DATA(OTHRTYP)
SET OTHRTYP=""
+59 IF '$DATA(ICDCAT)
SET ICDCAT=""
+60 IF '$DATA(CPTCAT)
SET CPTCAT=""
+61 IF $GET(PRIMREF)'=""
Begin DoDot:1
+62 SET FDA(90001,"+1,",101)=SECNSFX
+63 SET FDA(90001,"+1,",102)=PRIMREF
End DoDot:1
+64 SET FDA(90001,"+1,",.01)=RFDT
+65 SET FDA(90001,"+1,",.02)=REFNMBR
+66 SET FDA(90001,"+1,",.03)=PTIEN
+67 SET FDA(90001,"+1,",.04)=TYPE
+68 SET FDA(90001,"+1,",.05)=RQSTFAC
+69 SET FDA(90001,"+1,",.14)=IORO
+70 SET FDA(90001,"+1,",.06)=RQPR
+71 SET FDA(90001,"+1,",.11)=PRIMPYR
+72 IF ICDCAT'=""
SET FDA(90001,"+1,",.12)=ICDCAT
+73 IF CPTCAT'=""
SET FDA(90001,"+1,",.13)=CPTCAT
+74 SET FDA(90001,"+1,",1201)=PURPOS
+75 SET FDA(90001,"+1,",.32)=PRORTY
+76 ;;CHS - Vendor
IF ((TYPE="C"))
SET FDA(90001,"+1,",.07)=$SELECT(TYPEX'="":TYPEX,TYPEX="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"")
+77 ;;CHS - Vendor and Other can be set at the same time
IF ((TYPE="C")&(OTHRTYP'=""))
SET FDA(90001,"+1,",.09)=OTHRTYP
+78 ;;OTHER - RCIS Specific provider
IF ((TYPE="O")&(OTHRTYP'=""))
SET FDA(90001,"+1,",.09)=OTHRTYP
+79 ;;CHS - Vendor and Other can be set at the same time
IF ((TYPE="O"))
SET FDA(90001,"+1,",.07)=$SELECT(TYPEX'="":TYPEX,TYPEX="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"")
+80 ;;IN-HOUSE - Clinic Stop
IF ((TYPE="N")&(TYPEX'=""))
SET FDA(90001,"+1,",.23)=TYPEX
+81 ;;IHS (Another facility) - Location (TO IHS FACILITY)
IF ((TYPE="I")&(TYPEX'=""))
SET FDA(90001,"+1,",.08)=TYPEX
+82 IF VSTS'=""
SET FDA(90001,"+1,",1111)=VSTS
+83 IF CHSSTATS'=""
SET FDA(90001,"+1,",1112)=CHSSTATS
+84 IF NOTESCHD'=""
SET FDA(90001,"+1,",1301)=NOTESCHD
+85 IF CASEMGR'=""
SET FDA(90001,"+1,",.19)=CASEMGR
+86 ;;Schedule With In days
IF SCHWIDAY'=""
SET FDA(90001,"+1,",1302)=SCHWIDAY
+87 ;;Expected Schedule DOS
IF $GET(EXPSCHDT)'=""
SET FDA(90001,"+1,",1105)=$GET(EXPSCHDT)
+88 ;;INCLUDE PCC VISIT FORM
IF "YN"[IPCC
SET FDA(90001,"+1,",401)=IPCC
+89 ;;INCLUDE SPECIALTY CLINIC NOTES
IF "YN"[ICLNT
SET FDA(90001,"+1,",402)=ICLNT
+90 ;;INCLUDE PRENATAL RECORD(S)
IF "YN"[IPRNL
SET FDA(90001,"+1,",403)=IPRNL
+91 ;;INCLUDE SIGNED TUBAL CONSENT
IF "YN"[ITUBL
SET FDA(90001,"+1,",404)=ITUBL
+92 ;;INCLUDE FACE SHEET
IF "YN"[IFSHT
SET FDA(90001,"+1,",405)=IFSHT
+93 ;;INCLUDE HEALTH SUMMARY
IF "YN"[IHLSM
SET FDA(90001,"+1,",406)=IHLSM
+94 ;;INCLUDE MOST RECENT EKG
IF "YN"[IEKG
SET FDA(90001,"+1,",407)=IEKG
+95 ;;INCLUDE HISTORY AND PHYSICAL
IF "YN"[IHSPH
SET FDA(90001,"+1,",408)=IHSPH
+96 ;;INCLUDE X-RAY / REPORT
IF "YN"[IXRYR
SET FDA(90001,"+1,",409)=IXRYR
+97 ;;INCLUDE X-RAY FILM
IF "YN"[IXRYF
SET FDA(90001,"+1,",410)=IXRYF
+98 ;;INCLUDE CONSULTATION REPORT
IF "YN"[ICSRP
SET FDA(90001,"+1,",411)=ICSRP
+99 ;;INCLUDE MOST RECENT LAB REPORT
IF "YN"[ILBRP
SET FDA(90001,"+1,",412)=ILBRP
+100 IF IPCC_ICLNT_IPRNL_ITUBL_IFSHT_IHLSM_IEKG_IHSPH_IXRYR_IXRYF_ICSRP_ILBRP["Y"
SET ADTLINFO=1
+101 SET FDA(90001,"+1,",.34)=ADTLINFO
+102 SET FDA(90001,"+1,",.15)=REFSTATS
+103 SET FDA(90001,"+1,",.25)=DUZ
+104 SET FDA(90001,"+1,",.26)=DT
+105 SET FDA(90001,"+1,",.27)=DT
+106 SET FDA(90001,"+1,",1304)="P"
+107 IF $GET(VST)'=""
SET FDA(90001,"+1,",1309)=$GET(VST)
+108 ;;If Template was used for this 'Add Referral'; fetch extra info for that template
IF TMIEN>0
Begin DoDot:1
+109 SET BMCPDRG=$$GET1^DIQ(90001.32,TMIEN_",",.21,"I")
IF BMCPDRG'=""
SET FDA(90001,"+1,",.21)=BMCPDRG
+110 SET BMCECOST=$$GET1^DIQ(90001.32,TMIEN_",",1101,"")
IF BMCECOST'=""
SET FDA(90001,"+1,",1101)=BMCECOST
+111 SET BMCIHSCT=$$GET1^DIQ(90001.32,TMIEN_",",1103,"")
IF BMCIHSCT'=""
SET FDA(90001,"+1,",1103)=BMCIHSCT
+112 SET BMCINLOS=$$GET1^DIQ(90001.32,TMIEN_",",1109,"")
IF BMCINLOS'=""
SET FDA(90001,"+1,",1109)=BMCINLOS
End DoDot:1
+113 NEW FDAIEN
SET FDAIEN=""
+114 ;GDIT/HS/BEE 10/19/17 - p12 CR#8106;Replace next line with three lines, XQY0 is already defined
+115 ;D UPDATE^DIE("","FDA","FDAIEN","ERR1")
+116 SET OXQY0=$GET(XQY0)
SET XQY0="CIAV VUECENTRIC"
+117 DO UPDATE^DIE("","FDA","FDAIEN","ERR1")
+118 ;Return to original value
SET XQY0=OXQY0
+119 ;End of CR#8106 changes
+120 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error adding referral: "_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+121 ;S ^TMP("FAR4",1)="SNOW 980"_"^PAT "_$G(PTIEN)_"^VST "_$G(VST)_"^REF IEN "_$G(FDAIEN(1))_"^DATE "_DT_"."_$REPLACE($ZT($H),":","")_"^PROV "
+122 ;_$G(PRVDR)_"^LOC "_$G(LOC)_"^ PROV"_$G(PRVDR)_"^ REF PROV "_$G(RPNM)_"^LOC "_$G(LOC)_"^DUZ "_$G(DUZ)_"^B COmments"_$G(BCMT)
+123 ;S ^TMP("FAR4",1)="980"_"^"_$G(PTIEN)_"^"_$G(VST)_"^"_$G(FDAIEN(1))_"^"_DT_"."_$REPLACE($ZT($H),":","")_"^"_$G(PRVDR)_"^"_$G(LOC)_"^"_$G(PRVDR)_"^"_$G(RQPR)_"^"_$G(LOC)_"^"_$G(DUZ)
+124 SET NREFIEN=$GET(FDAIEN(1))
+125 ;GDIT/HS/BEE 10/19/17 - p12 CR#8779: Change to pass requesting provider into call, set outside provider to null
+126 ;S VREFIEN=$$CRENVREF^BMCRPC4(.OUT,SNMDCT,SNMDPT,PTIEN,$G(VST),$G(PROB),NREFIEN,$$NOW^XLFDT,PRVDR,LOC,PRVDR,"",RPNM,LOC,$$NOW^XLFDT,DUZ)
+127 ;GDIT/HS/BEE 10/19/17 - p12 CR#8779
SET VREFIEN=$$CRENVREF^BMCRPC4(.OUT,SNMDCT,SNMDPT,PTIEN,$GET(VST),$GET(PROB),NREFIEN,$$NOW^XLFDT,RPNM,LOC,PRVDR,"","",LOC,$$NOW^XLFDT,DUZ)
+128 IF $GET(SNMDST)'=""
DO CRENSCT^BMCRPC3("",NREFIEN,$GET(SNMDST))
+129 IF ($GET(NREFIEN)'="")&($GET(VREFIEN)'="")&('$DATA(ERR1("DIERR")))
Begin DoDot:1
+130 KILL FDA,ERR1
+131 NEW FDA,ERR1
+132 SET FDA(90001,NREFIEN_",",1303)=$GET(VREFIEN)
+133 DO FILE^DIE("","FDA","ERR1")
End DoDot:1
+134 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error updating V Referral IEN:"_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+135 ;
+136 ;
+137 ;; EP-ALERT FOR PHYS
DO SENDALRT^BMCRPC3(NREFIEN)
+138 ;; Send mailman message
DO SENDXM^BMCRPC3(NREFIEN,"A")
+139 ;; fill in EXP (5101 - 5114) fields in RCIS REF file...
DO STATIC^BMCRPC3(PTIEN,NREFIEN)
+140 IF $DATA(HXCMT)
Begin DoDot:1
+141 IF HXCMT'=""
DO SETMEDHX^BMCRPC3(.RS,HXCMT,PTIEN,NREFIEN,"M")
End DoDot:1
+142 IF $DATA(BCMT)
Begin DoDot:1
+143 IF BCMT'=""
DO SETMEDHX^BMCRPC3(.RS,BCMT,PTIEN,NREFIEN,"B")
End DoDot:1
+144 IF $PIECE($GET(RS),"^")="~`0"
SET RSLT=RS
QUIT RSLT
+145 SET RSLT="~`1^"_NREFIEN
+146 QUIT RSLT
+147 ;
UPDREFRL(RSLT,REFIEN,TYPE,INOROUT,ICDCAT,CPTCAT,PURPOSE,PRIORITY,TYPEEXT,VISITS,NOTESCHD,HXCMNTS,SCHWIDAY,ICSRP,IFSHT,IHLSM,IHSPH,IEKG,ILBRP,IPCC,IPRNL,ITUBL,ICLNT,IXRYR,IXRYF,BCMNTS,OTHRTYP,SNMDCT,PROB,SNMDST) ;;update referral data
+1 KILL ^TMP($JOB)
+2 NEW OUT,FDA,ERR1,PATIEN,ADTLINFO,EXPSCHDT,VREFIEN
+3 ;S ^TMP("FAR12",2)=REFIEN_"~"_SCHWIDAY
+4 ;;ADDITIONAL INFO flag
SET ADTLINFO=0
+5 IF '$DATA(REFIEN)
SET RSLT="~`0^Referral Ien is not provided"
QUIT RSLT
+6 IF REFIEN'>0
SET RSLT="~`0^Referral Ien is not provided"
QUIT RSLT
+7 IF '$DATA(TYPE)
SET TYPE=""
+8 IF '$DATA(TYPEEXT)
SET TYPEEXT=""
+9 IF '$DATA(OTHRTYP)
SET OTHRTYP=""
+10 IF '$DATA(ICDCAT)
SET ICDCAT=""
+11 IF '$DATA(CPTCAT)
SET CPTCAT=""
+12 IF $PIECE($GET(SCHWIDAY),"^",2)'=""
Begin DoDot:1
+13 SET EXPSCHDT=$PIECE($PIECE($GET(SCHWIDAY),"^",2),"@",1)
+14 DO DT^DILF("",EXPSCHDT,.EXPSCHDT)
IF EXPSCHDT="-1"
SET EXPSCHDT=""
+15 ;GDIT/HS/BEE 10/19/17 - p12 - Fixed SAC issue - changed $REPLACE to $TR()
+16 ;I $G(EXPSCHDT)'="" S EXPSCHDT=$G(EXPSCHDT)_"."_$REPLACE($P($P($G(SCHWIDAY),"^",2),"@",2),":","")
+17 IF $GET(EXPSCHDT)'=""
SET EXPSCHDT=$GET(EXPSCHDT)_"."_$TRANSLATE($PIECE($PIECE($GET(SCHWIDAY),"^",2),"@",2),":","")
+18 SET SCHWIDAY=$PIECE($GET(SCHWIDAY),"^",1)
End DoDot:1
+19 SET SCHWIDAY=$PIECE($GET(SCHWIDAY),"^",1)
+20 IF TYPE'=""
SET FDA(90001,REFIEN_",",.04)=TYPE
+21 IF INOROUT'=""
SET FDA(90001,REFIEN_",",.14)=INOROUT
+22 IF ICDCAT'=""
SET FDA(90001,REFIEN_",",.12)=ICDCAT
+23 IF CPTCAT'=""
SET FDA(90001,REFIEN_",",.13)=CPTCAT
+24 IF PURPOSE'=""
SET FDA(90001,REFIEN_",",1201)=PURPOSE
+25 IF PRIORITY'=""
SET FDA(90001,REFIEN_",",.32)=PRIORITY
+26 ;; CHS - Set Vendor - leave specific provider as is - delete To IHS FAC and Clinic Stop
IF (TYPE="C")
Begin DoDot:1
+27 SET FDA(90001,REFIEN_",",.23)="@"
SET FDA(90001,REFIEN_",",.08)="@"
SET FDA(90001,REFIEN_",",.07)="@"
SET FDA(90001,REFIEN_",",.09)="@"
+28 SET FDA(90001,REFIEN_",",.07)=$SELECT(TYPEEXT'="":TYPEEXT,TYPEEXT="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"")
+29 IF (OTHRTYP'="")
SET FDA(90001,REFIEN_",",.09)=OTHRTYP
End DoDot:1
+30 ;; OTHER - set Specific provider - leave Vendor as is - delete To IHS FAC and Clinic Stop
IF (TYPE="O")
Begin DoDot:1
+31 SET FDA(90001,REFIEN_",",.23)="@"
SET FDA(90001,REFIEN_",",.08)="@"
SET FDA(90001,REFIEN_",",.07)="@"
SET FDA(90001,REFIEN_",",.09)="@"
+32 SET FDA(90001,REFIEN_",",.07)=$SELECT(TYPEEXT'="":TYPEEXT,TYPEEXT="":$$FIND1^DIC(9999999.11,"","BQX","UNSPECIFIED","B"),1:"")
+33 IF (OTHRTYP'="")
SET FDA(90001,REFIEN_",",.09)=OTHRTYP
End DoDot:1
+34 ;; IN-HOUSE - set Clinic Stop - delete Specific provider - Vendor - To IHS FAC
IF (TYPE="N")
Begin DoDot:1
+35 SET FDA(90001,REFIEN_",",.07)="@"
SET FDA(90001,REFIEN_",",.09)="@"
SET FDA(90001,REFIEN_",",.08)="@"
SET FDA(90001,REFIEN_",",.23)="@"
+36 IF (TYPEEXT'="")
SET FDA(90001,REFIEN_",",.23)=TYPEEXT
End DoDot:1
+37 ;IHS(Another facility)-Set Location(FACILITY)-delete SpecificProvider-Vendor-ClinicStop
IF (TYPE="I")
Begin DoDot:1
+38 SET FDA(90001,REFIEN_",",.07)="@"
SET FDA(90001,REFIEN_",",.09)="@"
SET FDA(90001,REFIEN_",",.23)="@"
SET FDA(90001,REFIEN_",",.08)="@"
+39 IF (TYPEEXT'="")
SET FDA(90001,REFIEN_",",.08)=TYPEEXT
End DoDot:1
+40 IF VISITS'=""
SET FDA(90001,REFIEN_",",1111)=VISITS
+41 IF NOTESCHD'=""
SET FDA(90001,REFIEN_",",1301)=NOTESCHD
+42 ;; Schedule With In days
IF SCHWIDAY'=""
SET FDA(90001,REFIEN_",",1302)=SCHWIDAY
+43 ;;Expected Schedule DOS
IF $GET(EXPSCHDT)'=""
SET FDA(90001,REFIEN_",",1105)=$GET(EXPSCHDT)
+44 ;;Expected Schedule DOS
IF $GET(EXPSCHDT)=""
SET FDA(90001,REFIEN_",",1105)="@"
+45 ;; INCLUDE PCC VISIT FORM
IF "YN"[IPCC
SET FDA(90001,REFIEN_",",401)=IPCC
+46 ;; INCLUDE SPECIALTY CLINIC NOTES
IF "YN"[ICLNT
SET FDA(90001,REFIEN_",",402)=ICLNT
+47 ;;INCLUDE PRENATAL RECORD(S)
IF "YN"[IPRNL
SET FDA(90001,REFIEN_",",403)=IPRNL
+48 ;;INCLUDE SIGNED TUBAL CONSENT
IF "YN"[ITUBL
SET FDA(90001,REFIEN_",",404)=ITUBL
+49 ;;INCLUDE FACE SHEET
IF "YN"[IFSHT
SET FDA(90001,REFIEN_",",405)=IFSHT
+50 ;;INCLUDE HEALTH SUMMARY
IF "YN"[IHLSM
SET FDA(90001,REFIEN_",",406)=IHLSM
+51 ;; INCLUDE MOST RECENT EKG
IF "YN"[IEKG
SET FDA(90001,REFIEN_",",407)=IEKG
+52 ;; INCLUDE HISTORY AND PHYSICAL
IF "YN"[IHSPH
SET FDA(90001,REFIEN_",",408)=IHSPH
+53 ;;INCLUDE X-RAY / REPORT
IF "YN"[IXRYR
SET FDA(90001,REFIEN_",",409)=IXRYR
+54 ;; INCLUDE X-RAY FILM
IF "YN"[IXRYF
SET FDA(90001,REFIEN_",",410)=IXRYF
+55 ;;INCLUDE CONSULTATION REPORT
IF "YN"[ICSRP
SET FDA(90001,REFIEN_",",411)=ICSRP
+56 ;;INCLUDE MOST RECENT LAB REPORT
IF "YN"[ILBRP
SET FDA(90001,REFIEN_",",412)=ILBRP
+57 IF IPCC_ICLNT_IPRNL_ITUBL_IFSHT_IHLSM_IEKG_IHSPH_IXRYR_IXRYF_ICSRP_ILBRP["Y"
SET ADTLINFO=1
+58 SET FDA(90001,REFIEN_",",.34)=ADTLINFO
+59 ;; Date last updated - set to current system date
SET FDA(90001,REFIEN_",",.27)=DT
+60 DO FILE^DIE("","FDA","ERR1")
+61 IF $DATA(ERR1("DIERR"))
SET RSLT="~`0^Error updating referral:"_$GET(ERR1("DIERR","1","TEXT",1))
QUIT RSLT
+62 KILL ^BMCREF(REFIEN,22)
+63 IF $GET(SNMDST)'=""
DO CRENSCT^BMCRPC3("",REFIEN,$GET(SNMDST))
+64 ;
SET VREFIEN=$$GET1^DIQ(90001,REFIEN_",",1303,"I")
+65 ;S ^TMP("1221")=$G(VREFIEN)_"^"_$G(SNMDCT)_"^"_$G(DUZ)_"^"_$G(PROB)
+66 IF $GET(VREFIEN)'=""
SET RSLT=$$UPENVREF^BMCRPC4(VREFIEN,$GET(SNMDCT),$GET(DUZ),$GET(PROB))
+67 IF $GET(VREFIEN)=""
SET RSLT="~`1^"
+68 IF $GET(RSLT)'="~`1^"
QUIT RSLT
+69 ;;Send mailman message
DO SENDXM^BMCRPC3(REFIEN,"M")
+70 IF $DATA(HXCMNTS)
Begin DoDot:1
+71 IF HXCMNTS'=""
SET PATIEN=$$GET1^DIQ(90001,REFIEN_",",.03,"I")
DO SETMEDHX^BMCRPC3(.RS,HXCMNTS,PATIEN,REFIEN,"M")
End DoDot:1
+72 IF $DATA(BCMNTS)
Begin DoDot:1
+73 IF BCMNTS'=""
SET PATIEN=$$GET1^DIQ(90001,REFIEN_",",.03,"I")
DO SETMEDHX^BMCRPC3(.RS,BCMNTS,PATIEN,REFIEN,"B")
End DoDot:1
+74 IF $PIECE($GET(RS),"^")="~`0"
SET RSLT=RS
QUIT RSLT
+75 SET RSLT="~`1"
+76 QUIT RSLT
+77 ;
CHKYEAR(RSLT,SITE) ;BMC CHK YEAR SITE PARAM
+1 ;S SITE="2011 DEMO HOSPITAL"
+2 IF $GET(DUZ(2))=""
SET RSLT="0"
QUIT RSLT
+3 SET YEAR=$$GET1^DIQ(90001.31,$GET(DUZ(2))_",",.02)
+4 IF $GET(YEAR)=""
SET RSLT="0"
QUIT RSLT
+5 SET RSLT=$GET(YEAR)
+6 QUIT RSLT
+7 ;
