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