BHLPV1I ; cmi/flag/maw - BHL Process Inbound PV1 Segment ;
;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002
;
;this routine will file the inbound PV1 segment, it will also
;create a visit from the information contained in the segment
;we will not modify visits via hl7
;
MAIN ;-- this is the main routine driver
D FILE,EOJ
Q
;
FILE ;-- get the data and file it
S BHLDA=0 F S BHLDA=$O(@BHLTMP@(BHLDA)) Q:BHLDA=""!(BHLDA>1) D
. S BHLAPLL=$P($G(@BHLTMP@(BHLDA,3)),CS)
. I BHLAPLL="" S BHLAPLL=$G(@BHLTMP@(BHLDA,39))
. S BHLAPLL=$O(^AUTTLOC("B",BHLAPLL,0))
. S (BHLOI,BHLCLN)=$P($G(@BHLTMP@(BHLDA,3)),CS,2)
. S BHLADMT="DIRECT"
. ;S BHLATD=$P($G(@BHLTMP@(BHLDA,7)),CS) ; if provider code is passed
. S BHLATD=$P($G(@BHLTMP@(BHLDA,7)),CS,2)
. ;I BHLATD'="" S BHLATD=$O(^DIC(6,"GIHS",BHLATD,0)) if prv code is passed
. ;I BHLATD'="" S BHLATD=$$VAL^XBDIQ1(6,BHLATD,.01) ;if name
. S BHLCDT=$G(@BHLTMP@(BHLDA,9))
. S BHLTVIEN=$G(@BHLTMP@(BHLDA,19)) ;visit ien
. I BHLTVIEN'="" D
.. S BHLVERR=$$VSTCHK(BHLTVIEN)
. I $G(BHLVERR) S BHLERCD="NOVMTCH" X BHLERR Q
. S BHLDD=$G(@BHLTMP@(BHLDA,36))
. I BHLDD'="" S BHLDD=$$VAL^XBDIQ1(405.1,BHLDD,.01)
. S BHLADTM=$G(@BHLTMP@(BHLDA,44))
. S %DT="TX",X=BHLADTM D ^%DT S BHLADTM=Y
. S BHLDDTM=$G(@BHLTMP@(BHLDA,45))
. S %DT="TX",X=BHLDDTM D ^%DT S BHLDDTM=Y
. S BHLDADS=$G(@BHLTMP@(BHLDA,10))
. S BHLDADS=$S(BHLDADS'="":$O(^DIC(45.7,"B",BHLDADS,0)),1:"")
. I BHLDADS'="" S BHLDADS=$$VAL^XBDIQ1(45.7,BHLDADS,.01)
. S BHLDDDS=$G(@BHLTMP@(BHLDA,10))
. S BHLDDDS=$S(BHLDDDS'="":$O(^DIC(45.7,"B",BHLDDDS,0)),1:"")
. I BHLDDDS'="" S BHLDDDS=$$VAL^XBDIQ1(45.7,BHLDDDS,.01)
. I $O(BHL("ZV1",0)) D FILE^BHLZV1I
. Q:$D(BHLERR("FATAL"))
. I BHLET="A01" D @BHLET
. I BHLET="A03" D @BHLET Q
. I BHLET="A06" D @BHLET
. I BHLET="A08" D @BHLET
. I BHLET="A11" D @BHLET Q
. I BHLAPLL="" S BHLAPLL=DUZ(2)
. S APCDALVR("APCDDATE")=BHLADTM
. S APCDALVR("APCDPAT")=BHLPAT
. S APCDALVR("APCDLOC")=BHLAPLL
. S APCDALVR("APCDCLN")=BHLCLN
. D UP
. Q:$D(BHLERR("FATAL"))
. I $O(BHL("ZV1",0)) D VF^BHLZV1I
. D PRV
Q
;
A01 ;-- this is an A01 event, we need to update as current patient
S BHLCLN=""
S BHLFL=2,BHLFLD=.1,BHLVAL=BHLDWRD,BHLX=BHLPAT X BHLDIE
S BHLDSC="H" ;service category
Q
;use the following if we want observations
I $G(@BHLTMP@(BHLDA,10))="OBSERVATION" D
. S BHLDSC="O"
. S BHLCLN=$O(^DIC(40.7,"B","OBSERVATION",0))
;admitting diagnosis will be in DG1 segment
Q
;
A03 ;-- add v hosp
Q:$G(@BHLTMP@(BHLDA,10))="OBSERVATION"
Q:'$G(APCDALVR("APCDVSIT"))
S APCDALVR("APCDPAT")=BHLPAT
S APCDALVR("APCDLOOK")=BHLDDTM
S APCDALVR("APCDATMP")="[APCDALVR 9000010.02 (ADD)]"
S APCDALVR("APCDTADS")=BHLDADS
S APCDALVR("APCDTDCS")=BHLDDDS
S APCDALVR("APCDTAT")=BHLADMT
S APCDALVR("APCDTDT")=BHLDD
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVHOSP" X BHLERR Q
S BHLFL=2,BHLFLD=.1,BHLVAL="@",BHLX=BHLPAT X BHLDIE
Q
;
A06 ;-- create a hospitalization visit from A06
S BHLCLN=""
S BHLFL=2,BHLFLD=.1,BHLVAL=BHLDWRD,BHLX=BHLPAT X BHLDIE
S BHLDSC="H" ;service category
I $G(@BHLTMP@(BHLDA,10))="OBSERVATION" D
. S BHLDSC="O"
. S BHLCLN=$O(^DIC(40.7,"B","OBSERVATION",0))
Q
;
A08 ;-- just in case they update the patient
I $G(@BHLTMP@(BHLDA,10))="OBSERVATION" D
. S BHLDSC="O"
. S BHLCLN=$O(^DIC(40.7,"B","OBSERVATION",0))
Q
;
A11 ;-- cancel admit for a patient
S AUPNVSIT=$O(^AUPNVSIT("AXT",BHLACCT,0))
Q:AUPNVSIT=""
S BHLPRIEN=$O(^AUPNVPRV("AD",AUPNVSIT,0))
Q:BHLPRIEN=""
S DIK="^AUPNVPRV(",DA=BHLPRIEN D ^DIK
D DEL^AUPNVSIT
Q
;
UP ;-- this is for an all events except for the A03 event
S APCDALVR("APCDTYPE")=BHLDVT
S APCDALVR("APCDCAT")=BHLDSC
D ^APCDALV
I $D(APCDAFLG("ERR")) S BHLERCD="NOVST" X BHLERR Q
S BHLVSIT=APCDALVR("APCDVSIT")
S BHLFL=9000010,BHLFLD=1211,BHLVAL=BHLACCT,BHLX=BHLVSIT X BHLDIE
Q
;
PRV ;-- let's set up the v provider file
D PP
Q:BHLPRV=""
D CHKV
Q:$G(BHLMTCH)
D UPV
Q
;
PP ;-- get the primary provider
S BHLPRV=BHLATD
K BHLMTCH
Q
;
CHKV ;-- check the v provider file
S BHLVDA=0 F S BHLVDA=$O(^AUPNVPRV("AD",BHLVSIT,BHLVDA)) Q:BHLVDA=""!$D(BHLMTCH) D
. S BHLVPRV=$$VAL^XBDIQ1(6,$P(^AUPNVPRV(BHLVDA,0),U),.01)
. I BHLVPRV=BHLPRV S BHLMTCH=1
Q:$D(BHLMTCH)
Q
;
UPV ;-- create the v provider file entry if none exists
S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
S APCDALVR("APCDTPRO")=BHLATD
S APCDALVR("APCDTPS")="P"
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S BHLERCD="NOVPRV" X BHLERR Q
Q
;
VSTCHK(VIEN) ;-- check the visit information to see if match
I '$D(^AUPNVSIT(VIEN,0)) Q 1
I $P($G(^AUPNVSIT(VIEN,0)),U,5)'=BHLPAT Q 1
I $P($G(^AUPNVSIT(VIEN,0)),U)'=BHLEXVDT Q 1
I $P($G(^AUPNVSIT(VIEN,0)),U,8)'=BHLCLN Q 1
Q 0
;
EOJ ;-- kill variables and quit
K @BHLTMP
K BHLAPL,BHLADMT,BHLATD,BHLCDT,BHLDD,BHLDTL,BHLADTM,BHLDDTM,BHLTPB
K BHLCL,BHLWIA,BHLLVOS,BHLELG,BHLAB,BHLDDS,BHLOL,BHLADS,BHLNOC
K BHLMREL,BHLAOB,BHLAN,BHLAF,BHLTC,BHLSB,BHLNOV,BHLHVN,BHLVNDR
K BHLACT,BHLTM,BHLPYS,BHLPRV,BHLVPRV,BHLVDA,BHLPDA,P,BHLCLN
Q
;
BHLPV1I ; cmi/flag/maw - BHL Process Inbound PV1 Segment ;
+1 ;;3.01;BHL IHS Interfaces with GIS;**1**;JUN 01, 2002
+2 ;
+3 ;this routine will file the inbound PV1 segment, it will also
+4 ;create a visit from the information contained in the segment
+5 ;we will not modify visits via hl7
+6 ;
MAIN ;-- this is the main routine driver
+1 DO FILE
DO EOJ
+2 QUIT
+3 ;
FILE ;-- get the data and file it
+1 SET BHLDA=0
FOR
SET BHLDA=$ORDER(@BHLTMP@(BHLDA))
IF BHLDA=""!(BHLDA>1)
QUIT
Begin DoDot:1
+2 SET BHLAPLL=$PIECE($GET(@BHLTMP@(BHLDA,3)),CS)
+3 IF BHLAPLL=""
SET BHLAPLL=$GET(@BHLTMP@(BHLDA,39))
+4 SET BHLAPLL=$ORDER(^AUTTLOC("B",BHLAPLL,0))
+5 SET (BHLOI,BHLCLN)=$PIECE($GET(@BHLTMP@(BHLDA,3)),CS,2)
+6 SET BHLADMT="DIRECT"
+7 ;S BHLATD=$P($G(@BHLTMP@(BHLDA,7)),CS) ; if provider code is passed
+8 SET BHLATD=$PIECE($GET(@BHLTMP@(BHLDA,7)),CS,2)
+9 ;I BHLATD'="" S BHLATD=$O(^DIC(6,"GIHS",BHLATD,0)) if prv code is passed
+10 ;I BHLATD'="" S BHLATD=$$VAL^XBDIQ1(6,BHLATD,.01) ;if name
+11 SET BHLCDT=$GET(@BHLTMP@(BHLDA,9))
+12 ;visit ien
SET BHLTVIEN=$GET(@BHLTMP@(BHLDA,19))
+13 IF BHLTVIEN'=""
Begin DoDot:2
+14 SET BHLVERR=$$VSTCHK(BHLTVIEN)
End DoDot:2
+15 IF $GET(BHLVERR)
SET BHLERCD="NOVMTCH"
XECUTE BHLERR
QUIT
+16 SET BHLDD=$GET(@BHLTMP@(BHLDA,36))
+17 IF BHLDD'=""
SET BHLDD=$$VAL^XBDIQ1(405.1,BHLDD,.01)
+18 SET BHLADTM=$GET(@BHLTMP@(BHLDA,44))
+19 SET %DT="TX"
SET X=BHLADTM
DO ^%DT
SET BHLADTM=Y
+20 SET BHLDDTM=$GET(@BHLTMP@(BHLDA,45))
+21 SET %DT="TX"
SET X=BHLDDTM
DO ^%DT
SET BHLDDTM=Y
+22 SET BHLDADS=$GET(@BHLTMP@(BHLDA,10))
+23 SET BHLDADS=$SELECT(BHLDADS'="":$ORDER(^DIC(45.7,"B",BHLDADS,0)),1:"")
+24 IF BHLDADS'=""
SET BHLDADS=$$VAL^XBDIQ1(45.7,BHLDADS,.01)
+25 SET BHLDDDS=$GET(@BHLTMP@(BHLDA,10))
+26 SET BHLDDDS=$SELECT(BHLDDDS'="":$ORDER(^DIC(45.7,"B",BHLDDDS,0)),1:"")
+27 IF BHLDDDS'=""
SET BHLDDDS=$$VAL^XBDIQ1(45.7,BHLDDDS,.01)
+28 IF $ORDER(BHL("ZV1",0))
DO FILE^BHLZV1I
+29 IF $DATA(BHLERR("FATAL"))
QUIT
+30 IF BHLET="A01"
DO @BHLET
+31 IF BHLET="A03"
DO @BHLET
QUIT
+32 IF BHLET="A06"
DO @BHLET
+33 IF BHLET="A08"
DO @BHLET
+34 IF BHLET="A11"
DO @BHLET
QUIT
+35 IF BHLAPLL=""
SET BHLAPLL=DUZ(2)
+36 SET APCDALVR("APCDDATE")=BHLADTM
+37 SET APCDALVR("APCDPAT")=BHLPAT
+38 SET APCDALVR("APCDLOC")=BHLAPLL
+39 SET APCDALVR("APCDCLN")=BHLCLN
+40 DO UP
+41 IF $DATA(BHLERR("FATAL"))
QUIT
+42 IF $ORDER(BHL("ZV1",0))
DO VF^BHLZV1I
+43 DO PRV
End DoDot:1
+44 QUIT
+45 ;
A01 ;-- this is an A01 event, we need to update as current patient
+1 SET BHLCLN=""
+2 SET BHLFL=2
SET BHLFLD=.1
SET BHLVAL=BHLDWRD
SET BHLX=BHLPAT
XECUTE BHLDIE
+3 ;service category
SET BHLDSC="H"
+4 QUIT
+5 ;use the following if we want observations
+6 IF $GET(@BHLTMP@(BHLDA,10))="OBSERVATION"
Begin DoDot:1
+7 SET BHLDSC="O"
+8 SET BHLCLN=$ORDER(^DIC(40.7,"B","OBSERVATION",0))
End DoDot:1
+9 ;admitting diagnosis will be in DG1 segment
+10 QUIT
+11 ;
A03 ;-- add v hosp
+1 IF $GET(@BHLTMP@(BHLDA,10))="OBSERVATION"
QUIT
+2 IF '$GET(APCDALVR("APCDVSIT"))
QUIT
+3 SET APCDALVR("APCDPAT")=BHLPAT
+4 SET APCDALVR("APCDLOOK")=BHLDDTM
+5 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.02 (ADD)]"
+6 SET APCDALVR("APCDTADS")=BHLDADS
+7 SET APCDALVR("APCDTDCS")=BHLDDDS
+8 SET APCDALVR("APCDTAT")=BHLADMT
+9 SET APCDALVR("APCDTDT")=BHLDD
+10 DO ^APCDALVR
+11 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVHOSP"
XECUTE BHLERR
QUIT
+12 SET BHLFL=2
SET BHLFLD=.1
SET BHLVAL="@"
SET BHLX=BHLPAT
XECUTE BHLDIE
+13 QUIT
+14 ;
A06 ;-- create a hospitalization visit from A06
+1 SET BHLCLN=""
+2 SET BHLFL=2
SET BHLFLD=.1
SET BHLVAL=BHLDWRD
SET BHLX=BHLPAT
XECUTE BHLDIE
+3 ;service category
SET BHLDSC="H"
+4 IF $GET(@BHLTMP@(BHLDA,10))="OBSERVATION"
Begin DoDot:1
+5 SET BHLDSC="O"
+6 SET BHLCLN=$ORDER(^DIC(40.7,"B","OBSERVATION",0))
End DoDot:1
+7 QUIT
+8 ;
A08 ;-- just in case they update the patient
+1 IF $GET(@BHLTMP@(BHLDA,10))="OBSERVATION"
Begin DoDot:1
+2 SET BHLDSC="O"
+3 SET BHLCLN=$ORDER(^DIC(40.7,"B","OBSERVATION",0))
End DoDot:1
+4 QUIT
+5 ;
A11 ;-- cancel admit for a patient
+1 SET AUPNVSIT=$ORDER(^AUPNVSIT("AXT",BHLACCT,0))
+2 IF AUPNVSIT=""
QUIT
+3 SET BHLPRIEN=$ORDER(^AUPNVPRV("AD",AUPNVSIT,0))
+4 IF BHLPRIEN=""
QUIT
+5 SET DIK="^AUPNVPRV("
SET DA=BHLPRIEN
DO ^DIK
+6 DO DEL^AUPNVSIT
+7 QUIT
+8 ;
UP ;-- this is for an all events except for the A03 event
+1 SET APCDALVR("APCDTYPE")=BHLDVT
+2 SET APCDALVR("APCDCAT")=BHLDSC
+3 DO ^APCDALV
+4 IF $DATA(APCDAFLG("ERR"))
SET BHLERCD="NOVST"
XECUTE BHLERR
QUIT
+5 SET BHLVSIT=APCDALVR("APCDVSIT")
+6 SET BHLFL=9000010
SET BHLFLD=1211
SET BHLVAL=BHLACCT
SET BHLX=BHLVSIT
XECUTE BHLDIE
+7 QUIT
+8 ;
PRV ;-- let's set up the v provider file
+1 DO PP
+2 IF BHLPRV=""
QUIT
+3 DO CHKV
+4 IF $GET(BHLMTCH)
QUIT
+5 DO UPV
+6 QUIT
+7 ;
PP ;-- get the primary provider
+1 SET BHLPRV=BHLATD
+2 KILL BHLMTCH
+3 QUIT
+4 ;
CHKV ;-- check the v provider file
+1 SET BHLVDA=0
FOR
SET BHLVDA=$ORDER(^AUPNVPRV("AD",BHLVSIT,BHLVDA))
IF BHLVDA=""!$DATA(BHLMTCH)
QUIT
Begin DoDot:1
+2 SET BHLVPRV=$$VAL^XBDIQ1(6,$PIECE(^AUPNVPRV(BHLVDA,0),U),.01)
+3 IF BHLVPRV=BHLPRV
SET BHLMTCH=1
End DoDot:1
+4 IF $DATA(BHLMTCH)
QUIT
+5 QUIT
+6 ;
UPV ;-- create the v provider file entry if none exists
+1 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
+2 SET APCDALVR("APCDTPRO")=BHLATD
+3 SET APCDALVR("APCDTPS")="P"
+4 DO ^APCDALVR
+5 IF $DATA(APCDALVR("APCDAFLG"))
SET BHLERCD="NOVPRV"
XECUTE BHLERR
QUIT
+6 QUIT
+7 ;
VSTCHK(VIEN) ;-- check the visit information to see if match
+1 IF '$DATA(^AUPNVSIT(VIEN,0))
QUIT 1
+2 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,5)'=BHLPAT
QUIT 1
+3 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U)'=BHLEXVDT
QUIT 1
+4 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,8)'=BHLCLN
QUIT 1
+5 QUIT 0
+6 ;
EOJ ;-- kill variables and quit
+1 KILL @BHLTMP
+2 KILL BHLAPL,BHLADMT,BHLATD,BHLCDT,BHLDD,BHLDTL,BHLADTM,BHLDDTM,BHLTPB
+3 KILL BHLCL,BHLWIA,BHLLVOS,BHLELG,BHLAB,BHLDDS,BHLOL,BHLADS,BHLNOC
+4 KILL BHLMREL,BHLAOB,BHLAN,BHLAF,BHLTC,BHLSB,BHLNOV,BHLHVN,BHLVNDR
+5 KILL BHLACT,BHLTM,BHLPYS,BHLPRV,BHLVPRV,BHLVDA,BHLPDA,P,BHLCLN
+6 QUIT
+7 ;
