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
Q
;
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
Q
;
DH ;death dx
S BHLFL=9000001,BHLFLD=1114,BHLX=APCDALVR("APCDVSIT"),BHLVAL=BHLDC
X BHLDIE
Q
;
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
Q
;
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
Q
;
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
Q
;
EOJ ;-- kill variables and quit
K BHLDA,BHLDC,BHLDTP,BHLDCL,BHLVIEN,BHLFL,BHLFLD,BHLX,BHLVAL,BHLPVN
K BHLSTG,BHLMOD,BHLCAU,BHLFR,BHLCOI,BHLDCL
Q
;
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 ;
