DGPFHLT ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
;;Per VA Directive 6402, this routine should not be modified.
;
; This is the main driver for sending QBP^Q11 (PRF flag transfer request) messages.
;
Q
;
SEND(DFN,FLAG,FCLTY,REASON) ; entry point
; DFN - Patient's DFN
; FLAG - PRF flag to transfer (ien in file 26.15)
; FCLTY - Facility to send the message to (ien in file 4)
; REASON - request reason
;
; Returns status^HL7 message id^error code^error description^error source
; status is the following set of codes:
; 0 = failure
; 1 = success
; error source is the following set of codes:
; 1 = HL7
; 2 = Filer (UPDATE^DIE)
;
N HL,HLCMP,HLECH,HLFS,HLL,HLSCMP ; HL7 variables
N DGDTM,DGFAC,DGFDA,DGERR,DGICN,DGHLLNK,DGHLRSLT,REQBY,REQID,SEGCNT
;
I +$G(DFN)'>0 Q "0^0^^Invalid DFN"
; ICN must be national
I '$$MPIOK^DGPFUT(DFN,.DGICN) Q "0^0^^Invalid ICN"
; Retrieve treating facility HL Logical Link
S DGHLLNK=$$GETLINK^DGPFHLUT(FCLTY)
I DGHLLNK=0 Q "0^0^^Unable to get HL7 logical link for facility "_$$STA^XUAF4(FCLTY)_". Please contact the National Help Desk to rectify the issue. As a workaround, please utilize the existing 'CO - Change Ownership' functionality."
;
S REQBY=$$GET1^DIQ(200,DUZ_",",.01) ; Requester's name
S DGDTM=$$NOW^XLFDT()
S REQID=$$GENQID(DGDTM) ; Next available query ID
S HLL("LINKS",1)="DGPF PRF QBP/Q11 SUBSC"_U_DGHLLNK
; Initialize the HL7
D INIT^HLFNC2("DGPF PRF QBP/Q11 EVENT",.HL)
S HLFS=HL("FS"),HLECH=HL("ECH"),HLCMP=$E(HLECH),HLSCMP=$E(HL("ECH"),4)
K ^TMP("HLS",$J)
; Create HL7 message
S SEGCNT=0
S SEGCNT=$$SAVESEG(SEGCNT,$$QPD()) ; QPD segment
S SEGCNT=$$SAVESEG(SEGCNT,$$NTE()) ; NTE segment
S SEGCNT=$$SAVESEG(SEGCNT,$$RCP()) ; RCP segment
; Send HL7 message
D GENERATE^HLMA("DGPF PRF QBP/Q11 EVENT","GM",1,.DGHLRSLT)
; DHLRSLT = message ID^error code^error description
I $P(DGHLRSLT,U)>0,$P(DGHLRSLT,U,2)="" D
.; File new entry into log file 26.22
.S DGFDA(26.22,"+1,",.01)=DGDTM
.S DGFDA(26.22,"+1,",.02)=REQBY
.S DGFDA(26.22,"+1,",.03)=DFN
.S DGFDA(26.22,"+1,",.04)=FLAG
.S DGFDA(26.22,"+1,",.05)=1
.S DGFDA(26.22,"+1,",.08)=REQID
.S DGFDA(26.22,"+1,",.09)=$P(DGHLRSLT,U)
.S DGFDA(26.22,"+1,",.1)=DUZ(2)
.S DGFDA(26.22,"+1,",2.01)=REASON
.D UPDATE^DIE(,"DGFDA",,"DGERR")
.Q
K ^TMP("HLS",$J)
I $D(DGERR) Q "0^0^"_$G(DGERR("DIERR",1))_U_$G(DGERR("DIERR",1,"TEXT",1))_"^2"
; change status of previous requests with "SENT" status to "NO RESPONSE"
D NORESP^DGPFHLT1(DFN,FLAG,1)
;
Q $S($P(DGHLRSLT,U,2)'="":0,1:1)_U_DGHLRSLT_"^1"
;
QPD() ; create QPD segment
N SEG
S $P(SEG,HLFS)="PRFREQ01"_HLCMP_"PRF Ownership Transfer Request" ; field 1
S $P(SEG,HLFS,2)=REQID ; field 2
S $P(SEG,HLFS,3)=DGICN ; field 3
S $P(SEG,HLFS,4)=$$ENCHL7^DGPFHLUT($$GET1^DIQ(26.15,FLAG_",",.01)) ; field 4
S SEG="QPD"_HLFS_SEG
Q SEG
;
NTE() ; create NTE segment
N NAME,SEG,Z
S $P(SEG,HLFS)="1" ; field 1
S $P(SEG,HLFS,3)=$$ENCHL7^DGPFHLUT(REASON) ; field 3
S $P(SEG,HLFS,4)="RE" ; field 4
S NAME=$$ENCHL7^DGPFHLUT(REQBY)
S Z=$$HLNAME^HLFNC(NAME,HLECH)
S $P(Z,HLCMP,14)=HLSCMP_$$STA^XUAF4(DUZ(2))
S $P(SEG,HLFS,5)=Z ; field 5
S $P(SEG,HLFS,6)=$$HLDATE^HLFNC(DGDTM) ; field 6
S SEG="NTE"_HLFS_SEG
Q SEG
;
RCP() ; create RCP segment
N SEG
S $P(SEG,HLFS)="D" ; field 1
S $P(SEG,HLFS,2)="1"_HLCMP_"LI" ; field 2
S $P(SEG,HLFS,3)="T" ; field 3
S SEG="RCP"_HLFS_SEG
Q SEG
;
SAVESEG(SEGCNT,SEG) ; save created segment in ^TMP global
; SEGCNT - current segment count
; SEG - segment to save
;
S SEGCNT=SEGCNT+1
S ^TMP("HLS",$J,SEGCNT)=SEG
Q SEGCNT
;
GENQID(DGDTM) ; generate new query ID
;
; DGDTM - timestamp to use in ID generation
;
; returns next available query ID
;
N QID,SEQ,STOP
S QID=$$STA^XUAF4(DUZ(2))_$TR($G(DGDTM),".","")
S STOP=0 F SEQ=1:1:99999 S:'$O(^DGPF(26.22,"C",QID_SEQ,"")) STOP=1 Q:STOP
Q QID_SEQ
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLT 4278 printed Dec 13, 2024@02:47:47 Page 2
DGPFHLT ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This is the main driver for sending QBP^Q11 (PRF flag transfer request) messages.
+5 ;
+6 QUIT
+7 ;
SEND(DFN,FLAG,FCLTY,REASON) ; entry point
+1 ; DFN - Patient's DFN
+2 ; FLAG - PRF flag to transfer (ien in file 26.15)
+3 ; FCLTY - Facility to send the message to (ien in file 4)
+4 ; REASON - request reason
+5 ;
+6 ; Returns status^HL7 message id^error code^error description^error source
+7 ; status is the following set of codes:
+8 ; 0 = failure
+9 ; 1 = success
+10 ; error source is the following set of codes:
+11 ; 1 = HL7
+12 ; 2 = Filer (UPDATE^DIE)
+13 ;
+14 ; HL7 variables
NEW HL,HLCMP,HLECH,HLFS,HLL,HLSCMP
+15 NEW DGDTM,DGFAC,DGFDA,DGERR,DGICN,DGHLLNK,DGHLRSLT,REQBY,REQID,SEGCNT
+16 ;
+17 IF +$GET(DFN)'>0
QUIT "0^0^^Invalid DFN"
+18 ; ICN must be national
+19 IF '$$MPIOK^DGPFUT(DFN,.DGICN)
QUIT "0^0^^Invalid ICN"
+20 ; Retrieve treating facility HL Logical Link
+21 SET DGHLLNK=$$GETLINK^DGPFHLUT(FCLTY)
+22 IF DGHLLNK=0
QUIT "0^0^^Unable to get HL7 logical link for facility "_$$STA^XUAF4(FCLTY)_". Please contact the National Help Desk to rectify the issue. As a workaround, please utilize the existing 'CO - Change Ownership' functionality."
+23 ;
+24 ; Requester's name
SET REQBY=$$GET1^DIQ(200,DUZ_",",.01)
+25 SET DGDTM=$$NOW^XLFDT()
+26 ; Next available query ID
SET REQID=$$GENQID(DGDTM)
+27 SET HLL("LINKS",1)="DGPF PRF QBP/Q11 SUBSC"_U_DGHLLNK
+28 ; Initialize the HL7
+29 DO INIT^HLFNC2("DGPF PRF QBP/Q11 EVENT",.HL)
+30 SET HLFS=HL("FS")
SET HLECH=HL("ECH")
SET HLCMP=$EXTRACT(HLECH)
SET HLSCMP=$EXTRACT(HL("ECH"),4)
+31 KILL ^TMP("HLS",$JOB)
+32 ; Create HL7 message
+33 SET SEGCNT=0
+34 ; QPD segment
SET SEGCNT=$$SAVESEG(SEGCNT,$$QPD())
+35 ; NTE segment
SET SEGCNT=$$SAVESEG(SEGCNT,$$NTE())
+36 ; RCP segment
SET SEGCNT=$$SAVESEG(SEGCNT,$$RCP())
+37 ; Send HL7 message
+38 DO GENERATE^HLMA("DGPF PRF QBP/Q11 EVENT","GM",1,.DGHLRSLT)
+39 ; DHLRSLT = message ID^error code^error description
+40 IF $PIECE(DGHLRSLT,U)>0
IF $PIECE(DGHLRSLT,U,2)=""
Begin DoDot:1
+41 ; File new entry into log file 26.22
+42 SET DGFDA(26.22,"+1,",.01)=DGDTM
+43 SET DGFDA(26.22,"+1,",.02)=REQBY
+44 SET DGFDA(26.22,"+1,",.03)=DFN
+45 SET DGFDA(26.22,"+1,",.04)=FLAG
+46 SET DGFDA(26.22,"+1,",.05)=1
+47 SET DGFDA(26.22,"+1,",.08)=REQID
+48 SET DGFDA(26.22,"+1,",.09)=$PIECE(DGHLRSLT,U)
+49 SET DGFDA(26.22,"+1,",.1)=DUZ(2)
+50 SET DGFDA(26.22,"+1,",2.01)=REASON
+51 DO UPDATE^DIE(,"DGFDA",,"DGERR")
+52 QUIT
End DoDot:1
+53 KILL ^TMP("HLS",$JOB)
+54 IF $DATA(DGERR)
QUIT "0^0^"_$GET(DGERR("DIERR",1))_U_$GET(DGERR("DIERR",1,"TEXT",1))_"^2"
+55 ; change status of previous requests with "SENT" status to "NO RESPONSE"
+56 DO NORESP^DGPFHLT1(DFN,FLAG,1)
+57 ;
+58 QUIT $SELECT($PIECE(DGHLRSLT,U,2)'="":0,1:1)_U_DGHLRSLT_"^1"
+59 ;
QPD() ; create QPD segment
+1 NEW SEG
+2 ; field 1
SET $PIECE(SEG,HLFS)="PRFREQ01"_HLCMP_"PRF Ownership Transfer Request"
+3 ; field 2
SET $PIECE(SEG,HLFS,2)=REQID
+4 ; field 3
SET $PIECE(SEG,HLFS,3)=DGICN
+5 ; field 4
SET $PIECE(SEG,HLFS,4)=$$ENCHL7^DGPFHLUT($$GET1^DIQ(26.15,FLAG_",",.01))
+6 SET SEG="QPD"_HLFS_SEG
+7 QUIT SEG
+8 ;
NTE() ; create NTE segment
+1 NEW NAME,SEG,Z
+2 ; field 1
SET $PIECE(SEG,HLFS)="1"
+3 ; field 3
SET $PIECE(SEG,HLFS,3)=$$ENCHL7^DGPFHLUT(REASON)
+4 ; field 4
SET $PIECE(SEG,HLFS,4)="RE"
+5 SET NAME=$$ENCHL7^DGPFHLUT(REQBY)
+6 SET Z=$$HLNAME^HLFNC(NAME,HLECH)
+7 SET $PIECE(Z,HLCMP,14)=HLSCMP_$$STA^XUAF4(DUZ(2))
+8 ; field 5
SET $PIECE(SEG,HLFS,5)=Z
+9 ; field 6
SET $PIECE(SEG,HLFS,6)=$$HLDATE^HLFNC(DGDTM)
+10 SET SEG="NTE"_HLFS_SEG
+11 QUIT SEG
+12 ;
RCP() ; create RCP segment
+1 NEW SEG
+2 ; field 1
SET $PIECE(SEG,HLFS)="D"
+3 ; field 2
SET $PIECE(SEG,HLFS,2)="1"_HLCMP_"LI"
+4 ; field 3
SET $PIECE(SEG,HLFS,3)="T"
+5 SET SEG="RCP"_HLFS_SEG
+6 QUIT SEG
+7 ;
SAVESEG(SEGCNT,SEG) ; save created segment in ^TMP global
+1 ; SEGCNT - current segment count
+2 ; SEG - segment to save
+3 ;
+4 SET SEGCNT=SEGCNT+1
+5 SET ^TMP("HLS",$JOB,SEGCNT)=SEG
+6 QUIT SEGCNT
+7 ;
GENQID(DGDTM) ; generate new query ID
+1 ;
+2 ; DGDTM - timestamp to use in ID generation
+3 ;
+4 ; returns next available query ID
+5 ;
+6 NEW QID,SEQ,STOP
+7 SET QID=$$STA^XUAF4(DUZ(2))_$TRANSLATE($GET(DGDTM),".","")
+8 SET STOP=0
FOR SEQ=1:1:99999
if '$ORDER(^DGPF(26.22,"C",QID_SEQ,""))
SET STOP=1
if STOP
QUIT
+9 QUIT QID_SEQ
