Routine: BHLDG1I

BHLDG1I ; cmi/sitka/maw - BHL File Inbound DG1 segment ;

 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 ;this routine will file the inbound DG1 segment

MAIN ;-- this is the main routine driver

 Q:'$G(BHLVSIT)

 D FILE,EOJ

FILE ;-- get the data and file it

 F M="DH","AD","NB","PV" S BHLDGC(M)=1

 S BHLDA=0 F  S BHLDA=$O(@BHLTMP@(BHLDA)) Q:BHLDA=""  D

 . S BHLDC=$P($G(@BHLTMP@(BHLDA,3)),CS)

 . Q:BHLDC=""

 . S BHLDCI=$O(^ICD9("BA",BHLDC,0))

 . S BHLDTP=$G(@BHLTMP@(BHLDA,6))

 . S BHLDCL=$G(@BHLTMP@(BHLDA,19))

 . I $O(BHL("ZDX",0)) D FILE^BHLZDXI

 . I '$D(BHLDGC(BHLDTP)) S BHLERCD="NODGTP" X BHLERR Q

 . I BHLDTP="PV" D PV Q

 . D @BHLDTP,PV

DH ;death dx

 S BHLFL=9000001,BHLFLD=1114,BHLX=APCDALVR("APCDVSIT"),BHLVAL=BHLDC

 X BHLDIE

AD ;-- admitting dx

 S BHLVIEN=$O(^AUPNVINP("AD",APCDALVR("APCDVSIT"),0))

 I BHLVIEN="" S BHLERCD="NOVHOSP" X BHLERR Q

 S BHLFL=9000010.02,BHLFLD=.12,BHLX=BHLVIEN,BHLVAL=BHLDC X BHLDIE

NB ;-- newborn diagnosis

 S BHLVIEN=$O(^AUPNVCHS("AD",APCDALVR("APCDVSIT"),0))

 I BHLVIEN="" S BHLERCD="NOVCHS" X BHLERR Q

 S BHLFL=9000010.03,BHLFLD=.09,BHLX=BHLVIEN,BHLVAL=BHLDC X BHLDIE

PV ;-- purpose of visit

 K BHLPOVE

 S BHLPDA=0 F  S BHLPDA=$O(^AUPNVPOV("AD",BHLVSIT,BHLPDA)) Q:BHLPDA=""!($D(BHLPOVE))  D

 . I $P(^AUPNVPOV(BHLPDA,0),U)=BHLDCI S BHLPOVE=1 Q

 Q:$D(BHLPOVE)

 X BHLKSV

 S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"

 S APCDALVR("APCDTPOV")=BHLDC

 S APCDALVR("APCDTNQ")=$G(BHLPVN)

 S APCDALVR("APCDTSTG")=$G(BHLSTG)

 S APCDALVR("APCDTMOD")=$G(BHLMOD)

 S APCDALVR("APCDTCD")=$G(BHLCAU)

 S APCDALVR("APCDTFR")=$G(BHLFR)

 S APCDALVR("APCDTCI")=$G(BHLCOI)

 S APCDALVR("APCDTPS")=$G(BHLDCL)

 D ^APCDALVR

 I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVPOV" X BHLERR

EOJ ;-- kill variables and quit

 K BHLDA,BHLDC,BHLDTP,BHLDCL,BHLVIEN,BHLFL,BHLFLD,BHLX,BHLVAL,BHLPVN

 K BHLSTG,BHLMOD,BHLCAU,BHLFR,BHLCOI,BHLDCL

BHLDG1I   ; cmi/sitka/maw - BHL File Inbound DG1 segment ;

 +1       ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 +2       ;

 +3       ;this routine will file the inbound DG1 segment

 +4       ;

MAIN      ;-- this is the main routine driver

 +1        IF '$GET(BHLVSIT)

               QUIT

 +2        DO FILE

           DO EOJ

 +3        QUIT

 +4       ;

FILE      ;-- get the data and file it

 +1        FOR M="DH","AD","NB","PV"

               SET BHLDGC(M)=1

 +2        SET BHLDA=0

