BHLOBXI.m

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      ;