BMCALERT ; IHS/PHXAO/TMJ - RCIS ALERTS ; 02 Mar 2009 2:48 PM
;;4.0;REFERRED CARE INFO SYSTEM;**3,4,5,8**;JAN 09, 2006;Build 101
;BMC*4.0*3 9.20.2007 IHS.OIT.FCJ ADDED NEW ALERT FOR PRIM PROV AND REF PHY
;BMC*4.0*4 11.12.2008 IHS.OIT.FCJ FIXED ALERT TO TRANSFER TO EHR
;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ ADDED TXT AND COM SECTION TO RNT FOR ALERT
;
EN1 ; EP - POSSIBLE HIGH COST ALERT (ROLL AND SCROLL)
Q:$P(^BMCREF(BMCRIEN,0),U,4)="O" ; quit if type=other
W !,"You are entering a diagnosis that indicates this may be a high cost case.",!,"You may want to carefully explore alternative resources and alert your case",!,"manager."
Q
;
EN2 ; EP - COSMETIC PROCEDURE ALERT (ROLL AND SCROLL)
Q:$P(^BMCREF(BMCRIEN,0),U,4)="O" ; quit if type=other
W !,"You are entering a cosmetic procedure that may require CMO approval."
Q
;
EN3 ;EP - POSSIBLE HIGH COST PROCEDURE ALERT (ROLL AND SCROLL)
;
Q:$P(^BMCREF(BMCRIEN,0),U,4)="O" ; quit if type=other
W !,"You are entering a procedure that indicates this may be a high cost case.",!,"You may want to carefully explore alternative resources and alert your case",!,"manager."
Q
;
EN4 ;EP - EXPERIMENTAL CPT PROCEDURE ALERT (ROLL AND SCROLL)
;
;
Q:$P(^BMCREF(BMCRIEN,0),U,4)="O" ; quit if type=other
W !,"You are entering a procedure that indicates this may be a Experimental",!,"Procedure. If so, CHS funds cannot be used to pay for this procedure."
Q
;
EN5 ;EP - 3RD PARTY LIABILITY ALERT (ROLL AND SCROLL)
;
Q:$P(^BMCREF(BMCRIEN,0),U,4)="O" ; quit if type=other
W !,"You are entering a diagnosis that indicates this may involve third party",!,"liability. You may want to investigate this possibility in order to recover",!,"costs."
Q
PALRT1 ;EP-ALERT FOR PHYS
;BMC*4.0*3 9.20.2007 IHS.OIT.FCJ ADDED NEW ALERT FOR PRIM PROV AND REF PHY
;
W !!,"Processing alert for Physician(s)." H 1
NEW XQAID,XQAMSG,XQAROU,XQADATA,XQAARCH,XQAFLG,XQAGUID,XQAOPT,XQASUPV,XQASURO,XQATEXT,XQALERR
;BMC*4.0*4 7/9/2008 IHS/OIT/FCJ Changed Package ID To "OR" and 27 which is service consult/request in the OE/RR notification file- Required for EHR
;S XQAID="BMC REFERRED CARE INFO SYSTEM"
S XQAID="OR,"_BMCDFN_",46"
S XQAMSG="Referral "_BMCRHDR_": "_BMCREC("PAT NAME")
S XQAROU="PALRT2^BMCALERT"
S XQADATA=BMCRIEN
;SETS PRIM PROV AND REF PROV TO AUTO SEND MESSAGE TO
I '$D(XQA) D
.I $P($G(^BMCPARM(DUZ(2),4100)),U,10)="Y" S BMCPPRV=$P(^AUPNPAT(BMCDFN,0),U,14) I BMCPPRV'="" S XQA(BMCPPRV)=""
.I $P($G(^BMCPARM(DUZ(2),4100)),U,9)="Y" S BMCRPRV=$P(^BMCREF(BMCRIEN,0),U,6) I BMCRPRV'="" S XQA(BMCRPRV)=""
I '$G(BMCPPRV) W !,"Primary Care Provider is not definned.",?45,"***ALERT WAS NOT SENT***"
I '$G(BMCRPRV) W !,"Referring Provider is not definned.",?45,"***ALERT WAS NOT SENT***"
Q:'$G(BMCPPRV)&'$G(BMCRPRV)
;FCJ COMMENTED OUT NXT LINE AND ADDED FOLLOWING 3 LINES
;D TXT S XQATEXT="BMCTXT" ;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ NEW LINE
D TXT
I $$PATCH^XPDUTL("XU*8.0*1016") M XQATEXT=BMCTXT
E S XQATEXT="BMCTXT"
D SETUP^XQALERT
K XQA,XQAID,XQAMSG,XQAROU,XQADATA,XQAARCH,XQAFLG,XQAGUID,XQAOPT,XQASUPV,XQASURO,XQATEXT,XQALERR,BMCTXT
Q
PALRT2 ;ALERT TO DISPLAY
S BMCRIEN=XQADATA
S BMCREC=^BMCREF(BMCRIEN,0)
D EN^BMCAL1
Q
TXT ;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ ADDED SECTION
S BMCTXT(1)="Patient: "_$E($P(^DPT($P(^BMCREF(BMCRIEN,0),U,3),0),U),1,25)_" Chart #: "_$S($D(^AUPNPAT($P(^BMCREF(BMCRIEN,0),U,3),41,DUZ(2),0)):$P(^(0),U,2),1:"None")
S BMCTXT(2)="Date Referral Initiated: "_$$VAL^XBDIQ1(90001,BMCRIEN,.01)
S BMCTXT(3)="Requesting Provider: "_$$VAL^XBDIQ1(90001,BMCRIEN,.06)
S BMCTXT(4)="Purpose of Referral: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
S BMCTXT(5)="Referred To: "_$$TOFAC^BMC(BMCRIEN)
S BMCTST(6)="Notes to Scheduler: ",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1301)
S BMCSTR="Priority: "_$$VAL^XBDIQ1(90001,BMCRIEN,.32)
S BMCTXT(7)=BMCSTR_" Ref Type: "_$$VAL^XBDIQ1(90001,BMCRIEN,.04)_" Date of Service: "_$$AVDOS^BMCRLU(BMCRIEN,"C")
S BMCT=7
Q:BMCRHDR="New" ;BMC*4.0*8 NEW LINE
D COM
Q
COM ;BO COMMENTS;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ ADDED SECTION
Q:'$D(^BMCCOM("AD",BMCRIEN))
S BMCCDFN="" F S BMCCDFN=$O(^BMCCOM("AD",BMCRIEN,BMCCDFN)) Q:BMCCDFN'?1N.N D
.Q:$P(^BMCCOM(BMCCDFN,0),U,5)'="B"
.S BMCT=BMCT+1,BMCTXT(BMCT)="",BMCT=BMCT+1
.S BMCTXT(BMCT)="COMMENT DATE: "_$$VAL^XBDIQ1(90001.03,BMCCDFN,.01)_" REVIEWER: "_$$VAL^XBDIQ1(90001.03,BMCCDFN,.04)
.S F=0 F S F=$O(^BMCCOM(BMCCDFN,1,F)) Q:F'?1N.N D
..S BMCT=BMCT+1
..S BMCTXT(BMCT)=^BMCCOM(BMCCDFN,1,F,0)
K F,BMCT
Q
APRV ;BMC*4.0*8 5.14.2013 IHS/ITSC/FCJ ALERT FOR REF STATUS CHG TO APPROVED
S Y=DA D START^BMCREF
Q:'$P(^BMCREF(BMCRIEN,0),U,6) ;CALL-IN REF DO NOT HAVE A REF PROV
S BMCPPRV=$P(^AUPNPAT(BMCDFN,0),U,14),BMCRPRV=$P(^BMCREF(BMCRIEN,0),U,6),BMCRHDR="Approved"
NEW XQA
S XQA(BMCRPRV)="" ;REF PHYS
I BMCPPRV'="",BMCPPRV'=BMCRPRV S XQA(BMCPPRV)="" ;PRIM PROV IF DIFFERENT
I $D(XQA) D PALRT1
Q
BMCALERT ; IHS/PHXAO/TMJ - RCIS ALERTS ; 02 Mar 2009 2:48 PM
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3,4,5,8**;JAN 09, 2006;Build 101
+2 ;BMC*4.0*3 9.20.2007 IHS.OIT.FCJ ADDED NEW ALERT FOR PRIM PROV AND REF PHY
+3 ;BMC*4.0*4 11.12.2008 IHS.OIT.FCJ FIXED ALERT TO TRANSFER TO EHR
+4 ;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ ADDED TXT AND COM SECTION TO RNT FOR ALERT
+5 ;
EN1 ; EP - POSSIBLE HIGH COST ALERT (ROLL AND SCROLL)
+1 ; quit if type=other
IF $PIECE(^BMCREF(BMCRIEN,0),U,4)="O"
QUIT
+2 WRITE !,"You are entering a diagnosis that indicates this may be a high cost case.",!,"You may want to carefully explore alternative resources and alert your case",!,"manager."
+3 QUIT
+4 ;
EN2 ; EP - COSMETIC PROCEDURE ALERT (ROLL AND SCROLL)
+1 ; quit if type=other
IF $PIECE(^BMCREF(BMCRIEN,0),U,4)="O"
QUIT
+2 WRITE !,"You are entering a cosmetic procedure that may require CMO approval."
+3 QUIT
+4 ;
EN3 ;EP - POSSIBLE HIGH COST PROCEDURE ALERT (ROLL AND SCROLL)
+1 ;
+2 ; quit if type=other
IF $PIECE(^BMCREF(BMCRIEN,0),U,4)="O"
QUIT
+3 WRITE !,"You are entering a procedure that indicates this may be a high cost case.",!,"You may want to carefully explore alternative resources and alert your case",!,"manager."
+4 QUIT
+5 ;
EN4 ;EP - EXPERIMENTAL CPT PROCEDURE ALERT (ROLL AND SCROLL)
+1 ;
+2 ;
+3 ; quit if type=other
IF $PIECE(^BMCREF(BMCRIEN,0),U,4)="O"
QUIT
+4 WRITE !,"You are entering a procedure that indicates this may be a Experimental",!,"Procedure. If so, CHS funds cannot be used to pay for this procedure."
+5 QUIT
+6 ;
EN5 ;EP - 3RD PARTY LIABILITY ALERT (ROLL AND SCROLL)
+1 ;
+2 ; quit if type=other
IF $PIECE(^BMCREF(BMCRIEN,0),U,4)="O"
QUIT
+3 WRITE !,"You are entering a diagnosis that indicates this may involve third party",!,"liability. You may want to investigate this possibility in order to recover",!,"costs."
+4 QUIT
PALRT1 ;EP-ALERT FOR PHYS
+1 ;BMC*4.0*3 9.20.2007 IHS.OIT.FCJ ADDED NEW ALERT FOR PRIM PROV AND REF PHY
+2 ;
+3 WRITE !!,"Processing alert for Physician(s)."
HANG 1
+4 NEW XQAID,XQAMSG,XQAROU,XQADATA,XQAARCH,XQAFLG,XQAGUID,XQAOPT,XQASUPV,XQASURO,XQATEXT,XQALERR
+5 ;BMC*4.0*4 7/9/2008 IHS/OIT/FCJ Changed Package ID To "OR" and 27 which is service consult/request in the OE/RR notification file- Required for EHR
+6 ;S XQAID="BMC REFERRED CARE INFO SYSTEM"
+7 SET XQAID="OR,"_BMCDFN_",46"
+8 SET XQAMSG="Referral "_BMCRHDR_": "_BMCREC("PAT NAME")
+9 SET XQAROU="PALRT2^BMCALERT"
+10 SET XQADATA=BMCRIEN
+11 ;SETS PRIM PROV AND REF PROV TO AUTO SEND MESSAGE TO
+12 IF '$DATA(XQA)
Begin DoDot:1
+13 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,10)="Y"
SET BMCPPRV=$PIECE(^AUPNPAT(BMCDFN,0),U,14)
IF BMCPPRV'=""
SET XQA(BMCPPRV)=""
+14 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,9)="Y"
SET BMCRPRV=$PIECE(^BMCREF(BMCRIEN,0),U,6)
IF BMCRPRV'=""
SET XQA(BMCRPRV)=""
End DoDot:1
+15 IF '$GET(BMCPPRV)
WRITE !,"Primary Care Provider is not definned.",?45,"***ALERT WAS NOT SENT***"
+16 IF '$GET(BMCRPRV)
WRITE !,"Referring Provider is not definned.",?45,"***ALERT WAS NOT SENT***"
+17 IF '$GET(BMCPPRV)&'$GET(BMCRPRV)
QUIT
+18 ;FCJ COMMENTED OUT NXT LINE AND ADDED FOLLOWING 3 LINES
+19 ;D TXT S XQATEXT="BMCTXT" ;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ NEW LINE
+20 DO TXT
+21 IF $$PATCH^XPDUTL("XU*8.0*1016")
MERGE XQATEXT=BMCTXT
+22 IF '$TEST
SET XQATEXT="BMCTXT"
+23 DO SETUP^XQALERT
+24 KILL XQA,XQAID,XQAMSG,XQAROU,XQADATA,XQAARCH,XQAFLG,XQAGUID,XQAOPT,XQASUPV,XQASURO,XQATEXT,XQALERR,BMCTXT
+25 QUIT
PALRT2 ;ALERT TO DISPLAY
+1 SET BMCRIEN=XQADATA
+2 SET BMCREC=^BMCREF(BMCRIEN,0)
+3 DO EN^BMCAL1
+4 QUIT
TXT ;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ ADDED SECTION
+1 SET BMCTXT(1)="Patient: "_$EXTRACT($PIECE(^DPT($PIECE(^BMCREF(BMCRIEN,0),U,3),0),U),1,25)_" Chart #: "_$SELECT($DATA(^AUPNPAT($PIECE(^BMCREF(BMCRIEN,0),U,3),41,DUZ(2),0)):$PIECE(^(0),U,2),1:"None")
+2 SET BMCTXT(2)="Date Referral Initiated: "_$$VAL^XBDIQ1(90001,BMCRIEN,.01)
+3 SET BMCTXT(3)="Requesting Provider: "_$$VAL^XBDIQ1(90001,BMCRIEN,.06)
+4 SET BMCTXT(4)="Purpose of Referral: "_$$VAL^XBDIQ1(90001,BMCRIEN,1201)
+5 SET BMCTXT(5)="Referred To: "_$$TOFAC^BMC(BMCRIEN)
+6 SET BMCTST(6)="Notes to Scheduler: "
SET BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1301)
+7 SET BMCSTR="Priority: "_$$VAL^XBDIQ1(90001,BMCRIEN,.32)
+8 SET BMCTXT(7)=BMCSTR_" Ref Type: "_$$VAL^XBDIQ1(90001,BMCRIEN,.04)_" Date of Service: "_$$AVDOS^BMCRLU(BMCRIEN,"C")
+9 SET BMCT=7
+10 ;BMC*4.0*8 NEW LINE
IF BMCRHDR="New"
QUIT
+11 DO COM
+12 QUIT
COM ;BO COMMENTS;BMC*4.0*5 3.4.2009 IHS.OIT.FCJ ADDED SECTION
+1 IF '$DATA(^BMCCOM("AD",BMCRIEN))
QUIT
+2 SET BMCCDFN=""
FOR
SET BMCCDFN=$ORDER(^BMCCOM("AD",BMCRIEN,BMCCDFN))
IF BMCCDFN'?1N.N
QUIT
Begin DoDot:1
+3 IF $PIECE(^BMCCOM(BMCCDFN,0),U,5)'="B"
QUIT
+4 SET BMCT=BMCT+1
SET BMCTXT(BMCT)=""
SET BMCT=BMCT+1
+5 SET BMCTXT(BMCT)="COMMENT DATE: "_$$VAL^XBDIQ1(90001.03,BMCCDFN,.01)_" REVIEWER: "_$$VAL^XBDIQ1(90001.03,BMCCDFN,.04)
+6 SET F=0
FOR
SET F=$ORDER(^BMCCOM(BMCCDFN,1,F))
IF F'?1N.N
QUIT
Begin DoDot:2
+7 SET BMCT=BMCT+1
+8 SET BMCTXT(BMCT)=^BMCCOM(BMCCDFN,1,F,0)
End DoDot:2
End DoDot:1
+9 KILL F,BMCT
+10 QUIT
APRV ;BMC*4.0*8 5.14.2013 IHS/ITSC/FCJ ALERT FOR REF STATUS CHG TO APPROVED
+1 SET Y=DA
DO START^BMCREF
+2 ;CALL-IN REF DO NOT HAVE A REF PROV
IF '$PIECE(^BMCREF(BMCRIEN,0),U,6)
QUIT
+3 SET BMCPPRV=$PIECE(^AUPNPAT(BMCDFN,0),U,14)
SET BMCRPRV=$PIECE(^BMCREF(BMCRIEN,0),U,6)
SET BMCRHDR="Approved"
+4 NEW XQA
+5 ;REF PHYS
SET XQA(BMCRPRV)=""
+6 ;PRIM PROV IF DIFFERENT
IF BMCPPRV'=""
IF BMCPPRV'=BMCRPRV
SET XQA(BMCPPRV)=""
+7 IF $DATA(XQA)
DO PALRT1
+8 QUIT
