BMCADDS ;IHS/ITSC/FCJ - ADD SECONDARY REFERRAL; [ 09/27/2006 1:31 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,2,3,8,12**;JAN 09, 2006;Build 101
;
; 4.0 ADD THE BMCMODE VAR AND CALLIN OPTION
; 4.0*1 IHS/OIT/FCJ SP BAR VAR
; 4.0*2 IHS/OIT/FCJ ADDED EP FOR API ROUTINE
; 4.0*2 8/15/06 IHS/OIT/FCJ ADDED AUTO POP POV
; 4.0*3 8.13.07 IHS.OIT.FCJ ADD BO/CHS COMMENTS
; 4.0*12 9.12.17 IHS.OIT.FCJ ADDED CALL IN NOTIFICATION
;
; See ^BMCVDOC for system wide variables set by main menu
; Subscripted BMCREC is EXTERNAL form.
; BMCREC("PAT NAME")=patient name
; BMCREC("REF DATE")=referral date
; BMCDFN=patient ien
; BMCRDATE=referral date in internal FileMan form
; BMCRNUMB=referral number
; BMCRIEN=referral ien
; BMCSRIEN=Secondary referral ien
; BMCMODE=A for add, M for modify
; BMCRSTAT=referral status (.15 field)
; BMCRTYPE=type of referral (.04 field)
; BMCRIO=Inpatient or Outpatient (.14 field)
; BMCVCT=Vist count
; BMCCURFY=Restrict access to current fiscal year only
;
START ;
D:'$D(BMCPARM) PARMCHK^BMC
F D MAIN Q:BMCQ D HDR^BMC
G EXIT
Q
;
MAIN ;
S BMCQ=0,BMCMODE="A",BMCSTRM="",BMCPROV="" ;BMC*4.0*8 ADDED BMCSTRM
D GETREF ; Select Prim referral
Q:BMCQ
D CALLIN Q:BMCQ
D ADD Q:BMCQ ;ADD NEW SEC REF
I BMCPCC,'$G(BMCOUTR),'BMCCAL S BMCIEN=BMCRIEN,BMCRIEN=BMCSRIEN D DSPV^BMCADDP S BMCRIEN=BMCIEN I BMCQ D DELETE Q ;BMC*4.0*8 TEST FOR PCC LINK AND GO TO REQUIRE A VST
D EDIT I BMCQ D DELETE Q
I BMCPCC,'$G(BMCCAL) S BMCIEN=BMCRIEN,BMCRIEN=BMCSRIEN D ADDVREF^BMCADD S BMCRIEN=BMCIEN ;BMC*4.0*8 Add to V Ref file
D MEDHX
D SBCOM ;BMC*4.0*3 8.13.07 IHS.OIT.FCJ ADD BO/CHS COMMENTS
Q
;
GETREF ;Screens out closed Referrals
S BMCQ=1
W !
I $G(BMCRIEN) S DA=BMCRIEN
;S DIC="^BMCREF(",DIC("S")="I $$FILTER^BMCFLTR(0,BMCCURFY)",DIC(0)="AEMQ",DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "
S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "
;S DIC("S")="I $$FILTER^BMCFLTR(0,BMCCURFY,0)"
;S DIC("S")="I $$FILTER^BMCFLTR(0,0,0)"
S DIC("S")="I $$FILTER^BMCFLTR(3,0,0)" ;*9 ALLOW CLOSED REF
D DIC^BMCFMC
Q:Y<1
S BMCRIEN=+Y
S BMCREC=^BMCREF(BMCRIEN,0)
S BMCQ=0
Q
CALLIN ;EP;TEST FOR CALL-IN REF
S BMCCAL=0
S DIR(0)="Y",DIR("A")="Is this a Call-in Secondary Referral",DIR("B")="NO"
D ^DIR K DIR
;S:Y=1 BMCCAL=1
I Y=1 S BMCCAL=1 D CALLIN^BMCADD ;BMC*4.0*12
I $D(DUOUT) S BMCQ=1
Q
;
ADD ;EP;FIND SUFFIX
S (Y1,Y2,Y3)=0
I '$D(^BMCREF("S",BMCRNUMB)) S Y1=0
E S Y="" F S Y=$O(^BMCREF("S",BMCRNUMB,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,BMCSUF="A"_Y1
;VISTS REMAINING
S BMCVCT=($P(^BMCREF(BMCRIEN,11),U,11)-Y2)
S:BMCVCT<0 BMCVCT=0
;ADD SECONDARY REF ENTRY
D ^XBFMK K DIADD,DINUM
S X=DT,DIC="^BMCREF(",DIC(0)="L",DLAYGO=90001
;BMC*4.0*8 SPLIT NXT LINE AND ADDED TOC STATUS FIELD 1304
S BMCPROV=$P(BMCREC,U,6)
S DIC("DR")=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.04////"_BMCRTYPE_";.25////"_DUZ_";1304////P"
S DIC("DR")=DIC("DR")_";101////"_BMCSUF_";102////"_BMCRIEN_";1111////"_BMCVCT
S DIC("DR")=DIC("DR")_";.11////"_$P(BMCREC,U,11)_";.14////"_$P(BMCREC,U,14)_";.15////A"_";.26////"_DT_";.32////"_$P(BMCREC,U,32)
I BMCCAL=0 S DIC("DR")=DIC("DR")_";.06////"_$P(BMCREC,U,6)
E S DIC("DR")=DIC("DR")_";103////"_BMCCDT_";104////"_BMCCBY ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY
;BMC 4.0*2 8/15/06 IHS/OIT/FCJ ADDED NXT LINE TO AUTO POP POV 1.26.07 ADD $TR TO STR BECAUSE OF FM
I $P($G(^BMCPARM(DUZ(2),4100)),U,6)="Y" S DIC("DR")=DIC("DR")_";1201////"_$TR($P(^BMCREF(BMCRIEN,12),U),";"," ")
K DD,DO D FILE^DICN S BMCSRIEN=+Y D ^XBFMK K DIADD,DINUM
Q ;BMC*4.0*8 ADDED TO ADD CALL FOR VISIT
EDIT ; EDIT REFERRAL RECORD JUST ADDED
S DDSFILE=90001,DA=BMCSRIEN,DDSPARM="C"
S DR=$S(BMCCAL=1:"[BMC SEC REF ADD CI]",1:"[BMC SEC REF ADD]")
D DDS^BMCFMC
I '$G(DDSCHANG) D DELETE S BMCQ=1 Q
S X=$S(BMCRTYPE="I":$P(^BMCREF(BMCSRIEN,0),U,8),BMCRTYPE="N":$P(^BMCREF(BMCSRIEN,0),U,23),1:$P(^BMCREF(BMCSRIEN,0),U,7))
I 'X W !,"You must enter a Vendor or IHS Facility, depending on the Referral type.",! D PAUSE^BMC G EDIT
Q
;
DELETE ; DELETE REFERRAL JUST ADDED BECAUSE OPERATOR DIDN'T FINISH
W !!,"INCOMPLETE SECONDARY REFERRAL...BEING DELETED!",!!
S DIK="^BMCREF(",DA=BMCSRIEN D ^DIK
D PAUSE^BMC
Q
MEDHX ;EP;DISPLAY MED HX COMMENTS IF ANY AND ADD NEW COMMENTS TO SEC REF
S BMCV="COM",BMCTERM="Medical HX/Findings Comments",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
;BMC*4.0*3 12.14.07 IHS.OIT.FCJ ADDED S BMCRIEN IN NXT LINE
S BMCCTYP="M",BMCRIEN=$P(^BMCREF(BMCSRIEN,1),U,2)
W @IOF,!,$$CTR^BMC("MEDICAL COMMENTS FROM PRIMARY REFERRAL",80)
W !,$$CTR^BMC("REFERRAL: "_BMCRNUMB_" PATIENT: "_BMCREC("PAT NAME"),80),!
F I=1:1:80 W "-"
S BMCNONE=0 D DISPCOM^BMCMOD1
I BMCNONE=1 W !,"THERE ARE NOT ANY MEDICAL COMMENTS FROM PRIMARY REFERRAL TO DISPLAY...",!
W ! F I=1:1:80 W "-"
W !,"Enter Comments for Secondary Referral..."
MEDCOM ;ADD MED HX COMMENTS
W !
S DIR("A")="Do you want to enter Medical History and Findings Comments"
S BMCCTYP="M"
S BMCTMPS=BMCSRIEN,BMCTMP=BMCRIEN,BMCRIEN=BMCSRIEN
D COMMENTS^BMCADD
S BMCRIEN=BMCTMP,BMCSRIEN=BMCTMPS
Q
;
SBCOM ;ADD BO/CHS COMMENTS ;BMC*4.0*3 8.13.07 IHS.OIT.FCJ ADD BO/CHS COMMENTS
S BMCV="COM",BMCTERM="Business Office/CHS Comments",BMCATEMP="[BMC COMMENTS ADD]",BMCG="^BMCCOM(",BMCETEMP="[BMC COMMENTS EDIT]"
S BMCCTYP="S"
S BMCTMPS=BMCSRIEN,BMCTMP=BMCRIEN,BMCRIEN=BMCSRIEN
D ASK^BMCMOD
S BMCRIEN=BMCTMP,BMCSRIEN=BMCTMPS
;
RECORD ;RECORD SECONDARY REFERRAL
W !!,"Secondary Referral has been completed, "_BMCRNUMB_BMCSUF,!
D PAUSE^BMC
S ^DISV(DUZ,"^BMCREF(")=$P(^BMCREF(BMCSRIEN,1),U,2) ;BMC*4.0*1 IHS/OIT/FCJ SP BAR VAR
Q
;
BUSINESS ; EDIT BUSINESS OFFICE COMMENTS
D 80^BMCMOD
Q
EXIT ;EXIT PROGRAM
D ^BMCKILL
K DDSCHANG,DDSPARM,DILN,DISYS,DIWI,DIWTC,DIWX,DIC,DIE,DA,Y,Y1,Y2,W1
K BMCMODE,BMCRSTAT,BMCRIEN,BMCSUF,BMCVCT,BMCTMP,BMCTMPS,BMCCAL
Q
BMCADDS ;IHS/ITSC/FCJ - ADD SECONDARY REFERRAL; [ 09/27/2006 1:31 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,3,8,12**;JAN 09, 2006;Build 101
+2 ;
+3 ; 4.0 ADD THE BMCMODE VAR AND CALLIN OPTION
+4 ; 4.0*1 IHS/OIT/FCJ SP BAR VAR
+5 ; 4.0*2 IHS/OIT/FCJ ADDED EP FOR API ROUTINE
+6 ; 4.0*2 8/15/06 IHS/OIT/FCJ ADDED AUTO POP POV
+7 ; 4.0*3 8.13.07 IHS.OIT.FCJ ADD BO/CHS COMMENTS
+8 ; 4.0*12 9.12.17 IHS.OIT.FCJ ADDED CALL IN NOTIFICATION
+9 ;
+10 ; See ^BMCVDOC for system wide variables set by main menu
+11 ; Subscripted BMCREC is EXTERNAL form.
+12 ; BMCREC("PAT NAME")=patient name
+13 ; BMCREC("REF DATE")=referral date
+14 ; BMCDFN=patient ien
+15 ; BMCRDATE=referral date in internal FileMan form
+16 ; BMCRNUMB=referral number
+17 ; BMCRIEN=referral ien
+18 ; BMCSRIEN=Secondary referral ien
+19 ; BMCMODE=A for add, M for modify
+20 ; BMCRSTAT=referral status (.15 field)
+21 ; BMCRTYPE=type of referral (.04 field)
+22 ; BMCRIO=Inpatient or Outpatient (.14 field)
+23 ; BMCVCT=Vist count
+24 ; BMCCURFY=Restrict access to current fiscal year only
+25 ;
START ;
+1 IF '$DATA(BMCPARM)
DO PARMCHK^BMC
+2 FOR
DO MAIN
IF BMCQ
QUIT
DO HDR^BMC
+3 GOTO EXIT
+4 QUIT
+5 ;
MAIN ;
+1 ;BMC*4.0*8 ADDED BMCSTRM
SET BMCQ=0
SET BMCMODE="A"
SET BMCSTRM=""
SET BMCPROV=""
+2 ; Select Prim referral
DO GETREF
+3 IF BMCQ
QUIT
+4 DO CALLIN
IF BMCQ
QUIT
+5 ;ADD NEW SEC REF
DO ADD
IF BMCQ
QUIT
+6 ;BMC*4.0*8 TEST FOR PCC LINK AND GO TO REQUIRE A VST
IF BMCPCC
IF '$GET(BMCOUTR)
IF 'BMCCAL
SET BMCIEN=BMCRIEN
SET BMCRIEN=BMCSRIEN
DO DSPV^BMCADDP
SET BMCRIEN=BMCIEN
IF BMCQ
DO DELETE
QUIT
+7 DO EDIT
IF BMCQ
DO DELETE
QUIT
+8 ;BMC*4.0*8 Add to V Ref file
IF BMCPCC
IF '$GET(BMCCAL)
SET BMCIEN=BMCRIEN
SET BMCRIEN=BMCSRIEN
DO ADDVREF^BMCADD
SET BMCRIEN=BMCIEN
+9 DO MEDHX
+10 ;BMC*4.0*3 8.13.07 IHS.OIT.FCJ ADD BO/CHS COMMENTS
DO SBCOM
+11 QUIT
+12 ;
GETREF ;Screens out closed Referrals
+1 SET BMCQ=1
+2 WRITE !
+3 IF $GET(BMCRIEN)
SET DA=BMCRIEN
+4 ;S DIC="^BMCREF(",DIC("S")="I $$FILTER^BMCFLTR(0,BMCCURFY)",DIC(0)="AEMQ",DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "
+5 SET DIC="^BMCREF("
SET DIC(0)="AEMQ"
SET DIC("A")="Select REFERRAL by Patient or by Referral Date or #: "
+6 ;S DIC("S")="I $$FILTER^BMCFLTR(0,BMCCURFY,0)"
+7 ;S DIC("S")="I $$FILTER^BMCFLTR(0,0,0)"
+8 ;*9 ALLOW CLOSED REF
SET DIC("S")="I $$FILTER^BMCFLTR(3,0,0)"
+9 DO DIC^BMCFMC
+10 IF Y<1
QUIT
+11 SET BMCRIEN=+Y
+12 SET BMCREC=^BMCREF(BMCRIEN,0)
+13 SET BMCQ=0
+14 QUIT
CALLIN ;EP;TEST FOR CALL-IN REF
+1 SET BMCCAL=0
+2 SET DIR(0)="Y"
SET DIR("A")="Is this a Call-in Secondary Referral"
SET DIR("B")="NO"
+3 DO ^DIR
KILL DIR
+4 ;S:Y=1 BMCCAL=1
+5 ;BMC*4.0*12
IF Y=1
SET BMCCAL=1
DO CALLIN^BMCADD
+6 IF $DATA(DUOUT)
SET BMCQ=1
+7 QUIT
+8 ;
ADD ;EP;FIND SUFFIX
+1 SET (Y1,Y2,Y3)=0
+2 IF '$DATA(^BMCREF("S",BMCRNUMB))
SET Y1=0
+3 IF '$TEST
SET Y=""
FOR
SET Y=$ORDER(^BMCREF("S",BMCRNUMB,Y))
IF Y=""
QUIT
Begin DoDot:1
+4 SET Y3=$EXTRACT(Y,2,$LENGTH(Y))
SET Y2=Y2+1
+5 IF Y3>Y1
SET Y1=Y3
End DoDot:1
+6 SET Y1=Y1+1
SET Y2=Y2+1
SET BMCSUF="A"_Y1
+7 ;VISTS REMAINING
+8 SET BMCVCT=($PIECE(^BMCREF(BMCRIEN,11),U,11)-Y2)
+9 IF BMCVCT<0
SET BMCVCT=0
+10 ;ADD SECONDARY REF ENTRY
+11 DO ^XBFMK
KILL DIADD,DINUM
+12 SET X=DT
SET DIC="^BMCREF("
SET DIC(0)="L"
SET DLAYGO=90001
+13 ;BMC*4.0*8 SPLIT NXT LINE AND ADDED TOC STATUS FIELD 1304
+14 SET BMCPROV=$PIECE(BMCREC,U,6)
+15 SET DIC("DR")=".02////"_BMCRNUMB_";.03////"_BMCDFN_";.04////"_BMCRTYPE_";.25////"_DUZ_";1304////P"
+16 SET DIC("DR")=DIC("DR")_";101////"_BMCSUF_";102////"_BMCRIEN_";1111////"_BMCVCT
+17 SET DIC("DR")=DIC("DR")_";.11////"_$PIECE(BMCREC,U,11)_";.14////"_$PIECE(BMCREC,U,14)_";.15////A"_";.26////"_DT_";.32////"_$PIECE(BMCREC,U,32)
+18 IF BMCCAL=0
SET DIC("DR")=DIC("DR")_";.06////"_$PIECE(BMCREC,U,6)
+19 ;BMC*4.0*12 OIT/IHS/FCJ CALL DATE AND BY
IF '$TEST
SET DIC("DR")=DIC("DR")_";103////"_BMCCDT_";104////"_BMCCBY
+20 ;BMC 4.0*2 8/15/06 IHS/OIT/FCJ ADDED NXT LINE TO AUTO POP POV 1.26.07 ADD $TR TO STR BECAUSE OF FM
+21 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,6)="Y"
SET DIC("DR")=DIC("DR")_";1201////"_$TRANSLATE($PIECE(^BMCREF(BMCRIEN,12),U),";"," ")
+22 KILL DD,DO
DO FILE^DICN
SET BMCSRIEN=+Y
DO ^XBFMK
KILL DIADD,DINUM
+23 ;BMC*4.0*8 ADDED TO ADD CALL FOR VISIT
QUIT
EDIT ; EDIT REFERRAL RECORD JUST ADDED
+1 SET DDSFILE=90001
SET DA=BMCSRIEN
SET DDSPARM="C"
+2 SET DR=$SELECT(BMCCAL=1:"[BMC SEC REF ADD CI]",1:"[BMC SEC REF ADD]")
+3 DO DDS^BMCFMC
+4 IF '$GET(DDSCHANG)
DO DELETE
SET BMCQ=1
QUIT
+5 SET X=$SELECT(BMCRTYPE="I":$PIECE(^BMCREF(BMCSRIEN,0),U,8),BMCRTYPE="N":$PIECE(^BMCREF(BMCSRIEN,0),U,23),1:$PIECE(^BMCREF(BMCSRIEN,0),U,7))
+6 IF 'X
WRITE !,"You must enter a Vendor or IHS Facility, depending on the Referral type.",!
DO PAUSE^BMC
GOTO EDIT
+7 QUIT
+8 ;
DELETE ; DELETE REFERRAL JUST ADDED BECAUSE OPERATOR DIDN'T FINISH
+1 WRITE !!,"INCOMPLETE SECONDARY REFERRAL...BEING DELETED!",!!
+2 SET DIK="^BMCREF("
SET DA=BMCSRIEN
DO ^DIK
+3 DO PAUSE^BMC
+4 QUIT
MEDHX ;EP;DISPLAY MED HX COMMENTS IF ANY AND ADD NEW COMMENTS TO SEC REF
+1 SET BMCV="COM"
SET BMCTERM="Medical HX/Findings Comments"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+2 ;BMC*4.0*3 12.14.07 IHS.OIT.FCJ ADDED S BMCRIEN IN NXT LINE
+3 SET BMCCTYP="M"
SET BMCRIEN=$PIECE(^BMCREF(BMCSRIEN,1),U,2)
+4 WRITE @IOF,!,$$CTR^BMC("MEDICAL COMMENTS FROM PRIMARY REFERRAL",80)
+5 WRITE !,$$CTR^BMC("REFERRAL: "_BMCRNUMB_" PATIENT: "_BMCREC("PAT NAME"),80),!
+6 FOR I=1:1:80
WRITE "-"
+7 SET BMCNONE=0
DO DISPCOM^BMCMOD1
+8 IF BMCNONE=1
WRITE !,"THERE ARE NOT ANY MEDICAL COMMENTS FROM PRIMARY REFERRAL TO DISPLAY...",!
+9 WRITE !
FOR I=1:1:80
WRITE "-"
+10 WRITE !,"Enter Comments for Secondary Referral..."
MEDCOM ;ADD MED HX COMMENTS
+1 WRITE !
+2 SET DIR("A")="Do you want to enter Medical History and Findings Comments"
+3 SET BMCCTYP="M"
+4 SET BMCTMPS=BMCSRIEN
SET BMCTMP=BMCRIEN
SET BMCRIEN=BMCSRIEN
+5 DO COMMENTS^BMCADD
+6 SET BMCRIEN=BMCTMP
SET BMCSRIEN=BMCTMPS
+7 QUIT
+8 ;
SBCOM ;ADD BO/CHS COMMENTS ;BMC*4.0*3 8.13.07 IHS.OIT.FCJ ADD BO/CHS COMMENTS
+1 SET BMCV="COM"
SET BMCTERM="Business Office/CHS Comments"
SET BMCATEMP="[BMC COMMENTS ADD]"
SET BMCG="^BMCCOM("
SET BMCETEMP="[BMC COMMENTS EDIT]"
+2 SET BMCCTYP="S"
+3 SET BMCTMPS=BMCSRIEN
SET BMCTMP=BMCRIEN
SET BMCRIEN=BMCSRIEN
+4 DO ASK^BMCMOD
+5 SET BMCRIEN=BMCTMP
SET BMCSRIEN=BMCTMPS
+6 ;
RECORD ;RECORD SECONDARY REFERRAL
+1 WRITE !!,"Secondary Referral has been completed, "_BMCRNUMB_BMCSUF,!
+2 DO PAUSE^BMC
+3 ;BMC*4.0*1 IHS/OIT/FCJ SP BAR VAR
SET ^DISV(DUZ,"^BMCREF(")=$PIECE(^BMCREF(BMCSRIEN,1),U,2)
+4 QUIT
+5 ;
BUSINESS ; EDIT BUSINESS OFFICE COMMENTS
+1 DO 80^BMCMOD
+2 QUIT
EXIT ;EXIT PROGRAM
+1 DO ^BMCKILL
+2 KILL DDSCHANG,DDSPARM,DILN,DISYS,DIWI,DIWTC,DIWX,DIC,DIE,DA,Y,Y1,Y2,W1
+3 KILL BMCMODE,BMCRSTAT,BMCRIEN,BMCSUF,BMCVCT,BMCTMP,BMCTMPS,BMCCAL
+4 QUIT
