BMCAL1 ; IHS/OIT/FCJ-RCIS LIST FOR ALERT; 20-SEP-2007
;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
; New routine for patch 3 to send a Physician Alert
;
EN ; -- main entry point for BMC ALERT REC DISPLAY
D BROWSE
Q
;
HDR ; -- header code
S BMCRREC=^BMCREF(BMCRIEN,0)
S VALMHDR(1)="Patient Name: "_$E($P(^DPT($P(BMCRREC,U,3),0),U),1,25)
S VALMHDR(1)=VALMHDR(1)_" Chart #: "_$S($D(^AUPNPAT($P(BMCRREC,U,3),41,DUZ(2),0)):$P(^(0),U,2),1:"None")
Q
;
INIT ; -- init variables and list array
S BMCSTR="",BMCCTR=0
S BMCSTR="Referral #: "_$$VAL^XBDIQ1(90001,BMCRIEN,.02)
S BMCSTR=BMCSTR_" Date Referral Initiated: "_$$VAL^XBDIQ1(90001,BMCRIEN,.01) D SET
S BMCH="Requesting Provider",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,.06),C=23 D BUILD1
S BMCH="Purpose of Referral",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1201),C=23 D BUILD1,SET
S BMCH="Referred To",BMCV=$$TOFAC^BMC(BMCRIEN),C=15 D BUILD1
S BMCH="Notes to Scheduler",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1301),C=22 D BUILD1,SET
S BMCSTR="Priority: "_$$VAL^XBDIQ1(90001,BMCRIEN,.32)
S BMCSTR=BMCSTR_" Date of Service: "_$$AVDOS^BMCRLU(BMCRIEN,"C") D SET
S BMCH="Referral Type",BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,.04),C=17 D BUILD1,SET
D BOCOM
S VALMCNT=$O(^TMP("BMCALT",$J,""),-1)
Q
BOCOM ; PRINT BO COMMENTS
S BMCVFLE="90001.03",BMCVDG=^DIC(BMCVFLE,0,"GL")
S BMCVNM="Business/CHS Comment",BMCVIGR=BMCVDG_"""AD"",BMCRIEN,BMCVDFN)",BMCCTYP="B"
S BMCVDFN="",BMCVI=1 F S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN="" D
.I $P(^BMCCOM(BMCVDFN,0),U,5)=BMCCTYP D BOCOM1 S BMCVI=2
E F BMCVI=1:1 S BMCVDFN=$O(@BMCVIGR) Q:BMCVDFN="" D BOCOM1
S VALMCNT=$O(^TMP("BMCALT",$J,""),-1)
Q
BOCOM1 ;
I BMCVI<2 S BMCSTR="" D SET S BMCSTR="=============== "_BMCVNM_"s ===============",X=(80-$L(BMCSTR)\2) D SET
K BMCAR D ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01:.019999;.04:999999","BMCAR(","E")
S BMCSTR="" D SET
S F=0 F S F=$O(BMCAR(F)) Q:F'=+F D
.I $G(BMCAR(F))]"" D
..S BMCH=$P(^DD(BMCVFLE,F,0),U)
..S BMCV=BMCAR(F)
..Q:(BMCVFLE="90001.03")&(F=".05")
..D BUILD1
.S G=0 F S G=$O(BMCAR(F,G)) Q:G'=+G I $G(BMCAR(F,G))]"" D
..S BMCSTR=BMCAR(F,G)
..D SET
K G
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
BUILD1 ;
S BMCSTR=$E(BMCH,1,25)_":",BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,C,$L(BMCV))
D SET
Q
SET ;set array
S BMCCTR=BMCCTR+1
S ^TMP("BMCALT",$J,BMCCTR,0)=BMCSTR
S BMCSTR=""
Q
EXIT ; -- exit code
K BMCCTR,BMCSTR,BMCV,C,BMCV,BMCH,BMCAR,F,G,BMCVFLE,BMCVDFN,BMCVNM,BMCVIGR,BMCCTYP,BMCVI
K BMCRREC,BMCRIEN,^TMP("BMCALT",$J),BMCRNUMB,BMCVI,BMCVDG,BMCVL
Q
;
BROWSE ;
S XBRP="DISP^BMCAL1"
S XBRC="",XBRX="EXIT^BMCAL1",XBIOP=0 D ^XBDBQUE
Q
DISP ;EP
D EN^VALM("BMC ALERT REC DISPLAY")
D CLEAR^VALM1
Q
;
BMCAL1 ; IHS/OIT/FCJ-RCIS LIST FOR ALERT; 20-SEP-2007
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**3**;JAN 09, 2006;Build 101
+2 ; New routine for patch 3 to send a Physician Alert
+3 ;
EN ; -- main entry point for BMC ALERT REC DISPLAY
+1 DO BROWSE
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET BMCRREC=^BMCREF(BMCRIEN,0)
+2 SET VALMHDR(1)="Patient Name: "_$EXTRACT($PIECE(^DPT($PIECE(BMCRREC,U,3),0),U),1,25)
+3 SET VALMHDR(1)=VALMHDR(1)_" Chart #: "_$SELECT($DATA(^AUPNPAT($PIECE(BMCRREC,U,3),41,DUZ(2),0)):$PIECE(^(0),U,2),1:"None")
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 SET BMCSTR=""
SET BMCCTR=0
+2 SET BMCSTR="Referral #: "_$$VAL^XBDIQ1(90001,BMCRIEN,.02)
+3 SET BMCSTR=BMCSTR_" Date Referral Initiated: "_$$VAL^XBDIQ1(90001,BMCRIEN,.01)
DO SET
+4 SET BMCH="Requesting Provider"
SET BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,.06)
SET C=23
DO BUILD1
+5 SET BMCH="Purpose of Referral"
SET BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1201)
SET C=23
DO BUILD1
DO SET
+6 SET BMCH="Referred To"
SET BMCV=$$TOFAC^BMC(BMCRIEN)
SET C=15
DO BUILD1
+7 SET BMCH="Notes to Scheduler"
SET BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,1301)
SET C=22
DO BUILD1
DO SET
+8 SET BMCSTR="Priority: "_$$VAL^XBDIQ1(90001,BMCRIEN,.32)
+9 SET BMCSTR=BMCSTR_" Date of Service: "_$$AVDOS^BMCRLU(BMCRIEN,"C")
DO SET
+10 SET BMCH="Referral Type"
SET BMCV=$$VAL^XBDIQ1(90001,BMCRIEN,.04)
SET C=17
DO BUILD1
DO SET
+11 DO BOCOM
+12 SET VALMCNT=$ORDER(^TMP("BMCALT",$JOB,""),-1)
+13 QUIT
BOCOM ; PRINT BO COMMENTS
+1 SET BMCVFLE="90001.03"
SET BMCVDG=^DIC(BMCVFLE,0,"GL")
+2 SET BMCVNM="Business/CHS Comment"
SET BMCVIGR=BMCVDG_"""AD"",BMCRIEN,BMCVDFN)"
SET BMCCTYP="B"
+3 SET BMCVDFN=""
SET BMCVI=1
FOR
SET BMCVDFN=$ORDER(@BMCVIGR)
IF BMCVDFN=""
QUIT
Begin DoDot:1
+4 IF $PIECE(^BMCCOM(BMCVDFN,0),U,5)=BMCCTYP
DO BOCOM1
SET BMCVI=2
End DoDot:1
+5 IF '$TEST
FOR BMCVI=1:1
SET BMCVDFN=$ORDER(@BMCVIGR)
IF BMCVDFN=""
QUIT
DO BOCOM1
+6 SET VALMCNT=$ORDER(^TMP("BMCALT",$JOB,""),-1)
+7 QUIT
BOCOM1 ;
+1 IF BMCVI<2
SET BMCSTR=""
DO SET
SET BMCSTR="=============== "_BMCVNM_"s ==============="
SET X=(80-$LENGTH(BMCSTR)\2)
DO SET
+2 KILL BMCAR
DO ENP^XBDIQ1(BMCVFLE,BMCVDFN,".01:.019999;.04:999999","BMCAR(","E")
+3 SET BMCSTR=""
DO SET
+4 SET F=0
FOR
SET F=$ORDER(BMCAR(F))
IF F'=+F
QUIT
Begin DoDot:1
+5 IF $GET(BMCAR(F))]""
Begin DoDot:2
+6 SET BMCH=$PIECE(^DD(BMCVFLE,F,0),U)
+7 SET BMCV=BMCAR(F)
+8 IF (BMCVFLE="90001.03")&(F=".05")
QUIT
+9 DO BUILD1
End DoDot:2
+10 SET G=0
FOR
SET G=$ORDER(BMCAR(F,G))
IF G'=+G
QUIT
IF $GET(BMCAR(F,G))]""
Begin DoDot:2
+11 SET BMCSTR=BMCAR(F,G)
+12 DO SET
End DoDot:2
End DoDot:1
+13 KILL G
+14 QUIT
+15 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
BUILD1 ;
+1 SET BMCSTR=$EXTRACT(BMCH,1,25)_":"
SET BMCSTR=$$SETSTR^VALM1(BMCV,BMCSTR,C,$LENGTH(BMCV))
+2 DO SET
+3 QUIT
SET ;set array
+1 SET BMCCTR=BMCCTR+1
+2 SET ^TMP("BMCALT",$JOB,BMCCTR,0)=BMCSTR
+3 SET BMCSTR=""
+4 QUIT
EXIT ; -- exit code
+1 KILL BMCCTR,BMCSTR,BMCV,C,BMCV,BMCH,BMCAR,F,G,BMCVFLE,BMCVDFN,BMCVNM,BMCVIGR,BMCCTYP,BMCVI
+2 KILL BMCRREC,BMCRIEN,^TMP("BMCALT",$JOB),BMCRNUMB,BMCVI,BMCVDG,BMCVL
+3 QUIT
+4 ;
BROWSE ;
+1 SET XBRP="DISP^BMCAL1"
+2 SET XBRC=""
SET XBRX="EXIT^BMCAL1"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
DISP ;EP
+1 DO EN^VALM("BMC ALERT REC DISPLAY")
+2 DO CLEAR^VALM1
+3 QUIT
+4 ;
