- 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 Jan 18, 2025@03:48:24 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