DGPFHLT1 ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
;;5.3;Registration;**951,1113**;Aug 13, 1993;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
; This is the main driver for processing QBP^Q11 (PRF flag transfer request) messages.
;
Q
;
EN ; entry point
; DATAARY array has the following structure:
; DATAARY("ACTIVE") = 1 if PRF flag is active, 0 otherwise
; DATAARY("REVBY") = name of the person reviewing the request
; DATAARY("REVDUZ") = DUZ of the person reviewing the request
; DATAARY("REVDTM") = Date/time of the review
; DATAARY("REVRES") = Result of the review
; "A" for approval
; "D" for denial/rejection
; DATAARY("REVCMT") = review comment/reason
; DATAARY("DFN") = patient DFN
; DATAARY("FLAG") = PRF flag ien in file 26.15
; DATAARY("ICN") = patient ICN
; DATAARY("MSGID") = HL7 message Id
; DATAARY("QOK") = flag for QAK segment in RSP^K11 message
; 1 if patient + PRF flag data has been found and retrieved
; 0 otherwise
; DATAARY("REQBY") = requester name
; DATAARY("REQDTM") = request date/time
; DATAARY("REQCMT") = request comment/reason
; DATAARY("REQID") = query id
; DATAARY("SENDTO") = file 4 ien of facility we're sending HL7 message to
; DATAARY("SFIEN") = ien of sending facility in file 4
; DATAARY("SFNAME") = formatted name of sending facility
; DATAARY("ORIGOWN")= file 4 ien of flag's original owner
;
N HLCMP,HLECH,HLFS,HLREP,HLSCMP ; HL7 variables
N CNT,DATAARY,DGERR,DGFDA,DGIEN,DGPFA,DGPFAH,DIERR,FLAGNM,MSGTYPE,SEGCNT,SEGNM,SEGSTR,SNDDIV,SNDFAC
;
S HLFS=HL("FS"),HLECH=HL("ECH"),HLCMP=$E(HLECH),HLREP=$E(HL("ECH"),2),HLSCMP=$E(HL("ECH"),4)
K ^TMP("DGPFHLT1",$J)
; load segments into ^TMP global
F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
.S CNT=0,^TMP("DGPFHLT1",$J,SEGCNT,CNT)=HLNODE
.F S CNT=$O(HLNODE(CNT)) Q:'CNT S ^TMP("DGPFHLT1",$J,SEGCNT,CNT)=HLNODE(CNT)
.Q
; check message type
S SEGSTR=$G(^TMP("DGPFHLT1",$J,1,0))
; if ACK, just bail out
I $P(SEGSTR,HLFS)="MSH",$P($P(SEGSTR,HLFS,9),HLCMP)="ACK" K ^TMP("DGPFHLT1",$J) Q
; if RSP^K11 call DGPFHLT3 and bail out
I $P(SEGSTR,HLFS)="MSH",$P($P(SEGSTR,HLFS,9),HLCMP)="RSP" D EN^DGPFHLT3 Q
;
S (SNDDIV,SNDFAC,FLAGNM)=""
; parse the message
S SEGCNT="" F S SEGCNT=$O(^TMP("DGPFHLT1",$J,SEGCNT)) Q:SEGCNT="" D
.S SEGSTR=$G(^TMP("DGPFHLT1",$J,SEGCNT,0))
.S SEGNM=$P(SEGSTR,HLFS)
.I SEGNM="MSH" D
..; parse MSH segment
..S SNDFAC=$P($P(SEGSTR,HLFS,4),HLCMP) ; sending facility (station #)
..S DATAARY("MSGID")=$P(SEGSTR,HLFS,10)
..Q
.I SEGNM="QPD" D
..; parse QPD segment
..S DATAARY("REQID")=$P(SEGSTR,HLFS,3)
..S DATAARY("ICN")=$P(SEGSTR,HLFS,4)
..S FLAGNM=$$DECHL7^DGPFHLUT($P(SEGSTR,HLFS,5)) ; PRF flag name
..Q
.I SEGNM="NTE" D
..; parse NTE segment
..S DATAARY("REQCMT")=$$DECHL7^DGPFHLUT($P(SEGSTR,HLFS,4))
..S DATAARY("REQBY")=$$FMNAME^HLFNC($P($P(SEGSTR,HLFS,6),HLCMP,1,5),HLECH)
..S DATAARY("REQBY")=$$DECHL7^DGPFHLUT(DATAARY("REQBY")) ; requester's name
..S SNDDIV=$P($P($P(SEGSTR,HLFS,6),HLCMP,14),HLSCMP,2) ; sending division (station #)
..S DATAARY("REQDTM")=$$FMDATE^HLFNC($P(SEGSTR,HLFS,7))
..Q
.Q
; make sure that we got all necessary pieces of data
S DATAARY("QOK")=0,DGERR=$$CHK()
; determine if flag is active
S DATAARY("ACTIVE")=$S($P($G(DGPFA("STATUS")),U)=1:1,1:0)
I 'DATAARY("ACTIVE") D
.N DIERR,DGHERR
.S DATAARY("REVBY")="DGPRF,INTERFACE"
.S DATAARY("REVDUZ")=+$$FIND1^DIC(200,"","X",DATAARY("REVBY"),,,"DGHERR")
.I 'DATAARY("REVDUZ") S DGERR="Receiver tried to use invalid reviewer name."
.I 'DGERR S DATAARY("REVDTM")=$$NOW^XLFDT(),DATAARY("REVRES")="A"
.Q
; send ACK message
D SEND^DGPFHLT4(DATAARY("MSGID"),DGERR)
; if everything checked out, file a log entry
I DGERR="" S DGERR=$$UPDLOG(.DATAARY)
I DGERR="" D
.; change status of previous requests with "PENDING" status to "NO RESPONSE"
.D NORESP(DATAARY("DFN"),DATAARY("FLAG"),2)
.; if flag is active, send Mailman notification
.I DATAARY("ACTIVE") D TREQMSG^DGPFHLTM(.DATAARY,.DGPFA,1)
.;if flag is inactive, activate it and transfer ownership to the requester
.I 'DATAARY("ACTIVE") D
..S DATAARY("ORIGOWN")=$P($G(DGPFA("OWNER")),U)
..S DGERR=$$UPDASGN(1,DGIEN,.DATAARY,.DGPFA)
..S DATAARY("SENDTO")=$P($$PARENT^DGPFUT1(DATAARY("SFIEN")),U)
..I DATAARY("SENDTO")=0 S DATAARY("SENDTO")=DATAARY("SFIEN")
..; send response message (RSP^K11)
..D SEND^DGPFHLT2(DGERR,.DATAARY)
..Q
.Q
I DGERR'="" D
.; Send Mailman notification
.S ERTXT(1)="Error while processing QBP^Q11 HL7 message with message Id "_$G(DATAARY("MSGID"))_"."
.S ERTXT(4)="Error description: "_DGERR
.D TERRMSG^DGPFHLTM($G(DATAARY("MSGID")),.ERTXT)
.Q
K ^TMP("DGPFHLT1",$J)
Q
;
CHK() ; Check data in incoming message
; Called from EN tag, relies on (and sets) some variables defined in there
; Returns "" if there are no problems, or error message otherwise
;
N DGTFL,FCLTY,OWNER,DIERR,DGHERR
I $G(DATAARY("MSGID"))="" Q "Missing message Id in MSH segment."
I SNDDIV="" Q "Missing sending facility in NTE segment."
I $G(DATAARY("REQID"))="" Q "Missing query Id in QPD segment."
S DATAARY("DFN")=+$$GETDFN^MPIF001($G(DATAARY("ICN")))
I DATAARY("DFN")'>0 Q "Invalid or missing ICN in QPD segment."
S DATAARY("SFIEN")=+$$IEN^XUAF4(SNDDIV)
I DATAARY("SFIEN")'>0 Q "Invalid sending facility in NTE segment."
D BLDTFL^DGPFUT2(DATAARY("DFN"),.DGTFL)
I '$D(DGTFL(+$$IEN^XUAF4(SNDFAC))) Q "Sending facility in MSH segment is not on receiver's treating facility list."
S DATAARY("SFNAME")="Station # "_SNDDIV_"("_$$NAME^XUAF4(DATAARY("SFIEN"))_")"
S DATAARY("FLAG")=+$$FIND1^DIC(26.15,,"X",FLAGNM,,,"DGHERR")
I DATAARY("FLAG")'>0 Q "Invalid or missing PRF flag name in QPD segment."
S DGIEN=$$FNDASGN^DGPFAA(DATAARY("DFN"),DATAARY("FLAG")_";DGPF(26.15,") ; PRF assignment ien in file 26.13
I DGIEN'>0 Q "Receiver was unable to find corresponding PRF flag assignment."
I '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1) Q "Receiver was unable to retrieve corresponding PRF flag assignment."
S DATAARY("QOK")=1
S OWNER=$P($G(DGPFA("OWNER")),U)
S FCLTY=$P($$SITE^VASITE(),U)
I OWNER'=FCLTY,$P($$PARENT^DGPFUT1(OWNER),U)'=FCLTY Q "Receiver is not the owner of PRF flag in question."
I $G(DATAARY("REQBY"))="" Q "Invalid or missing requester's name in NTE segment."
I $G(DATAARY("REQDTM"))="" Q "Invalid or missing request date/time in NTE segment."
Q ""
;
UPDLOG(DATA) ; file a log entry
; DATA - Array of values to file (see tag EN)
; Returns "" if there are no problems, or error message otherwise
;
N DGFDA,DIEERR,DIERR
S DGFDA(26.22,"+1,",.01)=$G(DATA("REQDTM"))
S DGFDA(26.22,"+1,",.02)=$G(DATA("REQBY"))
S DGFDA(26.22,"+1,",.03)=$G(DATA("DFN"))
S DGFDA(26.22,"+1,",.04)=$G(DATA("FLAG"))
S DGFDA(26.22,"+1,",.05)=$S($G(DATA("ACTIVE"))=1:2,1:3)
I $G(DATA("REVBY"))'="" D
.S DGFDA(26.22,"+1,",.06)=DATA("REVBY")
.S DGFDA(26.22,"+1,",.07)=$G(DATA("REVDTM"))
.Q
S DGFDA(26.22,"+1,",.08)=$G(DATA("REQID"))
S DGFDA(26.22,"+1,",.09)=$G(DATA("MSGID"))
S DGFDA(26.22,"+1,",.1)=$G(DATA("SFIEN"))
S DGFDA(26.22,"+1,",2.01)=$G(DATA("REQCMT"))
D UPDATE^DIE(,"DGFDA",,"DIEERR")
I $D(DIEERR) Q $E("Log filer: "_$G(DIEERR("DIERR",1,"TEXT",1)),1,80)
Q ""
;
UPDASGN(AFLG,DGIEN,DATA,DGPFA) ; update PRF assignment and assignment history
; AFLG - 1 if flag needs to be reactivated, 0 otherwise
; DGIEN - ien of PRF assignment record
; DATA - Array of values to work with (see tag EN)
; DGPFA - PRF assignment array
; Returns "" if there are no problems, or error message otherwise
;
N DBRSCNT,DBRSDATA,DBRSNUM,RES,Z
S RES=""
S DGPFAH("APPRVBY")=$G(DATA("REVDUZ"))
S DGPFAH("ASSIGNDT")=$G(DATA("REVDTM"))
S DGPFAH("ENTERBY")=$G(DATA("REVDUZ"))
S DGPFA("REVIEWDT")=""
S DGPFA("STATUS")=1 ; flag status = Active
S DGPFAH("ORIGFAC")=+$$SITE^VASITE
S DGPFAH("COMMENT",1,0)="Ownership transfer request has been received for this flag."
; add DBRS data to DGPFAH array
D GETDBRS^DGPFUT6(.DBRSDATA,DGIEN)
S (DBRSCNT,DBRSNUM)=0 F S DBRSNUM=$O(DBRSDATA(DBRSNUM)) Q:DBRSNUM="" D
.S DBRSCNT=DBRSCNT+1
.S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$P($G(DBRSDATA(DBRSNUM,"OTHER")),U)_U_$P($G(DBRSDATA(DBRSNUM,"DATE")),U)
.S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"N"_U_$P($G(DBRSDATA(DBRSNUM,"SITE")),U)
.Q
; reactivate flag if it's inactive
I AFLG D
.S DGPFAH("ACTION")=4 ; Action = Reactivate
.S DGPFAH("COMMENT",2,0)="As a result, flag has been reactivated."
.S Z=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,,"")
.I $P(Z,U)'>0 S RES="Receiver was unable to update PRF assignment record." Q
.I $P(Z,U,2)'>0 S RES="Receiver was unable to update PRF history record." Q
.; send ORU HL7 message for reactivation
.S:'$$SNDORU^DGPFHLS(DGIEN) RES="Receiver was unable to send HL7 message update (ORU message)."
.Q
I RES="" D
.; change ownership
.S DGPFAH("ACTION")=2 ; Action = Continue
.S DGPFA("OWNER")=$G(DATA("SFIEN")) ; New owner site
.S DGPFAH("COMMENT",2,0)="As a result, flag ownership has been transferred"
.S DGPFAH("COMMENT",3,0)="to "_$G(DATA("SFNAME"))
.H 1 S DGPFAH("ASSIGNDT")=$$NOW^XLFDT() ; ensure that date/time of this history record differs from the previous one (reactivation)
.S Z=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,,"")
.I $P(Z,U)'>0 S RES="Receiver was unable to update PRF assignment record." Q
.I $P(Z,U,2)'>0 S RES="Receiver was unable to update PRF history record." Q
.; send ORU HL7 message for ownership transfer
.S:'$$SNDORU^DGPFHLS(DGIEN) RES="Receiver was unable to send HL7 message update (ORU message)."
.Q
Q RES
;
NORESP(DFN,FLAG,STATUS) ; set status of entries in file 26.22 to "NO RESPONSE"
; DFN - patient DFN
; FLAG - flag ien in file 26.15
; STATUS - current status of entries that should be flipped to "NO RESPONSE" (internal code)
;
N DATE,DGFDA,DGHERR,DIERR,IEN
I +DFN'>0 Q
I +FLAG'>0 Q
I +STATUS'>0 Q
; skip the latest entry
S DATE=$O(^DGPF(26.22,"D",DFN,FLAG,STATUS,""),-1)
; loop backwards, starting from the second to last entry
F S DATE=$O(^DGPF(26.22,"D",DFN,FLAG,STATUS,DATE),-1) Q:DATE="" D
.S IEN=+$O(^DGPF(26.22,"D",DFN,FLAG,STATUS,DATE,""))
.S DGFDA(26.22,IEN_",",.05)=6
.D FILE^DIE(,"DGFDA","DGHERR") K DGFDA
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLT1 10446 printed Oct 16, 2024@18:48:25 Page 2
DGPFHLT1 ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
+1 ;;5.3;Registration;**951,1113**;Aug 13, 1993;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This is the main driver for processing QBP^Q11 (PRF flag transfer request) messages.
+5 ;
+6 QUIT
+7 ;
EN ; entry point
+1 ; DATAARY array has the following structure:
+2 ; DATAARY("ACTIVE") = 1 if PRF flag is active, 0 otherwise
+3 ; DATAARY("REVBY") = name of the person reviewing the request
+4 ; DATAARY("REVDUZ") = DUZ of the person reviewing the request
+5 ; DATAARY("REVDTM") = Date/time of the review
+6 ; DATAARY("REVRES") = Result of the review
+7 ; "A" for approval
+8 ; "D" for denial/rejection
+9 ; DATAARY("REVCMT") = review comment/reason
+10 ; DATAARY("DFN") = patient DFN
+11 ; DATAARY("FLAG") = PRF flag ien in file 26.15
+12 ; DATAARY("ICN") = patient ICN
+13 ; DATAARY("MSGID") = HL7 message Id
+14 ; DATAARY("QOK") = flag for QAK segment in RSP^K11 message
+15 ; 1 if patient + PRF flag data has been found and retrieved
+16 ; 0 otherwise
+17 ; DATAARY("REQBY") = requester name
+18 ; DATAARY("REQDTM") = request date/time
+19 ; DATAARY("REQCMT") = request comment/reason
+20 ; DATAARY("REQID") = query id
+21 ; DATAARY("SENDTO") = file 4 ien of facility we're sending HL7 message to
+22 ; DATAARY("SFIEN") = ien of sending facility in file 4
+23 ; DATAARY("SFNAME") = formatted name of sending facility
+24 ; DATAARY("ORIGOWN")= file 4 ien of flag's original owner
+25 ;
+26 ; HL7 variables
NEW HLCMP,HLECH,HLFS,HLREP,HLSCMP
+27 NEW CNT,DATAARY,DGERR,DGFDA,DGIEN,DGPFA,DGPFAH,DIERR,FLAGNM,MSGTYPE,SEGCNT,SEGNM,SEGSTR,SNDDIV,SNDFAC
+28 ;
+29 SET HLFS=HL("FS")
SET HLECH=HL("ECH")
SET HLCMP=$EXTRACT(HLECH)
SET HLREP=$EXTRACT(HL("ECH"),2)
SET HLSCMP=$EXTRACT(HL("ECH"),4)
+30 KILL ^TMP("DGPFHLT1",$JOB)
+31 ; load segments into ^TMP global
+32 FOR SEGCNT=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+33 SET CNT=0
SET ^TMP("DGPFHLT1",$JOB,SEGCNT,CNT)=HLNODE
+34 FOR
SET CNT=$ORDER(HLNODE(CNT))
if 'CNT
QUIT
SET ^TMP("DGPFHLT1",$JOB,SEGCNT,CNT)=HLNODE(CNT)
+35 QUIT
End DoDot:1
+36 ; check message type
+37 SET SEGSTR=$GET(^TMP("DGPFHLT1",$JOB,1,0))
+38 ; if ACK, just bail out
+39 IF $PIECE(SEGSTR,HLFS)="MSH"
IF $PIECE($PIECE(SEGSTR,HLFS,9),HLCMP)="ACK"
KILL ^TMP("DGPFHLT1",$JOB)
QUIT
+40 ; if RSP^K11 call DGPFHLT3 and bail out
+41 IF $PIECE(SEGSTR,HLFS)="MSH"
IF $PIECE($PIECE(SEGSTR,HLFS,9),HLCMP)="RSP"
DO EN^DGPFHLT3
QUIT
+42 ;
+43 SET (SNDDIV,SNDFAC,FLAGNM)=""
+44 ; parse the message
+45 SET SEGCNT=""
FOR
SET SEGCNT=$ORDER(^TMP("DGPFHLT1",$JOB,SEGCNT))
if SEGCNT=""
QUIT
Begin DoDot:1
+46 SET SEGSTR=$GET(^TMP("DGPFHLT1",$JOB,SEGCNT,0))
+47 SET SEGNM=$PIECE(SEGSTR,HLFS)
+48 IF SEGNM="MSH"
Begin DoDot:2
+49 ; parse MSH segment
+50 ; sending facility (station #)
SET SNDFAC=$PIECE($PIECE(SEGSTR,HLFS,4),HLCMP)
+51 SET DATAARY("MSGID")=$PIECE(SEGSTR,HLFS,10)
+52 QUIT
End DoDot:2
+53 IF SEGNM="QPD"
Begin DoDot:2
+54 ; parse QPD segment
+55 SET DATAARY("REQID")=$PIECE(SEGSTR,HLFS,3)
+56 SET DATAARY("ICN")=$PIECE(SEGSTR,HLFS,4)
+57 ; PRF flag name
SET FLAGNM=$$DECHL7^DGPFHLUT($PIECE(SEGSTR,HLFS,5))
+58 QUIT
End DoDot:2
+59 IF SEGNM="NTE"
Begin DoDot:2
+60 ; parse NTE segment
+61 SET DATAARY("REQCMT")=$$DECHL7^DGPFHLUT($PIECE(SEGSTR,HLFS,4))
+62 SET DATAARY("REQBY")=$$FMNAME^HLFNC($PIECE($PIECE(SEGSTR,HLFS,6),HLCMP,1,5),HLECH)
+63 ; requester's name
SET DATAARY("REQBY")=$$DECHL7^DGPFHLUT(DATAARY("REQBY"))
+64 ; sending division (station #)
SET SNDDIV=$PIECE($PIECE($PIECE(SEGSTR,HLFS,6),HLCMP,14),HLSCMP,2)
+65 SET DATAARY("REQDTM")=$$FMDATE^HLFNC($PIECE(SEGSTR,HLFS,7))
+66 QUIT
End DoDot:2
+67 QUIT
End DoDot:1
+68 ; make sure that we got all necessary pieces of data
+69 SET DATAARY("QOK")=0
SET DGERR=$$CHK()
+70 ; determine if flag is active
+71 SET DATAARY("ACTIVE")=$SELECT($PIECE($GET(DGPFA("STATUS")),U)=1:1,1:0)
+72 IF 'DATAARY("ACTIVE")
Begin DoDot:1
+73 NEW DIERR,DGHERR
+74 SET DATAARY("REVBY")="DGPRF,INTERFACE"
+75 SET DATAARY("REVDUZ")=+$$FIND1^DIC(200,"","X",DATAARY("REVBY"),,,"DGHERR")
+76 IF 'DATAARY("REVDUZ")
SET DGERR="Receiver tried to use invalid reviewer name."
+77 IF 'DGERR
SET DATAARY("REVDTM")=$$NOW^XLFDT()
SET DATAARY("REVRES")="A"
+78 QUIT
End DoDot:1
+79 ; send ACK message
+80 DO SEND^DGPFHLT4(DATAARY("MSGID"),DGERR)
+81 ; if everything checked out, file a log entry
+82 IF DGERR=""
SET DGERR=$$UPDLOG(.DATAARY)
+83 IF DGERR=""
Begin DoDot:1
+84 ; change status of previous requests with "PENDING" status to "NO RESPONSE"
+85 DO NORESP(DATAARY("DFN"),DATAARY("FLAG"),2)
+86 ; if flag is active, send Mailman notification
+87 IF DATAARY("ACTIVE")
DO TREQMSG^DGPFHLTM(.DATAARY,.DGPFA,1)
+88 ;if flag is inactive, activate it and transfer ownership to the requester
+89 IF 'DATAARY("ACTIVE")
Begin DoDot:2
+90 SET DATAARY("ORIGOWN")=$PIECE($GET(DGPFA("OWNER")),U)
+91 SET DGERR=$$UPDASGN(1,DGIEN,.DATAARY,.DGPFA)
+92 SET DATAARY("SENDTO")=$PIECE($$PARENT^DGPFUT1(DATAARY("SFIEN")),U)
+93 IF DATAARY("SENDTO")=0
SET DATAARY("SENDTO")=DATAARY("SFIEN")
+94 ; send response message (RSP^K11)
+95 DO SEND^DGPFHLT2(DGERR,.DATAARY)
+96 QUIT
End DoDot:2
+97 QUIT
End DoDot:1
+98 IF DGERR'=""
Begin DoDot:1
+99 ; Send Mailman notification
+100 SET ERTXT(1)="Error while processing QBP^Q11 HL7 message with message Id "_$GET(DATAARY("MSGID"))_"."
+101 SET ERTXT(4)="Error description: "_DGERR
+102 DO TERRMSG^DGPFHLTM($GET(DATAARY("MSGID")),.ERTXT)
+103 QUIT
End DoDot:1
+104 KILL ^TMP("DGPFHLT1",$JOB)
+105 QUIT
+106 ;
CHK() ; Check data in incoming message
+1 ; Called from EN tag, relies on (and sets) some variables defined in there
+2 ; Returns "" if there are no problems, or error message otherwise
+3 ;
+4 NEW DGTFL,FCLTY,OWNER,DIERR,DGHERR
+5 IF $GET(DATAARY("MSGID"))=""
QUIT "Missing message Id in MSH segment."
+6 IF SNDDIV=""
QUIT "Missing sending facility in NTE segment."
+7 IF $GET(DATAARY("REQID"))=""
QUIT "Missing query Id in QPD segment."
+8 SET DATAARY("DFN")=+$$GETDFN^MPIF001($GET(DATAARY("ICN")))
+9 IF DATAARY("DFN")'>0
QUIT "Invalid or missing ICN in QPD segment."
+10 SET DATAARY("SFIEN")=+$$IEN^XUAF4(SNDDIV)
+11 IF DATAARY("SFIEN")'>0
QUIT "Invalid sending facility in NTE segment."
+12 DO BLDTFL^DGPFUT2(DATAARY("DFN"),.DGTFL)
+13 IF '$DATA(DGTFL(+$$IEN^XUAF4(SNDFAC)))
QUIT "Sending facility in MSH segment is not on receiver's treating facility list."
+14 SET DATAARY("SFNAME")="Station # "_SNDDIV_"("_$$NAME^XUAF4(DATAARY("SFIEN"))_")"
+15 SET DATAARY("FLAG")=+$$FIND1^DIC(26.15,,"X",FLAGNM,,,"DGHERR")
+16 IF DATAARY("FLAG")'>0
QUIT "Invalid or missing PRF flag name in QPD segment."
+17 ; PRF assignment ien in file 26.13
SET DGIEN=$$FNDASGN^DGPFAA(DATAARY("DFN"),DATAARY("FLAG")_";DGPF(26.15,")
+18 IF DGIEN'>0
QUIT "Receiver was unable to find corresponding PRF flag assignment."
+19 IF '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1)
QUIT "Receiver was unable to retrieve corresponding PRF flag assignment."
+20 SET DATAARY("QOK")=1
+21 SET OWNER=$PIECE($GET(DGPFA("OWNER")),U)
+22 SET FCLTY=$PIECE($$SITE^VASITE(),U)
+23 IF OWNER'=FCLTY
IF $PIECE($$PARENT^DGPFUT1(OWNER),U)'=FCLTY
QUIT "Receiver is not the owner of PRF flag in question."
+24 IF $GET(DATAARY("REQBY"))=""
QUIT "Invalid or missing requester's name in NTE segment."
+25 IF $GET(DATAARY("REQDTM"))=""
QUIT "Invalid or missing request date/time in NTE segment."
+26 QUIT ""
+27 ;
UPDLOG(DATA) ; file a log entry
+1 ; DATA - Array of values to file (see tag EN)
+2 ; Returns "" if there are no problems, or error message otherwise
+3 ;
+4 NEW DGFDA,DIEERR,DIERR
+5 SET DGFDA(26.22,"+1,",.01)=$GET(DATA("REQDTM"))
+6 SET DGFDA(26.22,"+1,",.02)=$GET(DATA("REQBY"))
+7 SET DGFDA(26.22,"+1,",.03)=$GET(DATA("DFN"))
+8 SET DGFDA(26.22,"+1,",.04)=$GET(DATA("FLAG"))
+9 SET DGFDA(26.22,"+1,",.05)=$SELECT($GET(DATA("ACTIVE"))=1:2,1:3)
+10 IF $GET(DATA("REVBY"))'=""
Begin DoDot:1
+11 SET DGFDA(26.22,"+1,",.06)=DATA("REVBY")
+12 SET DGFDA(26.22,"+1,",.07)=$GET(DATA("REVDTM"))
+13 QUIT
End DoDot:1
+14 SET DGFDA(26.22,"+1,",.08)=$GET(DATA("REQID"))
+15 SET DGFDA(26.22,"+1,",.09)=$GET(DATA("MSGID"))
+16 SET DGFDA(26.22,"+1,",.1)=$GET(DATA("SFIEN"))
+17 SET DGFDA(26.22,"+1,",2.01)=$GET(DATA("REQCMT"))
+18 DO UPDATE^DIE(,"DGFDA",,"DIEERR")
+19 IF $DATA(DIEERR)
QUIT $EXTRACT("Log filer: "_$GET(DIEERR("DIERR",1,"TEXT",1)),1,80)
+20 QUIT ""
+21 ;
UPDASGN(AFLG,DGIEN,DATA,DGPFA) ; update PRF assignment and assignment history
+1 ; AFLG - 1 if flag needs to be reactivated, 0 otherwise
+2 ; DGIEN - ien of PRF assignment record
+3 ; DATA - Array of values to work with (see tag EN)
+4 ; DGPFA - PRF assignment array
+5 ; Returns "" if there are no problems, or error message otherwise
+6 ;
+7 NEW DBRSCNT,DBRSDATA,DBRSNUM,RES,Z
+8 SET RES=""
+9 SET DGPFAH("APPRVBY")=$GET(DATA("REVDUZ"))
+10 SET DGPFAH("ASSIGNDT")=$GET(DATA("REVDTM"))
+11 SET DGPFAH("ENTERBY")=$GET(DATA("REVDUZ"))
+12 SET DGPFA("REVIEWDT")=""
+13 ; flag status = Active
SET DGPFA("STATUS")=1
+14 SET DGPFAH("ORIGFAC")=+$$SITE^VASITE
+15 SET DGPFAH("COMMENT",1,0)="Ownership transfer request has been received for this flag."
+16 ; add DBRS data to DGPFAH array
+17 DO GETDBRS^DGPFUT6(.DBRSDATA,DGIEN)
+18 SET (DBRSCNT,DBRSNUM)=0
FOR
SET DBRSNUM=$ORDER(DBRSDATA(DBRSNUM))
if DBRSNUM=""
QUIT
Begin DoDot:1
+19 SET DBRSCNT=DBRSCNT+1
+20 SET DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$PIECE($GET(DBRSDATA(DBRSNUM,"OTHER")),U)_U_$PIECE($GET(DBRSDATA(DBRSNUM,"DATE")),U)
+21 SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"N"_U_$PIECE($GET(DBRSDATA(DBRSNUM,"SITE")),U)
+22 QUIT
End DoDot:1
+23 ; reactivate flag if it's inactive
+24 IF AFLG
Begin DoDot:1
+25 ; Action = Reactivate
SET DGPFAH("ACTION")=4
+26 SET DGPFAH("COMMENT",2,0)="As a result, flag has been reactivated."
+27 SET Z=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,,"")
+28 IF $PIECE(Z,U)'>0
SET RES="Receiver was unable to update PRF assignment record."
QUIT
+29 IF $PIECE(Z,U,2)'>0
SET RES="Receiver was unable to update PRF history record."
QUIT
+30 ; send ORU HL7 message for reactivation
+31 if '$$SNDORU^DGPFHLS(DGIEN)
SET RES="Receiver was unable to send HL7 message update (ORU message)."
+32 QUIT
End DoDot:1
+33 IF RES=""
Begin DoDot:1
+34 ; change ownership
+35 ; Action = Continue
SET DGPFAH("ACTION")=2
+36 ; New owner site
SET DGPFA("OWNER")=$GET(DATA("SFIEN"))
+37 SET DGPFAH("COMMENT",2,0)="As a result, flag ownership has been transferred"
+38 SET DGPFAH("COMMENT",3,0)="to "_$GET(DATA("SFNAME"))
+39 ; ensure that date/time of this history record differs from the previous one (reactivation)
HANG 1
SET DGPFAH("ASSIGNDT")=$$NOW^XLFDT()
+40 SET Z=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,,"")
+41 IF $PIECE(Z,U)'>0
SET RES="Receiver was unable to update PRF assignment record."
QUIT
+42 IF $PIECE(Z,U,2)'>0
SET RES="Receiver was unable to update PRF history record."
QUIT
+43 ; send ORU HL7 message for ownership transfer
+44 if '$$SNDORU^DGPFHLS(DGIEN)
SET RES="Receiver was unable to send HL7 message update (ORU message)."
+45 QUIT
End DoDot:1
+46 QUIT RES
+47 ;
NORESP(DFN,FLAG,STATUS) ; set status of entries in file 26.22 to "NO RESPONSE"
+1 ; DFN - patient DFN
+2 ; FLAG - flag ien in file 26.15
+3 ; STATUS - current status of entries that should be flipped to "NO RESPONSE" (internal code)
+4 ;
+5 NEW DATE,DGFDA,DGHERR,DIERR,IEN
+6 IF +DFN'>0
QUIT
+7 IF +FLAG'>0
QUIT
+8 IF +STATUS'>0
QUIT
+9 ; skip the latest entry
+10 SET DATE=$ORDER(^DGPF(26.22,"D",DFN,FLAG,STATUS,""),-1)
+11 ; loop backwards, starting from the second to last entry
+12 FOR
SET DATE=$ORDER(^DGPF(26.22,"D",DFN,FLAG,STATUS,DATE),-1)
if DATE=""
QUIT
Begin DoDot:1
+13 SET IEN=+$ORDER(^DGPF(26.22,"D",DFN,FLAG,STATUS,DATE,""))
+14 SET DGFDA(26.22,IEN_",",.05)=6
+15 DO FILE^DIE(,"DGFDA","DGHERR")
KILL DGFDA
+16 QUIT
End DoDot:1
+17 QUIT
