BCHHL7F ; IHS/TUCSON/LAB - ADD NEW CHR ACTIVITY RECORDS ; [ 04/28/06 3:21 PM ]
;;1.0;IHS RPMS CHR SYSTEM;**16**;OCT 28, 1996
;
; Driver for filing HL7 messages.
; Array of data is passed from GIS
;
;
MAIN ;EP - called from GIS interface
S BHLNOST=1 D ^BHLSETI
D ^BHLFO
S U="^"
I '$D(BHL) Q ;no BHL array so don't bother
D EN^XBVK("BCH")
K BCHDAR ;array of data values for filing
D CHECK ;check for required pieces of data/valid data, if req element missing file error
I BCHERR D ERRLOG,XIT Q
D GETPAT
I BCHERR D ERRLOG,XIT Q
D FILEREC
I $G(BCHERR) D ERRLOG
D XIT
Q
GETPAT ;
S BCHPAT=""
S BCHNAME=$P($G(BHL("PID",1,5)),U,1)_","_$P($G(BHL("PID",1,5)),U,2)
S BCHCHRN=$P($G(BHL("PID",1,3)),"^",1)
S BCHFACH=$E(BCHCHRN,1,6)
S BCHFHRN=$O(^AUTTLOC("C",BCHFACH,0))
S BCHHRN=+$E(BCHCHRN,7,99)
I 'BCHFHRN Q
S BCHSEX=$G(BHL("PID",1,8))
S BCHDOB=""
S X=$G(BHL("PID",1,7))
I X]"" S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4),%DT="P" D ^%DT S BCHDOB=Y I Y=-1 S BCHDOB=""
S X=0 F S X=$O(^AUPNPAT("D",BCHHRN,X)) Q:X'=+X I $D(^AUPNPAT("D",BCHHRN,X,BCHFHRN)) S BCHPAT=X
I 'BCHPAT Q
;now check DOB and sex, if they don't match don't point to patient
I $P(^DPT(BCHPAT,0),"^",2)'=BCHSEX S BCHPAT="" Q
I $P(^DPT(BCHPAT,0),"^",3)'=BCHDOB S BCHPAT="" Q
Q
FILEREC ;
S X=$O(^BCHR("CUI",BCHUID,0)) I X S BCHACT="M" ;says add but have that record
I BCHACT="M" D MODIFY Q
D ADD
Q
ADD ;
;create and file BCHR record entry
D ^XBFMK
S DIC="^BCHR(",DIC(0)="L",X=BCHDOS,%DT="T" D ^%DT S X=Y,DLAYGO=90002,DIC("DR")=".16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////R" K DD,DO D FILE^DICN
I Y=-1 S BCHERR=1,BCHERR("ERROR")="CREATING CHR RECORD ENTRY FAILED" Q
S BCHR=+Y
D EDITREC
I BCHERR Q
D POVS
D FILEMEAS
D FILEDMO
D PCCLINK
Q
EDITREC ;
K BCHFDA
S BCHFDA(90002,BCHR_",",.02)=BCHPROG
S BCHFDA(90002,BCHR_",",.03)=BCHCHR
I $G(BCHPAT) S BCHFDA(90002,BCHR_",",.04)=BCHPAT
I $G(BCHFACL) S BCHFDA(90002,BCHR_",",.05)=BCHFACL
S BCHFDA(90002,BCHR_",",.06)=BCHACTLI
S BCHFDA(90002,BCHR_",",.07)=BCHREFT
S BCHFDA(90002,BCHR_",",.08)=BCHREFF
S BCHFDA(90002,BCHR_",",.09)=BCHEVAL
S BCHFDA(90002,BCHR_",",.11)=BCHTRAV
S BCHFDA(90002,BCHR_",",.12)=BCHNS
S BCHFDA(90002,BCHR_",",.21)=BCHUID
S BCHFDA(90002,BCHR_",",1108)=BCHTEMPR
S BCHERR=""
D FILE^DIE("KS","BCHFDA","BCHERR")
I BCHERR S BCHERR("ERROR")="UPDATING CHR RECORD ENTRY FAILED FILEMAN"
K BCHFDA
Q
POVS ;
D ^XBFMK
Q:'$D(BCHPOVS)
S APCDOVRR=1
S BCHN=0 F S BCHN=$O(BCHPOVS(BCHN)) Q:'BCHN D
.S X=$P(BCHPOVS(BCHN),U),X=$$UP^XLFSTR(X) I X="" S BHLERR=1,BHLERR("ERROR")="POV PROBLEM CODE FAILED" Q
.S DIC="^BCHRPROB(",DIC("DR")=".02////^S X=$G(BCHPAT);.03////^S X=BCHR",DLAYGO=90002.01,DIADD=1,DIC(0)="L" K DD,DO D FILE^DICN K DIADD,DLAYGO
.I Y=-1 S BHLERR=1,BCHERR("ERROR")="ERROR IN DICN ADDING A POV" Q
.S BCHPOV=+Y
.D ^XBFMK
.S DA=BCHPOV,DIE="^BCHRPROB("
.S BCHSRV=$P(BCHPOVS(BCHN),U,2),BCHSRV="`"_BCHSRV
.S DR=".04///"_BCHSRV_";.05////"_$P(BCHPOVS(BCHN),U,3)_";.06///"_$P(BCHPOVS(BCHN),U,4)_";.07///"_$P(BCHPOVS(BCHN),U,5)
.D ^DIE
.I $D(Y) S BCHERR=1,BCHERR("ERROR")="ERROR UPDATING POV RECORD - DIE"
.D ^XBFMK
K APCDOVRR
Q
;
FILEDMO ; get patient based on chart number passed, check dob and sex
; if same use IEN, otherwise do not
;
Q:BCHPAT
I BCHNAME="",BCHDOB="",BCHSEX="" Q ;not a patient encounter
S BCHSSN=$G(BHL("PID",1,19)) I BCHSSN'?9N S BCHSSN=""
S BCHTRI=$P($G(BHL("ZP2",1,15)),"^",1) I BCHTRI S BCHTRI=$O(^AUTTTRI("C",BCHTRI,0))
S BCHCOM=$G(BHL("ZHR",1,1)) I BCHCOM]"" S BCHCOMP=$O(^AUTTCOM("C",BCHCOM,0))
D ^XBFMK
S DIE="^BCHR(",DA=BCHR,DR="1101///"_BCHNAME_";1102////"_BCHDOB_";1103///"_BCHSEX_";1104///"_BCHSSN_";1111///"_BCHHRN_";1109////"_BCHFHRN
S DR=DR_";1107////"_BCHCOM_";1105////"_BCHTRI_";1106////"_BCHCOMP
D ^DIE
I $D(Y) S BHLERR="ERROR UPDATING AN ITEM IN THE DEMO NODE"
Q
;
FILEMEAS ; file all tests
;
Q:'$D(BCHMEAS)
S BCHN=0 F S BCHN=$O(BCHMEAS(BCHN)) Q:'BCHN S BCHMTYP=$P(BCHMEAS(BCHN),U,1),BCHVALUE=$P(BCHMEAS(BCHN),U,2) D
.S BCHTIEN=$O(^BCHTMT("B",BCHMTYP,0)) I BCHTIEN="" S BCHERR=1,BCHERR("ERROR")="MEASUREMENT TYPE NOT FOUND IN TABLE" Q
.S BCHFIELD=$P(^BCHTMT(BCHTIEN,0),U,3) I BCHFIELD="" Q ;this is temporary ************ only fields 1201-1210 work, will do lab tests later
.;file measurement
.D ^XBFMK S DIE="^BCHR(",DA=BCHR,DR=BCHFIELD_"///"_BCHVALUE D ^DIE
.I $D(Y) S BCHERR="DIE FAILED UPDATING "_BCHMTYP_" VALUE" Q
.Q
Q
PCCLINK ;
;
S BCHEV("TYPE")="A" ; add, edit or delete
D PROTOCOL^BCHUADD1
K BCHEV,BCHR
Q
MODIFY ;
S BCHR=$O(^BCHR("CUI",BCHUID,0))
I BCHR="" D ADD Q ;couldn't find this record so do add
S BCHSTOP=1 D DELETE^BCHUDEL K BCHSTOP
D ADD
Q
ERRLOG ;
;file error into CHR
D ^XBFMK K DLAYGO,DIADD
S U="^"
S X=$$NOW^XLFDT,DIC="^BCHHLER(",DIC(0)="L",DIADD=1,DLAYGO=90002
K DD,D0,DO D FILE^DICN K DIADD,DLAYGO
S BCHEIEN=+Y
Q:'BCHEIEN
D ^XBFMK
S DIE="^BCHHLER(",DA=BCHEIEN,DR=".02////"_BCHERR("ERROR") D ^DIE
S BCHTEXT="ERRF" F BCHX=1:1 S BCHDATA=$P($T(@BCHTEXT+BCHX),";;",2,99) Q:BCHDATA="" D
.D ^XBFMK
.S V=$P(BCHDATA,";;",2) S X="" X V
.S DR=$P(BCHDATA,";;",1)_"////"_X,DIE="^BCHHLER(",DA=BCHEIEN D ^DIE
.Q
;now save off the BHL obr and obx arrays into 12 nodes
S BCHC=0,BCHCNTR=0 F S BCHC=$O(BHL("OBR",BCHC)) Q:BCHC'=+BCHC D
.S BCHD=0 F S BCHD=$O(BHL("OBR",BCHC,BCHD)) Q:BCHD'=+BCHD D
..Q:BHL("OBR",BCHC,BCHD)=""
..S BCHCNTR=BCHCNTR+1,^BCHHLER(BCHEIEN,12,BCHCNTR,0)=BHL("OBR",BCHC,BCHD)
.S BCHE=0 F S BCHE=$O(BHL("OBX",BCHC,BCHE)) Q:BCHE'=+BCHE D
..S BCHF=0 F S BCHF=$O(BHL("OBX",BCHC,BCHE,BCHF)) Q:BCHF'=+BCHF D
...Q:BHL("OBX",BCHC,BCHE,BCHF)=""
...S BCHCNTR=BCHCNTR+1,^BCHHLER(BCHEIEN,12,BCHCNTR,0)=BHL("OBX",BCHC,BCHE,BCHF)
..Q
.Q
S ^BCHHLER(BCHEIEN,12,0)="^^"_BCHCNTR_"^"_BCHCNTR_"^"_DT_"^"
Q
XIT ;
D KILL^AUPNPAT
D EN^XBVK("BCH")
K BHL
Q
CHECK ;
; - in order to file a record into the CHR Module
; - the following field values must be present and valid
; . there must be at least one OBR/OBX combination that is
; not a test and measurement OBR this segment must have a
; health problem code and activity code pair in OBX
; . CHR - provider ID, OBR 32
; . DATE OF SERVICE - OBR 7
; . CHR PROGRAM CODE - ZHR 2
; . ACTIVITY LOCATION - ZHR 3
;
; check for value and transform into fileable format in separate array
; chr program code in variable BCHPROG, can be 4 slashed
K BCHERR
S BCHERR=0 ;if error then set to 1 and set BCHERR("ERROR")="error message"
S X=$G(BHL("ZHR",1,2)) I X="" S BCHERR=1,BCHERR("ERROR")="Program code missing" Q
S BCHPROG=$O(^BCHTPROG("C",X,0)) I X="" S BCHERR=1,BCHERR("ERROR")="Program code passed could not be found in table." Q
; check for chr activity location
S (X,BCHACTL)=$G(BHL("ZHR",1,3)) S:X="-" (X,BCHACTL)="--" I X="" S BCHERR=1,BCHERR("ERROR")="Activity Location missing" Q
S BCHACTLI=$O(^BCHTACTL("D",X,0)) I BCHACTLI="" S BCHERR=1,BCHERR("ERROR")="Invalid Activity Location passed" Q
;BCHACTLI can be 4 slashed when filing, internal format of pointer
S BCHFACL=$G(BHL("PV1",1,3)) S:BCHACTL'="HC" BCHFACL="" I BCHACTL="HC" D Q:BCHERR
.I BCHFACL="" S BCHERR=1,BCHERR("ERROR")="Patient location missing and activity location is HC" Q
.S BCHFACL=$O(^AUTTLOC("C",BCHFACL,0)) I BCHFACL="" S BCHERR=1,BCHERR("ERROR")="Invalid patient location passed for activity location HC" Q
; check and set OBR/OBX
K BCHPOVS
K BCHMEAS
S BCHPOVC=0
S BCHC=0 F S BCHC=$O(BHL("OBR",BCHC)) Q:BCHC'=+BCHC!(BCHERR) D
. ;get date of service from field 7
. S (BCHPROB,BCHSRV,BCHMIN,BCHNARR,BCHSUBST)=""
. S BCHDOS=$G(BHL("OBR",BCHC,7)) I BCHDOS="" S BCHERR=1,BCHERR("ERROR")="Date of Service Missing" Q
. S BCHDOS=$E(BCHDOS,1,7)
. ;convert to internal fileman format
. ;NEW G,X,Y,%DT S X=BCHDOS,%DT="P" D ^%DT S BCHDOS=Y I BCHDOS=-1 S BCHERR=1,BCHERR("ERROR")="Date of service invalid" Q
. ;get provider from field 32
. S BCHT=$G(BHL("OBR",BCHC,4))
. I BCHT["TM^TESTS AND MEASUREMENTS" D MEAS Q
. ;process problem code/service code obxs
. S BCHCHR=$P($G(BHL("OBR",BCHC,32)),"^",2) I BCHCHR="" S BCHERR=1,BCHERR("ERROR")="CHR Provider missing" Q
. S BCHCHR=$O(^VA(200,"GIHS",BCHCHR,0)) I BCHCHR="" S BCHERR=1,BCHERR("ERROR")="CHR Provider not found in Provider file (file 200)." Q
. S BCHX=0 F S BCHX=$O(BHL("OBX",BCHC,BCHX)) Q:BCHX'=+BCHX!(BCHERR) D
.. S BCHVAL=$G(BHL("OBX",BCHC,BCHX,3))
.. S BCHT=$P(BCHVAL,"^",3)
.. I BCHT="" S BCHERR=1,BCHERR("ERROR")="Error in OBX segment, unknown type" Q
.. I BCHT'="99CHRHAC",BCHT'="99CHRSVC" S BCHERR=1,BCHERR("ERROR")="obr table definition not HAC OR SVC" Q
.. I BCHT="99CHRHAC" D PROBLK Q:BCHERR
.. I BCHT="99CHRSVC" D SRVLK Q:BCHERR
.. S BCHMIN=BHL("OBR",BCHC,20) I BCHMIN="" S BCHMIN=1
.. S BCHSUBST=$G(BHL("OBR",BCHC,21)) I BCHSUBST]"","YN"'[BCHSUBST S BCHSUBST=""
.. I BCHT="99CHRSVC" S BCHNARR=$G(BHL("OBX",BCHC,BCHX,5)) I BCHNARR="" S BCHNARR=$P(^BCHTPROB(BCHPROB,0),U)_": "_$P(^BCHTSERV(BCHSRV,0),"^",1)
. S BCHPOVC=BCHPOVC+1
. S BCHPOVS(BCHPOVC)=BCHPROB_"^"_BCHSRV_"^"_BCHMIN_"^"_BCHNARR_"^"_BCHSUBST
;now get other stuff
;
Q:BCHERR
S BCHTRAV=$G(BHL("ZV1",1,23)) I BCHTRAV="" S BCHTRAV=0
S BCHREFT="",X=$G(BHL("ZHR",1,4)) I X]"" S X=$O(^BCHTREF("D",X,0)) S:X BCHREFT=X I X="" S BCHERR=1,BCHERR("ERROR")="Invalid Referred to code passed" Q
S BCHREFF="",X=$G(BHL("ZHR",1,5)) I X]"" S X=$O(^BCHTREF("D",X,0)) S:X BCHREFF=X I X="" S BCHERR=1,BCHERR("ERROR")="Invalid Referred from code passed" Q
S BCHNS=$G(BHL("ZHR",1,7)) I BCHNS="" S BCHNS=0 ;number served
S BCHEVAL=$G(BHL("ZHR",1,6)) I BCHEVAL]"",BCHEVAL'="UI",BCHEVAL'="CI",BCHEVAL'="FI",BCHEVAL'="PR" S BCHEVAL=""
S BCHACT=$G(BHL("ZHR",1,9)) I BCHACT="" S BCHACT="A"
S BCHUID=$G(BHL("ZHR",1,8))
S BCHTEMPR=$G(BHL("PID",1,11)) S BCHTEMPR=$E(BCHTEMPR,1,30)
Q
MEAS ;
K BCHMEAS
S BCHMEAS=0
S BCHX=0 F S BCHX=$O(BHL("OBX",BCHC,BCHX)) Q:BCHX'=+BCHX!(BCHERR) D
. S BCHVAL=$G(BHL("OBX",BCHC,BCHX,3))
. S BCHVAL=$P(BCHVAL,"^",1)
. S BCHMFIEL=$O(^BCHTMT("B",BCHVAL,0))
. I BCHMFIEL="" S BCHERR=1,BCHERR("ERROR")="Error in measurement/test type "_BCHVAL Q
. S BCHMFIEL=$P(^BCHTMT(BCHMFIEL,0),U,3) I BCHMFIEL="" S BCHERR=1,BCHERR("ERROR")="Error in measurement type field number" Q
. S BCHMRES=$G(BHL("OBX",BCHC,BCHX,5))
. I BCHVAL="VU"!(BCHVAL="VC") S BCHMRES=$P($P(BCHMRES,"~"),"/",2)_"/"_$P($P(BCHMRES,"~",2),"/",2)
. K BCHZ D CHK^DIE(90002,BCHMFIEL,"E",BCHMRES,.BCHZ)
. I BCHZ="^" S BCHERR=1,BCHERR("ERROR")="Invalid measurement/test value passed "_BCHVAL_" - "_BCHMRES Q
. S BCHMEAS=BCHMEAS+1,BCHMEAS(BCHMEAS)=BCHVAL_"^"_BCHMRES_"^"_BCHMFIEL
. Q
Q
PROBLK ;
S X=$P(BCHVAL,"^",1)
S Y=$O(^BCHTPROB("C",X,0))
I Y="" S BCHERR=1,BCHERR("ERROR")="Invalid problem code passed "_X Q
S BCHPROB=Y
Q
SRVLK ;
S X=$P(BCHVAL,"^",1)
S Y=$O(^BCHTSERV("D",X,0))
I Y="" S BCHERR=1,BCHERR("ERROR")="Invalid service code passed "_X Q
S BCHSRV=Y
Q
ERRF ;
;;1101;;S X=$G(BHL("OBR",1,7))
;;1102;;S X=$G(BHL("ZHR",1,2))
;;1103;;S X=$P($G(BHL("OBR",1,32)),U,2)
;;1104;;S X=$P($G(BHL("PID",1,5)),U,1)_","_$P($G(BHL("PID",1,5)),U,2)
;;1105;;S X=$TR($G(BHL("PID",1,3)),U,"~")
;;1106;;S X=$G(BHL("PID",1,8))
;;1107;;S X=$G(BHL("PID",1,9))
;;1108;;S X=$TR($G(BHL("ZP2",1,15)),"^","~")
;;1109;;S X=$TR($G(BHL("ZHR",1,2)),"^","~")
;;1110;;S X=$TR($G(BHL("PID",1,19)),"^","~")
;;1111;;S X=$TR($G(BHL("ZHR",1,3)),"^","~")
;;1301;;S X=$TR($G(BHL("ZHR",1,32)),"^","~")
;;
BCHHL7F ; IHS/TUCSON/LAB - ADD NEW CHR ACTIVITY RECORDS ; [ 04/28/06 3:21 PM ]
+1 ;;1.0;IHS RPMS CHR SYSTEM;**16**;OCT 28, 1996
+2 ;
+3 ; Driver for filing HL7 messages.
+4 ; Array of data is passed from GIS
+5 ;
+6 ;
MAIN ;EP - called from GIS interface
+1 SET BHLNOST=1
DO ^BHLSETI
+2 DO ^BHLFO
+3 SET U="^"
+4 ;no BHL array so don't bother
IF '$DATA(BHL)
QUIT
+5 DO EN^XBVK("BCH")
+6 ;array of data values for filing
KILL BCHDAR
+7 ;check for required pieces of data/valid data, if req element missing file error
DO CHECK
+8 IF BCHERR
DO ERRLOG
DO XIT
QUIT
+9 DO GETPAT
+10 IF BCHERR
DO ERRLOG
DO XIT
QUIT
+11 DO FILEREC
+12 IF $GET(BCHERR)
DO ERRLOG
+13 DO XIT
+14 QUIT
GETPAT ;
+1 SET BCHPAT=""
+2 SET BCHNAME=$PIECE($GET(BHL("PID",1,5)),U,1)_","_$PIECE($GET(BHL("PID",1,5)),U,2)
+3 SET BCHCHRN=$PIECE($GET(BHL("PID",1,3)),"^",1)
+4 SET BCHFACH=$EXTRACT(BCHCHRN,1,6)
+5 SET BCHFHRN=$ORDER(^AUTTLOC("C",BCHFACH,0))
+6 SET BCHHRN=+$EXTRACT(BCHCHRN,7,99)
+7 IF 'BCHFHRN
QUIT
+8 SET BCHSEX=$GET(BHL("PID",1,8))
+9 SET BCHDOB=""
+10 SET X=$GET(BHL("PID",1,7))
+11 IF X]""
SET X=$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,1,4)
SET %DT="P"
DO ^%DT
SET BCHDOB=Y
IF Y=-1
SET BCHDOB=""
+12 SET X=0
FOR
SET X=$ORDER(^AUPNPAT("D",BCHHRN,X))
IF X'=+X
QUIT
IF $DATA(^AUPNPAT("D",BCHHRN,X,BCHFHRN))
SET BCHPAT=X
+13 IF 'BCHPAT
QUIT
+14 ;now check DOB and sex, if they don't match don't point to patient
+15 IF $PIECE(^DPT(BCHPAT,0),"^",2)'=BCHSEX
SET BCHPAT=""
QUIT
+16 IF $PIECE(^DPT(BCHPAT,0),"^",3)'=BCHDOB
SET BCHPAT=""
QUIT
+17 QUIT
FILEREC ;
+1 ;says add but have that record
SET X=$ORDER(^BCHR("CUI",BCHUID,0))
IF X
SET BCHACT="M"
+2 IF BCHACT="M"
DO MODIFY
QUIT
+3 DO ADD
+4 QUIT
ADD ;
+1 ;create and file BCHR record entry
+2 DO ^XBFMK
+3 SET DIC="^BCHR("
SET DIC(0)="L"
SET X=BCHDOS
SET %DT="T"
DO ^%DT
SET X=Y
SET DLAYGO=90002
SET DIC("DR")=".16////"_DUZ_";.17////"_DT_";.22////"_DT_";.26////R"
KILL DD,DO
DO FILE^DICN
+4 IF Y=-1
SET BCHERR=1
SET BCHERR("ERROR")="CREATING CHR RECORD ENTRY FAILED"
QUIT
+5 SET BCHR=+Y
+6 DO EDITREC
+7 IF BCHERR
QUIT
+8 DO POVS
+9 DO FILEMEAS
+10 DO FILEDMO
+11 DO PCCLINK
+12 QUIT
EDITREC ;
+1 KILL BCHFDA
+2 SET BCHFDA(90002,BCHR_",",.02)=BCHPROG
+3 SET BCHFDA(90002,BCHR_",",.03)=BCHCHR
+4 IF $GET(BCHPAT)
SET BCHFDA(90002,BCHR_",",.04)=BCHPAT
+5 IF $GET(BCHFACL)
SET BCHFDA(90002,BCHR_",",.05)=BCHFACL
+6 SET BCHFDA(90002,BCHR_",",.06)=BCHACTLI
+7 SET BCHFDA(90002,BCHR_",",.07)=BCHREFT
+8 SET BCHFDA(90002,BCHR_",",.08)=BCHREFF
+9 SET BCHFDA(90002,BCHR_",",.09)=BCHEVAL
+10 SET BCHFDA(90002,BCHR_",",.11)=BCHTRAV
+11 SET BCHFDA(90002,BCHR_",",.12)=BCHNS
+12 SET BCHFDA(90002,BCHR_",",.21)=BCHUID
+13 SET BCHFDA(90002,BCHR_",",1108)=BCHTEMPR
+14 SET BCHERR=""
+15 DO FILE^DIE("KS","BCHFDA","BCHERR")
+16 IF BCHERR
SET BCHERR("ERROR")="UPDATING CHR RECORD ENTRY FAILED FILEMAN"
+17 KILL BCHFDA
+18 QUIT
POVS ;
+1 DO ^XBFMK
+2 IF '$DATA(BCHPOVS)
QUIT
+3 SET APCDOVRR=1
+4 SET BCHN=0
FOR
SET BCHN=$ORDER(BCHPOVS(BCHN))
IF 'BCHN
QUIT
Begin DoDot:1
+5 SET X=$PIECE(BCHPOVS(BCHN),U)
SET X=$$UP^XLFSTR(X)
IF X=""
SET BHLERR=1
SET BHLERR("ERROR")="POV PROBLEM CODE FAILED"
QUIT
+6 SET DIC="^BCHRPROB("
SET DIC("DR")=".02////^S X=$G(BCHPAT);.03////^S X=BCHR"
SET DLAYGO=90002.01
SET DIADD=1
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
KILL DIADD,DLAYGO
+7 IF Y=-1
SET BHLERR=1
SET BCHERR("ERROR")="ERROR IN DICN ADDING A POV"
QUIT
+8 SET BCHPOV=+Y
+9 DO ^XBFMK
+10 SET DA=BCHPOV
SET DIE="^BCHRPROB("
+11 SET BCHSRV=$PIECE(BCHPOVS(BCHN),U,2)
SET BCHSRV="`"_BCHSRV
+12 SET DR=".04///"_BCHSRV_";.05////"_$PIECE(BCHPOVS(BCHN),U,3)_";.06///"_$PIECE(BCHPOVS(BCHN),U,4)_";.07///"_$PIECE(BCHPOVS(BCHN),U,5)
+13 DO ^DIE
+14 IF $DATA(Y)
SET BCHERR=1
SET BCHERR("ERROR")="ERROR UPDATING POV RECORD - DIE"
+15 DO ^XBFMK
End DoDot:1
+16 KILL APCDOVRR
+17 QUIT
+18 ;
FILEDMO ; get patient based on chart number passed, check dob and sex
+1 ; if same use IEN, otherwise do not
+2 ;
+3 IF BCHPAT
QUIT
+4 ;not a patient encounter
IF BCHNAME=""
IF BCHDOB=""
IF BCHSEX=""
QUIT
+5 SET BCHSSN=$GET(BHL("PID",1,19))
IF BCHSSN'?9N
SET BCHSSN=""
+6 SET BCHTRI=$PIECE($GET(BHL("ZP2",1,15)),"^",1)
IF BCHTRI
SET BCHTRI=$ORDER(^AUTTTRI("C",BCHTRI,0))
+7 SET BCHCOM=$GET(BHL("ZHR",1,1))
IF BCHCOM]""
SET BCHCOMP=$ORDER(^AUTTCOM("C",BCHCOM,0))
+8 DO ^XBFMK
+9 SET DIE="^BCHR("
SET DA=BCHR
SET DR="1101///"_BCHNAME_";1102////"_BCHDOB_";1103///"_BCHSEX_";1104///"_BCHSSN_";1111///"_BCHHRN_";1109////"_BCHFHRN
+10 SET DR=DR_";1107////"_BCHCOM_";1105////"_BCHTRI_";1106////"_BCHCOMP
+11 DO ^DIE
+12 IF $DATA(Y)
SET BHLERR="ERROR UPDATING AN ITEM IN THE DEMO NODE"
+13 QUIT
+14 ;
FILEMEAS ; file all tests
+1 ;
+2 IF '$DATA(BCHMEAS)
QUIT
+3 SET BCHN=0
FOR
SET BCHN=$ORDER(BCHMEAS(BCHN))
IF 'BCHN
QUIT
SET BCHMTYP=$PIECE(BCHMEAS(BCHN),U,1)
SET BCHVALUE=$PIECE(BCHMEAS(BCHN),U,2)
Begin DoDot:1
+4 SET BCHTIEN=$ORDER(^BCHTMT("B",BCHMTYP,0))
IF BCHTIEN=""
SET BCHERR=1
SET BCHERR("ERROR")="MEASUREMENT TYPE NOT FOUND IN TABLE"
QUIT
+5 ;this is temporary ************ only fields 1201-1210 work, will do lab tests later
SET BCHFIELD=$PIECE(^BCHTMT(BCHTIEN,0),U,3)
IF BCHFIELD=""
QUIT
+6 ;file measurement
+7 DO ^XBFMK
SET DIE="^BCHR("
SET DA=BCHR
SET DR=BCHFIELD_"///"_BCHVALUE
DO ^DIE
+8 IF $DATA(Y)
SET BCHERR="DIE FAILED UPDATING "_BCHMTYP_" VALUE"
QUIT
+9 QUIT
End DoDot:1
+10 QUIT
PCCLINK ;
+1 ;
+2 ; add, edit or delete
SET BCHEV("TYPE")="A"
+3 DO PROTOCOL^BCHUADD1
+4 KILL BCHEV,BCHR
+5 QUIT
MODIFY ;
+1 SET BCHR=$ORDER(^BCHR("CUI",BCHUID,0))
+2 ;couldn't find this record so do add
IF BCHR=""
DO ADD
QUIT
+3 SET BCHSTOP=1
DO DELETE^BCHUDEL
KILL BCHSTOP
+4 DO ADD
+5 QUIT
ERRLOG ;
+1 ;file error into CHR
+2 DO ^XBFMK
KILL DLAYGO,DIADD
+3 SET U="^"
+4 SET X=$$NOW^XLFDT
SET DIC="^BCHHLER("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=90002
+5 KILL DD,D0,DO
DO FILE^DICN
KILL DIADD,DLAYGO
+6 SET BCHEIEN=+Y
+7 IF 'BCHEIEN
QUIT
+8 DO ^XBFMK
+9 SET DIE="^BCHHLER("
SET DA=BCHEIEN
SET DR=".02////"_BCHERR("ERROR")
DO ^DIE
+10 SET BCHTEXT="ERRF"
FOR BCHX=1:1
SET BCHDATA=$PIECE($TEXT(@BCHTEXT+BCHX),";;",2,99)
IF BCHDATA=""
QUIT
Begin DoDot:1
+11 DO ^XBFMK
+12 SET V=$PIECE(BCHDATA,";;",2)
SET X=""
XECUTE V
+13 SET DR=$PIECE(BCHDATA,";;",1)_"////"_X
SET DIE="^BCHHLER("
SET DA=BCHEIEN
DO ^DIE
+14 QUIT
End DoDot:1
+15 ;now save off the BHL obr and obx arrays into 12 nodes
+16 SET BCHC=0
SET BCHCNTR=0
FOR
SET BCHC=$ORDER(BHL("OBR",BCHC))
IF BCHC'=+BCHC
QUIT
Begin DoDot:1
+17 SET BCHD=0
FOR
SET BCHD=$ORDER(BHL("OBR",BCHC,BCHD))
IF BCHD'=+BCHD
QUIT
Begin DoDot:2
+18 IF BHL("OBR",BCHC,BCHD)=""
QUIT
+19 SET BCHCNTR=BCHCNTR+1
SET ^BCHHLER(BCHEIEN,12,BCHCNTR,0)=BHL("OBR",BCHC,BCHD)
End DoDot:2
+20 SET BCHE=0
FOR
SET BCHE=$ORDER(BHL("OBX",BCHC,BCHE))
IF BCHE'=+BCHE
QUIT
Begin DoDot:2
+21 SET BCHF=0
FOR
SET BCHF=$ORDER(BHL("OBX",BCHC,BCHE,BCHF))
IF BCHF'=+BCHF
QUIT
Begin DoDot:3
+22 IF BHL("OBX",BCHC,BCHE,BCHF)=""
QUIT
+23 SET BCHCNTR=BCHCNTR+1
SET ^BCHHLER(BCHEIEN,12,BCHCNTR,0)=BHL("OBX",BCHC,BCHE,BCHF)
End DoDot:3
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 SET ^BCHHLER(BCHEIEN,12,0)="^^"_BCHCNTR_"^"_BCHCNTR_"^"_DT_"^"
+27 QUIT
XIT ;
+1 DO KILL^AUPNPAT
+2 DO EN^XBVK("BCH")
+3 KILL BHL
+4 QUIT
CHECK ;
+1 ; - in order to file a record into the CHR Module
+2 ; - the following field values must be present and valid
+3 ; . there must be at least one OBR/OBX combination that is
+4 ; not a test and measurement OBR this segment must have a
+5 ; health problem code and activity code pair in OBX
+6 ; . CHR - provider ID, OBR 32
+7 ; . DATE OF SERVICE - OBR 7
+8 ; . CHR PROGRAM CODE - ZHR 2
+9 ; . ACTIVITY LOCATION - ZHR 3
+10 ;
+11 ; check for value and transform into fileable format in separate array
+12 ; chr program code in variable BCHPROG, can be 4 slashed
+13 KILL BCHERR
+14 ;if error then set to 1 and set BCHERR("ERROR")="error message"
SET BCHERR=0
+15 SET X=$GET(BHL("ZHR",1,2))
IF X=""
SET BCHERR=1
SET BCHERR("ERROR")="Program code missing"
QUIT
+16 SET BCHPROG=$ORDER(^BCHTPROG("C",X,0))
IF X=""
SET BCHERR=1
SET BCHERR("ERROR")="Program code passed could not be found in table."
QUIT
+17 ; check for chr activity location
+18 SET (X,BCHACTL)=$GET(BHL("ZHR",1,3))
IF X="-"
SET (X,BCHACTL)="--"
IF X=""
SET BCHERR=1
SET BCHERR("ERROR")="Activity Location missing"
QUIT
+19 SET BCHACTLI=$ORDER(^BCHTACTL("D",X,0))
IF BCHACTLI=""
SET BCHERR=1
SET BCHERR("ERROR")="Invalid Activity Location passed"
QUIT
+20 ;BCHACTLI can be 4 slashed when filing, internal format of pointer
+21 SET BCHFACL=$GET(BHL("PV1",1,3))
IF BCHACTL'="HC"
SET BCHFACL=""
IF BCHACTL="HC"
Begin DoDot:1
+22 IF BCHFACL=""
SET BCHERR=1
SET BCHERR("ERROR")="Patient location missing and activity location is HC"
QUIT
+23 SET BCHFACL=$ORDER(^AUTTLOC("C",BCHFACL,0))
IF BCHFACL=""
SET BCHERR=1
SET BCHERR("ERROR")="Invalid patient location passed for activity location HC"
QUIT
End DoDot:1
IF BCHERR
QUIT
+24 ; check and set OBR/OBX
+25 KILL BCHPOVS
+26 KILL BCHMEAS
+27 SET BCHPOVC=0
+28 SET BCHC=0
FOR
SET BCHC=$ORDER(BHL("OBR",BCHC))
IF BCHC'=+BCHC!(BCHERR)
QUIT
Begin DoDot:1
+29 ;get date of service from field 7
+30 SET (BCHPROB,BCHSRV,BCHMIN,BCHNARR,BCHSUBST)=""
+31 SET BCHDOS=$GET(BHL("OBR",BCHC,7))
IF BCHDOS=""
SET BCHERR=1
SET BCHERR("ERROR")="Date of Service Missing"
QUIT
+32 SET BCHDOS=$EXTRACT(BCHDOS,1,7)
+33 ;convert to internal fileman format
+34 ;NEW G,X,Y,%DT S X=BCHDOS,%DT="P" D ^%DT S BCHDOS=Y I BCHDOS=-1 S BCHERR=1,BCHERR("ERROR")="Date of service invalid" Q
+35 ;get provider from field 32
+36 SET BCHT=$GET(BHL("OBR",BCHC,4))
+37 IF BCHT["TM^TESTS AND MEASUREMENTS"
DO MEAS
QUIT
+38 ;process problem code/service code obxs
+39 SET BCHCHR=$PIECE($GET(BHL("OBR",BCHC,32)),"^",2)
IF BCHCHR=""
SET BCHERR=1
SET BCHERR("ERROR")="CHR Provider missing"
QUIT
+40 SET BCHCHR=$ORDER(^VA(200,"GIHS",BCHCHR,0))
IF BCHCHR=""
SET BCHERR=1
SET BCHERR("ERROR")="CHR Provider not found in Provider file (file 200)."
QUIT
+41 SET BCHX=0
FOR
SET BCHX=$ORDER(BHL("OBX",BCHC,BCHX))
IF BCHX'=+BCHX!(BCHERR)
QUIT
Begin DoDot:2
+42 SET BCHVAL=$GET(BHL("OBX",BCHC,BCHX,3))
+43 SET BCHT=$PIECE(BCHVAL,"^",3)
+44 IF BCHT=""
SET BCHERR=1
SET BCHERR("ERROR")="Error in OBX segment, unknown type"
QUIT
+45 IF BCHT'="99CHRHAC"
IF BCHT'="99CHRSVC"
SET BCHERR=1
SET BCHERR("ERROR")="obr table definition not HAC OR SVC"
QUIT
+46 IF BCHT="99CHRHAC"
DO PROBLK
IF BCHERR
QUIT
+47 IF BCHT="99CHRSVC"
DO SRVLK
IF BCHERR
QUIT
+48 SET BCHMIN=BHL("OBR",BCHC,20)
IF BCHMIN=""
SET BCHMIN=1
+49 SET BCHSUBST=$GET(BHL("OBR",BCHC,21))
IF BCHSUBST]""
IF "YN"'[BCHSUBST
SET BCHSUBST=""
+50 IF BCHT="99CHRSVC"
SET BCHNARR=$GET(BHL("OBX",BCHC,BCHX,5))
IF BCHNARR=""
SET BCHNARR=$PIECE(^BCHTPROB(BCHPROB,0),U)_": "_$PIECE(^BCHTSERV(BCHSRV,0),"^",1)
End DoDot:2
+51 SET BCHPOVC=BCHPOVC+1
+52 SET BCHPOVS(BCHPOVC)=BCHPROB_"^"_BCHSRV_"^"_BCHMIN_"^"_BCHNARR_"^"_BCHSUBST
End DoDot:1
+53 ;now get other stuff
+54 ;
+55 IF BCHERR
QUIT
+56 SET BCHTRAV=$GET(BHL("ZV1",1,23))
IF BCHTRAV=""
SET BCHTRAV=0
+57 SET BCHREFT=""
SET X=$GET(BHL("ZHR",1,4))
IF X]""
SET X=$ORDER(^BCHTREF("D",X,0))
IF X
SET BCHREFT=X
IF X=""
SET BCHERR=1
SET BCHERR("ERROR")="Invalid Referred to code passed"
QUIT
+58 SET BCHREFF=""
SET X=$GET(BHL("ZHR",1,5))
IF X]""
SET X=$ORDER(^BCHTREF("D",X,0))
IF X
SET BCHREFF=X
IF X=""
SET BCHERR=1
SET BCHERR("ERROR")="Invalid Referred from code passed"
QUIT
+59 ;number served
SET BCHNS=$GET(BHL("ZHR",1,7))
IF BCHNS=""
SET BCHNS=0
+60 SET BCHEVAL=$GET(BHL("ZHR",1,6))
IF BCHEVAL]""
IF BCHEVAL'="UI"
IF BCHEVAL'="CI"
IF BCHEVAL'="FI"
IF BCHEVAL'="PR"
SET BCHEVAL=""
+61 SET BCHACT=$GET(BHL("ZHR",1,9))
IF BCHACT=""
SET BCHACT="A"
+62 SET BCHUID=$GET(BHL("ZHR",1,8))
+63 SET BCHTEMPR=$GET(BHL("PID",1,11))
SET BCHTEMPR=$EXTRACT(BCHTEMPR,1,30)
+64 QUIT
MEAS ;
+1 KILL BCHMEAS
+2 SET BCHMEAS=0
+3 SET BCHX=0
FOR
SET BCHX=$ORDER(BHL("OBX",BCHC,BCHX))
IF BCHX'=+BCHX!(BCHERR)
QUIT
Begin DoDot:1
+4 SET BCHVAL=$GET(BHL("OBX",BCHC,BCHX,3))
+5 SET BCHVAL=$PIECE(BCHVAL,"^",1)
+6 SET BCHMFIEL=$ORDER(^BCHTMT("B",BCHVAL,0))
+7 IF BCHMFIEL=""
SET BCHERR=1
SET BCHERR("ERROR")="Error in measurement/test type "_BCHVAL
QUIT
+8 SET BCHMFIEL=$PIECE(^BCHTMT(BCHMFIEL,0),U,3)
IF BCHMFIEL=""
SET BCHERR=1
SET BCHERR("ERROR")="Error in measurement type field number"
QUIT
+9 SET BCHMRES=$GET(BHL("OBX",BCHC,BCHX,5))
+10 IF BCHVAL="VU"!(BCHVAL="VC")
SET BCHMRES=$PIECE($PIECE(BCHMRES,"~"),"/",2)_"/"_$PIECE($PIECE(BCHMRES,"~",2),"/",2)
+11 KILL BCHZ
DO CHK^DIE(90002,BCHMFIEL,"E",BCHMRES,.BCHZ)
+12 IF BCHZ="^"
SET BCHERR=1
SET BCHERR("ERROR")="Invalid measurement/test value passed "_BCHVAL_" - "_BCHMRES
QUIT
+13 SET BCHMEAS=BCHMEAS+1
SET BCHMEAS(BCHMEAS)=BCHVAL_"^"_BCHMRES_"^"_BCHMFIEL
+14 QUIT
End DoDot:1
+15 QUIT
PROBLK ;
+1 SET X=$PIECE(BCHVAL,"^",1)
+2 SET Y=$ORDER(^BCHTPROB("C",X,0))
+3 IF Y=""
SET BCHERR=1
SET BCHERR("ERROR")="Invalid problem code passed "_X
QUIT
+4 SET BCHPROB=Y
+5 QUIT
SRVLK ;
+1 SET X=$PIECE(BCHVAL,"^",1)
+2 SET Y=$ORDER(^BCHTSERV("D",X,0))
+3 IF Y=""
SET BCHERR=1
SET BCHERR("ERROR")="Invalid service code passed "_X
QUIT
+4 SET BCHSRV=Y
+5 QUIT
ERRF ;
+1 ;;1101;;S X=$G(BHL("OBR",1,7))
+2 ;;1102;;S X=$G(BHL("ZHR",1,2))
+3 ;;1103;;S X=$P($G(BHL("OBR",1,32)),U,2)
+4 ;;1104;;S X=$P($G(BHL("PID",1,5)),U,1)_","_$P($G(BHL("PID",1,5)),U,2)
+5 ;;1105;;S X=$TR($G(BHL("PID",1,3)),U,"~")
+6 ;;1106;;S X=$G(BHL("PID",1,8))
+7 ;;1107;;S X=$G(BHL("PID",1,9))
+8 ;;1108;;S X=$TR($G(BHL("ZP2",1,15)),"^","~")
+9 ;;1109;;S X=$TR($G(BHL("ZHR",1,2)),"^","~")
+10 ;;1110;;S X=$TR($G(BHL("PID",1,19)),"^","~")
+11 ;;1111;;S X=$TR($G(BHL("ZHR",1,3)),"^","~")
+12 ;;1301;;S X=$TR($G(BHL("ZHR",1,32)),"^","~")
+13 ;;
