Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPFHLT1

DGPFHLT1.m

Go to the documentation of this file.
  1. DGPFHLT1 ;SHRPE/YMG - PRF HL7 QBP/RSP PROCESSING ; 05/02/18
  1. ;;5.3;Registration;**951,1113**;Aug 13, 1993;Build 10
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; This is the main driver for processing QBP^Q11 (PRF flag transfer request) messages.
  1. ;
  1. Q
  1. ;
  1. EN ; entry point
  1. ; DATAARY array has the following structure:
  1. ; DATAARY("ACTIVE") = 1 if PRF flag is active, 0 otherwise
  1. ; DATAARY("REVBY") = name of the person reviewing the request
  1. ; DATAARY("REVDUZ") = DUZ of the person reviewing the request
  1. ; DATAARY("REVDTM") = Date/time of the review
  1. ; DATAARY("REVRES") = Result of the review
  1. ; "A" for approval
  1. ; "D" for denial/rejection
  1. ; DATAARY("REVCMT") = review comment/reason
  1. ; DATAARY("DFN") = patient DFN
  1. ; DATAARY("FLAG") = PRF flag ien in file 26.15
  1. ; DATAARY("ICN") = patient ICN
  1. ; DATAARY("MSGID") = HL7 message Id
  1. ; DATAARY("QOK") = flag for QAK segment in RSP^K11 message
  1. ; 1 if patient + PRF flag data has been found and retrieved
  1. ; 0 otherwise
  1. ; DATAARY("REQBY") = requester name
  1. ; DATAARY("REQDTM") = request date/time
  1. ; DATAARY("REQCMT") = request comment/reason
  1. ; DATAARY("REQID") = query id
  1. ; DATAARY("SENDTO") = file 4 ien of facility we're sending HL7 message to
  1. ; DATAARY("SFIEN") = ien of sending facility in file 4
  1. ; DATAARY("SFNAME") = formatted name of sending facility
  1. ; DATAARY("ORIGOWN")= file 4 ien of flag's original owner
  1. ;
  1. N HLCMP,HLECH,HLFS,HLREP,HLSCMP ; HL7 variables
  1. N CNT,DATAARY,DGERR,DGFDA,DGIEN,DGPFA,DGPFAH,DIERR,FLAGNM,MSGTYPE,SEGCNT,SEGNM,SEGSTR,SNDDIV,SNDFAC
  1. ;
  1. S HLFS=HL("FS"),HLECH=HL("ECH"),HLCMP=$E(HLECH),HLREP=$E(HL("ECH"),2),HLSCMP=$E(HL("ECH"),4)
  1. K ^TMP("DGPFHLT1",$J)
  1. ; load segments into ^TMP global
  1. F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
  1. .S CNT=0,^TMP("DGPFHLT1",$J,SEGCNT,CNT)=HLNODE
  1. .F S CNT=$O(HLNODE(CNT)) Q:'CNT S ^TMP("DGPFHLT1",$J,SEGCNT,CNT)=HLNODE(CNT)
  1. .Q
  1. ; check message type
  1. S SEGSTR=$G(^TMP("DGPFHLT1",$J,1,0))
  1. ; if ACK, just bail out
  1. I $P(SEGSTR,HLFS)="MSH",$P($P(SEGSTR,HLFS,9),HLCMP)="ACK" K ^TMP("DGPFHLT1",$J) Q
  1. ; if RSP^K11 call DGPFHLT3 and bail out
  1. I $P(SEGSTR,HLFS)="MSH",$P($P(SEGSTR,HLFS,9),HLCMP)="RSP" D EN^DGPFHLT3 Q
  1. ;
  1. S (SNDDIV,SNDFAC,FLAGNM)=""
  1. ; parse the message
  1. S SEGCNT="" F S SEGCNT=$O(^TMP("DGPFHLT1",$J,SEGCNT)) Q:SEGCNT="" D
  1. .S SEGSTR=$G(^TMP("DGPFHLT1",$J,SEGCNT,0))
  1. .S SEGNM=$P(SEGSTR,HLFS)
  1. .I SEGNM="MSH" D
  1. ..; parse MSH segment
  1. ..S SNDFAC=$P($P(SEGSTR,HLFS,4),HLCMP) ; sending facility (station #)
  1. ..S DATAARY("MSGID")=$P(SEGSTR,HLFS,10)
  1. ..Q
  1. .I SEGNM="QPD" D
  1. ..; parse QPD segment
  1. ..S DATAARY("REQID")=$P(SEGSTR,HLFS,3)
  1. ..S DATAARY("ICN")=$P(SEGSTR,HLFS,4)
  1. ..S FLAGNM=$$DECHL7^DGPFHLUT($P(SEGSTR,HLFS,5)) ; PRF flag name
  1. ..Q
  1. .I SEGNM="NTE" D
  1. ..; parse NTE segment
  1. ..S DATAARY("REQCMT")=$$DECHL7^DGPFHLUT($P(SEGSTR,HLFS,4))
  1. ..S DATAARY("REQBY")=$$FMNAME^HLFNC($P($P(SEGSTR,HLFS,6),HLCMP,1,5),HLECH)
  1. ..S DATAARY("REQBY")=$$DECHL7^DGPFHLUT(DATAARY("REQBY")) ; requester's name
  1. ..S SNDDIV=$P($P($P(SEGSTR,HLFS,6),HLCMP,14),HLSCMP,2) ; sending division (station #)
  1. ..S DATAARY("REQDTM")=$$FMDATE^HLFNC($P(SEGSTR,HLFS,7))
  1. ..Q
  1. .Q
  1. ; make sure that we got all necessary pieces of data
  1. S DATAARY("QOK")=0,DGERR=$$CHK()
  1. ; determine if flag is active
  1. S DATAARY("ACTIVE")=$S($P($G(DGPFA("STATUS")),U)=1:1,1:0)
  1. I 'DATAARY("ACTIVE") D
  1. .N DIERR,DGHERR
  1. .S DATAARY("REVBY")="DGPRF,INTERFACE"
  1. .S DATAARY("REVDUZ")=+$$FIND1^DIC(200,"","X",DATAARY("REVBY"),,,"DGHERR")
  1. .I 'DATAARY("REVDUZ") S DGERR="Receiver tried to use invalid reviewer name."
  1. .I 'DGERR S DATAARY("REVDTM")=$$NOW^XLFDT(),DATAARY("REVRES")="A"
  1. .Q
  1. ; send ACK message
  1. D SEND^DGPFHLT4(DATAARY("MSGID"),DGERR)
  1. ; if everything checked out, file a log entry
  1. I DGERR="" S DGERR=$$UPDLOG(.DATAARY)
  1. I DGERR="" D
  1. .; change status of previous requests with "PENDING" status to "NO RESPONSE"
  1. .D NORESP(DATAARY("DFN"),DATAARY("FLAG"),2)
  1. .; if flag is active, send Mailman notification
  1. .I DATAARY("ACTIVE") D TREQMSG^DGPFHLTM(.DATAARY,.DGPFA,1)
  1. .;if flag is inactive, activate it and transfer ownership to the requester
  1. .I 'DATAARY("ACTIVE") D
  1. ..S DATAARY("ORIGOWN")=$P($G(DGPFA("OWNER")),U)
  1. ..S DGERR=$$UPDASGN(1,DGIEN,.DATAARY,.DGPFA)
  1. ..S DATAARY("SENDTO")=$P($$PARENT^DGPFUT1(DATAARY("SFIEN")),U)
  1. ..I DATAARY("SENDTO")=0 S DATAARY("SENDTO")=DATAARY("SFIEN")
  1. ..; send response message (RSP^K11)
  1. ..D SEND^DGPFHLT2(DGERR,.DATAARY)
  1. ..Q
  1. .Q
  1. I DGERR'="" D
  1. .; Send Mailman notification
  1. .S ERTXT(1)="Error while processing QBP^Q11 HL7 message with message Id "_$G(DATAARY("MSGID"))_"."
  1. .S ERTXT(4)="Error description: "_DGERR
  1. .D TERRMSG^DGPFHLTM($G(DATAARY("MSGID")),.ERTXT)
  1. .Q
  1. K ^TMP("DGPFHLT1",$J)
  1. Q
  1. ;
  1. CHK() ; Check data in incoming message
  1. ; Called from EN tag, relies on (and sets) some variables defined in there
  1. ; Returns "" if there are no problems, or error message otherwise
  1. ;
  1. N DGTFL,FCLTY,OWNER,DIERR,DGHERR
  1. I $G(DATAARY("MSGID"))="" Q "Missing message Id in MSH segment."
  1. I SNDDIV="" Q "Missing sending facility in NTE segment."
  1. I $G(DATAARY("REQID"))="" Q "Missing query Id in QPD segment."
  1. S DATAARY("DFN")=+$$GETDFN^MPIF001($G(DATAARY("ICN")))
  1. I DATAARY("DFN")'>0 Q "Invalid or missing ICN in QPD segment."
  1. S DATAARY("SFIEN")=+$$IEN^XUAF4(SNDDIV)
  1. I DATAARY("SFIEN")'>0 Q "Invalid sending facility in NTE segment."
  1. D BLDTFL^DGPFUT2(DATAARY("DFN"),.DGTFL)
  1. I '$D(DGTFL(+$$IEN^XUAF4(SNDFAC))) Q "Sending facility in MSH segment is not on receiver's treating facility list."
  1. S DATAARY("SFNAME")="Station # "_SNDDIV_"("_$$NAME^XUAF4(DATAARY("SFIEN"))_")"
  1. S DATAARY("FLAG")=+$$FIND1^DIC(26.15,,"X",FLAGNM,,,"DGHERR")
  1. I DATAARY("FLAG")'>0 Q "Invalid or missing PRF flag name in QPD segment."
  1. S DGIEN=$$FNDASGN^DGPFAA(DATAARY("DFN"),DATAARY("FLAG")_";DGPF(26.15,") ; PRF assignment ien in file 26.13
  1. I DGIEN'>0 Q "Receiver was unable to find corresponding PRF flag assignment."
  1. I '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1) Q "Receiver was unable to retrieve corresponding PRF flag assignment."
  1. S DATAARY("QOK")=1
  1. S OWNER=$P($G(DGPFA("OWNER")),U)
  1. S FCLTY=$P($$SITE^VASITE(),U)
  1. I OWNER'=FCLTY,$P($$PARENT^DGPFUT1(OWNER),U)'=FCLTY Q "Receiver is not the owner of PRF flag in question."
  1. I $G(DATAARY("REQBY"))="" Q "Invalid or missing requester's name in NTE segment."
  1. I $G(DATAARY("REQDTM"))="" Q "Invalid or missing request date/time in NTE segment."
  1. Q ""
  1. ;
  1. UPDLOG(DATA) ; file a log entry
  1. ; DATA - Array of values to file (see tag EN)
  1. ; Returns "" if there are no problems, or error message otherwise
  1. ;
  1. N DGFDA,DIEERR,DIERR
  1. S DGFDA(26.22,"+1,",.01)=$G(DATA("REQDTM"))
  1. S DGFDA(26.22,"+1,",.02)=$G(DATA("REQBY"))
  1. S DGFDA(26.22,"+1,",.03)=$G(DATA("DFN"))
  1. S DGFDA(26.22,"+1,",.04)=$G(DATA("FLAG"))
  1. S DGFDA(26.22,"+1,",.05)=$S($G(DATA("ACTIVE"))=1:2,1:3)
  1. I $G(DATA("REVBY"))'="" D
  1. .S DGFDA(26.22,"+1,",.06)=DATA("REVBY")
  1. .S DGFDA(26.22,"+1,",.07)=$G(DATA("REVDTM"))
  1. .Q
  1. S DGFDA(26.22,"+1,",.08)=$G(DATA("REQID"))
  1. S DGFDA(26.22,"+1,",.09)=$G(DATA("MSGID"))
  1. S DGFDA(26.22,"+1,",.1)=$G(DATA("SFIEN"))
  1. S DGFDA(26.22,"+1,",2.01)=$G(DATA("REQCMT"))
  1. D UPDATE^DIE(,"DGFDA",,"DIEERR")
  1. I $D(DIEERR) Q $E("Log filer: "_$G(DIEERR("DIERR",1,"TEXT",1)),1,80)
  1. Q ""
  1. ;
  1. UPDASGN(AFLG,DGIEN,DATA,DGPFA) ; update PRF assignment and assignment history
  1. ; AFLG - 1 if flag needs to be reactivated, 0 otherwise
  1. ; DGIEN - ien of PRF assignment record
  1. ; DATA - Array of values to work with (see tag EN)
  1. ; DGPFA - PRF assignment array
  1. ; Returns "" if there are no problems, or error message otherwise
  1. ;
  1. N DBRSCNT,DBRSDATA,DBRSNUM,RES,Z
  1. S RES=""
  1. S DGPFAH("APPRVBY")=$G(DATA("REVDUZ"))
  1. S DGPFAH("ASSIGNDT")=$G(DATA("REVDTM"))
  1. S DGPFAH("ENTERBY")=$G(DATA("REVDUZ"))
  1. S DGPFA("REVIEWDT")=""
  1. S DGPFA("STATUS")=1 ; flag status = Active
  1. S DGPFAH("ORIGFAC")=+$$SITE^VASITE
  1. S DGPFAH("COMMENT",1,0)="Ownership transfer request has been received for this flag."
  1. ; add DBRS data to DGPFAH array
  1. D GETDBRS^DGPFUT6(.DBRSDATA,DGIEN)
  1. S (DBRSCNT,DBRSNUM)=0 F S DBRSNUM=$O(DBRSDATA(DBRSNUM)) Q:DBRSNUM="" D
  1. .S DBRSCNT=DBRSCNT+1
  1. .S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$P($G(DBRSDATA(DBRSNUM,"OTHER")),U)_U_$P($G(DBRSDATA(DBRSNUM,"DATE")),U)
  1. .S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"N"_U_$P($G(DBRSDATA(DBRSNUM,"SITE")),U)
  1. .Q
  1. ; reactivate flag if it's inactive
  1. I AFLG D
  1. .S DGPFAH("ACTION")=4 ; Action = Reactivate
  1. .S DGPFAH("COMMENT",2,0)="As a result, flag has been reactivated."
  1. .S Z=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,,"")
  1. .I $P(Z,U)'>0 S RES="Receiver was unable to update PRF assignment record." Q
  1. .I $P(Z,U,2)'>0 S RES="Receiver was unable to update PRF history record." Q
  1. .; send ORU HL7 message for reactivation
  1. .S:'$$SNDORU^DGPFHLS(DGIEN) RES="Receiver was unable to send HL7 message update (ORU message)."
  1. .Q
  1. I RES="" D
  1. .; change ownership
  1. .S DGPFAH("ACTION")=2 ; Action = Continue
  1. .S DGPFA("OWNER")=$G(DATA("SFIEN")) ; New owner site
  1. .S DGPFAH("COMMENT",2,0)="As a result, flag ownership has been transferred"
  1. .S DGPFAH("COMMENT",3,0)="to "_$G(DATA("SFNAME"))
  1. .H 1 S DGPFAH("ASSIGNDT")=$$NOW^XLFDT() ; ensure that date/time of this history record differs from the previous one (reactivation)
  1. .S Z=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,,"")
  1. .I $P(Z,U)'>0 S RES="Receiver was unable to update PRF assignment record." Q
  1. .I $P(Z,U,2)'>0 S RES="Receiver was unable to update PRF history record." Q
  1. .; send ORU HL7 message for ownership transfer
  1. .S:'$$SNDORU^DGPFHLS(DGIEN) RES="Receiver was unable to send HL7 message update (ORU message)."
  1. .Q
  1. Q RES
  1. ;
  1. NORESP(DFN,FLAG,STATUS) ; set status of entries in file 26.22 to "NO RESPONSE"
  1. ; DFN - patient DFN
  1. ; FLAG - flag ien in file 26.15
  1. ; STATUS - current status of entries that should be flipped to "NO RESPONSE" (internal code)
  1. ;
  1. N DATE,DGFDA,DGHERR,DIERR,IEN
  1. I +DFN'>0 Q
  1. I +FLAG'>0 Q
  1. I +STATUS'>0 Q
  1. ; skip the latest entry
  1. S DATE=$O(^DGPF(26.22,"D",DFN,FLAG,STATUS,""),-1)
  1. ; loop backwards, starting from the second to last entry
  1. F S DATE=$O(^DGPF(26.22,"D",DFN,FLAG,STATUS,DATE),-1) Q:DATE="" D
  1. .S IEN=+$O(^DGPF(26.22,"D",DFN,FLAG,STATUS,DATE,""))
  1. .S DGFDA(26.22,IEN_",",.05)=6
  1. .D FILE^DIE(,"DGFDA","DGHERR") K DGFDA
  1. .Q
  1. Q