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

GMRCCCRI.m

Go to the documentation of this file. 
  1. GMRCCCRI ;DAL/PHH/MBJ - PROCESS HL7 RRI^I13 MESSAGES FROM HSRM ;8/29/18
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**123**;FEB 2019;Build 51
  1.  ;
  1.  ; Built from pieces of GMRCHL7I and modified for CCRA consult status update
  1.  Q
  1.  ; Documented API's and Integration Agreements
  1.  ; ----------------------------------------------
  1.  ; 2165   GENACK^HLMA1
  1.  ; 2701   $$GETDFN^MPIF001
  1.  ; 2701   $$GETICN^MPIF001
  1.  ; 3535   MAKEADD^TIUSRVP2
  1.  ; 10103  $$HL7TFM^XLFDT
  1.  ;
  1. EN ; Entry point for routine
  1.  N FS,CS,RS,ES,SS,MID,HLQUIT,HLNODE,I13MSG,ABORT,ERR1,NAKMSG
  1.  S FS=$G(HL("FS"),"|")
  1.  S CS=$E($G(HL("ECH")),1) S:CS="" CS="^"
  1.  S RS=$E($G(HL("ECH")),2) S:RS="" RS="~"
  1.  S ES=$E($G(HL("ECH")),3) S:ES="" ES="\"
  1.  S SS=$E($G(HL("ECH")),4) S:SS="" SS="&"
  1.  S MID=$G(HL("MID"))
  1.  S (HLQUIT,HLNODE)=0
  1.  D COPYMSG(.I13MSG)
  1.  Q:$$CHKMSG(.I13MSG)
  1.  Q:$$PROCMSG(.I13MSG)
  1.  D ACK("CA",MID)
  1.  Q
  1.  ;
  1. COPYMSG(Y) ; Copy HL7 Message to array Y (by reference)
  1.  ; Based on HL*1.6*56 VISTA HL7 Site Manager & Developer Manual
  1.  ; Paragraph 9.7, page 9-4
  1.  I $L($G(HLNEXT)) ;HL7 context
  1.  E  Q
  1.  N I,J
  1.  F I=1:1 X HLNEXT Q:HLQUIT'>0  D
  1.  .S Y(I)=HLNODE,J=0
  1.  .F  S J=$O(HLNODE(J)) Q:'J  D
  1.  ..S Y(I)=Y(I)_HLNODE(J)
  1.  Q
  1.  ;
  1. CHKMSG(Y) ; Check Message for all required segments
  1.  N QUIT,REQSEG,SEGFND,I,SEGTYP,ICN,DFN
  1.  S QUIT=0
  1.  F REQSEG="MSH","RF1","PRD","PID","PV1" D  Q:QUIT
  1.  .S (SEGFND,I)=0
  1.  .F  S I=$O(Y(I)) Q:'I!(SEGFND)  D
  1.  ..S SEGTYP=$E(Y(I),1,3)
  1.  ..I SEGTYP=REQSEG S SEGFND=1
  1.  ..;
  1.  ..I SEGTYP="MSH",$P(Y(I),FS,10)="" D
  1.  ...S QUIT=1
  1.  ...D ACK("CE",MID,"MSH","",10,101,"MESSAGE CONTROL ID MISSING")
  1.  ..;
  1.  .I 'SEGFND D
  1.  ..S QUIT=1
  1.  ..D ACK("CE",MID,REQSEG,"","",100,REQSEG_" SEGMENT MISSING OR OUT OF ORDER")
  1.  Q QUIT
  1.  ;
  1. PROCMSG(Y) ; Process message
  1.  N QUIT,I,SEGTYP,GMRCRF1,GMRCPID,GMRCPRD,GMRCOBR,GMRCNTE,GMRCIEN,GMRCICN,GMRCEML
  1.  N GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU,STID,PROGAUTH,REFDT,REFXDT,XDT
  1.  S (QUIT,I)=0,GMRCEML=""
  1.  F  S I=$O(Y(I)) Q:'I  D
  1.  .S SEGTYP=$E(Y(I),1,3)
  1.  .I SEGTYP="RF1" D RF1(Y(I),.GMRCRF1)
  1.  .I SEGTYP="PID" D PID(Y(I),.GMRCPID)
  1.  .I SEGTYP="PRD" D PRD(Y(I),.GMRCPRD)
  1.  ;
  1.  S GMRCIEN=+GMRCRF1,GMRCSTS=$P(GMRCRF1,FS,2)
  1.  ;
  1.  I 'GMRCIEN!('$D(^GMR(123,+GMRCIEN,0))) D  Q QUIT
  1.  .S QUIT=1
  1.  .D ACK("CE",MID,"RF1","",6,"VA207","INVALID IEN FOR CONSULT",1)
  1.  ;
  1.  S GMRCICN=GMRCPID
  1.  S GMRCDFN=$$GETDFN^MPIF001($P(GMRCICN,"V"))
  1.  I GMRCDFN'>0 D  Q QUIT
  1.  .S QUIT=1
  1.  .D ACK("CE",MID,"PID",1,3,"VA207",$P(GMRCDFN,"^",2),1)
  1.  I GMRCICN'=$$GETICN^MPIF001(GMRCDFN) D  Q QUIT
  1.  .S QUIT=1
  1.  .D ACK("CE",MID,"PID",1,3,"VA207","ICN CHECKSUM DOES NOT MATCH CHECKSUM IN DATABASE",1)
  1.  ;
  1.  I $P(^GMR(123,GMRCIEN,0),"^",2)'=GMRCDFN D  Q QUIT
  1.  .S QUIT=1
  1.  .D ACK("CE",MID,"RF1","",6,"VA207","ICN DOES NOT MATCH PATIENT DFN IN CONSULT",1)
  1.  ;
  1.  ; check for valid VistA user via user email value, create NAK if invalid and quit
  1.  S GMRCDT=$$NOW^XLFDT(),GMRCDT1=$$FMTE^XLFDT(GMRCDT,2)
  1.  ; S XDT=$E($P(GMRCDT1,".",2)+1000000,2,5),GMRCDT1=$P(GMRCDT1,".")_XDT
  1.  S GMRCUSER=$$LOW^XLFSTR(GMRCEML)
  1.  I GMRCUSER'="" S GMRCUSER=$O(^VA(200,"ADUPN",$G(GMRCUSER),""))
  1.  I GMRCUSER'>0 S (NAKMSG,ERR1)="HSRM USER DOESN'T HAVE AN ACCOUNT ON THIS SYSTEM",ABORT="1^"_ERR1
  1.  I $G(NAKMSG)'="" S QUIT=1 D ANAK^GMRCCCR1($G(NAKMSG),$G(GMRCEML),$G(GMRCICN),$G(GMRCDFN),$G(GMRCIEN),GMRCDT1)
  1.  I +$G(ABORT)>0 D MESSAGE2^GMRCCCR1(MID,.ABORT,GMRCIEN) Q 1
  1.  ;
  1.  ; Reject if Referral Status is not valid
  1.  S STID=$P(GMRCSTS,CS)
  1.  I "A,AC,AP,BP,C,D,P,RJ,X,"'[STID_"," D
  1.  .S QUIT=1
  1.  .D ACK("CE",MID,"RF1","",1,"VA207","INVALID REFERRAL STATUS",1)
  1.  ;
  1.  Q:QUIT
  1.  S GMRCSTS=$S(STID="A":"SCHEDULED",STID="AC":"ACTIVE",STID="AP":"ACTIVE",STID="BP":"COMPLETE",STID="C":"ACTIVE",STID="D":"COMPLETE",STID="P":"PENDING",STID="RJ":"ACTIVE",STID="X":"CANCELLED",1:"")
  1.  I GMRCSTS'="" D
  1.  . ; file status into field 8 of consult file
  1.  . K FDA S FDA(123,GMRCIEN_",",8)=GMRCSTS
  1.  . D FILE^DIE("E","FDA")
  1.  . K FDA,GMRCFDA
  1.  . ;
  1.  . S GMRCSTID=$S(STID="X":"CANCELLED",STID="A":"SCHEDULED",STID="BP":"COMPLETE/UPDATE",STID="D":"COMPLETE/UPDATE",1:"ADDED COMMENT")
  1.  . S GMRCSTID=$O(^GMR(123.1,"B",GMRCSTID,""))
  1.  . K FDA S FDA(123,GMRCIEN_",",9)=GMRCSTID
  1.  . D FILE^DIE("","FDA") K FDA
  1.  . ;
  1.  . ; create consult note for new status
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",1)=GMRCSTID
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
  1.  . D UPDATE^DIE("","GMRCFDA","GMRCCIEN")
  1.  . S GMRCTXT(1)="CONSULT STATUS CHANGED TO "_GMRCSTS_" "_GMRCDT1
  1.  . D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
  1.  . K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
  1.  ;
  1.  ; create consult note with new referral date from HSRM
  1.  I REFDT]"" D
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
  1.  . D UPDATE^DIE("","GMRCFDA","GMRCCIEN","GMRCERR")
  1.  . S GMRCTXT(1)="REFERRAL DATE IS "_REFDT ;
  1.  . D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
  1.  . K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
  1.  ;
  1.  ; create consult note with new referral expiration date from HSRM
  1.  I REFXDT]"" D
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
  1.  . D UPDATE^DIE("","GMRCFDA","GMRCCIEN")
  1.  . S GMRCTXT(1)="REFERRAL EXPIRATION DATE IS "_REFXDT ;
  1.  . D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
  1.  . K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
  1.  ;
  1.  ; create consult note with new program authority value from HSRM
  1.  I PROGAUTH]"" D
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",.01)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",2)=GMRCDT
  1.  . S GMRCFDA(123.02,"+1,"_GMRCIEN_",",4)=GMRCUSER
  1.  . D UPDATE^DIE("","GMRCFDA","GMRCCIEN")
  1.  . S GMRCTXT(1)="PROGRAM AUTHORITY IS "_PROGAUTH
  1.  . D WP^DIE(123.02,GMRCCIEN(1)_","_GMRCIEN_",",5,"","GMRCTXT","GMRCERR")
  1.  . K FDA,GMRCFDA,GMRCCIEN,GMRCTXT,GMRCERR
  1.  ;
  1.  K GMRCFDA,GMRCDT,GMRCDT1,GMRCCIEN,GMRCSTID,GMRCTXT,GMRCUSER
  1.  Q QUIT
  1.  ;
  1. RF1(RF1SEG,RETVAL) ; Process RF1 Segment
  1.  N GMRCSTS,GMRCIEN
  1.  S GMRCSTS=$P(RF1SEG,FS,2)
  1.  S GMRCIEN=$P(RF1SEG,FS,7)
  1.  S REFDT=$P($P(RF1SEG,FS,8),CS)
  1.  S REFXDT=$P($P(RF1SEG,FS,9),CS)
  1.  S PROGAUTH=$P($P(RF1SEG,FS,11),CS,2)
  1.  S RETVAL=GMRCIEN_FS_GMRCSTS
  1.  Q
  1.  ;
  1. PID(PIDSEG,RETVAL) ; Process PID Segment
  1.  N GMRCICN,I,J,GMRCI,GMRCJ
  1.  S GMRCJ=$P(PIDSEG,FS,4),GMRCICN=""
  1.  F J=1:1:$L(GMRCJ,RS) D  Q:GMRCICN'=""
  1.  . S GMRCI=$P(GMRCJ,RS,J)
  1.  . F I=1:1:$L(GMRCI,CS) D  Q:GMRCICN'=""
  1.  .. I $P($P(GMRCJ,CS,I),RS)["NI" S GMRCICN=$P(GMRCI,CS,J) Q
  1.  S RETVAL=GMRCICN
  1.  Q
  1.  ;
  1. PRD(PRDSEG,RETVAL) ; Process PRD segment
  1.  I $L(GMRCEML)>0 S RETVAL=GMRCEML Q RETVAL ; already found in previous PRD segment
  1.  I $P($P(PRDSEG,FS,2),CS,1)'="RP" S RETVAL=0 Q RETVAL
  1.  S GMRCEML=$P(PRDSEG,FS,6),GMRCEML=$P(GMRCEML,CS,4)
  1.  S RETVAL=GMRCEML Q RETVAL
  1.  ;
  1. ACK(STAT,MID,SID,SEG,FLD,CD,TXT,ACKTYP) ; Creates ACKs for HL7 Message
  1.  ;STAT = Status (Acknowledgment Code) (REQUIRED)
  1.  ;MID = Message ID (REQUIRED)
  1.  ;SID = Segment ID (set if ERR occurred in segment) (OPTIONAL)
  1.  ;SEG = Segment location of error (OPTIONAL)
  1.  ;FLD = Field location of error (OPTIONAL)
  1.  ;CD = Error Code (OPTIONAL)
  1.  ;TXT = Text describing error (OPTIONAL)
  1.  ;ACKTYP = Acknowledgment Type (OPTIONAL)
  1.  ;
  1.  N HLA,EID,EIDS,RES,ERRI
  1.  ;
  1.  ;Make sure the parameters are defined
  1.  S STAT=$G(STAT),MID=$G(MID),SID=$G(SID),SEG=$G(SEG)
  1.  S FLD=$G(FLD),CD=$G(CD),TXT=$G(TXT)
  1.  ;
  1.  ;Create MSA Segment
  1.  S HLA("HLA",1)="MSA"_FS_STAT_FS_MID
  1.  S EID=$G(HL("EID"))
  1.  S EIDS=$G(HL("EIDS"))
  1.  Q:((EID="")!($G(HLMTIENS)="")!(EIDS=""))
  1.  ;
  1.  S RES=""
  1.  ;If Segment ID (SID) is set, create ERR segment
  1.  D:$L(SID)>0
  1.  . K ERRARY
  1.  . S HLA("HLA",2)="ERR"
  1.  . S $P(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD
  1.  . S $P(HLA("HLA",2),FS,5)="E"
  1.  . ;
  1.  . ; Commit Error
  1.  . I '+$G(ACKTYP) D
  1.  .. S $P(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357"
  1.  . ;
  1.  . ; Application Error
  1.  . I +$G(ACKTYP)=1 D
  1.  .. S ERRI=0
  1.  .. S $P(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT
  1.  .. ;Process Error
  1.  .. S ERRI=ERRI+1
  1.  .. S ERRARY(ERRI,2)=$P($G(HLA("HLA",2)),"|",3)
  1.  .. I $P($G(HLA("HLA",2)),"|",6)'="" D  ;
  1.  ... S ERRARY(ERRI,3)=$P($P($G(HLA("HLA",2)),"|",6),"^",4)_"^"_$P($P($G(HLA("HLA",2)),"|",6),"^",5)
  1.  .. I $P($G(HLA("HLA",2)),"|",6)="" S ERRARY(ERRI,3)=$P($G(HLA("HLA",2)),"|",4)
  1.  . I $D(ERRARY) D MESSAGE(MID,.ERRARY)
  1.  . ; build message for MailMan
  1.  ;
  1.  D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
  1.  Q
  1. MESSAGE(MSGID,ERRARY) ; Send a MailMan Message with the errors
  1.  N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J
  1.  S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1)))
  1.  S XMSUB="GMRC CCRA Consult Updates from HSRM HL7 Error"
  1.  S MSGTEXT(1)=" "
  1.  S MSGTEXT(2)="Error in receiving HL7 message from HSRM"
  1.  S MSGTEXT(3)="Date:       "_DATE
  1.  S MSGTEXT(4)="Message ID: "_MSGID
  1.  S MSGTEXT(5)="Error(s):"
  1.  S I=0,J=5 F  S I=$O(ERRARY(I)) Q:'I  D
  1.  . S J=J+1,MSGTEXT(J)=" "
  1.  . S J=J+1,MSGTEXT(J)="   "_$P($G(ERRARY(I,3)),U)_" - "_$P($G(ERRARY(I,3)),U,2)
  1.  . I $P($G(ERRARY(I,2)),U,1)'="" S J=J+1,MSGTEXT(J)="      Segment:       "_$P($G(ERRARY(I,2)),U,1)
  1.  . I $P($G(ERRARY(I,2)),U,2)'="" S J=J+1,MSGTEXT(J)="      Sequence:      "_$P($G(ERRARY(I,2)),U,2)
  1.  . I $P($G(ERRARY(I,2)),U,3)'="" S J=J+1,MSGTEXT(J)="      Field:         "_$P($G(ERRARY(I,2)),U,3)
  1.  . I $P($G(ERRARY(I,2)),U,4)'="" S J=J+1,MSGTEXT(J)="      Fld Rep:       "_$P($G(ERRARY(I,2)),U,4)
  1.  . I $P($G(ERRARY(I,2)),U,5)'="" S J=J+1,MSGTEXT(J)="      Component:     "_$P($G(ERRARY(I,2)),U,5)
  1.  . I $P($G(ERRARY(I,2)),U,6)'="" S J=J+1,MSGTEXT(J)="      Sub-component: "_$P($G(ERRARY(I,2)),U,6)
  1.  S XMTEXT="MSGTEXT("
  1.  S XMDUZ="GMRC-CCRA<-HSRP Transaction Error"
  1.  S XMY("G.GMRC HCP HL7 MESSAGES")=""  ;  ** CHECK THIS OUT **
  1.  D ^XMD
  1.  Q