DGPFHLQ4 ;ALB/RPM - PRF HL7 ORF PROCESSING ; 12/13/04
;;5.3;Registration;**425,650,951**;Aug 13, 1993;Build 135
;;Per VA Directive 6402, this routine should not be modified.
;
PARSORF(DGWRK,DGHL,DGROOT,DGMSG) ;Parse ORF~R04 Message/Segments
;
; Input:
; DGWRK - Closed root work global reference
; DGHL - HL7 environment array
; DGROOT - Closed root ORF results array
;
; Output:
; DGROOT - array of ORF results
; OBRsetID,assigndt,"ACTION"
; OBRsetID,assigndt,"COMMENT",line#
; OBRsetID,"FLAG"
; OBRsetID,"NARR",line#
; OBRsetID,"OWNER"
; "ACKCODE" - acknowledgment code ("AA","AE","AR")
; "ICN" - patient's Integrated Control Number
; "MSGDTM" - message creation date/time in FileMan format
; "MSGID" -
; "QID" - query ID (DFN)
; "RCVFAC" - receiving facility
; "SNDFAC" - sending facility
;
; DGMSG - undefined on success, array of MailMan text on failure
;
N DGFS ;field separator
N DGCS ;component separator
N DGRS ;repetition separator
N DGSS ;sub-component separator
N DGCURLIN ;current line
;
S DGFS=DGHL("FS")
S DGCS=$E(DGHL("ECH"),1)
S DGRS=$E(DGHL("ECH"),2)
S DGSS=$E(DGHL("ECH"),4)
S HLECH=DGHL("ECH"),HLFS=DGHL("FS")
S DGCURLIN=0
;
;loop through the message segments and retrieve the field data
F D Q:'DGCURLIN
. N DGSEG
. S DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
. Q:'DGCURLIN
. D @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,DGROOT,.DGMSG)")
Q
;
MSH(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORF - array of ORF results
; "SNDFAC" - sending facility
; "RCVFAC" - receiving facility
; "MSGDTM" - message creation date/time in FileMan format
; DGERR - undefined on success, error array on failure
;
N DGARR
D MSH^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGARR,.DGERR)
I $D(DGARR) M @DGORF=DGARR
Q
;
MSA(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORF - array of ORF results
; "ACKCODE" - Acknowledgment code
; "MSGID" - Message Control ID of the message being ACK'ed
; DGERR - undefined on success, error array on failure
;
N DGARR
D MSA^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGARR,.DGERR)
I $D(DGARR) M @DGORF=DGARR
Q
;
ERR(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORF - array of ORF results
; DGERR - undefined on success, error array on failure
;
N DGARR
D ERR^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGARR,.DGERR)
I $D(DGARR) M @DGORF=DGARR
Q
;
QRD(DGSEG,DGCS,DGRS,DGSS,DGQRY,DGERR) ;
;
; Input:
; DGSEG - MSH segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGQRY("ICN") - Patient's Integrated Control Number
; DGQRY("QID") - Query ID
; DGERR - undefined on success, error array on failure
; format: DGERR(seg_id,sequence,fld_pos)=error code
;
S @DGQRY@("QID")=$G(DGSEG(4))
S @DGQRY@("ICN")=+$P($G(DGSEG(8)),DGCS,1)
Q
;
OBR(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
;
; Input:
; DGSEG - OBR segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORF(setid,"FLAG") - FLAG NAME (.02) field, file #26.13
; DGORF(setid,"OWNER") - OWNER SITE (.04) field, file #26.13
; DGORF(setid,"ORIGSITE") - ORIGINATING SITE (.05) field, file #26.13
; DGORF("SETID") - OBR segment Set ID
; DGERR - undefined on success, error array on failure
; format: DGERR(seg_id,sequence,fld_pos)=error code
N DGSETID ;OBR segment Set ID
N PRFFLG ; ien of received PRF flag in file 26.15
;
S (@DGORF@("SETID"),DGSETID)=+$G(DGSEG(1))
I DGSETID>0 D
.S PRFFLG=+$$FIND1^DIC(26.15,,"X",$$DECHL7^DGPFHLUT($P($G(DGSEG(4)),DGCS,2)))
.I 'PRFFLG S DGSTAT="RJ",DGERR($O(DGERR(""),-1)+1)=261120 Q ; bail out with "Unable to file" error
.S @DGORF@(DGSETID,"FLAG")=PRFFLG_";DGPF(26.15,"
.S @DGORF@(DGSETID,"OWNER")=$$IEN^XUAF4($G(DGSEG(20)))
.S @DGORF@(DGSETID,"ORIGSITE")=$$IEN^XUAF4($G(DGSEG(21)))
.Q
Q
;
OBX(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
;
; Input:
; DGSEG - OBX segment field array
; DGCS - HL7 component separator
; DGRS - HL7 repetition separator
; DGSS - HL7 sub-component separator
;
; Output:
; DGORF(setid,"NARR",line) - ASSIGNMENT NARRATIVE (1) field,
; file #26.13
; DGORF(setid,assigndt,"ACTION") - ACTION (.03) field,
; file #26.14
; DGORF(setid,assigndt,"COMMENT",line) - HISTORY COMMENTS (1) field,
; file #26.14
; 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 ;text line counter
N DGRSLT
N DGSETID ;OBR segment Set ID
N DGRSLT,DBRSACT,DBRSDT,DBRSNUM,DBRSOTH,DBRSSITE
;
S DGSETID=+$G(@DGORF@("SETID"))
Q:(DGSETID'>0)
; Narrative Observation Identifier
I $P(DGSEG(3),DGCS,1)="N" D
.S DGLINE=$O(@DGORF@(DGSETID,"NARR",""),-1)
.F DGI=1:1:$L(DGSEG(5),DGRS) S @DGORF@(DGSETID,"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 @DGORF@(DGSETID,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(@DGORF@(DGSETID,DGADT,"COMMENT",""),-1)
.F DGI=1:1:$L(DGSEG(5),DGRS) D
..S @DGORF@(DGSETID,DGADT,"COMMENT",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($P(DGSEG(5),DGRS,DGI))
..Q
.S @DGORF@(DGSETID,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 @DGORF@(DGSETID,"DBRS",DBRSNUM,"ACTION")=DBRSACT
.S @DGORF@(DGSETID,"DBRS",DBRSNUM,"OTHER")=DBRSOTH
.S @DGORF@(DGSETID,"DBRS",DBRSNUM,"DATE")=DBRSDT
.S @DGORF@(DGSETID,"DBRS",DBRSNUM,"SITE")=$S(DBRSSITE>0:DBRSSITE,1:"")
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLQ4 7526 printed Dec 13, 2024@02:47:43 Page 2
DGPFHLQ4 ;ALB/RPM - PRF HL7 ORF PROCESSING ; 12/13/04
+1 ;;5.3;Registration;**425,650,951**;Aug 13, 1993;Build 135
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
PARSORF(DGWRK,DGHL,DGROOT,DGMSG) ;Parse ORF~R04 Message/Segments
+1 ;
+2 ; Input:
+3 ; DGWRK - Closed root work global reference
+4 ; DGHL - HL7 environment array
+5 ; DGROOT - Closed root ORF results array
+6 ;
+7 ; Output:
+8 ; DGROOT - array of ORF results
+9 ; OBRsetID,assigndt,"ACTION"
+10 ; OBRsetID,assigndt,"COMMENT",line#
+11 ; OBRsetID,"FLAG"
+12 ; OBRsetID,"NARR",line#
+13 ; OBRsetID,"OWNER"
+14 ; "ACKCODE" - acknowledgment code ("AA","AE","AR")
+15 ; "ICN" - patient's Integrated Control Number
+16 ; "MSGDTM" - message creation date/time in FileMan format
+17 ; "MSGID" -
+18 ; "QID" - query ID (DFN)
+19 ; "RCVFAC" - receiving facility
+20 ; "SNDFAC" - sending facility
+21 ;
+22 ; DGMSG - undefined on success, array of MailMan text on failure
+23 ;
+24 ;field separator
NEW DGFS
+25 ;component separator
NEW DGCS
+26 ;repetition separator
NEW DGRS
+27 ;sub-component separator
NEW DGSS
+28 ;current line
NEW DGCURLIN
+29 ;
+30 SET DGFS=DGHL("FS")
+31 SET DGCS=$EXTRACT(DGHL("ECH"),1)
+32 SET DGRS=$EXTRACT(DGHL("ECH"),2)
+33 SET DGSS=$EXTRACT(DGHL("ECH"),4)
+34 SET HLECH=DGHL("ECH")
SET HLFS=DGHL("FS")
+35 SET DGCURLIN=0
+36 ;
+37 ;loop through the message segments and retrieve the field data
+38 FOR
Begin DoDot:1
+39 NEW DGSEG
+40 SET DGCURLIN=$$NXTSEG^DGPFHLUT(DGWRK,DGCURLIN,DGFS,.DGSEG)
+41 if 'DGCURLIN
QUIT
+42 DO @(DGSEG("TYPE")_"(.DGSEG,DGCS,DGRS,DGSS,DGROOT,.DGMSG)")
End DoDot:1
if 'DGCURLIN
QUIT
+43 QUIT
+44 ;
MSH(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORF - array of ORF results
+10 ; "SNDFAC" - sending facility
+11 ; "RCVFAC" - receiving facility
+12 ; "MSGDTM" - message creation date/time in FileMan format
+13 ; DGERR - undefined on success, error array on failure
+14 ;
+15 NEW DGARR
+16 DO MSH^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGARR,.DGERR)
+17 IF $DATA(DGARR)
MERGE @DGORF=DGARR
+18 QUIT
+19 ;
MSA(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORF - array of ORF results
+10 ; "ACKCODE" - Acknowledgment code
+11 ; "MSGID" - Message Control ID of the message being ACK'ed
+12 ; DGERR - undefined on success, error array on failure
+13 ;
+14 NEW DGARR
+15 DO MSA^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGARR,.DGERR)
+16 IF $DATA(DGARR)
MERGE @DGORF=DGARR
+17 QUIT
+18 ;
ERR(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORF - array of ORF results
+10 ; DGERR - undefined on success, error array on failure
+11 ;
+12 NEW DGARR
+13 DO ERR^DGPFHLU4(.DGSEG,DGCS,DGRS,DGSS,.DGARR,.DGERR)
+14 IF $DATA(DGARR)
MERGE @DGORF=DGARR
+15 QUIT
+16 ;
QRD(DGSEG,DGCS,DGRS,DGSS,DGQRY,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - MSH segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGQRY("ICN") - Patient's Integrated Control Number
+10 ; DGQRY("QID") - Query ID
+11 ; DGERR - undefined on success, error array on failure
+12 ; format: DGERR(seg_id,sequence,fld_pos)=error code
+13 ;
+14 SET @DGQRY@("QID")=$GET(DGSEG(4))
+15 SET @DGQRY@("ICN")=+$PIECE($GET(DGSEG(8)),DGCS,1)
+16 QUIT
+17 ;
OBR(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - OBR segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORF(setid,"FLAG") - FLAG NAME (.02) field, file #26.13
+10 ; DGORF(setid,"OWNER") - OWNER SITE (.04) field, file #26.13
+11 ; DGORF(setid,"ORIGSITE") - ORIGINATING SITE (.05) field, file #26.13
+12 ; DGORF("SETID") - OBR segment Set ID
+13 ; DGERR - undefined on success, error array on failure
+14 ; format: DGERR(seg_id,sequence,fld_pos)=error code
+15 ;OBR segment Set ID
NEW DGSETID
+16 ; ien of received PRF flag in file 26.15
NEW PRFFLG
+17 ;
+18 SET (@DGORF@("SETID"),DGSETID)=+$GET(DGSEG(1))
+19 IF DGSETID>0
Begin DoDot:1
+20 SET PRFFLG=+$$FIND1^DIC(26.15,,"X",$$DECHL7^DGPFHLUT($PIECE($GET(DGSEG(4)),DGCS,2)))
+21 ; bail out with "Unable to file" error
IF 'PRFFLG
SET DGSTAT="RJ"
SET DGERR($ORDER(DGERR(""),-1)+1)=261120
QUIT
+22 SET @DGORF@(DGSETID,"FLAG")=PRFFLG_";DGPF(26.15,"
+23 SET @DGORF@(DGSETID,"OWNER")=$$IEN^XUAF4($GET(DGSEG(20)))
+24 SET @DGORF@(DGSETID,"ORIGSITE")=$$IEN^XUAF4($GET(DGSEG(21)))
+25 QUIT
End DoDot:1
+26 QUIT
+27 ;
OBX(DGSEG,DGCS,DGRS,DGSS,DGORF,DGERR) ;
+1 ;
+2 ; Input:
+3 ; DGSEG - OBX segment field array
+4 ; DGCS - HL7 component separator
+5 ; DGRS - HL7 repetition separator
+6 ; DGSS - HL7 sub-component separator
+7 ;
+8 ; Output:
+9 ; DGORF(setid,"NARR",line) - ASSIGNMENT NARRATIVE (1) field,
+10 ; file #26.13
+11 ; DGORF(setid,assigndt,"ACTION") - ACTION (.03) field,
+12 ; file #26.14
+13 ; DGORF(setid,assigndt,"COMMENT",line) - HISTORY COMMENTS (1) field,
+14 ; file #26.14
+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 ;text line counter
NEW DGLINE
+21 NEW DGRSLT
+22 ;OBR segment Set ID
NEW DGSETID
+23 NEW DGRSLT,DBRSACT,DBRSDT,DBRSNUM,DBRSOTH,DBRSSITE
+24 ;
+25 SET DGSETID=+$GET(@DGORF@("SETID"))
+26 if (DGSETID'>0)
QUIT
+27 ; Narrative Observation Identifier
+28 IF $PIECE(DGSEG(3),DGCS,1)="N"
Begin DoDot:1
+29 SET DGLINE=$ORDER(@DGORF@(DGSETID,"NARR",""),-1)
+30 FOR DGI=1:1:$LENGTH(DGSEG(5),DGRS)
SET @DGORF@(DGSETID,"NARR",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,DGI))
+31 QUIT
End DoDot:1
+32 ; Status Observation Identifier
+33 IF $PIECE(DGSEG(3),DGCS,1)="S"
Begin DoDot:1
+34 SET DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L")
+35 if (+DGADT'>0)
QUIT
+36 DO CHK^DIE(26.14,.03,,$$DECHL7^DGPFHLUT(DGSEG(5)),.DGRSLT)
SET @DGORF@(DGSETID,DGADT,"ACTION")=+DGRSLT
+37 QUIT
End DoDot:1
+38 ; Comment Observation Identifier
+39 IF $PIECE(DGSEG(3),DGCS,1)="C"
Begin DoDot:1
+40 SET DGADT=$$HL7TFM^XLFDT(DGSEG(14),"L")
+41 if (+DGADT'>0)
QUIT
+42 SET DGLINE=$ORDER(@DGORF@(DGSETID,DGADT,"COMMENT",""),-1)
+43 FOR DGI=1:1:$LENGTH(DGSEG(5),DGRS)
Begin DoDot:2
+44 SET @DGORF@(DGSETID,DGADT,"COMMENT",DGLINE+DGI,0)=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,DGI))
+45 QUIT
End DoDot:2
+46 SET @DGORF@(DGSETID,DGADT,"ORIGFAC")=$$IEN^XUAF4($PIECE($GET(DGSEG(23)),DGCS,3))
+47 QUIT
End DoDot:1
+48 ; DBRS Observation Identifier
+49 IF $PIECE(DGSEG(3),DGCS,1)="D"
Begin DoDot:1
+50 ; "U" = add/update, "D" = delete
SET DBRSACT=$SELECT($PIECE(DGSEG(3),DGCS,2)="DBRS-Delete":"D",1:"U")
+51 ; DBRS #
SET DBRSNUM=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,1))
if DBRSNUM=""
QUIT
+52 ; DBRS OTHER
SET DBRSOTH=$$DECHL7^DGPFHLUT($PIECE(DGSEG(5),DGRS,2))
+53 ; DBRS date
SET DBRSDT=+$$HL7TFM^XLFDT(DGSEG(14),"L")
+54 ; DBRS creating site
SET DBRSSITE=$$IEN^XUAF4($PIECE($GET(DGSEG(23)),DGCS,3))
+55 SET @DGORF@(DGSETID,"DBRS",DBRSNUM,"ACTION")=DBRSACT
+56 SET @DGORF@(DGSETID,"DBRS",DBRSNUM,"OTHER")=DBRSOTH
+57 SET @DGORF@(DGSETID,"DBRS",DBRSNUM,"DATE")=DBRSDT
+58 SET @DGORF@(DGSETID,"DBRS",DBRSNUM,"SITE")=$SELECT(DBRSSITE>0:DBRSSITE,1:"")
+59 QUIT
End DoDot:1
+60 QUIT
