DGPFHLU ;ALB/RPM - PRF HL7 ORU/ACK PROCESSING ; 6/21/06 10:27am
;;5.3;Registration;**425,718,650,1015**;Aug 13, 1993;Build 21
;
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 DGSTR ;field string
N DGTROOT ;text root
;
S DGHIEN=0
S DGSEG=0
;
I $D(DGPFA),$D(DGHARR),$G(DGROOT)]"" D
. ;
. ;build PID
. S DGSTR="1,2,3,5,7,8,19"
. S DGSEGSTR=$$EN^VAFHLPID(+DGPFA("DFN"),DGSTR,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) ;load asgn hx array
. S DGSET=1
. S DGSTR="1,4,7,20,21"
. S DGSEGSTR=$$OBR^DGPFHLU1(DGSET,.DGPFA,.DGPFAH,DGSTR,.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 DGSTR="1,2,3,5,11,14"
. . S DGSET=DGSET+1
. . S DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"S","",$P($G(DGPFAH("ACTION")),U,2),.DGPFAH,DGSTR,.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 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 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
;
S DGARR("FLAG")=$P($G(DGSEG(4)),DGCS,1)_";DGPF(26.15,"
I '$$TESTVAL^DGPFUT(26.13,.02,DGARR("FLAG")) D
. S DGERR("OBR",DGSEG(1),4)=261111 ;invalid flag
;
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
;
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
;
;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
;
; 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) D
. . S @DGORU@("NARR",DGLINE+DGI,0)=$P(DGSEG(5),DGRS,DGI)
;
; 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,,DGSEG(5),.DGRSLT)
. S @DGORU@(DGADT,"ACTION")=+DGRSLT
;
; 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) D
. . S @DGORU@(DGADT,"COMMENT",DGLINE+DGI,0)=$P(DGSEG(5),DGRS,DGI)
Q
DGPFHLU ;ALB/RPM - PRF HL7 ORU/ACK PROCESSING ; 6/21/06 10:27am
+1 ;;5.3;Registration;**425,718,650,1015**;Aug 13, 1993;Build 21
+2 ;
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 ;field string
NEW DGSTR
+21 ;text root
NEW DGTROOT
+22 ;
+23 SET DGHIEN=0
+24 SET DGSEG=0
+25 ;
+26 IF $DATA(DGPFA)
IF $DATA(DGHARR)
IF $GET(DGROOT)]""
Begin DoDot:1
+27 ;
+28 ;build PID
+29 SET DGSTR="1,2,3,5,7,8,19"
+30 SET DGSEGSTR=$$EN^VAFHLPID(+DGPFA("DFN"),DGSTR,1,1)
+31 IF (DGSEGSTR="")
QUIT
+32 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+33 ;
+34 ;build OBR
+35 ;get last assignment date
SET DGLDT=+$ORDER(DGHARR(""),-1)
+36 ;load asgn hx array
IF '$$GETHIST^DGPFAAH(DGHARR(DGLDT),.DGPFAH)
QUIT
+37 SET DGSET=1
+38 SET DGSTR="1,4,7,20,21"
+39 SET DGSEGSTR=$$OBR^DGPFHLU1(DGSET,.DGPFA,.DGPFAH,DGSTR,.DGHL)
+40 IF (DGSEGSTR="")
QUIT
+41 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+42 ;
+43 ;start OBX segments
+44 SET DGSET=0
+45 ;
+46 ;build narrative OBX segments
+47 SET DGTROOT="DGPFA(""NARR"")"
+48 IF '$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGSEG,.DGSET)
QUIT
+49 ;
+50 ;for each history build status & comment OBX segments
+51 SET DGADT=0
+52 FOR
SET DGADT=$ORDER(DGHARR(DGADT))
IF 'DGADT
QUIT
Begin DoDot:2
+53 NEW DGPFAH
+54 SET DGHIEN=0
+55 IF '$$GETHIST^DGPFAAH(DGHARR(DGADT),.DGPFAH)
QUIT
+56 ;
+57 ;build status OBX segment
+58 SET DGSTR="1,2,3,5,11,14"
+59 SET DGSET=DGSET+1
+60 SET DGSEGSTR=$$OBX^DGPFHLU2(DGSET,"S","",$PIECE($GET(DGPFAH("ACTION")),U,2),.DGPFAH,DGSTR,.DGHL)
+61 IF (DGSEGSTR="")
QUIT
+62 SET DGSEG=DGSEG+1
SET @DGROOT@(DGSEG)=DGSEGSTR
+63 ;
+64 ;build review comment OBX segments
+65 SET DGTROOT="DGPFAH(""COMMENT"")"
+66 IF '$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGSEG,.DGSET)
QUIT
+67 ;
+68 ;success
+69 SET DGHIEN=DGHARR(DGADT)
End DoDot:2
IF 'DGHIEN
QUIT
End DoDot:1
+70 ;
+71 QUIT DGHIEN
+72 ;
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 DGCURLIN=0
+33 ;
+34 ;loop through message segments and retrieve field data
+35 FOR
Begin DoDot:1
+36 NEW DGSEG
+37 SET DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
+38 IF 'DGCURLIN
QUIT
+39 DO @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGROOT,.DGPFERR)")
End DoDot:1
IF 'DGCURLIN
QUIT
+40 ;
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 ;
+20 SET DGARR("FLAG")=$PIECE($GET(DGSEG(4)),DGCS,1)_";DGPF(26.15,"
+21 IF '$$TESTVAL^DGPFUT(26.13,.02,DGARR("FLAG"))
Begin DoDot:1
+22 ;invalid flag
SET DGERR("OBR",DGSEG(1),4)=261111
End DoDot:1
+23 ;
+24 SET DGARR("OWNER")=$$IEN^XUAF4(DGSEG(20))
+25 IF (DGARR("OWNER")="")!('$$TESTVAL^DGPFUT(26.13,.04,DGARR("OWNER")))
Begin DoDot:1
+26 ;invalid owner site
SET DGERR("OBR",DGSEG(1),20)=261126
End DoDot:1
+27 ;
+28 SET DGARR("ORIGSITE")=$$IEN^XUAF4($GET(DGSEG(21)))
+29 IF DGARR("ORIGSITE")=""
SET DGARR("ORIGSITE")=@DGORU@("SNDFAC")
+30 IF (DGARR("ORIGSITE")="")!('$$TESTVAL^DGPFUT(26.13,.05,DGARR("ORIGSITE")))
Begin DoDot:1
+31 ;invalid originating site
SET DGERR("OBR",DGSEG(1),21)=261125
End DoDot:1
+32 ;
+33 ;load results array
+34 MERGE @DGORU=DGARR
+35 QUIT
+36 ;
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
+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)
Begin DoDot:2
+27 SET @DGORU@("NARR",DGLINE+DGI,0)=$PIECE(DGSEG(5),DGRS,DGI)
End DoDot:2
End DoDot:1
+28 ;
+29 ; Status Observation Identifier
+30 IF $PIECE(DGSEG(3),DGCS,1)="S"
Begin DoDot:1
+31 SET DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L")
+32 IF +DGADT'>0
QUIT
+33 DO CHK^DIE(26.14,.03,,DGSEG(5),.DGRSLT)
+34 SET @DGORU@(DGADT,"ACTION")=+DGRSLT
End DoDot:1
+35 ;
+36 ; Comment Observation Identifier
+37 IF $PIECE(DGSEG(3),DGCS,1)="C"
Begin DoDot:1
+38 SET DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L")
+39 IF +DGADT'>0
QUIT
+40 SET DGLINE=$ORDER(@DGORU@(DGADT,"COMMENT",""),-1)
+41 FOR DGI=1:1:$LENGTH(DGSEG(5),DGRS)
Begin DoDot:2
+42 SET @DGORU@(DGADT,"COMMENT",DGLINE+DGI,0)=$PIECE(DGSEG(5),DGRS,DGI)
End DoDot:2
End DoDot:1
+43 QUIT
