DGPFHLU ;ALB/RPM - PRF HL7 ORU/ACK PROCESSING ; 6/21/06 10:27am
;;5.3;Registration;**425,718,650,951,1063**;Aug 13, 1993;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
BLDORU(DGPFA,DGHARR,DGHL,DGROOT) ;Build ORU~R01 Message/Segments
;
; Input:
; DGPFA - (required) Assignment data array
; DGHARR - (required) Assignment history IENs array
; DGHL - (required) HL7 Kernel array passed by reference
; DGROOT - (required) Closed root segment storage array name
;
; Output:
; Function Value - IEN of last assignment history included in
; message segments, 0 on failure
; DGROOT - array of HL7 segments
;
N DGADT ;assignment date
N DGHIEN ;function value
N DGLDT ;last assignment date
N DGPFAH ;assignment history data array
N DGSEG ;segment counter
N DGSEGSTR ;formatted segment string
N DGSET ;set id
N DGTROOT ;text root
N LASTH ;last assignment history entry
N DBRSSTR,Z
;
S DGHIEN=0
S DGSEG=0
;
I $D(DGPFA),$D(DGHARR),$G(DGROOT)]"" D
.; build PID
.I $D(HL) N HL MERGE HL=DGHL ; Checking if HL array exists and merging with DGHL if it does to prevent discrepancies in the PID segments
.S DGSEGSTR=$$EN^VAFHLPID(+DGPFA("DFN"),"1,2,3,5,7,8,19",1,1) Q:DGSEGSTR=""
.S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR
.; build OBR
.S DGLDT=+$O(DGHARR(""),-1) ; get last assignment date
.Q:'$$GETHIST^DGPFAAH(DGHARR(DGLDT),.DGPFAH,1) ; load asgn hx array
.M LASTH=DGPFAH
.S DGSEGSTR=$$OBR^DGPFHLU1(1,.DGPFA,.DGPFAH,"1,4,7,20,21",.DGHL) Q:DGSEGSTR=""
.S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR
.; start OBX segments
.S DGSET=0
.; build narrative OBX segments
.S DGTROOT="DGPFA(""NARR"")"
.Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGSEG,.DGSET)
.; for each history build status & comment OBX segments
.S DGADT=0 F S DGADT=$O(DGHARR(DGADT)) Q:'DGADT D Q:'DGHIEN
..N DGPFAH
..S DGHIEN=0
..Q:'$$GETHIST^DGPFAAH(DGHARR(DGADT),.DGPFAH)
..; build status OBX segment
..S DGSET=DGSET+1
..S DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"S","",$P($G(DGPFAH("ACTION")),U,2),.DGPFAH,"1,2,3,5,11,14",.DGHL)
..Q:DGSEGSTR=""
..S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR
..; build review comment OBX segments
..S DGTROOT="DGPFAH(""COMMENT"")"
..Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGSEG,.DGSET)
..; success
..S DGHIEN=DGHARR(DGADT)
..Q
.; build DBRS OBX segments
.; build only if action is not "INACTIVATE"
.I +LASTH("ACTION")'=3 S Z="" F S Z=$O(LASTH("DBRS",Z)) Q:Z="" D Q:'DGHIEN
..S DBRSSTR=$G(LASTH("DBRS",Z))
..; don't send unchanged DBRS entries if action is "DBRS#/OTHER FIELD UPDATE"
..I $P($P(DBRSSTR,U,4),";")="N",+LASTH("ACTION")=6 Q
..S DGSET=DGSET+1
..S DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"D","",DBRSSTR,.LASTH,"1,2,3,5,11,14,23",.DGHL)
..I DGSEGSTR="" S DGHIEN=0 Q
..S DGSEG=DGSEG+1,@DGROOT@(DGSEG)=DGSEGSTR
..Q
.Q
;
Q DGHIEN
;
PARSORU(DGWRK,DGHL,DGROOT,DGPFERR) ;Parse ORU~R01 Message/Segments
;
; Input:
; DGWRK - Closed root work global reference
; DGHL - HL7 environment array
; DGROOT - Closed root ORU results array name
;
; Output:
; DGROOT - ORU results array
; Subscript Field name Fld# File#
; ----------------------- -------------------- ---- -----
; "SNDFAC" N/A N/A N/A
; "DFN" PATIENT NAME .01 26.13
; "FLAG" FLAG NAME .02 26.13
; "OWNER" OWNER SITE .04 26.13
; "ORIGSITE" ORIGINATING SITE .05 26.13
; "NARR",line ASSIGNMENT NARRATIVE 1 26.13
; assigndt,"ACTION" ACTION .03 26.13
; assigndt,"COMMENT",line HISTORY COMMENTS 1 26.14
; DGPFERR - Undefined on success, ERR segment data array on failure
; Format: DGPFERR(seg_id,sequence,fld_pos)=error_code
;
N DGFS ;field separator
N DGCS ;component separator
N DGRS ;repetition separator
N DGCURLIN ;current segment line
N DGSEG ;segment field data array
N DGERR ;error processing array
;
S DGFS=DGHL("FS")
S DGCS=$E(DGHL("ECH"),1)
S DGRS=$E(DGHL("ECH"),2)
S HLECH=DGHL("ECH"),HLFS=DGHL("FS")
S DGCURLIN=0
;
;loop through message segments and retrieve field data
F D Q:'DGCURLIN
. N DGSEG
. S DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
. Q:'DGCURLIN
. D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGROOT,.DGPFERR)")
;
MSH(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGORU - Closed root ORU results array name
;
; Output:
; DGORU - ORU results array
; Subscript
; ---------
; "SNDFAC"
; DGERR - undefined on success, error array on failure
; format: DGERR(seg_id,sequence,fld_pos)=error code
;
S @DGORU@("SNDFAC")=$$IEN^XUAF4($P(DGSEG(4),DGCS,1))
Q
;
PID(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
;
; Input:
; DGSEG - PID segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGORU - Closed root ORU results array name
;
; Output:
; DGORU - ORU results array
; Subscript
; ---------
; "DFN"
; DGERR - undefined on success, error array on failure
; format: DGERR(seg_id,sequence,fld_pos)=error code
;
N DGARR
N DGDFNERR
N DGICN
;
S DGICN=+$P(DGSEG(3),DGCS,1)
S DGARR("DFN")=$$GETDFN^DGPFUT2(DGICN,"DGDFNERR")
I 'DGARR("DFN"),$G(DGDFNERR("DIERR",1))]"" D
. S DGERR("PID",DGSEG(1),3)=DGDFNERR("DIERR",1) ;no match
;
;load results array
S @DGORU@("DFN")=DGARR("DFN")
Q
;
OBR(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
;
; Input:
; DGSEG - OBR segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGORU - Closed root ORU results array name
;
; Output:
; DGORU - ORU results array
; Subscript
; ----------------
; "FLAG"
; "OWNER"
; "ORIGSITE"
; DGERR - undefined on success, error array on failure
; format: DGERR(seg_id,sequence,fld_pos)=error code
;
N DGARR
N PRFFLG ; ien of received PRF flag in file 26.15
;
S PRFFLG=+$$FIND1^DIC(26.15,,"X",$$DECHL7^DGPFHLUT($P($G(DGSEG(4)),DGCS,2)))
S DGARR("FLAG")=PRFFLG_";DGPF(26.15,"
I '$$TESTVAL^DGPFUT(26.13,.02,DGARR("FLAG")) D
.S DGERR("OBR",DGSEG(1),4)=261111 ;invalid flag
.Q
;
S DGARR("OWNER")=$$IEN^XUAF4(DGSEG(20))
I (DGARR("OWNER")="")!('$$TESTVAL^DGPFUT(26.13,.04,DGARR("OWNER"))) D
.S DGERR("OBR",DGSEG(1),20)=261126 ;invalid owner site
.Q
;
S DGARR("ORIGSITE")=$$IEN^XUAF4($G(DGSEG(21)))
I DGARR("ORIGSITE")="" S DGARR("ORIGSITE")=@DGORU@("SNDFAC")
I (DGARR("ORIGSITE")="")!('$$TESTVAL^DGPFUT(26.13,.05,DGARR("ORIGSITE"))) D
.S DGERR("OBR",DGSEG(1),21)=261125 ;invalid originating site
.Q
;
;load results array
M @DGORU=DGARR
Q
;
OBX(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
;
; Input:
; DGSEG - OBX segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGORU - Closed root ORU results array name
;
; Output:
; DGORU - ORU results array
; Subscript
; -----------------------
; "NARR",line
; assigndt,"ACTION"
; assigndt,"COMMENT",line
; DGERR - undefined on success, error array on failure
; format: DGERR(seg_id,sequence,fld_pos)=error code
;
N DGADT ;assignment date
N DGI
N DGLINE ;word processing line count
N DGRSLT,DBRSACT,DBRSDT,DBRSNUM,DBRSOTH,DBRSSITE
;
; Narrative Observation Identifier
I $P(DGSEG(3),DGCS,1)="N" D
.S DGLINE=$O(@DGORU@("NARR",""),-1)
.F DGI=1:1:$L(DGSEG(5),DGRS) S @DGORU@("NARR",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($P(DGSEG(5),DGRS,DGI))
.Q
; Status Observation Identifier
I $P(DGSEG(3),DGCS,1)="S" D
.S DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L") Q:+DGADT'>0
.D CHK^DIE(26.14,.03,,$$DECHL7^DGPFHLUT(DGSEG(5)),.DGRSLT)
.S @DGORU@(DGADT,"ACTION")=+DGRSLT
.Q
; Comment Observation Identifier
I $P(DGSEG(3),DGCS,1)="C" D
.S DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L") Q:+DGADT'>0
.S DGLINE=$O(@DGORU@(DGADT,"COMMENT",""),-1)
.F DGI=1:1:$L(DGSEG(5),DGRS) S @DGORU@(DGADT,"COMMENT",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($P(DGSEG(5),DGRS,DGI))
.S @DGORU@(DGADT,"ORIGFAC")=$$IEN^XUAF4($P($G(DGSEG(23)),DGCS,3))
.Q
; DBRS Observation Identifier
I $P(DGSEG(3),DGCS,1)="D" D
.S DBRSACT=$S($P(DGSEG(3),DGCS,2)="DBRS-Delete":"D",1:"U") ; "U" = add/update, "D" = delete
.S DBRSNUM=$$DECHL7^DGPFHLUT($P(DGSEG(5),DGRS,1)) Q:DBRSNUM="" ; DBRS #
.S DBRSOTH=$$DECHL7^DGPFHLUT($P(DGSEG(5),DGRS,2)) ; DBRS OTHER
.S DBRSDT=+$$HL7TFM^XLFDT(DGSEG(14),"L") ; DBRS date
.S DBRSSITE=$$IEN^XUAF4($P($G(DGSEG(23)),DGCS,3)) ; DBRS creating site
.S @DGORU@("DBRS",DBRSNUM,"ACTION")=DBRSACT
.S @DGORU@("DBRS",DBRSNUM,"OTHER")=DBRSOTH
.S @DGORU@("DBRS",DBRSNUM,"DATE")=DBRSDT
.S @DGORU@("DBRS",DBRSNUM,"SITE")=$S(DBRSSITE>0:DBRSSITE,1:"")
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLU 9427 printed Apr 09, 2024@21:46:13 Page 2
DGPFHLU ;ALB/RPM - PRF HL7 ORU/ACK PROCESSING ; 6/21/06 10:27am
+1 ;;5.3;Registration;**425,718,650,951,1063**;Aug 13, 1993;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BLDORU(DGPFA,DGHARR,DGHL,DGROOT) ;Build ORU~R01 Message/Segments
+1 ;
+2 ; Input:
+3 ; DGPFA - (required) Assignment data array
+4 ; DGHARR - (required) Assignment history IENs array
+5 ; DGHL - (required) HL7 Kernel array passed by reference
+6 ; DGROOT - (required) Closed root segment storage array name
+7 ;
+8 ; Output:
+9 ; Function Value - IEN of last assignment history included in
+10 ; message segments, 0 on failure
+11 ; DGROOT - array of HL7 segments
+12 ;
+13 ;assignment date
NEW DGADT
+14 ;function value
NEW DGHIEN
+15 ;last assignment date
NEW DGLDT
+16 ;assignment history data array
NEW DGPFAH
+17 ;segment counter
NEW DGSEG
+18 ;formatted segment string
NEW DGSEGSTR
+19 ;set id
NEW DGSET
+20 ;text root
NEW DGTROOT
+21 ;last assignment history entry
NEW LASTH
+22 NEW DBRSSTR,Z
+23 ;
+24 SET DGHIEN=0
+25 SET DGSEG=0
+26 ;
+27 IF $DATA(DGPFA)
IF $DATA(DGHARR)
IF $GET(DGROOT)]""
Begin DoDot:1
+28 ; build PID
+29 ; Checking if HL array exists and merging with DGHL if it does to prevent discrepancies in the PID segments
IF $DATA(HL)
NEW HL
MERGE HL=DGHL
+30 SET DGSEGSTR=$$EN^VAFHLPID(+DGPFA("DFN"),"1,2,3,5,7,8,19",1,1)
if DGSEGSTR=""
QUIT
+31 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+32 ; build OBR
+33 ; get last assignment date
SET DGLDT=+$ORDER(DGHARR(""),-1)
+34 ; load asgn hx array
if '$$GETHIST^DGPFAAH(DGHARR(DGLDT),.DGPFAH,1)
QUIT
+35 MERGE LASTH=DGPFAH
+36 SET DGSEGSTR=$$OBR^DGPFHLU1(1,.DGPFA,.DGPFAH,"1,4,7,20,21",.DGHL)
if DGSEGSTR=""
QUIT
+37 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+38 ; start OBX segments
+39 SET DGSET=0
+40 ; build narrative OBX segments
+41 SET DGTROOT="DGPFA(""NARR"")"
+42 if '$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGSEG,.DGSET)
QUIT
+43 ; for each history build status & comment OBX segments
+44 SET DGADT=0
FOR
SET DGADT=$ORDER(DGHARR(DGADT))
if 'DGADT
QUIT
Begin DoDot:2
+45 NEW DGPFAH
+46 SET DGHIEN=0
+47 if '$$GETHIST^DGPFAAH(DGHARR(DGADT),.DGPFAH)
QUIT
+48 ; build status OBX segment
+49 SET DGSET=DGSET+1
+50 SET DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"S","",$PIECE($GET(DGPFAH("ACTION")),U,2),.DGPFAH,"1,2,3,5,11,14",.DGHL)
+51 if DGSEGSTR=""
QUIT
+52 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+53 ; build review comment OBX segments
+54 SET DGTROOT="DGPFAH(""COMMENT"")"
+55 if '$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGSEG,.DGSET)
QUIT
+56 ; success
+57 SET DGHIEN=DGHARR(DGADT)
+58 QUIT
End DoDot:2
if 'DGHIEN
QUIT
+59 ; build DBRS OBX segments
+60 ; build only if action is not "INACTIVATE"
+61 IF +LASTH("ACTION")'=3
SET Z=""
FOR
SET Z=$ORDER(LASTH("DBRS",Z))
if Z=""
QUIT
Begin DoDot:2
+62 SET DBRSSTR=$GET(LASTH("DBRS",Z))
+63 ; don't send unchanged DBRS entries if action is "DBRS#/OTHER FIELD UPDATE"
+64 IF $PIECE($PIECE(DBRSSTR,U,4),";")="N"
IF +LASTH("ACTION")=6
QUIT
+65 SET DGSET=DGSET+1
+66 SET DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"D","",DBRSSTR,.LASTH,"1,2,3,5,11,14,23",.DGHL)
+67 IF DGSEGSTR=""
SET DGHIEN=0
QUIT
+68 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+69 QUIT
End DoDot:2
if 'DGHIEN
QUIT
+70 QUIT
End DoDot:1
+71 ;
+72 QUIT DGHIEN
+73 ;
PARSORU(DGWRK,DGHL,DGROOT,DGPFERR) ;Parse ORU~R01 Message/Segments
+1 ;
+2 ; Input:
+3 ; DGWRK - Closed root work global reference
+4 ; DGHL - HL7 environment array
+5 ; DGROOT - Closed root ORU results array name
+6 ;
+7 ; Output:
+8 ; DGROOT - ORU results array
+9 ; Subscript Field name Fld# File#
+10 ; ----------------------- -------------------- ---- -----
+11 ; "SNDFAC" N/A N/A N/A
+12 ; "DFN" PATIENT NAME .01 26.13
+13 ; "FLAG" FLAG NAME .02 26.13
+14 ; "OWNER" OWNER SITE .04 26.13
+15 ; "ORIGSITE" ORIGINATING SITE .05 26.13
+16 ; "NARR",line ASSIGNMENT NARRATIVE 1 26.13
+17 ; assigndt,"ACTION" ACTION .03 26.13
+18 ; assigndt,"COMMENT",line HISTORY COMMENTS 1 26.14
+19 ; DGPFERR - Undefined on success, ERR segment data array on failure
+20 ; Format: DGPFERR(seg_id,sequence,fld_pos)=error_code
+21 ;
+22 ;field separator
NEW DGFS
+23 ;component separator
NEW DGCS
+24 ;repetition separator
NEW DGRS
+25 ;current segment line
NEW DGCURLIN
+26 ;segment field data array
NEW DGSEG
+27 ;error processing array
NEW DGERR
+28 ;
+29 SET DGFS=DGHL("FS")
+30 SET DGCS=$EXTRACT(DGHL("ECH"),1)
+31 SET DGRS=$EXTRACT(DGHL("ECH"),2)
+32 SET HLECH=DGHL("ECH")
SET HLFS=DGHL("FS")
+33 SET DGCURLIN=0
+34 ;
+35 ;loop through message segments and retrieve field data
+36 FOR
Begin DoDot:1
+37 NEW DGSEG
+38 SET DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
+39 if 'DGCURLIN
QUIT
+40 DO @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGROOT,.DGPFERR)")
End DoDot:1
if 'DGCURLIN
QUIT
+41 ;
MSH(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGORU - Closed root ORU results array name
+7 ;
+8 ; Output:
+9 ; DGORU - ORU results array
+10 ; Subscript
+11 ; ---------
+12 ; "SNDFAC"
+13 ; DGERR - undefined on success, error array on failure
+14 ; format: DGERR(seg_id,sequence,fld_pos)=error code
+15 ;
+16 SET @DGORU@("SNDFAC")=$$IEN^XUAF4($PIECE(DGSEG(4),DGCS,1))
+17 QUIT
+18 ;
PID(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - PID segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGORU - Closed root ORU results array name
+7 ;
+8 ; Output:
+9 ; DGORU - ORU results array
+10 ; Subscript
+11 ; ---------
+12 ; "DFN"
+13 ; DGERR - undefined on success, error array on failure
+14 ; format: DGERR(seg_id,sequence,fld_pos)=error code
+15 ;
+16 NEW DGARR
+17 NEW DGDFNERR
+18 NEW DGICN
+19 ;
+20 SET DGICN=+$PIECE(DGSEG(3),DGCS,1)
+21 SET DGARR("DFN")=$$GETDFN^DGPFUT2(DGICN,"DGDFNERR")
+22 IF 'DGARR("DFN")
IF $GET(DGDFNERR("DIERR",1))]""
Begin DoDot:1
+23 ;no match
SET DGERR("PID",DGSEG(1),3)=DGDFNERR("DIERR",1)
End DoDot:1
+24 ;
+25 ;load results array
+26 SET @DGORU@("DFN")=DGARR("DFN")
+27 QUIT
+28 ;
OBR(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - OBR segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGORU - Closed root ORU results array name
+7 ;
+8 ; Output:
+9 ; DGORU - ORU results array
+10 ; Subscript
+11 ; ----------------
+12 ; "FLAG"
+13 ; "OWNER"
+14 ; "ORIGSITE"
+15 ; DGERR - undefined on success, error array on failure
+16 ; format: DGERR(seg_id,sequence,fld_pos)=error code
+17 ;
+18 NEW DGARR
+19 ; ien of received PRF flag in file 26.15
NEW PRFFLG
+20 ;
+21 SET PRFFLG=+$$FIND1^DIC(26.15,,"X",$$DECHL7^DGPFHLUT($PIECE($GET(DGSEG(4)),DGCS,2)))
+22 SET DGARR("FLAG")=PRFFLG_";DGPF(26.15,"
+23 IF '$$TESTVAL^DGPFUT(26.13,.02,DGARR("FLAG"))
Begin DoDot:1
+24 ;invalid flag
SET DGERR("OBR",DGSEG(1),4)=261111
+25 QUIT
End DoDot:1
+26 ;
+27 SET DGARR("OWNER")=$$IEN^XUAF4(DGSEG(20))
+28 IF (DGARR("OWNER")="")!('$$TESTVAL^DGPFUT(26.13,.04,DGARR("OWNER")))
Begin DoDot:1
+29 ;invalid owner site
SET DGERR("OBR",DGSEG(1),20)=261126
+30 QUIT
End DoDot:1
+31 ;
+32 SET DGARR("ORIGSITE")=$$IEN^XUAF4($GET(DGSEG(21)))
+33 IF DGARR("ORIGSITE")=""
SET DGARR("ORIGSITE")=@DGORU@("SNDFAC")
+34 IF (DGARR("ORIGSITE")="")!('$$TESTVAL^DGPFUT(26.13,.05,DGARR("ORIGSITE")))
Begin DoDot:1
+35 ;invalid originating site
SET DGERR("OBR",DGSEG(1),21)=261125
+36 QUIT
End DoDot:1
+37 ;
+38 ;load results array
+39 MERGE @DGORU=DGARR
+40 QUIT
+41 ;
OBX(DGSEG,DGCS,DGRS,DGORU,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - OBX segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGORU - Closed root ORU results array name
+7 ;
+8 ; Output:
+9 ; DGORU - ORU results array
+10 ; Subscript
+11 ; -----------------------
+12 ; "NARR",line
+13 ; assigndt,"ACTION"
+14 ; assigndt,"COMMENT",line
+15 ; DGERR - undefined on success, error array on failure
+16 ; format: DGERR(seg_id,sequence,fld_pos)=error code
+17 ;
+18 ;assignment date
NEW DGADT
+19 NEW DGI
+20 ;word processing line count
NEW DGLINE
+21 NEW DGRSLT,DBRSACT,DBRSDT,DBRSNUM,DBRSOTH,DBRSSITE
+22 ;
+23 ; Narrative Observation Identifier
+24 IF $PIECE(DGSEG(3),DGCS,1)="N"
Begin DoDot:1
+25 SET DGLINE=$ORDER(@DGORU@("NARR",""),-1)
+26 FOR DGI=1:1:$LENGTH(DGSEG(5),DGRS)
SET @DGORU@("NARR",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,DGI))
+27 QUIT
End DoDot:1
+28 ; Status Observation Identifier
+29 IF $PIECE(DGSEG(3),DGCS,1)="S"
Begin DoDot:1
+30 SET DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L")
if +DGADT'>0
QUIT
+31 DO CHK^DIE(26.14,.03,,$$DECHL7^DGPFHLUT(DGSEG(5)),.DGRSLT)
+32 SET @DGORU@(DGADT,"ACTION")=+DGRSLT
+33 QUIT
End DoDot:1
+34 ; Comment Observation Identifier
+35 IF $PIECE(DGSEG(3),DGCS,1)="C"
Begin DoDot:1
+36 SET DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L")
if +DGADT'>0
QUIT
+37 SET DGLINE=$ORDER(@DGORU@(DGADT,"COMMENT",""),-1)
+38 FOR DGI=1:1:$LENGTH(DGSEG(5),DGRS)
SET @DGORU@(DGADT,"COMMENT",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,DGI))
+39 SET @DGORU@(DGADT,"ORIGFAC")=$$IEN^XUAF4($PIECE($GET(DGSEG(23)),DGCS,3))
+40 QUIT
End DoDot:1
+41 ; DBRS Observation Identifier
+42 IF $PIECE(DGSEG(3),DGCS,1)="D"
Begin DoDot:1
+43 ; "U" = add/update, "D" = delete
SET DBRSACT=$SELECT($PIECE(DGSEG(3),DGCS,2)="DBRS-Delete":"D",1:"U")
+44 ; DBRS #
SET DBRSNUM=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,1))
if DBRSNUM=""
QUIT
+45 ; DBRS OTHER
SET DBRSOTH=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,2))
+46 ; DBRS date
SET DBRSDT=+$$HL7TFM^XLFDT(DGSEG(14),"L")
+47 ; DBRS creating site
SET DBRSSITE=$$IEN^XUAF4($PIECE($GET(DGSEG(23)),DGCS,3))
+48 SET @DGORU@("DBRS",DBRSNUM,"ACTION")=DBRSACT
+49 SET @DGORU@("DBRS",DBRSNUM,"OTHER")=DBRSOTH
+50 SET @DGORU@("DBRS",DBRSNUM,"DATE")=DBRSDT
+51 SET @DGORU@("DBRS",DBRSNUM,"SITE")=$SELECT(DBRSSITE>0:DBRSSITE,1:"")
+52 QUIT
End DoDot:1
+53 QUIT
