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

GMRCIACT.m

Go to the documentation of this file. 
  1. GMRCIACT ;SLC/JFR - PROCESS ACTIONS ON IFC ; Aug 01, 2024@15:38:22
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**22,47,58,66,73,121,154,176,184,193,185,189**;DEC 27, 1997;Build 54
  1.  ;
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; Reference to $$FIND1^DIC in ICR #2051
  1.  ; Reference to ^DIE in ICR #2053
  1.  ; Reference to ^HLMA1 in ICR #2165
  1.  ; Reference to ^MPIF001 in ICR #2701
  1.  ; Reference to ^XLFDT in ICR #10103
  1.  ; Reference to ^XLFNAME in ICR #3065
  1.  ; Reference to ^XUAF4 in ICR #2171
  1.  ; Reference to ^XLFSTR in ICR #10104
  1.  ; Reference to $$ADD^DGPROSAD in ICR #7421
  1.  ; Reference to APPERROR^%ZTER in ICR #1621
  1.  ;
  1.  Q  ;don't start here!
  1. NW(ARRAY) ;process and file new order
  1.  ;Input:
  1.  ; ARRAY  = name of array containing message parts
  1.  ;
  1.  N GMRCFDA,GMRCORC,GMRCDA,GMRCITM,GMRCITER,GMRCROUT,GMRCFCN,GMRCLAC,OBR19 ;
  1.  K ^TMP("GMRCIN",$J)
  1.  M ^TMP("GMRCIN",$J)=@ARRAY
  1.  S GMRCORC=^TMP("GMRCIN",$J,"ORC")
  1.  D  I $D(GMRCITER) Q  ;Check for order already being on file
  1.  . S GMRCFCN=+$P(GMRCORC,"|",2)
  1.  . S GMRCROUT=$$IEN^XUAF4($P($P(GMRCORC,"|",2),U,2))
  1.  . I '$O(^GMR(123,"AIFC",GMRCROUT,GMRCFCN,0)) Q  ;no dup
  1.  . S GMRCITER=802
  1.  . S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",GMRCITER,GMRCCRNR,GMRCMSGI) ;send app. ack w/ error ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
  1.  . K ^TMP("GMRCIN",$J) Q
  1.  I '$D(^TMP("GMRCIN",$J,"PID")) Q  ;prepare reject message (no PID)
  1.  D  ;get patient DFN from ICN in message
  1.  . N PAT,CRNRACCT ; p184
  1.  . S PAT=$$GETDFN^MPIF001(+$P(^TMP("GMRCIN",$J,"PID"),"|",2))
  1.  . I +PAT'>1 S GMRCFDA(.02)="" Q
  1.  . S GMRCFDA(.02)=+PAT
  1.  ;
  1.  ;  Save patient account number in field #502.  Below code shifted out of patient lookup so CRNRACCT set whether patient found or not.  Needed for proxy add code. p189
  1.  ;
  1.  S CRNRACCT=$P(^TMP("GMRCIN",$J,"PID"),"|",18),GMRCFDA(502)=CRNRACCT ; p184, 189
  1.  ;
  1.  ;  Save ordering provider data and placer field 1 from OBR-16 and OBR-19 in fields #507 and 508
  1.  ;
  1.  I $D(^TMP("GMRCIN",$J,"OBR")) D  ;  P184, 189
  1.  . N OBR16 S OBR16=$P(^("OBR"),"|",16),GMRCFDA(507)=$E(OBR16,1,255) ;
  1.  . S OBR19=$P(^("OBR"),"|",19),GMRCFDA(508)=$E(OBR19,1,255) ; 184V10 WTC 6/28/2022
  1.  . N OBR20 S OBR20=$P(^("OBR"),"|",20) I OBR20'="" S GMRCFDA(511)=$E(OBR20,1) ; 185V2 WTC 4/24/2023
  1.  . N OBR27 S OBR27=$P($P(^("OBR"),"|",27),U,4) I OBR27'="" S GMRCFDA(512)=$E(OBR27,1,30) ; 185V2 WTC 4/24/2023
  1.  ;
  1.  ;  If patient not found and placer is Cerner, call proxy add to create patient.  p189 wtc 4/12/2023
  1.  ;
  1.  I '$G(GMRCFDA(.02)),$G(CRNRACCT)'="" D  ;
  1.  . ;
  1.  . ;  Extract EDIPI from PID-3.
  1.  . ;
  1.  . N EDIPI,RTNCODE,PIECE ;
  1.  . S EDIPI="" F PIECE=1:1 Q:$P($P(^TMP("GMRCIN",$J,"PID"),"|",3),"~",PIECE)=""  I $P($P($P(^TMP("GMRCIN",$J,"PID"),"|",3),"~",PIECE),U,4)="EDIPI" S EDIPI=$P($P($P(^TMP("GMRCIN",$J,"PID"),"|",3),"~",PIECE),U,1) Q  ;
  1.  . Q:EDIPI=""  ;
  1.  . ;
  1.  . ;  Call proxy add.  If successful, save DFN.  Otherwise, allow 201 error to be generated.
  1.  . ;
  1.  . S RTNCODE=$$ADD^DGPROSAD(EDIPI_"~USDOD~NI~200DOD",$P($$SITE^VASITE(),U,3)) ;  ICR 7421
  1.  . I RTNCODE<0 D FAILPRXY^GMRCIUT1(GMRCMSGI,EDIPI,"",GMRCFCN,OBR19,$P(GMRCORC,"|",15),$P($$SITE^VASITE(),U,3),$P(RTNCODE,U,2)) Q  ; P189 WTC 6/24/24
  1.  . S GMRCFDA(.02)=$P(RTNCODE,U,4) ;
  1.  ;
  1.  I '$G(GMRCFDA(.02)) D  Q  ;reject message, patient is unknown
  1.  . N STA S STA=$P($P(^TMP("GMRCIN",$J,"ORC"),"|",2),U,2)
  1.  . N OBR S OBR=^TMP("GMRCIN",$J,"OBR")
  1.  . D PTERRMSG^GMRCIERR(^TMP("GMRCIN",$J,"PID"),STA,,OBR)
  1.  . S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",201,GMRCCRNR,GMRCMSGI) ; send app. ack w/error ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
  1.  . K ^TMP("GMRCIN",$J) Q
  1.  D  ;get ordered item and service
  1.  . S GMRCITM=$P(^TMP("GMRCIN",$J,"OBR"),"|",4)
  1.  . I GMRCITM["VA1233" D  ; proc
  1.  .. N PROC
  1.  .. S PROC=$$GETPROC^GMRCIUTL(GMRCITM)
  1.  .. I +PROC'>0!('$P(PROC,U,2)) S GMRCITER=$P(PROC,U,3) Q
  1.  .. S GMRCFDA(4)=$P(PROC,U)_";GMR(123.3,"
  1.  .. S GMRCFDA(1)=$P(PROC,U,2)
  1.  . I GMRCITM["VA1235" D
  1.  .. N SERV
  1.  .. S SERV=$$GETSERV^GMRCIUTL(GMRCITM) ;consult
  1.  .. I +SERV'>0 S GMRCITER=$P(SERV,U,3)
  1.  .. S GMRCFDA(1)=SERV
  1.  I $D(GMRCITER) D  Q  ;error in procedure or service, reject new order
  1.  . S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",GMRCITER,GMRCCRNR,GMRCMSGI) ; send app. ACK  ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
  1.  . K ^TMP("GMRCIN",$J) Q
  1.  ;
  1.  S GMRCFDA(.01)=$$NOW^XLFDT
  1.  S GMRCFDA(3)=$$HL7TFM^XLFDT($P(GMRCORC,"|",15))
  1.  S GMRCFDA(6)=$$FIND1^DIC(101,"","X","GMRCPLACE - ON CALL")
  1.  S GMRCFDA(17)=$$HL7TFM^XLFDT($P($P(GMRCORC,"|",7),U,4)) ;WAT/66 Earliest Date
  1.  D  ;get urgency to file
  1.  . N URG
  1.  . S URG=$$URG^GMRCHL7A($P($P(GMRCORC,"|",7),U,6))
  1.  . I GMRCCRNR,URG="STAT" S URG="NEXT AVAILABLE" ;MKN *176
  1.  . S GMRCFDA(5)=$$FIND1^DIC(101,"","X","GMRCURGENCY - "_URG)
  1.  S GMRCFDA(8)=5
  1.  S GMRCFDA(9)=$S($P(GMRCORC,"|",16)["FI":24,1:23),GMRCLAC=GMRCFDA(9)
  1.  S GMRCFDA(14)=$P(^TMP("GMRCIN",$J,"OBR"),"|",18)
  1.  S GMRCFDA(.05)=$$IEN^XUAF4(+$P(GMRCORC,"|",17))
  1.  S GMRCFDA(.06)=GMRCFCN
  1.  S GMRCFDA(.07)=GMRCROUT
  1.  D  ;get and set ordering prov info & entering person info
  1.  . N GMRCOP
  1.  . S GMRCOP=$$FMNAME^XLFNAME($P(GMRCORC,"|",12))
  1.  . Q:'$L(GMRCOP)
  1.  . S GMRCFDA(.126)=GMRCOP
  1.  . Q
  1.  S GMRCFDA(.125)="F"
  1.  I $L($P(GMRCORC,"|",14)) D
  1.  . N GMRCP14 S GMRCP14=$P(GMRCORC,"|",14)
  1.  . S GMRCFDA(.132)=$P(GMRCP14,"B") ; requestor's phone number
  1.  . S GMRCFDA(.133)=$P(GMRCP14,"B",2) ; requestor's dig pager
  1.  S GMRCFDA(13)=$S($D(GMRCFDA(4)):"P",1:"C")
  1.  I $D(^TMP("GMRCIN",$J,"OBX",2)) D
  1.  . N GMRCCSYS,CODINTXT
  1.  . S GMRCFDA(30)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U,2)
  1.  . S GMRCFDA(30.1)=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U)
  1.  . S GMRCFDA(30.2)=$$HL7TFM^XLFDT($P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",14),U)) ;date OBX-14 WAT/73
  1.  . S GMRCCSYS=$P($P(^TMP("GMRCIN",$J,"OBX",2,1),"|",5),U,3) ;code system WAT/73
  1.  . S GMRCCSYS=$S($G(GMRCCSYS)="I9C":"ICD",1:"10D")
  1.  . S GMRCFDA(30.3)=GMRCCSYS
  1.  . I $D(GMRCFDA(30.1)) D  ;if dx code exists, ensure that code is removed from dx text
  1.  .. S CODINTXT="("_GMRCFDA(30.1)_")"
  1.  .. I GMRCFDA(30)[CODINTXT D
  1.  ... S GMRCFDA(30)=$E(GMRCFDA(30),0,($L(GMRCFDA(30))-$L(CODINTXT)))
  1.  ... S GMRCFDA(30)=$$TRIM^XLFSTR(GMRCFDA(30),"R")
  1.  ;
  1.  ;BL;121;Adding UCID to FILE #123 FIELD 80
  1.  ;check for NTE segment
  1.  I $D(^TMP("GMRCIN",$J,"NTE")) D
  1.  . N NODE,UCIDNODE
  1.  . S NODE=0
  1.  . F  S NODE=$O(^TMP("GMRCIN",$J,"NTE",NODE))  Q:NODE=""  D
  1.  . . S UCIDNODE=$P(^TMP("GMRCIN",$J,"NTE",NODE),"|",2)
  1.  . . S:UCIDNODE["UCID:" GMRCFDA(80)=$P(UCIDNODE,"UCID:",2)
  1.  ;
  1.  M FDA(1,123,"+1,")=GMRCFDA
  1.  D UPDATE^DIE("","FDA(1)","GMRCDA","GMRCERR")
  1.  I '$D(GMRCDA) D  Q  ;couldn't get new consult #
  1.  . S GMRCCRNR=$G(GMRCCRNR),GMRCMSGI=$G(GMRCMSGI) D APPACK^GMRCIAC2(0,"AR",901,GMRCCRNR,GMRCMSGI) ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
  1.  . K ^TMP("GMRCIN",$J) Q
  1.  K GMRCFDA,FDA
  1.  D  ; file reason for request
  1.  . D TRIMWP^GMRCIUTL($NA(^TMP("GMRCIN",$J,"OBX",1)),5)
  1.  . D WP^DIE(123,GMRCDA(1)_",",20,"K",$NA(^TMP("GMRCIN",$J,"OBX",1)))
  1.  . Q
  1.  D  ;file activity tracking
  1.  . N GMRCSEG
  1.  . S GMRCSEG("ORC")=GMRCORC
  1.  . S GMRCSEG("OBX",5,1)=^TMP("GMRCIN",$J,"OBX",5,1)
  1.  . D FILEACT^GMRCIAC2(GMRCDA(1),GMRCLAC,,"GMRCSEG",$G(GMRCCRNR),$G(GMRCROUT)) ; P184
  1.  D  ;print SF-513
  1.  . I GMRCLAC=24 Q  ;don't print if part of a FWD to IFC
  1.  . D PRNT^GMRCUTL1("",GMRCDA(1))
  1.  D  ;send notifications
  1.  . I GMRCLAC=24 Q  ;no alerts yet if part of FWD to IFC
  1.  . N GMRCORTX
  1.  . S GMRCORTX="New remotely ordered consult "_$$ORTX^GMRCAU(+GMRCDA(1))
  1.  . D MSG^GMRCP($P(^GMR(123,GMRCDA(1),0),U,2),GMRCORTX,GMRCDA(1),27,,1)
  1.  D  ;send appl ack :-(
  1.  . N GMRCRSLT
  1.  . D RESP^GMRCIUTL("AA",HL("MID"),$P(GMRCORC,"|"),GMRCDA(1))
  1.  . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
  1.  K ^TMP("GMRCIN",$J) Q:'GMRCCRNR  ;
  1.  ;
  1.  ;  Check if patient exists on converted VistA.  If not, add the entry.  p189 wtc 6/24/24
  1.  ;
  1.  N RTNCODE,SITE,STA ;
  1.  S SITE=$P(^GMR(123,GMRCDA(1),0),U,23) Q:'SITE  ;no ROUTING FACILITY
  1.  S STA=$$STA^XUAF4(SITE) I '$L(STA) Q  ;can't find station num for that site
  1.  S RTNCODE=$$CHKPROXY^GMRCIUT1(GMRCDA(1),$P(^GMR(123,GMRCDA(1),0),U,2),STA,1) ;
  1.  Q
  1.  ;
  1. DIS(GMRCAR,GMRCCRNR,GMRCMSGI) ;dis-associate a result from a remote request ; MKN GMRC*3.0*154 added GMRCCRNR and GMRCMSGI
  1.  ;Input:
  1.  ; GMRCAR = array name containing message
  1.  ;      e.g.  ^TMP("GMRCIF",$J)
  1.  ; GMRCCRNR = 1 if message came from Cerner
  1.  ; GMRCMSGI = message ID
  1.  ;
  1.  K ^TMP("GMRCID",$J) ;p193
  1.  N GMRCDA,GMRCFDA,FDA,GMRCERR,GMRCORC
  1.  M ^TMP("GMRCID",$J)=@GMRCAR
  1.  S GMRCORC=^TMP("GMRCID",$J,"ORC")
  1.  S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)
  1.  S GMRCCRNR=$G(GMRCCRNR,0),GMRCMSGI=$G(GMRCMSGI) ;MKN GMRC*3*154
  1.  I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
  1.  . D APPACK^GMRCIAC2(GMRCDA,"AR",901,GMRCCRNR,GMRCMSGI) ;send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
  1.  . K ^TMP("GMRCID",$J) Q
  1.  ;    v--check to see if a dup transmission
  1.  I $$DUPACT^GMRCIAC2(GMRCDA,12,GMRCORC,^TMP("GMRCID",$J,"OBX",4,1),GMRCCRNR,GMRCMSGI) K ^TMP("GMRCID",$J) Q  ;MKN GMRC*3*154 added CRNR and MSGI ;p193
  1.  ;
  1.  D FILEACT^GMRCIAC2(GMRCDA,12,,$NA(^TMP("GMRCID",$J)),$G(GMRCCRNR),$$GET1^DIQ(123,GMRCDA,.07,"I")) ; act. tracking ; P184
  1.  D FILRES^GMRCIAC2(GMRCDA,^TMP("GMRCID",$J,"OBX",4,1)) ;file results
  1.  K GMRCERR,FDA,GMRCFDA
  1.  I $$STSCHG^GMRCDIS(GMRCDA) S FDA(1,123,GMRCDA_",",8)=6
  1.  S FDA(1,123,GMRCDA_",",9)=12
  1.  D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and status
  1.  D  ;send notifications
  1.  . I $P(^GMR(123,GMRCDA,12),U,5)="F" Q  ;DIS from placer before IFC
  1.  . N GMRCORTX
  1.  . S GMRCORTX="Remote result removed from "_$$ORTX^GMRCAU(+GMRCDA)
  1.  . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCORTX,GMRCDA,63,,1)
  1.  D  ;send appl ACK
  1.  . D APPACK^GMRCIAC2(GMRCDA,"AA") ; send app. ACK and unlock record
  1.  K ^TMP("GMRCID",$J)
  1.  Q
  1.  ;
  1. OTHER(GMRCAR,GMRCCRNR,GMRCMSGI) ;process most IFC actions
  1.  ;will process the receive, schedule, DC, cancel and added comment action
  1.  ;
  1.  ;Input:
  1.  ; GMRCAR = array name containing message
  1.  ;      e.g.  ^TMP("GMRCIF",$J)
  1.  ; GMRCCRNR = 1 if message came from Cerner
  1.  ; GMRCMSGI = message ID
  1.  ;
  1.  N GMRCDA,GMRCFDA,GMRCORC,GMRCLAT,GMRCACT,GMRCROL,FDA
  1.  K ^TMP("GMRCIN",$J)
  1.  M ^TMP("GMRCIN",$J)=@GMRCAR
  1.  ;
  1.  S GMRCORC=^TMP("GMRCIN",$J,"ORC")
  1.  S GMRCDA=$$GETDA^GMRCIAC2(GMRCORC)  ;get ien to work on
  1.  S GMRCROL=$P(^GMR(123,GMRCDA,12),U,5)
  1.  S GMRCCRNR=$G(GMRCCRNR,0),GMRCMSGI=$G(GMRCMSGI) ;MKN GMRC*3*154
  1.  I '$$LOCKREC^GMRCUTL1(GMRCDA) D  Q  ;couldn't lock record
  1.  . D APPACK^GMRCIAC2(GMRCDA,"AR",901,GMRCCRNR,GMRCMSGI) ; send app. ACK ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI
  1.  . K ^TMP("GMRCIN",$J) Q
  1.  ;
  1.  I $P(GMRCORC,"|")'="IP" D  ; status update
  1.  . N GMRCOS S GMRCOS=$P(GMRCORC,"|",5)
  1.  . S GMRCFDA(8)=$S(GMRCOS="IP":6,GMRCOS="SC":8,GMRCOS="CA":13,1:1)
  1.  . ; IP=receive, SC=schedule, CA=cancel, DC=discontinue
  1.  D  ; get last action taken
  1.  . I '$G(GMRCFDA(8)) S (GMRCFDA(9),GMRCLAT)=20 Q
  1.  . I GMRCFDA(8)=6 S (GMRCFDA(9),GMRCLAT)=21 Q
  1.  . I GMRCFDA(8)=8 S (GMRCFDA(9),GMRCLAT)=8 Q
  1.  . I GMRCFDA(8)=1 S (GMRCFDA(9),GMRCLAT)=6 Q
  1.  . I GMRCFDA(8)=13 S (GMRCFDA(9),GMRCLAT)=19 Q
  1.  ;                         ^--last action taken
  1.  ;    v-- check to see if a dup transmission
  1.  I $$DUPACT^GMRCIAC2(GMRCDA,GMRCLAT,GMRCORC,,GMRCCRNR,GMRCMSGI) K ^TMP("GMRCIN",$J) Q  ;MKN GMRC*3*154 added GMRCCRNR and GMRCMSGI ;p193
  1.  ;
  1.  M FDA(1,123,GMRCDA_",")=GMRCFDA
  1.  D UPDATE^DIE("","FDA(1)",,"GMRCERR") ;file last action and update status
  1.  K GMRCFDA
  1.  D FILEACT^GMRCIAC2(GMRCDA,GMRCLAT,,$NA(^TMP("GMRCIN",$J)),$G(GMRCCRNR),$$GET1^DIQ(123,GMRCDA,.07,"I")) ; P184
  1.  D  ;send notifications
  1.  . N GMRCTX,GMRCNOT,GMRCFL
  1.  . S GMRCFL=1
  1.  . I GMRCLAT=20!(GMRCLAT=8)!(GMRCLAT=21) D
  1.  .. I GMRCLAT=20 D  I '$D(GMRCTX) Q
  1.  ... I $P(^GMR(123,GMRCDA,40,1,0),U,2)'=24 D  Q
  1.  .... S GMRCTX="Comment Added to remote"
  1.  ... N ACT S ACT=1
  1.  ... F  S ACT=$O(^GMR(123,GMRCDA,40,ACT)) Q:'ACT!($D(GMRCTX))  D
  1.  .... I $P(^GMR(123,GMRCDA,40,ACT,0),U,2)=25,$O(^GMR(123,GMRCDA,40,ACT)) D
  1.  ..... S GMRCTX="Comment Added to remote"
  1.  .. I '$D(GMRCTX),GMRCROL="F" Q  ;sch & rec on filler part of FWD 2 IFC
  1.  .. I GMRCLAT=8 S GMRCTX="Scheduled remote"
  1.  .. I GMRCLAT=21 S GMRCTX="Received remote"
  1.  .. S GMRCTX=GMRCTX_" Consult: "_$$ORTX^GMRCAU(+GMRCDA)
  1.  .. S GMRCNOT=63
  1.  . I GMRCLAT=6 D
  1.  .. S GMRCFL=$$DCNOTE^GMRCADC(GMRCDA,.5)
  1.  .. S GMRCTX="Discontinued remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
  1.  .. S GMRCNOT=23
  1.  . I GMRCLAT=19 D
  1.  .. I GMRCROL="F" Q  ;canc on a filler is part of FWD 2 IFC
  1.  .. S GMRCTX="Cancelled remote Consult: "_$$ORTX^GMRCAU(+GMRCDA)
  1.  .. S GMRCNOT=30
  1.  . I '$D(GMRCNOT) Q  ;don't send any alerts
  1.  . D MSG^GMRCP($P(^GMR(123,GMRCDA,0),U,2),GMRCTX,GMRCDA,GMRCNOT,,GMRCFL)
  1.  ;
  1.  D  ;send appl ACK
  1.  . D APPACK^GMRCIAC2(GMRCDA,"AA") ;send app. ACK and unlock record
  1.  K ^TMP("GMRCIN",$J)
  1.  Q
  1.  ;