BHLBCH2 ; IHS/TUCSON/DCP - HL7 ORU Message Processor (continued) ;
;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
;
; This routine is a continuation of BHLBCH1.
; It is not independently callable.
;
A ; ENTRY POINT from BHLBCH1
;
D FILEREC Q:BHLQUIT
D FILEDMO
D FILEPOV
D FILETEST
Q
;
E ; ENTRY POINT from BHLBCH1 - edit - delete original and do add
;
S BCHR=BHLR,BCHSTOP=1 D DELETE^BCHUDEL K BCHSTOP
D A
Q
;
FMKILL ; ENTRY POINT from BHLBCH1
;
K DIE,DIC,DA,DR,DLAYGO,DIADD,DIU,DIY,DIX,DIV,DIW,DD,D0,DO,DI,DK,DIG,DIH,DL,DQ
Q
FILEREC ;create and file chr record
S BHLFDA(90002,BHLR_",",.21)=BHLID
D FILE^DIE("KS","BHLFDA","BHLERR")
Q
FILEPOV ;file povs
K BHLTPOV
D FMKILL
Q:'$D(BHLBCH("POV"))
S APCDOVRR=1
S BHLN=0 F S BHLN=$O(BHLBCH("POV",BHLN)) Q:BHLN'=+BHLN D
.S X=$P(BHLBCH("POV",BHLN),U),X=$O(^BCHTPROB("C",X,0)) I X="" S HLERR="POV PROBLEM CODE FAILED",BHLQUIT=1 Q
.S DIC="^BCHRPROB(",DIC("DR")=".02////^S X=$G(IEN);.03////^S X=BHLR",DLAYGO=90002.01,DIADD=1,DIC(0)="L" D FILE^DICN
.I Y=-1 S HLERR="ERROR IN DICN ADDING A POV",BHLQUIT=1 Q
.S BHLPOV=+Y
.D FMKILL
.S DA=BHLPOV,DIE="^BCHRPROB("
.S BHLSRV=$O(^BCHTSERV("D",$P(BHLBCH("POV",BHLN),U,2),0)),BHLSRV="`"_BHLSRV
.S DR=".04///"_BHLSRV_";.05///"_$P(BHLBCH("POV",BHLN),U,3)_";.06///"_$P(BHLBCH("POV",BHLN),U,4)_";.07///"_$P(BHLBCH("POV",BHLN),U,5)
.D ^DIE
.I $D(Y) S HLERR="ERROR UPDATING POV RECORD - DIE",BHLQUIT=1
.D FMKILL
K APCDOVRR
I '$D(HLERR) S BHLTPOV(BHLPOV)=""
Q
FILEDMO ;
;get patient based on chart number passed, check dob and sex - if same use IEN, otherwise do not
S IEN=""
Q:'$D(BHLBCH("DEMO"))
S F=$P(BHLBCH("DEMO"),U,8) I F]"" S F=$O(^AUTTLOC("C",F,0))
S C=$P(BHLBCH("DEMO"),U,7),SEX=$P(BHLBCH("DEMO"),U,3),DOB=$P(BHLBCH("DEMO"),U,2)
I 'F!(C="") D NOIEN Q
S BHLDUZ2=DUZ(2),DUZ(2)=F,X=C,DIC="^AUPNPAT(",DIC(0)="M" D ^DIC
S DUZ(2)=BHLDUZ2 K BHLDUZ2 I +Y>0,SEX=$P(^DPT(+Y,0),U,2),DOB=$P(^DPT(+Y,0),U,3) S IEN=+Y,DIE="^BCHR(",DA=BHLR,DR=".04////^S X=IEN" D ^DIE D FMKILL D:$P(BHLBCH("DEMO"),U,9)]"" Q
.S DIE="^BCHR(",DA=BHLR,DR="1108///"_$P(BHLBCH("DEMO"),U,9) D ^DIE I $D(Y) S HLERR="TEMPORARY RESIDENCE FAILED",BHLQUIT=1 Q
.Q
D NOIEN
Q
NOIEN ;stuff demo stuff - no IEN found
D FMKILL
S DIE="^BCHR(",DA=BHLR,DR="1101///"_$P(BHLBCH("DEMO"),U)_";1102///"_$P(BHLBCH("DEMO"),U,2)_";1103///"_$P(BHLBCH("DEMO"),U,3)_";1104///"_$P(BHLBCH("DEMO"),U,4)_";1111///"_$P(BHLBCH("DEMO"),U,7)_";1109///"_$P(BHLBCH("DEMO"),U,8)
S DR=DR_";1107///"_$P(BHLBCH("DEMO"),U,6)_";1108///"_$P(BHLBCH("DEMO"),U,9)_";1105///"_$P(BHLBCH("DEMO"),U,5)_";1106///"_$P(BHLBCH("DEMO"),U,6)
D ^DIE
I $D(Y) S HLERR="ERROR UPDATING AN ITEM IN THE DEMO NODE",BHLQUIT=1
Q
FILETEST ;file all tests
Q:'$D(BHLBCH("MSR"))
S BHLN=0 F S BHLN=$O(BHLBCH("MSR",BHLN)) Q:BHLN'=+BHLN!(BHLQUIT) S BHLMTYP=$P(BHLBCH("MSR",BHLN),U),BHLVALUE=$P(BHLBCH("MSR",BHLN),U,2) D
.S BHLTIEN=$O(^BCHTMT("B",BHLMTYP,0)) I BHLTIEN="" S BHLQUIT=1,HLERR="MEASUREMENT TYPE NOT FOUND IN TABLE" Q
.S BHLFIELD=$P(^BCHTMT(BHLTIEN,0),U,3) I BHLFIELD="" Q ;this is temporary ************ only fields 1201-1210 work, will do lab tests later
.;file measurement
.D FMKILL S DIE="^BCHR(",DA=BHLR,DR=BHLFIELD_"///"_BHLVALUE D ^DIE
.I $D(Y) S HLERR="DIE FAILED UPDATING "_BHLMTYP_" VALUE",BHLQUIT=1 Q
.Q
Q
BHLBCH2 ; IHS/TUCSON/DCP - HL7 ORU Message Processor (continued) ;
+1 ;;1.0;IHS SUPPORT FOR HL7 INTERFACES;;JUL 7, 1997
+2 ;
+3 ; This routine is a continuation of BHLBCH1.
+4 ; It is not independently callable.
+5 ;
A ; ENTRY POINT from BHLBCH1
+1 ;
+2 DO FILEREC
IF BHLQUIT
QUIT
+3 DO FILEDMO
+4 DO FILEPOV
+5 DO FILETEST
+6 QUIT
+7 ;
E ; ENTRY POINT from BHLBCH1 - edit - delete original and do add
+1 ;
+2 SET BCHR=BHLR
SET BCHSTOP=1
DO DELETE^BCHUDEL
KILL BCHSTOP
+3 DO A
+4 QUIT
+5 ;
FMKILL ; ENTRY POINT from BHLBCH1
+1 ;
+2 KILL DIE,DIC,DA,DR,DLAYGO,DIADD,DIU,DIY,DIX,DIV,DIW,DD,D0,DO,DI,DK,DIG,DIH,DL,DQ
+3 QUIT
FILEREC ;create and file chr record
+1 SET BHLFDA(90002,BHLR_",",.21)=BHLID
+2 DO FILE^DIE("KS","BHLFDA","BHLERR")
+3 QUIT
FILEPOV ;file povs
+1 KILL BHLTPOV
+2 DO FMKILL
+3 IF '$DATA(BHLBCH("POV"))
QUIT
+4 SET APCDOVRR=1
+5 SET BHLN=0
FOR
SET BHLN=$ORDER(BHLBCH("POV",BHLN))
IF BHLN'=+BHLN
QUIT
Begin DoDot:1
+6 SET X=$PIECE(BHLBCH("POV",BHLN),U)
SET X=$ORDER(^BCHTPROB("C",X,0))
IF X=""
SET HLERR="POV PROBLEM CODE FAILED"
SET BHLQUIT=1
QUIT
+7 SET DIC="^BCHRPROB("
SET DIC("DR")=".02////^S X=$G(IEN);.03////^S X=BHLR"
SET DLAYGO=90002.01
SET DIADD=1
SET DIC(0)="L"
DO FILE^DICN
+8 IF Y=-1
SET HLERR="ERROR IN DICN ADDING A POV"
SET BHLQUIT=1
QUIT
+9 SET BHLPOV=+Y
+10 DO FMKILL
+11 SET DA=BHLPOV
SET DIE="^BCHRPROB("
+12 SET BHLSRV=$ORDER(^BCHTSERV("D",$PIECE(BHLBCH("POV",BHLN),U,2),0))
SET BHLSRV="`"_BHLSRV
+13 SET DR=".04///"_BHLSRV_";.05///"_$PIECE(BHLBCH("POV",BHLN),U,3)_";.06///"_$PIECE(BHLBCH("POV",BHLN),U,4)_";.07///"_$PIECE(BHLBCH("POV",BHLN),U,5)
+14 DO ^DIE
+15 IF $DATA(Y)
SET HLERR="ERROR UPDATING POV RECORD - DIE"
SET BHLQUIT=1
+16 DO FMKILL
End DoDot:1
+17 KILL APCDOVRR
+18 IF '$DATA(HLERR)
SET BHLTPOV(BHLPOV)=""
+19 QUIT
FILEDMO ;
+1 ;get patient based on chart number passed, check dob and sex - if same use IEN, otherwise do not
+2 SET IEN=""
+3 IF '$DATA(BHLBCH("DEMO"))
QUIT
+4 SET F=$PIECE(BHLBCH("DEMO"),U,8)
IF F]""
SET F=$ORDER(^AUTTLOC("C",F,0))
+5 SET C=$PIECE(BHLBCH("DEMO"),U,7)
SET SEX=$PIECE(BHLBCH("DEMO"),U,3)
SET DOB=$PIECE(BHLBCH("DEMO"),U,2)
+6 IF 'F!(C="")
DO NOIEN
QUIT
+7 SET BHLDUZ2=DUZ(2)
SET DUZ(2)=F
SET X=C
SET DIC="^AUPNPAT("
SET DIC(0)="M"
DO ^DIC
+8 SET DUZ(2)=BHLDUZ2
KILL BHLDUZ2
IF +Y>0
IF SEX=$PIECE(^DPT(+Y,0),U,2)
IF DOB=$PIECE(^DPT(+Y,0),U,3)
SET IEN=+Y
SET DIE="^BCHR("
SET DA=BHLR
SET DR=".04////^S X=IEN"
DO ^DIE
DO FMKILL
IF $PIECE(BHLBCH("DEMO"),U,9)]""
Begin DoDot:1
+9 SET DIE="^BCHR("
SET DA=BHLR
SET DR="1108///"_$PIECE(BHLBCH("DEMO"),U,9)
DO ^DIE
IF $DATA(Y)
SET HLERR="TEMPORARY RESIDENCE FAILED"
SET BHLQUIT=1
QUIT
+10 QUIT
End DoDot:1
QUIT
+11 DO NOIEN
+12 QUIT
NOIEN ;stuff demo stuff - no IEN found
+1 DO FMKILL
+2 SET DIE="^BCHR("
SET DA=BHLR
SET DR="1101///"_$PIECE(BHLBCH("DEMO"),U)_";1102///"_$PIECE(BHLBCH("DEMO"),U,2)_";1103///"_$PIECE(BHLBCH("DEMO"),U,3)_";1104///"_$PIECE(BHLBCH("DEMO"),U,4)_";1111///"_$PIECE(BHLBCH("DEMO"),U,7)_";1109///"_$PIECE(BHLBCH("DEMO"),U,8)
+3 SET DR=DR_";1107///"_$PIECE(BHLBCH("DEMO"),U,6)_";1108///"_$PIECE(BHLBCH("DEMO"),U,9)_";1105///"_$PIECE(BHLBCH("DEMO"),U,5)_";1106///"_$PIECE(BHLBCH("DEMO"),U,6)
+4 DO ^DIE
+5 IF $DATA(Y)
SET HLERR="ERROR UPDATING AN ITEM IN THE DEMO NODE"
SET BHLQUIT=1
+6 QUIT
FILETEST ;file all tests
+1 IF '$DATA(BHLBCH("MSR"))
QUIT
+2 SET BHLN=0
FOR
SET BHLN=$ORDER(BHLBCH("MSR",BHLN))
IF BHLN'=+BHLN!(BHLQUIT)
QUIT
SET BHLMTYP=$PIECE(BHLBCH("MSR",BHLN),U)
SET BHLVALUE=$PIECE(BHLBCH("MSR",BHLN),U,2)
Begin DoDot:1
+3 SET BHLTIEN=$ORDER(^BCHTMT("B",BHLMTYP,0))
IF BHLTIEN=""
SET BHLQUIT=1
SET HLERR="MEASUREMENT TYPE NOT FOUND IN TABLE"
QUIT
+4 ;this is temporary ************ only fields 1201-1210 work, will do lab tests later
SET BHLFIELD=$PIECE(^BCHTMT(BHLTIEN,0),U,3)
IF BHLFIELD=""
QUIT
+5 ;file measurement
+6 DO FMKILL
SET DIE="^BCHR("
SET DA=BHLR
SET DR=BHLFIELD_"///"_BHLVALUE
DO ^DIE
+7 IF $DATA(Y)
SET HLERR="DIE FAILED UPDATING "_BHLMTYP_" VALUE"
SET BHLQUIT=1
QUIT
+8 QUIT
End DoDot:1
+9 QUIT
