BHLOBRI ; cmi/sitka/maw - File Inbound OBR Segment ;
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;
;this routine will file the inbound OBR segment it will then call
;the corresponding entry point to file the OBX segment (result)
;
;
MAIN ;-- this is the main routine driver
S BHLODA=0 F S BHLODA=$O(@BHLTMP@(BHLODA)) Q:BHLODA="" D
. S BHLVFL=$P($G(@BHLTMP@(BHLODA,3)),CS,3)
. Q:BHLVFL=""
. Q:'$L($T(@BHLVFL))
. S BHLPAR=BHLODA
. D @BHLVFL
D EOJ
Q
;
MSR ;-- this is the v measurement file
X BHLKW
K BHLMTCH
S BHLTP=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLTP=""
I '$O(^AUTTMSR("B",BHLTP,0)) S BHLERCD="NOMSR" X BHLERR Q
S BHLTPI=$O(^AUTTMSR("B",BHLTP,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVMSR("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVMSR(BHLDA,0),U)=BHLTPI S BHLMTCH=1
Q:$D(BHLMTCH)
D @BHLVFL^BHLOBXI
Q
;
EYE ;-- this is the v eye glass file
X BHLKW
D @BHLVFL^BHLOBXI
Q
;
LAB ;-- this is the v lab file
X BHLKW
K BHLMTCH
S BHLLB=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLLB=""
I '$O(^LAB(60,"B",BHLLB,0)) S BHLERCD="NOLAB" X BHLERR Q
S BHLLBI=$O(^LAB(60,"B",BHLLB,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVLAB("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVLAB(BHLDA,0),U)=BHLLBI S BHLMTCH=1
Q:$D(BHLMTCH)
S BHLSITE=$G(@BHLTMP@(BHLODA,15))
I BHLSITE'="" D
. I '$O(^LAB(61,"B",BHLSITE,0)) S BHLERCD="NOLSITE" X BHLERR Q
. S BHLSITEI=$O(^LAB(61,"B",BHLSITE,0))
S BHLOP=$P($G(@BHLTMP@(BHLODA,16)),CS,2)
X BHLKSV
S APCDALVR("APCDTSTE")=BHLSITE
S APCDALVR("APCDTPRV")=BHLOP
D @BHLVFL^BHLOBXI
Q
;
SK ;-- this is the v skin test file
X BHLKW
K BHLMTCH
S BHLSK=$P($G(@BHLTMP@(BHLODA,4)),CS,5)
Q:BHLSK=""
I '$O(^AUTTSK("B",BHLSK,0)) S BHLERCD="NOSK" X BHLERR Q
S BHLSKI=$O(^AUTTSK("B",BHLSK,0))
S BHLOSD=$G(@BHLTMP@(BHLODA,7))
S BHLOED=$G(@BHLTMP@(BHLODA,8))
S BHLDA=0 F S BHLDA=$O(^AUPNVSK("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!$D(BHLERR("WARNING")) D
. I $P(^AUPNVSK(BHLDA,0),U)=BHLSKI S BHLMTCH=1
I '$D(BHLMTCH) D
. X BHLKSV
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.12 (ADD)]"
. S APCDALVR("APCDTSK")=BHLSK
. S APCDALVR("APCDTCDT")=BHLOSD
. S APCDALVR("APCDTDR")=BHLOED
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVSK" X BHLERR Q
D @BHLVFL^BHLOBXI
Q
;
XAM ;-- this is the v exam file
X BHLKW
K BHLMTCH
S BHLXM=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLXM=""
I '$O(^AUTTEXAM("B",BHLXM,0)) S BHLERCD="NOXAM" X BHLERR Q
S BHLXMI=$O(^AUTTEXAM("B",BHLXM,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVXAM("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVXAM(BHLDA,0),U)=BHLXMI S BHLMTCH=1
Q:$D(BHLMTCH)
X BHLKSV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
S APCDALVR("APCDTEX")=BHLXM
D @BHLVFL^BHLOBXI
Q
;
TRT ;-- this is the v treatment file
X BHLKW
K BHLMTCH
S BHLTRT=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLTRT=""
I '$O(^AUTTTRT("B",BHLTRT,0)) S BHLERCD="NOTRT" X BHLERR Q
S BHLTRTI=$O(^AUTTTRT("B",BHLTRT,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVTRT("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVTRT(BHLDA,0),U)=BHLTRTI S BHLMTCH=1
Q:$D(BHLMTCH)
X BHLKSV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.15 (ADD)]"
S APCDALVR("APCDTTRT")="`"_BHLTRTI
D @BHLVFL^BHLOBXI
Q
;
PED ;-- this is the v patient ed file
X BHLKW
K BHLMTCH
S BHLED=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
S BHLEDC=$P($G(@BHLTMP@(BHLODA,4)),CS,5)
Q:BHLED=""
I '$O(^AUTTEDT("B",BHLED,0)) S BHLERCD="NOPED" X BHLERR Q
S BHLEDI=$O(^AUTTEDT("B",BHLED,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVPED("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVPED(BHLDA,0),U)=BHLEDI S BHLMTCH=1
Q:$D(BHLMTCH)
X BHLKSV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
S APCDALVR("APCDTTOP")=BHLED
D @BHLVFL^BHLOBXI
Q
;
PT ;-- this is the v physical therapy file
X BHLKW
K BHLMTCH
S BHLPT=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLPT=""
I '$O(^AUTTPHTH("B",BHLPT,0)) S BHLERCD="NOPT" X BHLERR Q
S BHLPTI=$O(^AUTTPHTH("B",BHLPT,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVPT("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVPT(BHLDA,0),U)=BHLPTI S BHLMTCH=1
Q:$D(BHLMTCH)
X BHLKSV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.17 (ADD)]"
S APCDALVR("APCDTCOD")=BHLPT
D @BHLVFL^BHLOBXI
Q
;
CPT ;-- this is the v cpt file
X BHLKW
K BHLMTCH
S BHLC=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLC=""
I '$O(^ICPT("B",BHLC,0)) S BHLERCD="NOCPT" X BHLERR Q
S BHLCI=$O(^ICPT("B",BHLC,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVCPT("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVCPT(BHLDA,0),U)=BHLCI S BHLMTCH=1
Q:$D(BHLMTCH)
X BHLKSV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
S APCDALVR("APCDTCPT")=BHLC
D @BHLVFL^BHLOBXI
Q
;
DXP ;-- this is the v diagnostic procedure file
X BHLKW
K BHLMTCH
S BHLDXP=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLDXP=""
I '$O(^AUTTDXPR("B",BHLDXP,0)) S BHLERCD="NODXP" X BHLERR Q
S BHLDXPI=$O(^AUTTDXPR("B",BHLDXP,0))
S BHLPRV=$P($G(@BHLTMP@(BHLODA,16)),CS,2)
S BHLDA=0 F S BHLDA=$O(^AUPNVDXP("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!$D(BHLERR("WARNING")) D
. I $P(^AUPNVDXP(BHLDA,0),U)=BHLDXPI S BHLMTCH=1
I '$D(BHLMTCH) D
. X BHLKSV
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.21 (ADD)]"
. S APCDALVR("APCDTDXR")=BHLDXP
. S APCDALVR("APCDTPRV")=BHLPRV
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVDXP" X BHLERR Q
D @BHLVFL^BHLOBXI
Q
;
RAD ;-- this is the v radiology file
X BHLKW
K BHLMTCH
S BHLIMP=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLIMP=""
I '$O(^RAMIS(71,"B",BHLIMP,0)) S BHLERCD="NORAD" X BHLERR Q
S BHLIMPI=$O(^RAMIS(71,"B",BHLIMP,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVRAD("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!($D(BHLMTCH)) D
. I $P(^AUPNVRAD(BHLDA,0),U)=BHLIMPI S BHLMTCH=1
Q:$D(BHLMTCH)
S BHLPRV=$P($G(@BHLTMP@(BHLODA,16)),CS,2)
X BHLKSV
S APCDALVR("APCDATMP")="[APCDALVR 9000010.22 (ADD)]"
S APCDALVR("APCDTRAD")=BHLIMP
D @BHLVFL^BHLOBXI
Q
;
HF ;-- this is the v health factors file
X BHLKW
K BHLMTCH
S BHLHF=$P($G(@BHLTMP@(BHLODA,4)),CS,4)
Q:BHLHF=""
I '$O(^AUTTHF("B",BHLHF,0)) S BHLERCD="NOHF" X BHLERR Q
S BHLHFI=$O(^AUTTHF("B",BHLHF,0))
S BHLDA=0 F S BHLDA=$O(^AUPNVHF("AD",BHLVSIT,BHLDA)) Q:BHLDA=""!$D(BHLERR("WARNING")) D
. I $P(^AUPNVHF(BHLDA,0),U)=BHLHFI S BHLMTCH=1
I '$D(BHLMTCH) D
. X BHLKSV
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
. S APCDALVR("APCDTHF")=BHLHF
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVHF" X BHLERR Q
D @BHLVFL^BHLOBXI
Q
;
EOJ ;-- kill variables
K @BHLTMP
K BHLDA,BHLVFL,BHLMTCH,BHLTP,BHLTPI,BHLLB,BHLLBI,BHLSITE,BHLOP
K BHLSK,BHLOSD,BHLOED,BHLXM,BHLTRT,BHLED,BHLPT,BHLC,BHLDXP,BHLPRV
K BHLIMP,BHLHF,BHLVL,BHLVIEN,BHLFL,BHLFLD,BHLX,BHLUT,BHLRL,BHLRH
K BHLSITEI,BHLABN,BHLUP,BHLEDT,BHLVAL,BHLTPI,BHLLBI,BHLSKI,BHLXMI
K BHLTRTI,BHLEDI,BHLPTI,BHLCI,BHLDXPI,BHLIMPI,BHLHFI
Q
;
BHLOBRI ; cmi/sitka/maw - File Inbound OBR Segment ;
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;
+3 ;this routine will file the inbound OBR segment it will then call
+4 ;the corresponding entry point to file the OBX segment (result)
+5 ;
+6 ;
MAIN ;-- this is the main routine driver
+1 SET BHLODA=0
FOR
SET BHLODA=$ORDER(@BHLTMP@(BHLODA))
IF BHLODA=""
QUIT
Begin DoDot:1
+2 SET BHLVFL=$PIECE($GET(@BHLTMP@(BHLODA,3)),CS,3)
+3 IF BHLVFL=""
QUIT
+4 IF '$LENGTH($TEXT(@BHLVFL))
QUIT
+5 SET BHLPAR=BHLODA
+6 DO @BHLVFL
End DoDot:1
+7 DO EOJ
+8 QUIT
+9 ;
MSR ;-- this is the v measurement file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLTP=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLTP=""
QUIT
+5 IF '$ORDER(^AUTTMSR("B",BHLTP,0))
SET BHLERCD="NOMSR"
XECUTE BHLERR
QUIT
+6 SET BHLTPI=$ORDER(^AUTTMSR("B",BHLTP,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVMSR("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVMSR(BHLDA,0),U)=BHLTPI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 DO @BHLVFL^BHLOBXI
+11 QUIT
+12 ;
EYE ;-- this is the v eye glass file
+1 XECUTE BHLKW
+2 DO @BHLVFL^BHLOBXI
+3 QUIT
+4 ;
LAB ;-- this is the v lab file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLLB=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLLB=""
QUIT
+5 IF '$ORDER(^LAB(60,"B",BHLLB,0))
SET BHLERCD="NOLAB"
XECUTE BHLERR
QUIT
+6 SET BHLLBI=$ORDER(^LAB(60,"B",BHLLB,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVLAB("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVLAB(BHLDA,0),U)=BHLLBI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 SET BHLSITE=$GET(@BHLTMP@(BHLODA,15))
+11 IF BHLSITE'=""
Begin DoDot:1
+12 IF '$ORDER(^LAB(61,"B",BHLSITE,0))
SET BHLERCD="NOLSITE"
XECUTE BHLERR
QUIT
+13 SET BHLSITEI=$ORDER(^LAB(61,"B",BHLSITE,0))
End DoDot:1
+14 SET BHLOP=$PIECE($GET(@BHLTMP@(BHLODA,16)),CS,2)
+15 XECUTE BHLKSV
+16 SET APCDALVR("APCDTSTE")=BHLSITE
+17 SET APCDALVR("APCDTPRV")=BHLOP
+18 DO @BHLVFL^BHLOBXI
+19 QUIT
+20 ;
SK ;-- this is the v skin test file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLSK=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,5)
+4 IF BHLSK=""
QUIT
+5 IF '$ORDER(^AUTTSK("B",BHLSK,0))
SET BHLERCD="NOSK"
XECUTE BHLERR
QUIT
+6 SET BHLSKI=$ORDER(^AUTTSK("B",BHLSK,0))
+7 SET BHLOSD=$GET(@BHLTMP@(BHLODA,7))
+8 SET BHLOED=$GET(@BHLTMP@(BHLODA,8))
+9 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVSK("AD",BHLVSIT,BHLDA))
IF BHLDA=""!$DATA(BHLERR("WARNING"))
QUIT
Begin DoDot:1
+10 IF $PIECE(^AUPNVSK(BHLDA,0),U)=BHLSKI
SET BHLMTCH=1
End DoDot:1
+11 IF '$DATA(BHLMTCH)
Begin DoDot:1
+12 XECUTE BHLKSV
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.12 (ADD)]"
+14 SET APCDALVR("APCDTSK")=BHLSK
+15 SET APCDALVR("APCDTCDT")=BHLOSD
+16 SET APCDALVR("APCDTDR")=BHLOED
+17 DO ^APCDALVR
+18 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVSK"
XECUTE BHLERR
QUIT
End DoDot:1
+19 DO @BHLVFL^BHLOBXI
+20 QUIT
+21 ;
XAM ;-- this is the v exam file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLXM=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLXM=""
QUIT
+5 IF '$ORDER(^AUTTEXAM("B",BHLXM,0))
SET BHLERCD="NOXAM"
XECUTE BHLERR
QUIT
+6 SET BHLXMI=$ORDER(^AUTTEXAM("B",BHLXM,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVXAM("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVXAM(BHLDA,0),U)=BHLXMI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 XECUTE BHLKSV
+11 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.13 (ADD)]"
+12 SET APCDALVR("APCDTEX")=BHLXM
+13 DO @BHLVFL^BHLOBXI
+14 QUIT
+15 ;
TRT ;-- this is the v treatment file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLTRT=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLTRT=""
QUIT
+5 IF '$ORDER(^AUTTTRT("B",BHLTRT,0))
SET BHLERCD="NOTRT"
XECUTE BHLERR
QUIT
+6 SET BHLTRTI=$ORDER(^AUTTTRT("B",BHLTRT,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVTRT("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVTRT(BHLDA,0),U)=BHLTRTI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 XECUTE BHLKSV
+11 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.15 (ADD)]"
+12 SET APCDALVR("APCDTTRT")="`"_BHLTRTI
+13 DO @BHLVFL^BHLOBXI
+14 QUIT
+15 ;
PED ;-- this is the v patient ed file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLED=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 SET BHLEDC=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,5)
+5 IF BHLED=""
QUIT
+6 IF '$ORDER(^AUTTEDT("B",BHLED,0))
SET BHLERCD="NOPED"
XECUTE BHLERR
QUIT
+7 SET BHLEDI=$ORDER(^AUTTEDT("B",BHLED,0))
+8 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVPED("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNVPED(BHLDA,0),U)=BHLEDI
SET BHLMTCH=1
End DoDot:1
+10 IF $DATA(BHLMTCH)
QUIT
+11 XECUTE BHLKSV
+12 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
+13 SET APCDALVR("APCDTTOP")=BHLED
+14 DO @BHLVFL^BHLOBXI
+15 QUIT
+16 ;
PT ;-- this is the v physical therapy file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLPT=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLPT=""
QUIT
+5 IF '$ORDER(^AUTTPHTH("B",BHLPT,0))
SET BHLERCD="NOPT"
XECUTE BHLERR
QUIT
+6 SET BHLPTI=$ORDER(^AUTTPHTH("B",BHLPT,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVPT("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVPT(BHLDA,0),U)=BHLPTI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 XECUTE BHLKSV
+11 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.17 (ADD)]"
+12 SET APCDALVR("APCDTCOD")=BHLPT
+13 DO @BHLVFL^BHLOBXI
+14 QUIT
+15 ;
CPT ;-- this is the v cpt file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLC=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLC=""
QUIT
+5 IF '$ORDER(^ICPT("B",BHLC,0))
SET BHLERCD="NOCPT"
XECUTE BHLERR
QUIT
+6 SET BHLCI=$ORDER(^ICPT("B",BHLC,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVCPT("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVCPT(BHLDA,0),U)=BHLCI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 XECUTE BHLKSV
+11 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
+12 SET APCDALVR("APCDTCPT")=BHLC
+13 DO @BHLVFL^BHLOBXI
+14 QUIT
+15 ;
DXP ;-- this is the v diagnostic procedure file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLDXP=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLDXP=""
QUIT
+5 IF '$ORDER(^AUTTDXPR("B",BHLDXP,0))
SET BHLERCD="NODXP"
XECUTE BHLERR
QUIT
+6 SET BHLDXPI=$ORDER(^AUTTDXPR("B",BHLDXP,0))
+7 SET BHLPRV=$PIECE($GET(@BHLTMP@(BHLODA,16)),CS,2)
+8 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVDXP("AD",BHLVSIT,BHLDA))
IF BHLDA=""!$DATA(BHLERR("WARNING"))
QUIT
Begin DoDot:1
+9 IF $PIECE(^AUPNVDXP(BHLDA,0),U)=BHLDXPI
SET BHLMTCH=1
End DoDot:1
+10 IF '$DATA(BHLMTCH)
Begin DoDot:1
+11 XECUTE BHLKSV
+12 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.21 (ADD)]"
+13 SET APCDALVR("APCDTDXR")=BHLDXP
+14 SET APCDALVR("APCDTPRV")=BHLPRV
+15 DO ^APCDALVR
+16 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVDXP"
XECUTE BHLERR
QUIT
End DoDot:1
+17 DO @BHLVFL^BHLOBXI
+18 QUIT
+19 ;
RAD ;-- this is the v radiology file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLIMP=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLIMP=""
QUIT
+5 IF '$ORDER(^RAMIS(71,"B",BHLIMP,0))
SET BHLERCD="NORAD"
XECUTE BHLERR
QUIT
+6 SET BHLIMPI=$ORDER(^RAMIS(71,"B",BHLIMP,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVRAD("AD",BHLVSIT,BHLDA))
IF BHLDA=""!($DATA(BHLMTCH))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVRAD(BHLDA,0),U)=BHLIMPI
SET BHLMTCH=1
End DoDot:1
+9 IF $DATA(BHLMTCH)
QUIT
+10 SET BHLPRV=$PIECE($GET(@BHLTMP@(BHLODA,16)),CS,2)
+11 XECUTE BHLKSV
+12 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.22 (ADD)]"
+13 SET APCDALVR("APCDTRAD")=BHLIMP
+14 DO @BHLVFL^BHLOBXI
+15 QUIT
+16 ;
HF ;-- this is the v health factors file
+1 XECUTE BHLKW
+2 KILL BHLMTCH
+3 SET BHLHF=$PIECE($GET(@BHLTMP@(BHLODA,4)),CS,4)
+4 IF BHLHF=""
QUIT
+5 IF '$ORDER(^AUTTHF("B",BHLHF,0))
SET BHLERCD="NOHF"
XECUTE BHLERR
QUIT
+6 SET BHLHFI=$ORDER(^AUTTHF("B",BHLHF,0))
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVHF("AD",BHLVSIT,BHLDA))
IF BHLDA=""!$DATA(BHLERR("WARNING"))
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNVHF(BHLDA,0),U)=BHLHFI
SET BHLMTCH=1
End DoDot:1
+9 IF '$DATA(BHLMTCH)
Begin DoDot:1
+10 XECUTE BHLKSV
+11 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.23 (ADD)]"
+12 SET APCDALVR("APCDTHF")=BHLHF
+13 DO ^APCDALVR
+14 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVHF"
XECUTE BHLERR
QUIT
End DoDot:1
+15 DO @BHLVFL^BHLOBXI
+16 QUIT
+17 ;
EOJ ;-- kill variables
+1 KILL @BHLTMP
+2 KILL BHLDA,BHLVFL,BHLMTCH,BHLTP,BHLTPI,BHLLB,BHLLBI,BHLSITE,BHLOP
+3 KILL BHLSK,BHLOSD,BHLOED,BHLXM,BHLTRT,BHLED,BHLPT,BHLC,BHLDXP,BHLPRV
+4 KILL BHLIMP,BHLHF,BHLVL,BHLVIEN,BHLFL,BHLFLD,BHLX,BHLUT,BHLRL,BHLRH
+5 KILL BHLSITEI,BHLABN,BHLUP,BHLEDT,BHLVAL,BHLTPI,BHLLBI,BHLSKI,BHLXMI
+6 KILL BHLTRTI,BHLEDI,BHLPTI,BHLCI,BHLDXPI,BHLIMPI,BHLHFI
+7 QUIT
+8 ;
