- 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 ;
