DGPFHLQ ;ALB/RPM - PRF HL7 QRY/ORF PROCESSING ; 1/23/03
;;5.3;Registration;**425,650,951,1135,1148**;Aug 13, 1993;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
BLDQRY(DGDFN,DGICN,DGROOT,DGHL) ;Build QRY~R02 Message/Segments
;
; Input:
; DGDFN - (required) Pointer to patient in PATIENT (#2) file
; DGICN - (required) Patient's Integrated Control Number
; DGROOT - (required) Closed root array or global name for segment
; storage.
; DGHL - (required) VistA HL7 environment array
;
; Output:
; Function Value - 1 on success, 0 on failure
; DGROOT - array of HL7 segments on success
;
N DGCNT ;segment counter
N DGDEM ;pt. demographics array
N DGQRD ;formatted QRD segment
N DGQRF ;formatted QRF segment
N DGRSLT ;function value
N DGSTR ;field string
;
S DGRSLT=0
S DGCNT=0
;
I +$G(DGDFN),+$G(DGICN),$G(DGROOT)]"" D
. ;
. ;get patient demographics
. Q:'$$GETPAT^DGPFUT2(DGDFN,.DGDEM)
. ;
. ;build QRD
. S DGSTR="1,2,3,4,7,8,9,10"
. S DGQRD=$$QRD^DGPFHLQ1(DGDFN,DGICN,DGSTR,.DGHL)
. Q:(DGQRD="")
. S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGQRD
. ;
. ;build QRF
. S DGSTR="1,4,5"
. S DGQRF=$$QRF^DGPFHLQ2($G(DGDEM("SSN")),$G(DGDEM("DOB")),DGSTR,.DGHL)
. Q:(DGQRF="")
. S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGQRF
. ;
. S DGRSLT=1
Q DGRSLT
;
BLDORF(DGROOT,DGHL,DGDFN,DGQRY,DGSEGERR,DGQRYERR) ;Build ORF~R04 Message/Segments
;
; Input:
; DGROOT - (required) Segment array
; DGHL - (required) HL7 environment array
; DGDFN - (required) Pointer to patient in PATIENT (#2) file
; DGQRY - (required) Array of parsed QRY data
; DGSEGERR - (optional) Array of errors encountered during QRY parsing
; DGQRYERR - (optional) Error encountered during ICN to DFN conversion
;
; Output:
; Function Value - 1 on success, 0 on failure
;
N DGACK ;acknowledgment code (i.e. AA, AE)
N DGAIENS ;array of assignment IENS
N DGCNT ;segment counter
N DGI ;generic index
N DGOBROOT ;temporary storage of OBR/OBX segments
N DGRSLT ;function value
N DGSEGSTR ;formatted segment string
N DGSTR ;comma-delimited list of fields to include
;
S DGRSLT=0
S DGOBROOT=$NA(^TMP("DGPF OB",$J))
K @DGOBROOT
;
I $G(DGROOT)]"",$D(DGQRY) D
. S DGCNT=0
. S DGACK=$S($D(DGSEGERR):"AE",$D(DGQRYERR):"AE",1:"AA")
. ;
. ;build OBR/OBX segments for any Category I record flag assignments
. I DGACK="AA",$$GETALL^DGPFAA($G(DGDFN),.DGAIENS,"",1) D
. . ;
. . ;build and temporarily store OBR/OBX segments
. . Q:$$BLDALLOB(DGOBROOT,.DGAIENS,.DGHL)
. . ;
. . ;if we get here then the data retrieval failed
. . S DGQRYERR=261130 ;unable to retrieve existing assignments
. . S DGACK="AE"
. . K @DGOBROOT
. ;
. ;build MSA segment
. S DGSTR=$S($D(DGQRYERR):"1,2,6",1:"1,2")
. S DGSEGSTR=$$MSA^DGPFHLU3(DGACK,DGHL("MID"),.DGQRYERR,DGSTR,.DGHL)
. Q:(DGSEGSTR="")
. S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR
. ;
. ;build ERR segments for any segment parsing errors
. I $D(DGSEGERR),'$$BLDERR^DGPFHLU4(DGROOT,.DGSEGERR,.DGHL,.DGCNT) Q
. ;
. ;build QRD segment
. S DGSTR="1,2,3,4,7,8,9,10"
. S DGSEGSTR=$$QRD^DGPFHLQ1($G(DGQRY("QID")),$G(DGQRY("ICN")),DGSTR,.DGHL)
. Q:(DGSEGSTR="")
. S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR
. ;
. ;move any OBR/OBX segments into the message
. S DGI=0
. F S DGI=$O(@DGOBROOT@(DGI)) Q:'DGI D
. . S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=@DGOBROOT@(DGI)
. ;
. ;success
. S DGRSLT=1
;
;cleanup
K @DGOBROOT
;
Q DGRSLT
;
BLDALLOB(DGROOT,DGAIENS,DGHL) ;build all OBRs and OBXs for a patient
;
; Input:
; DGROOT - (required) Closed root array or global name for segment
; storage.
; DGAIENS - (required) Array of pointers to PRF ASSIGNMENT (#26.13) file
; DGHL - (required) VistA HL7 environment array
;
; Output:
; Function Value - 1 on success, 0 on failure
; DGROOT - array of HL7 segments on success
;
N DGAIEN ;single assignment IEN
N DGCNT ;segment counter
N DGHIEN ;single assignment history IEN
N DGHIENS ;array of assignment history IENs
N DGOBRSET ;OBR segment Set ID
N DGOBXOK ;OBX segment creation flag
N DGOBXSET ;OBX segment Set ID
N DGPFA ;assignment data array
N DGPFAH ;assignment history data array
N DGRSLT ;function value
N DGSEGSTR ;formatted segment string
N DGSTR ;comma-delimited list of fields to include
N DGTROOT ;closed root name of text array value
N LASTH ;last assignment history entry
N DBRSSTR,Z
;
S (DGCNT,DGRSLT)=0
I $G(DGROOT)]"",$D(DGAIENS) D
.S (DGAIEN,DGOBRSET)=0
.F S DGAIEN=$O(DGAIENS(DGAIEN)) Q:'DGAIEN D
..N DGHIENS ;array of assignment history IENS
..N DGPFA ;assignment data array
..;get assignment details
..Q:'$$GETASGN^DGPFAA(DGAIEN,.DGPFA)
..;get last assignment history for narrative observation date
..Q:'$$GETHIST^DGPFAAH($$GETLAST^DGPFAAH(DGAIEN),.DGPFAH,1)
..K LASTH M LASTH=DGPFAH
..;build OBR segment for this assignment
..S DGSTR="1,4,7,20,21"
..S DGOBRSET=DGOBRSET+1
..S DGSEGSTR=$$OBR^DGPFHLU1(DGOBRSET,.DGPFA,.DGPFAH,DGSTR,.DGHL)
..Q:DGSEGSTR=""
..S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR
..;build narrative OBX segment for this assignment
..S DGOBXSET=0
..S DGTROOT="DGPFA(""NARR"")"
..Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGCNT,.DGOBXSET)
..;get a list of all assignment histories
..Q:'$$GETALL^DGPFAAH(DGAIEN,.DGHIENS)
..S DGSTR="1,2,3,5,11,14,23"
..;loop through each assignment history entry
..S DGHIEN=0 F S DGHIEN=$O(DGHIENS(DGHIEN)) Q:'DGHIEN D Q:'DGOBXOK
...N DGPFAH
...S DGOBXOK=0
...;get single assignment history record
...Q:'$$GETHIST^DGPFAAH(DGHIEN,.DGPFAH)
...;build status OBX segment for this history record
...S DGOBXSET=DGOBXSET+1
...S DGSEGSTR=$$OBX^DGPFHLU2(DGOBXSET,"S","",$P($G(DGPFAH("ACTION")),U,2),.DGPFAH,DGSTR,.DGHL)
...Q:DGSEGSTR=""
...S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR
...;build review comment OBX segments for this history record
...S DGTROOT="DGPFAH(""COMMENT"")"
...Q:'$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGCNT,.DGOBXSET)
...S DGOBXOK=1
...Q
..Q:'DGOBXOK ;quit if issue with building history segment
..; build DBRS OBX segments
..; ORF message never updates existing assignment records, so send all DBRS data except for deleted entries
..; regardless of the action code in 26.14.
..S DGDBRSOK=1
..S Z="" F S Z=$O(LASTH("DBRS",Z)) Q:Z="" D
...S DBRSSTR=$G(LASTH("DBRS",Z))
...; don't send deleted DBRS entries
...I $P($P(DBRSSTR,U,4),";")="D" Q
...S DGDBRSOK=0
...S DGOBXSET=DGOBXSET+1
...S DGSEGSTR=$$OBX^DGPFHLU2(DGOBXSET,"D","",DBRSSTR,.LASTH,"1,2,3,5,11,14,23",.DGHL)
...Q:DGSEGSTR=""
...S DGCNT=DGCNT+1,@DGROOT@(DGCNT)=DGSEGSTR
...S DGDBRSOK=1
...Q
..Q:'DGDBRSOK
..S DGRSLT=1
..Q
.Q
Q DGRSLT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLQ 6986 printed Sep 23, 2025@20:23:32 Page 2
DGPFHLQ ;ALB/RPM - PRF HL7 QRY/ORF PROCESSING ; 1/23/03
+1 ;;5.3;Registration;**425,650,951,1135,1148**;Aug 13, 1993;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BLDQRY(DGDFN,DGICN,DGROOT,DGHL) ;Build QRY~R02 Message/Segments
+1 ;
+2 ; Input:
+3 ; DGDFN - (required) Pointer to patient in PATIENT (#2) file
+4 ; DGICN - (required) Patient's Integrated Control Number
+5 ; DGROOT - (required) Closed root array or global name for segment
+6 ; storage.
+7 ; DGHL - (required) VistA HL7 environment array
+8 ;
+9 ; Output:
+10 ; Function Value - 1 on success, 0 on failure
+11 ; DGROOT - array of HL7 segments on success
+12 ;
+13 ;segment counter
NEW DGCNT
+14 ;pt. demographics array
NEW DGDEM
+15 ;formatted QRD segment
NEW DGQRD
+16 ;formatted QRF segment
NEW DGQRF
+17 ;function value
NEW DGRSLT
+18 ;field string
NEW DGSTR
+19 ;
+20 SET DGRSLT=0
+21 SET DGCNT=0
+22 ;
+23 IF +$GET(DGDFN)
IF +$GET(DGICN)
IF $GET(DGROOT)]""
Begin DoDot:1
+24 ;
+25 ;get patient demographics
+26 if '$$GETPAT^DGPFUT2(DGDFN,.DGDEM)
QUIT
+27 ;
+28 ;build QRD
+29 SET DGSTR="1,2,3,4,7,8,9,10"
+30 SET DGQRD=$$QRD^DGPFHLQ1(DGDFN,DGICN,DGSTR,.DGHL)
+31 if (DGQRD="")
QUIT
+32 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGQRD
+33 ;
+34 ;build QRF
+35 SET DGSTR="1,4,5"
+36 SET DGQRF=$$QRF^DGPFHLQ2($GET(DGDEM("SSN")),$GET(DGDEM("DOB")),DGSTR,.DGHL)
+37 if (DGQRF="")
QUIT
+38 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGQRF
+39 ;
+40 SET DGRSLT=1
End DoDot:1
+41 QUIT DGRSLT
+42 ;
BLDORF(DGROOT,DGHL,DGDFN,DGQRY,DGSEGERR,DGQRYERR) ;Build ORF~R04 Message/Segments
+1 ;
+2 ; Input:
+3 ; DGROOT - (required) Segment array
+4 ; DGHL - (required) HL7 environment array
+5 ; DGDFN - (required) Pointer to patient in PATIENT (#2) file
+6 ; DGQRY - (required) Array of parsed QRY data
+7 ; DGSEGERR - (optional) Array of errors encountered during QRY parsing
+8 ; DGQRYERR - (optional) Error encountered during ICN to DFN conversion
+9 ;
+10 ; Output:
+11 ; Function Value - 1 on success, 0 on failure
+12 ;
+13 ;acknowledgment code (i.e. AA, AE)
NEW DGACK
+14 ;array of assignment IENS
NEW DGAIENS
+15 ;segment counter
NEW DGCNT
+16 ;generic index
NEW DGI
+17 ;temporary storage of OBR/OBX segments
NEW DGOBROOT
+18 ;function value
NEW DGRSLT
+19 ;formatted segment string
NEW DGSEGSTR
+20 ;comma-delimited list of fields to include
NEW DGSTR
+21 ;
+22 SET DGRSLT=0
+23 SET DGOBROOT=$NAME(^TMP("DGPF OB",$JOB))
+24 KILL @DGOBROOT
+25 ;
+26 IF $GET(DGROOT)]""
IF $DATA(DGQRY)
Begin DoDot:1
+27 SET DGCNT=0
+28 SET DGACK=$SELECT($DATA(DGSEGERR):"AE",$DATA(DGQRYERR):"AE",1:"AA")
+29 ;
+30 ;build OBR/OBX segments for any Category I record flag assignments
+31 IF DGACK="AA"
IF $$GETALL^DGPFAA($GET(DGDFN),.DGAIENS,"",1)
Begin DoDot:2
+32 ;
+33 ;build and temporarily store OBR/OBX segments
+34 if $$BLDALLOB(DGOBROOT,.DGAIENS,.DGHL)
QUIT
+35 ;
+36 ;if we get here then the data retrieval failed
+37 ;unable to retrieve existing assignments
SET DGQRYERR=261130
+38 SET DGACK="AE"
+39 KILL @DGOBROOT
End DoDot:2
+40 ;
+41 ;build MSA segment
+42 SET DGSTR=$SELECT($DATA(DGQRYERR):"1,2,6",1:"1,2")
+43 SET DGSEGSTR=$$MSA^DGPFHLU3(DGACK,DGHL("MID"),.DGQRYERR,DGSTR,.DGHL)
+44 if (DGSEGSTR="")
QUIT
+45 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGSEGSTR
+46 ;
+47 ;build ERR segments for any segment parsing errors
+48 IF $DATA(DGSEGERR)
IF '$$BLDERR^DGPFHLU4(DGROOT,.DGSEGERR,.DGHL,.DGCNT)
QUIT
+49 ;
+50 ;build QRD segment
+51 SET DGSTR="1,2,3,4,7,8,9,10"
+52 SET DGSEGSTR=$$QRD^DGPFHLQ1($GET(DGQRY("QID")),$GET(DGQRY("ICN")),DGSTR,.DGHL)
+53 if (DGSEGSTR="")
QUIT
+54 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGSEGSTR
+55 ;
+56 ;move any OBR/OBX segments into the message
+57 SET DGI=0
+58 FOR
SET DGI=$ORDER(@DGOBROOT@(DGI))
if 'DGI
QUIT
Begin DoDot:2
+59 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=@DGOBROOT@(DGI)
End DoDot:2
+60 ;
+61 ;success
+62 SET DGRSLT=1
End DoDot:1
+63 ;
+64 ;cleanup
+65 KILL @DGOBROOT
+66 ;
+67 QUIT DGRSLT
+68 ;
BLDALLOB(DGROOT,DGAIENS,DGHL) ;build all OBRs and OBXs for a patient
+1 ;
+2 ; Input:
+3 ; DGROOT - (required) Closed root array or global name for segment
+4 ; storage.
+5 ; DGAIENS - (required) Array of pointers to PRF ASSIGNMENT (#26.13) file
+6 ; DGHL - (required) VistA HL7 environment array
+7 ;
+8 ; Output:
+9 ; Function Value - 1 on success, 0 on failure
+10 ; DGROOT - array of HL7 segments on success
+11 ;
+12 ;single assignment IEN
NEW DGAIEN
+13 ;segment counter
NEW DGCNT
+14 ;single assignment history IEN
NEW DGHIEN
+15 ;array of assignment history IENs
NEW DGHIENS
+16 ;OBR segment Set ID
NEW DGOBRSET
+17 ;OBX segment creation flag
NEW DGOBXOK
+18 ;OBX segment Set ID
NEW DGOBXSET
+19 ;assignment data array
NEW DGPFA
+20 ;assignment history data array
NEW DGPFAH
+21 ;function value
NEW DGRSLT
+22 ;formatted segment string
NEW DGSEGSTR
+23 ;comma-delimited list of fields to include
NEW DGSTR
+24 ;closed root name of text array value
NEW DGTROOT
+25 ;last assignment history entry
NEW LASTH
+26 NEW DBRSSTR,Z
+27 ;
+28 SET (DGCNT,DGRSLT)=0
+29 IF $GET(DGROOT)]""
IF $DATA(DGAIENS)
Begin DoDot:1
+30 SET (DGAIEN,DGOBRSET)=0
+31 FOR
SET DGAIEN=$ORDER(DGAIENS(DGAIEN))
if 'DGAIEN
QUIT
Begin DoDot:2
+32 ;array of assignment history IENS
NEW DGHIENS
+33 ;assignment data array
NEW DGPFA
+34 ;get assignment details
+35 if '$$GETASGN^DGPFAA(DGAIEN,.DGPFA)
QUIT
+36 ;get last assignment history for narrative observation date
+37 if '$$GETHIST^DGPFAAH($$GETLAST^DGPFAAH(DGAIEN),.DGPFAH,1)
QUIT
+38 KILL LASTH
MERGE LASTH=DGPFAH
+39 ;build OBR segment for this assignment
+40 SET DGSTR="1,4,7,20,21"
+41 SET DGOBRSET=DGOBRSET+1
+42 SET DGSEGSTR=$$OBR^DGPFHLU1(DGOBRSET,.DGPFA,.DGPFAH,DGSTR,.DGHL)
+43 if DGSEGSTR=""
QUIT
+44 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGSEGSTR
+45 ;build narrative OBX segment for this assignment
+46 SET DGOBXSET=0
+47 SET DGTROOT="DGPFA(""NARR"")"
+48 if '$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"N",.DGPFAH,.DGHL,.DGCNT,.DGOBXSET)
QUIT
+49 ;get a list of all assignment histories
+50 if '$$GETALL^DGPFAAH(DGAIEN,.DGHIENS)
QUIT
+51 SET DGSTR="1,2,3,5,11,14,23"
+52 ;loop through each assignment history entry
+53 SET DGHIEN=0
FOR
SET DGHIEN=$ORDER(DGHIENS(DGHIEN))
if 'DGHIEN
QUIT
Begin DoDot:3
+54 NEW DGPFAH
+55 SET DGOBXOK=0
+56 ;get single assignment history record
+57 if '$$GETHIST^DGPFAAH(DGHIEN,.DGPFAH)
QUIT
+58 ;build status OBX segment for this history record
+59 SET DGOBXSET=DGOBXSET+1
+60 SET DGSEGSTR=$$OBX^DGPFHLU2(DGOBXSET,"S","",$PIECE($GET(DGPFAH("ACTION")),U,2),.DGPFAH,DGSTR,.DGHL)
+61 if DGSEGSTR=""
QUIT
+62 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGSEGSTR
+63 ;build review comment OBX segments for this history record
+64 SET DGTROOT="DGPFAH(""COMMENT"")"
+65 if '$$BLDOBXTX^DGPFHLU2(DGROOT,DGTROOT,"C",.DGPFAH,.DGHL,.DGCNT,.DGOBXSET)
QUIT
+66 SET DGOBXOK=1
+67 QUIT
End DoDot:3
if 'DGOBXOK
QUIT
+68 ;quit if issue with building history segment
if 'DGOBXOK
QUIT
+69 ; build DBRS OBX segments
+70 ; ORF message never updates existing assignment records, so send all DBRS data except for deleted entries
+71 ; regardless of the action code in 26.14.
+72 SET DGDBRSOK=1
+73 SET Z=""
FOR
SET Z=$ORDER(LASTH("DBRS",Z))
if Z=""
QUIT
Begin DoDot:3
+74 SET DBRSSTR=$GET(LASTH("DBRS",Z))
+75 ; don't send deleted DBRS entries
+76 IF $PIECE($PIECE(DBRSSTR,U,4),";")="D"
QUIT
+77 SET DGDBRSOK=0
+78 SET DGOBXSET=DGOBXSET+1
+79 SET DGSEGSTR=$$OBX^DGPFHLU2(DGOBXSET,"D","",DBRSSTR,.LASTH,"1,2,3,5,11,14,23",.DGHL)
+80 if DGSEGSTR=""
QUIT
+81 SET DGCNT=DGCNT+1
SET @DGROOT@(DGCNT)=DGSEGSTR
+82 SET DGDBRSOK=1
+83 QUIT
End DoDot:3
+84 if 'DGDBRSOK
QUIT
+85 SET DGRSLT=1
+86 QUIT
End DoDot:2
+87 QUIT
End DoDot:1
+88 QUIT DGRSLT
