BHLOBXI ; cmi/sitka/maw - BHL File Inbound OBX Segment ;
;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
;
;this routine will file the inbound OBX segment
;
Q
;
MSR ;-- this is the v measurement file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLTP
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. X BHLKSV
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
. S APCDALVR("APCDTTYP")=BHLTP
. S APCDALVR("APCDTVAL")=BHLVL
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVMSR" X BHLERR Q
Q
;
EYE ;-- this is the v eye glass file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. I '$O(^AUPNVEYE("AD",BHLVSIT,0)) D Q:$D(BHLERR("WARNING"))
.. X BHLKSV
.. S APCDALVR("APCDATMP")="[APCDALVR 9000010.04 (ADD)]"
.. D ^APCDALVR
.. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVEYE" X BHLERR Q
. S BHLVIEN=$O(^AUPNVEYE("AD",BHLVSIT,0))
. S BHLFL=9000010.04
. S BHLFLD=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
. I '$D(^DD(9000010.04,BHLFLD,0)) S BHLERCD="NOVFLD" X BHLERR Q
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. I $$VAL^XBDIQ1(9000010.04,BHLVIEN,BHLFLD)'="" Q
. S BHLVAL=BHLVL
. S BHLX=BHLVIEN X BHLDIE
Q
;
LAB ;-- this is the v lab file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLLB
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S BHLUT=$G(@BHLSTMP@(BHLXDA,6))
. S BHLRL=""
. S BHLRH=""
. I $O(^LAB(60,BHLLBI,1,"B",BHLSITEI,0)) D
.. S BHLRL=$P(^LAB(60,BHLLBI,1,BHLSITEI,0),U,2)
.. S BHLRH=$P(^LAB(60,BHLLBI,1,BHLSITEI,0),U,3)
. S BHLABN=$G(@BHLSTMP@(BHLXDA,8))
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]"
. S APCDALVR("APCDTLAB")=BHLLB
. S APCDALVR("APCDTRES")=BHLVL
. S APCDALVR("APCDTABN")=BHLABN
. S APCDALVR("APCDTUNI")=BHLUT
. S APCDALVR("APCDTRFL")=BHLRL
. S APCDALVR("APCDTRFH")=BHLRH
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVLAB" X BHLERR Q
Q
;
SK ;-- this is the v skin test file
K BHLSKC
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA="" D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLSK
. S BHLUP=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
. I '$D(^DD(9000010.12,BHLUP,0)) S BHLERCD="NOVFLD" X BHLERR Q
. S BHLVL=$P($G(@BHLSTMP@(BHLXDA,5)),CS)
. S BHLDA=0 F S BHLDA=$O(^AUPNVSK("AD",BHLVSIT,BHLDA)) Q:BHLDA="" D
.. Q:$P(^AUPNVSK(BHLDA,0),U)=BHLSKI
.. I $$VAL^XBDIQ1(9000010.12,BHLDA,BHLUP)'="" Q
.. S BHLFL=9000010.12,BHLFLD=BHLUP,BHLX=BHLDA,BHLVAL=BHLVL X BHLDIE
Q
;
XAM ;-- this is the v exam file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLXM
. S BHLVL=$P($G(@BHLSTMP@(BHLXDA,5)),CS,2)
. S APCDALVR("APCDTRES")=BHLVL
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVXAM" X BHLERR Q
Q
;
TRT ;-- this is the v treatment file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLTRT
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S APCDALVR("APCDTHM")=BHLVL
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVTRT" X BHLERR Q
Q
;
PED ;-- this is the v patient education file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLED
. S BHLVL=$P($G(@BHLSTMP@(BHLXDA,5)),CS,2)
. S BHLPRV=$P($G(@BHLSTMP@(BHLODA,16)),CS,2)
. S APCDALVR("APCDTPRO")=BHLPRV
. S APCDALVR("APCDTLOU")=BHLVL
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVPED" X BHLERR Q
Q
;
PT ;-- this is the v physical therapy file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLPT
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S APCDALVR("APCDTQTY")=BHLVL
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVPT" X BHLERR Q
Q
;
CPT ;-- this is the v cpt file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLC
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S APCDALVR("APCDTUN")=BHLVL
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVCPT" X BHLERR Q
Q
;
DXP ;-- this is the v diagnostic procedure file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA="" D
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S BHLABN=$G(@BHLSTMP@(BHLXDA,8))
. S BHLUP=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
. I '$D(^DD(9000010.21,BHLUP,0)) S BHLERCD="NOVFLD" X BHLERR Q
. S BHLEDT=$G(@BHLSTMP@(BHLODA,14))
. S BHLDA=0 F S BHLDA=$O(^AUPNVDXP("AD",BHLVSIT,BHLDA)) Q:BHLDA="" D
.. I $$VAL^XBDIQ1(9000010.21,BHLDA,BHLUP)'="" Q
.. I $P(^AUPNVDXP(BHLDA,0),U)=BHLDXPI S BHLFL=9000010.21,BHLFLD=BHLUP,BHLX=BHLDA,BHLVAL=BHLVL X BHLDIE
Q
;
RAD ;-- this is the v radiology file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA=""!($D(BHLERR("WARNING"))) D
. Q:$G(@BHLSTMP@(BHLXDA,4))'=BHLIMP
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S BHLABN=$G(@BHLSTMP@(BHLXDA,8))
. S BHLEDT=$G(@BHLSTMP@(BHLXDA,14))
. S APCDALVR("APCDTIMP")=BHLVL
. S APCDALVR("APCDTABN")=BHLABN
. S APCDALVR("APCDTCDT")=BHLEDT
. D ^APCDALVR
. I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVRAD" X BHLERR Q
Q
;
HF ;-- this is the v health factors file
N BHLR
S BHLR="OBX"
S BHLXDA=0 F S BHLXDA=$O(@BHLSTMP@(BHLXDA)) Q:BHLXDA="" D
. S BHLVL=$G(@BHLSTMP@(BHLXDA,5))
. S BHLUP=$P($G(@BHLSTMP@(BHLXDA,3)),CS)
. I '$D(^DD(9000010.23,BHLUP,0)) S BHLERCD="NOVFLD" X BHLERR Q
. S BHLDA=0 F S BHLDA=$O(^AUPNVHF("AD",BHLVSIT,BHLDA)) Q:BHLDA="" D
.. I $$VAL^XBDIQ1(9000010.23,BHLDA,BHLUP)'="" Q
.. I $P(^AUPNVHF(BHLDA,0),U)=BHLHFI S BHLFL=9000010.23,BHLFLD=BHLUP,BHLX=BHLDA,BHLVAL=BHLVL X BHLDIE
Q
;
BHLOBXI ; cmi/sitka/maw - BHL File Inbound OBX Segment ;
+1 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
+2 ;
+3 ;this routine will file the inbound OBX segment
+4 ;
+5 QUIT
+6 ;
MSR ;-- this is the v measurement file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLTP
QUIT
+5 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+6 XECUTE BHLKSV
+7 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+8 SET APCDALVR("APCDTTYP")=BHLTP
+9 SET APCDALVR("APCDTVAL")=BHLVL
+10 DO ^APCDALVR
+11 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVMSR"
XECUTE BHLERR
QUIT
End DoDot:1
+12 QUIT
+13 ;
EYE ;-- this is the v eye glass file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF '$ORDER(^AUPNVEYE("AD",BHLVSIT,0))
Begin DoDot:2
+5 XECUTE BHLKSV
+6 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.04 (ADD)]"
+7 DO ^APCDALVR
+8 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVEYE"
XECUTE BHLERR
QUIT
End DoDot:2
IF $DATA(BHLERR("WARNING"))
QUIT
+9 SET BHLVIEN=$ORDER(^AUPNVEYE("AD",BHLVSIT,0))
+10 SET BHLFL=9000010.04
+11 SET BHLFLD=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS)
+12 IF '$DATA(^DD(9000010.04,BHLFLD,0))
SET BHLERCD="NOVFLD"
XECUTE BHLERR
QUIT
+13 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+14 IF $$VAL^XBDIQ1(9000010.04,BHLVIEN,BHLFLD)'=""
QUIT
+15 SET BHLVAL=BHLVL
+16 SET BHLX=BHLVIEN
XECUTE BHLDIE
End DoDot:1
+17 QUIT
+18 ;
LAB ;-- this is the v lab file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLLB
QUIT
+5 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+6 SET BHLUT=$GET(@BHLSTMP@(BHLXDA,6))
+7 SET BHLRL=""
+8 SET BHLRH=""
+9 IF $ORDER(^LAB(60,BHLLBI,1,"B",BHLSITEI,0))
Begin DoDot:2
+10 SET BHLRL=$PIECE(^LAB(60,BHLLBI,1,BHLSITEI,0),U,2)
+11 SET BHLRH=$PIECE(^LAB(60,BHLLBI,1,BHLSITEI,0),U,3)
End DoDot:2
+12 SET BHLABN=$GET(@BHLSTMP@(BHLXDA,8))
+13 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]"
+14 SET APCDALVR("APCDTLAB")=BHLLB
+15 SET APCDALVR("APCDTRES")=BHLVL
+16 SET APCDALVR("APCDTABN")=BHLABN
+17 SET APCDALVR("APCDTUNI")=BHLUT
+18 SET APCDALVR("APCDTRFL")=BHLRL
+19 SET APCDALVR("APCDTRFH")=BHLRH
+20 DO ^APCDALVR
+21 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVLAB"
XECUTE BHLERR
QUIT
End DoDot:1
+22 QUIT
+23 ;
SK ;-- this is the v skin test file
+1 KILL BHLSKC
+2 NEW BHLR
+3 SET BHLR="OBX"
+4 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""
QUIT
Begin DoDot:1
+5 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLSK
QUIT
+6 SET BHLUP=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS)
+7 IF '$DATA(^DD(9000010.12,BHLUP,0))
SET BHLERCD="NOVFLD"
XECUTE BHLERR
QUIT
+8 SET BHLVL=$PIECE($GET(@BHLSTMP@(BHLXDA,5)),CS)
+9 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVSK("AD",BHLVSIT,BHLDA))
IF BHLDA=""
QUIT
Begin DoDot:2
+10 IF $PIECE(^AUPNVSK(BHLDA,0),U)=BHLSKI
QUIT
+11 IF $$VAL^XBDIQ1(9000010.12,BHLDA,BHLUP)'=""
QUIT
+12 SET BHLFL=9000010.12
SET BHLFLD=BHLUP
SET BHLX=BHLDA
SET BHLVAL=BHLVL
XECUTE BHLDIE
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
XAM ;-- this is the v exam file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLXM
QUIT
+5 SET BHLVL=$PIECE($GET(@BHLSTMP@(BHLXDA,5)),CS,2)
+6 SET APCDALVR("APCDTRES")=BHLVL
+7 DO ^APCDALVR
+8 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVXAM"
XECUTE BHLERR
QUIT
End DoDot:1
+9 QUIT
+10 ;
TRT ;-- this is the v treatment file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLTRT
QUIT
+5 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+6 SET APCDALVR("APCDTHM")=BHLVL
+7 DO ^APCDALVR
+8 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVTRT"
XECUTE BHLERR
QUIT
End DoDot:1
+9 QUIT
+10 ;
PED ;-- this is the v patient education file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLED
QUIT
+5 SET BHLVL=$PIECE($GET(@BHLSTMP@(BHLXDA,5)),CS,2)
+6 SET BHLPRV=$PIECE($GET(@BHLSTMP@(BHLODA,16)),CS,2)
+7 SET APCDALVR("APCDTPRO")=BHLPRV
+8 SET APCDALVR("APCDTLOU")=BHLVL
+9 DO ^APCDALVR
+10 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVPED"
XECUTE BHLERR
QUIT
End DoDot:1
+11 QUIT
+12 ;
PT ;-- this is the v physical therapy file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLPT
QUIT
+5 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+6 SET APCDALVR("APCDTQTY")=BHLVL
+7 DO ^APCDALVR
+8 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVPT"
XECUTE BHLERR
QUIT
End DoDot:1
+9 QUIT
+10 ;
CPT ;-- this is the v cpt file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLC
QUIT
+5 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+6 SET APCDALVR("APCDTUN")=BHLVL
+7 DO ^APCDALVR
+8 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVCPT"
XECUTE BHLERR
QUIT
End DoDot:1
+9 QUIT
+10 ;
DXP ;-- this is the v diagnostic procedure file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""
QUIT
Begin DoDot:1
+4 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+5 SET BHLABN=$GET(@BHLSTMP@(BHLXDA,8))
+6 SET BHLUP=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS)
+7 IF '$DATA(^DD(9000010.21,BHLUP,0))
SET BHLERCD="NOVFLD"
XECUTE BHLERR
QUIT
+8 SET BHLEDT=$GET(@BHLSTMP@(BHLODA,14))
+9 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVDXP("AD",BHLVSIT,BHLDA))
IF BHLDA=""
QUIT
Begin DoDot:2
+10 IF $$VAL^XBDIQ1(9000010.21,BHLDA,BHLUP)'=""
QUIT
+11 IF $PIECE(^AUPNVDXP(BHLDA,0),U)=BHLDXPI
SET BHLFL=9000010.21
SET BHLFLD=BHLUP
SET BHLX=BHLDA
SET BHLVAL=BHLVL
XECUTE BHLDIE
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
RAD ;-- this is the v radiology file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""!($DATA(BHLERR("WARNING")))
QUIT
Begin DoDot:1
+4 IF $GET(@BHLSTMP@(BHLXDA,4))'=BHLIMP
QUIT
+5 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+6 SET BHLABN=$GET(@BHLSTMP@(BHLXDA,8))
+7 SET BHLEDT=$GET(@BHLSTMP@(BHLXDA,14))
+8 SET APCDALVR("APCDTIMP")=BHLVL
+9 SET APCDALVR("APCDTABN")=BHLABN
+10 SET APCDALVR("APCDTCDT")=BHLEDT
+11 DO ^APCDALVR
+12 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVRAD"
XECUTE BHLERR
QUIT
End DoDot:1
+13 QUIT
+14 ;
HF ;-- this is the v health factors file
+1 NEW BHLR
+2 SET BHLR="OBX"
+3 SET BHLXDA=0
FOR
SET BHLXDA=$ORDER(@BHLSTMP@(BHLXDA))
IF BHLXDA=""
QUIT
Begin DoDot:1
+4 SET BHLVL=$GET(@BHLSTMP@(BHLXDA,5))
+5 SET BHLUP=$PIECE($GET(@BHLSTMP@(BHLXDA,3)),CS)
+6 IF '$DATA(^DD(9000010.23,BHLUP,0))
SET BHLERCD="NOVFLD"
XECUTE BHLERR
QUIT
+7 SET BHLDA=0
FOR
SET BHLDA=$ORDER(^AUPNVHF("AD",BHLVSIT,BHLDA))
IF BHLDA=""
QUIT
Begin DoDot:2
+8 IF $$VAL^XBDIQ1(9000010.23,BHLDA,BHLUP)'=""
QUIT
+9 IF $PIECE(^AUPNVHF(BHLDA,0),U)=BHLHFI
SET BHLFL=9000010.23
SET BHLFLD=BHLUP
SET BHLX=BHLDA
SET BHLVAL=BHLVL
XECUTE BHLDIE
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