FOR

               SET BHLDA=$ORDER(@BHLTMP@(BHLDA))

               IF BHLDA=""

                   QUIT

               Begin DoDot:1

 +3                SET BHLDC=$PIECE($GET(@BHLTMP@(BHLDA,3)),CS)

 +4                IF BHLDC=""

                       QUIT

 +5                SET BHLDCI=$ORDER(^ICD9("BA",BHLDC,0))

 +6                SET BHLDTP=$GET(@BHLTMP@(BHLDA,6))

 +7                SET BHLDCL=$GET(@BHLTMP@(BHLDA,19))

 +8                IF $ORDER(BHL("ZDX",0))

                       DO FILE^BHLZDXI

 +9                IF '$DATA(BHLDGC(BHLDTP))

                       SET BHLERCD="NODGTP"

                       XECUTE BHLERR

                       QUIT

 +10               IF BHLDTP="PV"

                       DO PV

                       QUIT

 +11               DO @BHLDTP

                   DO PV

               End DoDot:1

 +12       QUIT

 +13      ;

DH        ;death dx

 +1        SET BHLFL=9000001

           SET BHLFLD=1114

           SET BHLX=APCDALVR("APCDVSIT")

           SET BHLVAL=BHLDC

 +2        XECUTE BHLDIE

 +3        QUIT

 +4       ;

AD        ;-- admitting dx

 +1        SET BHLVIEN=$ORDER(^AUPNVINP("AD",APCDALVR("APCDVSIT"),0))

 +2        IF BHLVIEN=""

               SET BHLERCD="NOVHOSP"

               XECUTE BHLERR

               QUIT

 +3        SET BHLFL=9000010.02

           SET BHLFLD=.12

           SET BHLX=BHLVIEN

           SET BHLVAL=BHLDC

           XECUTE BHLDIE

 +4        QUIT

 +5       ;

NB        ;-- newborn diagnosis

 +1        SET BHLVIEN=$ORDER(^AUPNVCHS("AD",APCDALVR("APCDVSIT"),0))

 +2        IF BHLVIEN=""

               SET BHLERCD="NOVCHS"

               XECUTE BHLERR

               QUIT

 +3        SET BHLFL=9000010.03

           SET BHLFLD=.09

           SET BHLX=BHLVIEN

           SET BHLVAL=BHLDC

           XECUTE BHLDIE

 +4        QUIT

 +5       ;

PV        ;-- purpose of visit

 +1        KILL BHLPOVE

 +2        SET BHLPDA=0

FOR

               SET BHLPDA=$ORDER(^AUPNVPOV("AD",BHLVSIT,BHLPDA))

               IF BHLPDA=""!($DATA(BHLPOVE))

                   QUIT

               Begin DoDot:1

 +3                IF $PIECE(^AUPNVPOV(BHLPDA,0),U)=BHLDCI

                       SET BHLPOVE=1

                       QUIT

               End DoDot:1

 +4        IF $DATA(BHLPOVE)

               QUIT

 +5        XECUTE BHLKSV

 +6        SET APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"

 +7        SET APCDALVR("APCDTPOV")=BHLDC

 +8        SET APCDALVR("APCDTNQ")=$GET(BHLPVN)

 +9        SET APCDALVR("APCDTSTG")=$GET(BHLSTG)

 +10       SET APCDALVR("APCDTMOD")=$GET(BHLMOD)

 +11       SET APCDALVR("APCDTCD")=$GET(BHLCAU)

 +12       SET APCDALVR("APCDTFR")=$GET(BHLFR)

 +13       SET APCDALVR("APCDTCI")=$GET(BHLCOI)

 +14       SET APCDALVR("APCDTPS")=$GET(BHLDCL)

 +15       DO ^APCDALVR

 +16       IF $DATA(APCDALVR("APCDAFLG"))

               SET BHLERCD="NOVPOV"

               XECUTE BHLERR

 +17       QUIT

 +18      ;

EOJ       ;-- kill variables and quit

 +1        KILL BHLDA,BHLDC,BHLDTP,BHLDCL,BHLVIEN,BHLFL,BHLFLD,BHLX,BHLVAL,BHLPVN

 +2        KILL BHLSTG,BHLMOD,BHLCAU,BHLFR,BHLCOI,BHLDCL

 +3        QUIT

 +4       ;

BHLDG1I.m