- GMRCHL7I ;DAL/PHH - PROCESS HL7 RRI^I13 MESSAGES FROM HCPS ;8/7/14
- ;;3.0;CONSULT/REQUEST TRACKING;**75**;DEC 27, 1997;Build 22
- ;
- Q
- ; Documented API's and Integration Agreements
- ; ----------------------------------------------
- ; 2165 GENACK^HLMA1
- ; 2701 $$GETDFN^MPIF001
- ; 2701 $$GETICN^MPIF001
- ; 3535 MAKEADD^TIUSRVP2
- ; 10103 $$HL7TFM^XLFDT
- ;
- EN ; Entry point for routine
- N FS,CS,RS,ES,SS,MID,HLQUIT,HLNODE,I13MSG
- S FS=$G(HL("FS"),"|")
- S CS=$E($G(HL("ECH")),1) S:CS="" CS="^"
- S RS=$E($G(HL("ECH")),2) S:RS="" RS="~"
- S ES=$E($G(HL("ECH")),3) S:ES="" ES="\"
- S SS=$E($G(HL("ECH")),4) S:SS="" SS="&"
- S MID=$G(HL("MID"))
- S (HLQUIT,HLNODE)=0
- D COPYMSG(.I13MSG)
- Q:$$CHKMSG(.I13MSG)
- Q:$$PROCMSG(.I13MSG)
- D ACK("AA",MID)
- Q
- ;
- COPYMSG(Y) ; Copy HL7 Message to array Y (by reference)
- ; Based on HL*1.6*56 VISTA HL7 Site Manager & Developer Manual
- ; Paragraph 9.7, page 9-4
- I $L($G(HLNEXT)) ;HL7 context
- E Q
- N I,J
- F I=1:1 X HLNEXT Q:HLQUIT'>0 D
- .S Y(I)=HLNODE,J=0
- .F S J=$O(HLNODE(J)) Q:'J D
- ..S Y(I)=Y(I)_HLNODE(J)
- Q
- ;
- CHKMSG(Y) ; Check Message for all required segments
- N QUIT,REQSEG,SEGFND,I,SEGTYP,ICN,DFN
- S QUIT=0
- F REQSEG="MSH","RF1","PRD","PID","OBR","PV1","NTE" D Q:QUIT
- .S (SEGFND,I)=0
- .F S I=$O(Y(I)) Q:'I!(SEGFND) D
- ..S SEGTYP=$E(Y(I),1,3)
- ..I SEGTYP=REQSEG S SEGFND=1
- ..;
- ..I SEGTYP="MSH",$P(Y(I),FS,10)="" D
- ...S QUIT=1
- ...D ACK("AE",MID,"MSH","",10,101,"MESSAGE CONTROL ID MISSING")
- ..;
- .I 'SEGFND D
- ..S QUIT=1
- ..D ACK("AE",MID,REQSEG,"","",100,REQSEG_" SEGMENT MISSING OR OUT OF ORDER")
- Q QUIT
- ;
- PROCMSG(Y) ; Process message
- N QUIT,I,SEGTYP,GMRCRF1,GMRCPID,GMRCOBR,GMRCNTE,GMRCIEN,GMRCICN
- N GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU
- S (QUIT,I)=0
- F S I=$O(Y(I)) Q:'I D
- .S SEGTYP=$E(Y(I),1,3)
- .I SEGTYP="RF1" D RF1(Y(I),.GMRCRF1)
- .I SEGTYP="PID" D PID(Y(I),.GMRCPID)
- .I SEGTYP="OBR" D OBR(Y(I),.GMRCOBR)
- .I SEGTYP="NTE" D NTE(Y(I),.GMRCNTE)
- ;
- S GMRCIEN=+GMRCRF1
- ;
- I 'GMRCIEN!('$D(^GMR(123,+GMRCIEN,0))) D Q QUIT
- .S QUIT=1
- .D ACK("AE",MID,"RF1","",6,"VA207","INVALID IEN FOR CONSULT",1)
- ;
- S GMRCICN=GMRCPID
- S GMRCDFN=$$GETDFN^MPIF001($P(GMRCICN,"V"))
- I GMRCDFN'>0 D Q QUIT
- .S QUIT=1
- .D ACK("AE",MID,"PID",1,3,"VA207",$P(GMRCDFN,"^",2),1)
- I GMRCICN'=$$GETICN^MPIF001(GMRCDFN) D Q QUIT
- .S QUIT=1
- .D ACK("AE",MID,"PID",1,3,"VA207","ICN CHECKSUM DOES NOT MATCH CHECKSUM IN DATABASE",1)
- ;
- I $P(^GMR(123,GMRCIEN,0),"^",2)'=GMRCDFN D Q QUIT
- .S QUIT=1
- .D ACK("AE",MID,"RF1","",6,"VA207","ICN DOES NOT MATCH PATIENT DFN IN CONSULT",1)
- ;
- ; Reject if Referral Status is not valid
- I $P(GMRCRF1,FS,2)'="IP^ADDED COMMENT",$P(GMRCRF1,FS,2)'="CM^ADDENDED",$P(GMRCRF1,FS,2)'="IP^REJECTED" D Q QUIT
- .S QUIT=1
- .D ACK("AE",MID,"RF1","",1,"VA207","INVALID REFERRAL STATUS",1)
- ;
- ; Add comment to file #123
- I $P(GMRCRF1,FS,2)="IP^ADDED COMMENT"!($P(GMRCRF1,FS,2)="IP^REJECTED") D
- .;
- .; Quit if IEN being passed by HCP isn't for a Consult
- .I +GMRCOBR'=GMRCIEN!($P(GMRCOBR,FS,2)'="GMRC") D Q
- ..S QUIT=1
- ..D ACK("AE",MID,"OBR",1,3,"VA207","INVALID CONSULT REFERENCE",1)
- .;
- .I $D(GMRCNTE("WP")) D ADDCMT(GMRCIEN,.GMRCNTE)
- .I $P(GMRCRF1,FS,2)="IP^ADDED COMMENT" D SNDALRT(GMRCIEN)
- .I $P(GMRCRF1,FS,2)="IP^REJECTED" D SNDALRT(GMRCIEN,1)
- ;
- ; Add addendum to file #8925
- I $P(GMRCRF1,FS,2)="CM^ADDENDED" D
- .;
- .S GMRCTIU=+GMRCOBR,GMRCTIUS=""
- .D GETSTAT^TIUPRF2(.GMRCTIUS,GMRCTIU)
- .S GMRCTIUS=$P(GMRCTIUS,"^",2)
- .;
- .; Quit if IEN being passed by HCP isn't for a Progress Note
- .I 'GMRCTIU!($P(GMRCOBR,FS,2)'="TIU")!('$D(^TIU(8925,+GMRCTIU,0)))!(GMRCTIUS="RETRACTED") D Q
- ..S QUIT=1
- ..D ACK("AE",MID,"OBR",1,3,"VA207","INVALID PROGRESS NOTE REFERENCE",1)
- .;
- .D TIUTXT(.GMRCNTE,.ADDTXT)
- .D MAKEADD^TIUSRVP2(.GMRCATIU,GMRCTIU,.ADDTXT)
- .I +GMRCATIU>0 D UPDUSRS(GMRCTIU,GMRCATIU)
- .D SNDALRT(GMRCIEN)
- ;
- Q QUIT
- ;
- RF1(RF1SEG,RETVAL) ; Process RF1 Segment
- N GMRCSTS,GMRCIEN
- S GMRCSTS=$P(RF1SEG,FS,2)
- S GMRCIEN=$P(RF1SEG,FS,7)
- S RETVAL=GMRCIEN_FS_GMRCSTS
- Q
- ;
- PID(PIDSEG,RETVAL) ; Process PID Segment
- N GMRCICN
- S GMRCICN=$P($P(PIDSEG,FS,4),CS)
- S RETVAL=GMRCICN
- Q
- ;
- OBR(OBRSEG,RETVAL) ; Process OBR Segment
- N GMRCOIEN,GMRCTYP
- S GMRCOIEN=+$P(OBRSEG,FS,4)
- S GMRCTYP=$P($P(OBRSEG,FS,4),CS,2)
- S RETVAL=GMRCOIEN_FS_GMRCTYP
- Q
- ;
- NTE(NTESEG,RETVAL) ; Process NTE Segment
- N I,GMRCTXT
- S I=$P(NTESEG,FS,2)
- Q:'+I
- S GMRCTXT=$$DEESCAPE($P(NTESEG,FS,4))
- ; Strip the following only if HCPS is sending separately
- I GMRCTXT="Activity Comment" Q
- I GMRCTXT="Comment~~" Q
- ;
- I $E(GMRCTXT,1,8)="Author~~" D
- .S $E(GMRCTXT,1,8)="Author: "
- ;
- I $E(GMRCTXT,1,10)="Datetime~~" D Q
- .S RETVAL("Datetime")=$P(GMRCTXT,"Datetime~~",2)
- .; Strip any 'spaces'
- .S RETVAL("Datetime")=$TR(RETVAL("Datetime")," ","")
- ;
- I $E(GMRCTXT,1,9)="Comment~~" D
- .S $E(GMRCTXT,1,9)="Comment: "
- ;
- S RETVAL("WP",I)=GMRCTXT
- Q
- ;
- ADDCMT(GMRCIEN,NTEARY) ; Add comment to file #123
- N GMRCFDA,GMRCERR,GMRCCMT,GMRCLACT,GMRCPRXY
- S GMRCFDA(.01)=$$NOW^XLFDT
- S GMRCFDA(1)=$O(^GMR(123.1,"B","ADDED COMMENT",0))
- S GMRCFDA(2)=GMRCFDA(.01)
- I $G(NTEARY("Datetime"))'="" D
- .S GMRCFDA(2)=$$HL7TFM^XLFDT(NTEARY("Datetime"),"L")
- S GMRCPRXY=+$O(^VA(200,"B","HCPS,APPLICATION PROXY",0))
- I GMRCPRXY D
- .S GMRCFDA(3)=GMRCPRXY
- .S GMRCFDA(4)=GMRCPRXY
- K FDA
- M FDA(1,123.02,"+1,"_GMRCIEN_",")=GMRCFDA
- D UPDATE^DIE("","FDA(1)",,"GMRCERR")
- ;
- S GMRCCMT=$NA(NTEARY("WP"))
- S GMRCLACT=$O(^GMR(123,GMRCIEN,40," "),-1)
- D WP^DIE(123.02,GMRCLACT_","_GMRCIEN_",",5,"K",GMRCCMT)
- K FDA
- Q
- ;
- TIUTXT(NTEARY,RETVAL) ; Return TIU-formatted Text
- N I
- S I=0
- F S I=$O(NTEARY("WP",I)) Q:'I D
- .S RETVAL("TEXT",I,0)=NTEARY("WP",I)
- Q
- ;
- UPDUSRS(GMRCTIU,GMRCATIU) ; Update Users on Addendums
- N GMRC1302,GMRC1202,GMRC1204,DIE,DA,DR,X
- S GMRC1302=+$P($G(^TIU(8925,GMRCTIU,13)),"^",2) ; ENTERED BY
- S GMRC1202=+$P($G(^TIU(8925,GMRCTIU,12)),"^",2) ; AUTHOR/DICTATOR
- S GMRC1204=+$P($G(^TIU(8925,GMRCTIU,12)),"^",4) ; EXPECTED SIGNER
- ;
- S DIE="^TIU(8925,",DA=GMRCATIU
- S DR="1302///^S X=GMRC1302;1202///^S X=GMRC1202;1204///^S X=GMRC1204"
- L +^TIU(8925,GMRCATIU):$G(DILOCKTM,3)
- I $T D ^DIE L -^TIU(8925,GMRCATIU)
- Q
- ;
- DEESCAPE(TXTSTR) ; De-escape delimiters
- ; (assuming "\" is the escape character):
- ; - field separator (de-escape from \F\)
- ; - component separator (de-escape from \S\)
- ; - repetition separator (de-escape from \R\)
- ; - escape character (de-escape from \E\)
- ; - subcomponent separator (de-escape from \T\)
- ; \F\ will be de-escaped only if the length of FS is 1.
- ;
- N HLDATA,HLENCHR,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
- S HLDATA=$G(TXTSTR)
- Q:HLDATA']"" HLDATA
- ;
- S HLENCHR=$G(HL("ECH"),"^~\&")
- Q:$L(HLENCHR)<3 HLDATA
- ;
- S HLEN=$L(HLDATA)
- S HLOUT=""
- F HLI=1:1:HLEN D
- .S HLCHAR=$E(HLDATA,HLI)
- .S HLCHAR23=""
- .I HLCHAR=ES D
- ..S HLCHAR23=$E(HLDATA,HLI+1,HLI+2)
- .I $L($G(FS))=1,(HLCHAR23=("F"_ES)) D Q
- ..S HLOUT=HLOUT_FS
- ..S HLI=HLI+2
- .I HLCHAR23=("S"_ES) D Q
- ..S HLOUT=HLOUT_CS
- ..S HLI=HLI+2
- .I HLCHAR23=("R"_ES) D Q
- ..S HLOUT=HLOUT_RS
- ..S HLI=HLI+2
- .I HLCHAR23=("E"_ES) D Q
- ..S HLOUT=HLOUT_ES
- ..S HLI=HLI+2
- .I $L(HLENCHR)>3,(HLCHAR23=("T"_ES)) D Q
- ..S HLOUT=HLOUT_SS
- ..S HLI=HLI+2
- .S HLOUT=HLOUT_HLCHAR
- ;
- Q HLOUT
- ;
- SNDALRT(GMRCIEN,GMRCRJT) ; Send Alert
- ; GMRCRJT is optional, and is only set to 1 for a rejection status
- N GMRCORTX,GMRCORN,GMRCRP,GMRCADUZ,GMRCDFN
- S GMRCORTX="Updates received from HCP "
- I +$G(GMRCRJT) S GMRCORTX="Rejected status from HCP "
- S GMRCORN=63
- S GMRCRP=+$P($G(^GMR(123,+GMRCIEN,0)),"^",14) ; Requesting Provider
- S:GMRCRP GMRCADUZ(GMRCRP)=""
- I '$D(GMRCADUZ) S GMRCADUZ=""
- S GMRCDFN=$P($G(^GMR(123,+GMRCIEN,0)),"^",2)
- S GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCIEN)
- D MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCIEN,GMRCORN,.GMRCADUZ,"")
- Q
- ;
- ACK(STAT,MID,SID,SEG,FLD,CD,TXT,ACKTYP) ; Creates ACKs for HL7 Message
- ;STAT = Status (Acknowledgment Code) (REQUIRED)
- ;MID = Message ID (REQUIRED)
- ;SID = Segment ID (set if ERR occured in segment) (OPTIONAL)
- ;SEG = Segment location of error (OPTIONAL)
- ;FLD = Field location of error (OPTIONAL)
- ;CD = Error Code (OPTIONAL)
- ;TXT = Text describing error (OPTIONAL)
- ;ACKTYP = Acknowledgment Type (OPTIONAL)
- ;
- N HLA,EID,EIDS,RES,ERR
- ;
- ;Make sure the parameters are defined
- S STAT=$G(STAT),MID=$G(MID),SID=$G(SID),SEG=$G(SEG)
- S FLD=$G(FLD),CD=$G(CD),TXT=$G(TXT)
- ;
- ;Create MSA Segment
- S HLA("HLA",1)="MSA"_FS_STAT_FS_MID
- S EID=$G(HL("EID"))
- S EIDS=$G(HL("EIDS"))
- Q:((EID="")!($G(HLMTIENS)="")!(EIDS=""))
- ;
- S RES=""
- ;If Segment ID (SID) is set, create ERR segment
- D:$L(SID)>0
- .S HLA("HLA",2)="ERR"
- .S $P(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD
- .S $P(HLA("HLA",2),FS,5)="E"
- .;
- .; Commit Error
- .I '+$G(ACKTYP) D
- ..S $P(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357"
- .;
- .; Application Error
- .I +$G(ACKTYP)=1 D
- ..S $P(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT
- ;
- D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCHL7I 9088 printed Feb 18, 2025@23:12:13 Page 2
- GMRCHL7I ;DAL/PHH - PROCESS HL7 RRI^I13 MESSAGES FROM HCPS ;8/7/14
- +1 ;;3.0;CONSULT/REQUEST TRACKING;**75**;DEC 27, 1997;Build 22
- +2 ;
- +3 QUIT
- +4 ; Documented API's and Integration Agreements
- +5 ; ----------------------------------------------
- +6 ; 2165 GENACK^HLMA1
- +7 ; 2701 $$GETDFN^MPIF001
- +8 ; 2701 $$GETICN^MPIF001
- +9 ; 3535 MAKEADD^TIUSRVP2
- +10 ; 10103 $$HL7TFM^XLFDT
- +11 ;
- EN ; Entry point for routine
- +1 NEW FS,CS,RS,ES,SS,MID,HLQUIT,HLNODE,I13MSG
- +2 SET FS=$GET(HL("FS"),"|")
- +3 SET CS=$EXTRACT($GET(HL("ECH")),1)
- if CS=""
- SET CS="^"
- +4 SET RS=$EXTRACT($GET(HL("ECH")),2)
- if RS=""
- SET RS="~"
- +5 SET ES=$EXTRACT($GET(HL("ECH")),3)
- if ES=""
- SET ES="\"
- +6 SET SS=$EXTRACT($GET(HL("ECH")),4)
- if SS=""
- SET SS="&"
- +7 SET MID=$GET(HL("MID"))
- +8 SET (HLQUIT,HLNODE)=0
- +9 DO COPYMSG(.I13MSG)
- +10 if $$CHKMSG(.I13MSG)
- QUIT
- +11 if $$PROCMSG(.I13MSG)
- QUIT
- +12 DO ACK("AA",MID)
- +13 QUIT
- +14 ;
- COPYMSG(Y) ; Copy HL7 Message to array Y (by reference)
- +1 ; Based on HL*1.6*56 VISTA HL7 Site Manager & Developer Manual
- +2 ; Paragraph 9.7, page 9-4
- +3 ;HL7 context
- IF $LENGTH($GET(HLNEXT))
- +4 IF '$TEST
- QUIT
- +5 NEW I,J
- +6 FOR I=1:1
- XECUTE HLNEXT
- if HLQUIT'>0
- QUIT
- Begin DoDot:1
- +7 SET Y(I)=HLNODE
- SET J=0
- +8 FOR
- SET J=$ORDER(HLNODE(J))
- if 'J
- QUIT
- Begin DoDot:2
- +9 SET Y(I)=Y(I)_HLNODE(J)
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- CHKMSG(Y) ; Check Message for all required segments
- +1 NEW QUIT,REQSEG,SEGFND,I,SEGTYP,ICN,DFN
- +2 SET QUIT=0
- +3 FOR REQSEG="MSH","RF1","PRD","PID","OBR","PV1","NTE"
- Begin DoDot:1
- +4 SET (SEGFND,I)=0
- +5 FOR
- SET I=$ORDER(Y(I))
- if 'I!(SEGFND)
- QUIT
- Begin DoDot:2
- +6 SET SEGTYP=$EXTRACT(Y(I),1,3)
- +7 IF SEGTYP=REQSEG
- SET SEGFND=1
- +8 ;
- +9 IF SEGTYP="MSH"
- IF $PIECE(Y(I),FS,10)=""
- Begin DoDot:3
- +10 SET QUIT=1
- +11 DO ACK("AE",MID,"MSH","",10,101,"MESSAGE CONTROL ID MISSING")
- End DoDot:3
- +12 ;
- End DoDot:2
- +13 IF 'SEGFND
- Begin DoDot:2
- +14 SET QUIT=1
- +15 DO ACK("AE",MID,REQSEG,"","",100,REQSEG_" SEGMENT MISSING OR OUT OF ORDER")
- End DoDot:2
- End DoDot:1
- if QUIT
- QUIT
- +16 QUIT QUIT
- +17 ;
- PROCMSG(Y) ; Process message
- +1 NEW QUIT,I,SEGTYP,GMRCRF1,GMRCPID,GMRCOBR,GMRCNTE,GMRCIEN,GMRCICN
- +2 NEW GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU
- +3 SET (QUIT,I)=0
- +4 FOR
- SET I=$ORDER(Y(I))
- if 'I
- QUIT
- Begin DoDot:1
- +5 SET SEGTYP=$EXTRACT(Y(I),1,3)
- +6 IF SEGTYP="RF1"
- DO RF1(Y(I),.GMRCRF1)
- +7 IF SEGTYP="PID"
- DO PID(Y(I),.GMRCPID)
- +8 IF SEGTYP="OBR"
- DO OBR(Y(I),.GMRCOBR)
- +9 IF SEGTYP="NTE"
- DO NTE(Y(I),.GMRCNTE)
- End DoDot:1
- +10 ;
- +11 SET GMRCIEN=+GMRCRF1
- +12 ;
- +13 IF 'GMRCIEN!('$DATA(^GMR(123,+GMRCIEN,0)))
- Begin DoDot:1
- +14 SET QUIT=1
- +15 DO ACK("AE",MID,"RF1","",6,"VA207","INVALID IEN FOR CONSULT",1)
- End DoDot:1
- QUIT QUIT
- +16 ;
- +17 SET GMRCICN=GMRCPID
- +18 SET GMRCDFN=$$GETDFN^MPIF001($PIECE(GMRCICN,"V"))
- +19 IF GMRCDFN'>0
- Begin DoDot:1
- +20 SET QUIT=1
- +21 DO ACK("AE",MID,"PID",1,3,"VA207",$PIECE(GMRCDFN,"^",2),1)
- End DoDot:1
- QUIT QUIT
- +22 IF GMRCICN'=$$GETICN^MPIF001(GMRCDFN)
- Begin DoDot:1
- +23 SET QUIT=1
- +24 DO ACK("AE",MID,"PID",1,3,"VA207","ICN CHECKSUM DOES NOT MATCH CHECKSUM IN DATABASE",1)
- End DoDot:1
- QUIT QUIT
- +25 ;
- +26 IF $PIECE(^GMR(123,GMRCIEN,0),"^",2)'=GMRCDFN
- Begin DoDot:1
- +27 SET QUIT=1
- +28 DO ACK("AE",MID,"RF1","",6,"VA207","ICN DOES NOT MATCH PATIENT DFN IN CONSULT",1)
- End DoDot:1
- QUIT QUIT
- +29 ;
- +30 ; Reject if Referral Status is not valid
- +31 IF $PIECE(GMRCRF1,FS,2)'="IP^ADDED COMMENT"
- IF $PIECE(GMRCRF1,FS,2)'="CM^ADDENDED"
- IF $PIECE(GMRCRF1,FS,2)'="IP^REJECTED"
- Begin DoDot:1
- +32 SET QUIT=1
- +33 DO ACK("AE",MID,"RF1","",1,"VA207","INVALID REFERRAL STATUS",1)
- End DoDot:1
- QUIT QUIT
- +34 ;
- +35 ; Add comment to file #123
- +36 IF $PIECE(GMRCRF1,FS,2)="IP^ADDED COMMENT"!($PIECE(GMRCRF1,FS,2)="IP^REJECTED")
- Begin DoDot:1
- +37 ;
- +38 ; Quit if IEN being passed by HCP isn't for a Consult
- +39 IF +GMRCOBR'=GMRCIEN!($PIECE(GMRCOBR,FS,2)'="GMRC")
- Begin DoDot:2
- +40 SET QUIT=1
- +41 DO ACK("AE",MID,"OBR",1,3,"VA207","INVALID CONSULT REFERENCE",1)
- End DoDot:2
- QUIT
- +42 ;
- +43 IF $DATA(GMRCNTE("WP"))
- DO ADDCMT(GMRCIEN,.GMRCNTE)
- +44 IF $PIECE(GMRCRF1,FS,2)="IP^ADDED COMMENT"
- DO SNDALRT(GMRCIEN)
- +45 IF $PIECE(GMRCRF1,FS,2)="IP^REJECTED"
- DO SNDALRT(GMRCIEN,1)
- End DoDot:1
- +46 ;
- +47 ; Add addendum to file #8925
- +48 IF $PIECE(GMRCRF1,FS,2)="CM^ADDENDED"
- Begin DoDot:1
- +49 ;
- +50 SET GMRCTIU=+GMRCOBR
- SET GMRCTIUS=""
- +51 DO GETSTAT^TIUPRF2(.GMRCTIUS,GMRCTIU)
- +52 SET GMRCTIUS=$PIECE(GMRCTIUS,"^",2)
- +53 ;
- +54 ; Quit if IEN being passed by HCP isn't for a Progress Note
- +55 IF 'GMRCTIU!($PIECE(GMRCOBR,FS,2)'="TIU")!('$DATA(^TIU(8925,+GMRCTIU,0)))!(GMRCTIUS="RETRACTED")
- Begin DoDot:2
- +56 SET QUIT=1
- +57 DO ACK("AE",MID,"OBR",1,3,"VA207","INVALID PROGRESS NOTE REFERENCE",1)
- End DoDot:2
- QUIT
- +58 ;
- +59 DO TIUTXT(.GMRCNTE,.ADDTXT)
- +60 DO MAKEADD^TIUSRVP2(.GMRCATIU,GMRCTIU,.ADDTXT)
- +61 IF +GMRCATIU>0
- DO UPDUSRS(GMRCTIU,GMRCATIU)
- +62 DO SNDALRT(GMRCIEN)
- End DoDot:1
- +63 ;
- +64 QUIT QUIT
- +65 ;
- RF1(RF1SEG,RETVAL) ; Process RF1 Segment
- +1 NEW GMRCSTS,GMRCIEN
- +2 SET GMRCSTS=$PIECE(RF1SEG,FS,2)
- +3 SET GMRCIEN=$PIECE(RF1SEG,FS,7)
- +4 SET RETVAL=GMRCIEN_FS_GMRCSTS
- +5 QUIT
- +6 ;
- PID(PIDSEG,RETVAL) ; Process PID Segment
- +1 NEW GMRCICN
- +2 SET GMRCICN=$PIECE($PIECE(PIDSEG,FS,4),CS)
- +3 SET RETVAL=GMRCICN
- +4 QUIT
- +5 ;
- OBR(OBRSEG,RETVAL) ; Process OBR Segment
- +1 NEW GMRCOIEN,GMRCTYP
- +2 SET GMRCOIEN=+$PIECE(OBRSEG,FS,4)
- +3 SET GMRCTYP=$PIECE($PIECE(OBRSEG,FS,4),CS,2)
- +4 SET RETVAL=GMRCOIEN_FS_GMRCTYP
- +5 QUIT
- +6 ;
- NTE(NTESEG,RETVAL) ; Process NTE Segment
- +1 NEW I,GMRCTXT
- +2 SET I=$PIECE(NTESEG,FS,2)
- +3 if '+I
- QUIT
- +4 SET GMRCTXT=$$DEESCAPE($PIECE(NTESEG,FS,4))
- +5 ; Strip the following only if HCPS is sending separately
- +6 IF GMRCTXT="Activity Comment"
- QUIT
- +7 IF GMRCTXT="Comment~~"
- QUIT
- +8 ;
- +9 IF $EXTRACT(GMRCTXT,1,8)="Author~~"
- Begin DoDot:1
- +10 SET $EXTRACT(GMRCTXT,1,8)="Author: "
- End DoDot:1
- +11 ;
- +12 IF $EXTRACT(GMRCTXT,1,10)="Datetime~~"
- Begin DoDot:1
- +13 SET RETVAL("Datetime")=$PIECE(GMRCTXT,"Datetime~~",2)
- +14 ; Strip any 'spaces'
- +15 SET RETVAL("Datetime")=$TRANSLATE(RETVAL("Datetime")," ","")
- End DoDot:1
- QUIT
- +16 ;
- +17 IF $EXTRACT(GMRCTXT,1,9)="Comment~~"
- Begin DoDot:1
- +18 SET $EXTRACT(GMRCTXT,1,9)="Comment: "
- End DoDot:1
- +19 ;
- +20 SET RETVAL("WP",I)=GMRCTXT
- +21 QUIT
- +22 ;
- ADDCMT(GMRCIEN,NTEARY) ; Add comment to file #123
- +1 NEW GMRCFDA,GMRCERR,GMRCCMT,GMRCLACT,GMRCPRXY
- +2 SET GMRCFDA(.01)=$$NOW^XLFDT
- +3 SET GMRCFDA(1)=$ORDER(^GMR(123.1,"B","ADDED COMMENT",0))
- +4 SET GMRCFDA(2)=GMRCFDA(.01)
- +5 IF $GET(NTEARY("Datetime"))'=""
- Begin DoDot:1
- +6 SET GMRCFDA(2)=$$HL7TFM^XLFDT(NTEARY("Datetime"),"L")
- End DoDot:1
- +7 SET GMRCPRXY=+$ORDER(^VA(200,"B","HCPS,APPLICATION PROXY",0))
- +8 IF GMRCPRXY
- Begin DoDot:1
- +9 SET GMRCFDA(3)=GMRCPRXY
- +10 SET GMRCFDA(4)=GMRCPRXY
- End DoDot:1
- +11 KILL FDA
- +12 MERGE FDA(1,123.02,"+1,"_GMRCIEN_",")=GMRCFDA
- +13 DO UPDATE^DIE("","FDA(1)",,"GMRCERR")
- +14 ;
- +15 SET GMRCCMT=$NAME(NTEARY("WP"))
- +16 SET GMRCLACT=$ORDER(^GMR(123,GMRCIEN,40," "),-1)
- +17 DO WP^DIE(123.02,GMRCLACT_","_GMRCIEN_",",5,"K",GMRCCMT)
- +18 KILL FDA
- +19 QUIT
- +20 ;
- TIUTXT(NTEARY,RETVAL) ; Return TIU-formatted Text
- +1 NEW I
- +2 SET I=0
- +3 FOR
- SET I=$ORDER(NTEARY("WP",I))
- if 'I
- QUIT
- Begin DoDot:1
- +4 SET RETVAL("TEXT",I,0)=NTEARY("WP",I)
- End DoDot:1
- +5 QUIT
- +6 ;
- UPDUSRS(GMRCTIU,GMRCATIU) ; Update Users on Addendums
- +1 NEW GMRC1302,GMRC1202,GMRC1204,DIE,DA,DR,X
- +2 ; ENTERED BY
- SET GMRC1302=+$PIECE($GET(^TIU(8925,GMRCTIU,13)),"^",2)
- +3 ; AUTHOR/DICTATOR
- SET GMRC1202=+$PIECE($GET(^TIU(8925,GMRCTIU,12)),"^",2)
- +4 ; EXPECTED SIGNER
- SET GMRC1204=+$PIECE($GET(^TIU(8925,GMRCTIU,12)),"^",4)
- +5 ;
- +6 SET DIE="^TIU(8925,"
- SET DA=GMRCATIU
- +7 SET DR="1302///^S X=GMRC1302;1202///^S X=GMRC1202;1204///^S X=GMRC1204"
- +8 LOCK +^TIU(8925,GMRCATIU):$GET(DILOCKTM,3)
- +9 IF $TEST
- DO ^DIE
- LOCK -^TIU(8925,GMRCATIU)
- +10 QUIT
- +11 ;
- DEESCAPE(TXTSTR) ; De-escape delimiters
- +1 ; (assuming "\" is the escape character):
- +2 ; - field separator (de-escape from \F\)
- +3 ; - component separator (de-escape from \S\)
- +4 ; - repetition separator (de-escape from \R\)
- +5 ; - escape character (de-escape from \E\)
- +6 ; - subcomponent separator (de-escape from \T\)
- +7 ; \F\ will be de-escaped only if the length of FS is 1.
- +8 ;
- +9 NEW HLDATA,HLENCHR,HLI,HLCHAR,HLCHAR23,HLEN,HLOUT
- +10 SET HLDATA=$GET(TXTSTR)
- +11 if HLDATA']""
- QUIT HLDATA
- +12 ;
- +13 SET HLENCHR=$GET(HL("ECH"),"^~\&")
- +14 if $LENGTH(HLENCHR)<3
- QUIT HLDATA
- +15 ;
- +16 SET HLEN=$LENGTH(HLDATA)
- +17 SET HLOUT=""
- +18 FOR HLI=1:1:HLEN
- Begin DoDot:1
- +19 SET HLCHAR=$EXTRACT(HLDATA,HLI)
- +20 SET HLCHAR23=""
- +21 IF HLCHAR=ES
- Begin DoDot:2
- +22 SET HLCHAR23=$EXTRACT(HLDATA,HLI+1,HLI+2)
- End DoDot:2
- +23 IF $LENGTH($GET(FS))=1
- IF (HLCHAR23=("F"_ES))
- Begin DoDot:2
- +24 SET HLOUT=HLOUT_FS
- +25 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +26 IF HLCHAR23=("S"_ES)
- Begin DoDot:2
- +27 SET HLOUT=HLOUT_CS
- +28 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +29 IF HLCHAR23=("R"_ES)
- Begin DoDot:2
- +30 SET HLOUT=HLOUT_RS
- +31 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +32 IF HLCHAR23=("E"_ES)
- Begin DoDot:2
- +33 SET HLOUT=HLOUT_ES
- +34 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +35 IF $LENGTH(HLENCHR)>3
- IF (HLCHAR23=("T"_ES))
- Begin DoDot:2
- +36 SET HLOUT=HLOUT_SS
- +37 SET HLI=HLI+2
- End DoDot:2
- QUIT
- +38 SET HLOUT=HLOUT_HLCHAR
- End DoDot:1
- +39 ;
- +40 QUIT HLOUT
- +41 ;
- SNDALRT(GMRCIEN,GMRCRJT) ; Send Alert
- +1 ; GMRCRJT is optional, and is only set to 1 for a rejection status
- +2 NEW GMRCORTX,GMRCORN,GMRCRP,GMRCADUZ,GMRCDFN
- +3 SET GMRCORTX="Updates received from HCP "
- +4 IF +$GET(GMRCRJT)
- SET GMRCORTX="Rejected status from HCP "
- +5 SET GMRCORN=63
- +6 ; Requesting Provider
- SET GMRCRP=+$PIECE($GET(^GMR(123,+GMRCIEN,0)),"^",14)
- +7 if GMRCRP
- SET GMRCADUZ(GMRCRP)=""
- +8 IF '$DATA(GMRCADUZ)
- SET GMRCADUZ=""
- +9 SET GMRCDFN=$PIECE($GET(^GMR(123,+GMRCIEN,0)),"^",2)
- +10 SET GMRCORTX=GMRCORTX_$$ORTX^GMRCAU(+GMRCIEN)
- +11 DO MSG^GMRCP(GMRCDFN,GMRCORTX,+GMRCIEN,GMRCORN,.GMRCADUZ,"")
- +12 QUIT
- +13 ;
- ACK(STAT,MID,SID,SEG,FLD,CD,TXT,ACKTYP) ; Creates ACKs for HL7 Message
- +1 ;STAT = Status (Acknowledgment Code) (REQUIRED)
- +2 ;MID = Message ID (REQUIRED)
- +3 ;SID = Segment ID (set if ERR occured in segment) (OPTIONAL)
- +4 ;SEG = Segment location of error (OPTIONAL)
- +5 ;FLD = Field location of error (OPTIONAL)
- +6 ;CD = Error Code (OPTIONAL)
- +7 ;TXT = Text describing error (OPTIONAL)
- +8 ;ACKTYP = Acknowledgment Type (OPTIONAL)
- +9 ;
- +10 NEW HLA,EID,EIDS,RES,ERR
- +11 ;
- +12 ;Make sure the parameters are defined
- +13 SET STAT=$GET(STAT)
- SET MID=$GET(MID)
- SET SID=$GET(SID)
- SET SEG=$GET(SEG)
- +14 SET FLD=$GET(FLD)
- SET CD=$GET(CD)
- SET TXT=$GET(TXT)
- +15 ;
- +16 ;Create MSA Segment
- +17 SET HLA("HLA",1)="MSA"_FS_STAT_FS_MID
- +18 SET EID=$GET(HL("EID"))
- +19 SET EIDS=$GET(HL("EIDS"))
- +20 if ((EID="")!($GET(HLMTIENS)="")!(EIDS=""))
- QUIT
- +21 ;
- +22 SET RES=""
- +23 ;If Segment ID (SID) is set, create ERR segment
- +24 if $LENGTH(SID)>0
- Begin DoDot:1
- +25 SET HLA("HLA",2)="ERR"
- +26 SET $PIECE(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD
- +27 SET $PIECE(HLA("HLA",2),FS,5)="E"
- +28 ;
- +29 ; Commit Error
- +30 IF '+$GET(ACKTYP)
- Begin DoDot:2
- +31 SET $PIECE(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357"
- End DoDot:2
- +32 ;
- +33 ; Application Error
- +34 IF +$GET(ACKTYP)=1
- Begin DoDot:2
- +35 SET $PIECE(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT
- End DoDot:2
- End DoDot:1
- +36 ;
- +37 DO GENACK^HLMA1(EID,$GET(HLMTIENS),EIDS,"LM",1,.RES)
- +38 QUIT