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

GMRCIAC2.m

Go to the documentation of this file. 
  1. GMRCIAC2 ;SLC/JFR - FILE IFC ACTIVITIES CONT'D ;07/08/03 11:30
  1.  ;;3.0;CONSULT/REQUEST TRACKING;**22,28,35**;DEC 27, 1997
  1.  Q  ;can't start here
  1. FILRES(GMRCO,GMRCOBX) ;file or delete results
  1.  N GMRCRES,GMRCFIL,GMRCSITE,GMRCROOT,RESIEN,GMRCERR
  1.  S GMRCRES=+$P(GMRCOBX,"|",5)
  1.  S GMRCFIL=$P($P(GMRCOBX,"|",3),U,3)
  1.  S GMRCROOT=$S($P($P(GMRCOBX,"|",3),U,2)["TIU":"TIU(",1:"MCAR(")
  1.  S GMRCFIL=$P(GMRCFIL,"VA",2)
  1.  S GMRCRES=GMRCRES_";"_GMRCROOT_GMRCFIL
  1.  S GMRCSITE=$$IEN^XUAF4($P($P(GMRCOBX,"|",5),U,3))
  1.  I $P(GMRCOBX,"|",11)'="D" D  ;add new result
  1.  . S FDA(1,123.051,"+1,"_GMRCO_",",.01)=$$NOW^XLFDT
  1.  . S FDA(1,123.051,"+1,"_GMRCO_",",.02)=GMRCRES
  1.  . S FDA(1,123.051,"+1,"_GMRCO_",",.03)=GMRCSITE
  1.  I $P(GMRCOBX,"|",11)="D" D  ; find and delete result
  1.  . N RESIEN
  1.  . S RESIEN=$O(^GMR(123,GMRCO,51,"AR",GMRCRES,GMRCSITE,0))
  1.  . I 'RESIEN Q
  1.  . S FDA(1,123.051,RESIEN_","_GMRCO_",",.01)="@"
  1.  I '$D(FDA) Q
  1.  D UPDATE^DIE("","FDA(1)",,"GMRCERR")
  1.  Q
  1.  ;
  1. UPDORD(GMRCDA,GMRC40) ; update CPRS order if action on placer order.
  1.  ; Input:
  1.  ;  GMRCDA   = ien from file 123
  1.  ;  GMRC40 = ien of activity in 40 multiple
  1.  ;
  1.  N GMRCDFN,GMRCAD,AC,GMRCOC,GMRCMT
  1.  S GMRCDFN=$P(^GMR(123,GMRCDA,0),U,2)
  1.  I $O(^GMR(123,GMRCDA,40,GMRC40,1,0)) D
  1.  . S GMRCMT=1,GMRCMT(0)=GMRC40
  1.  S GMRCAD=$P(^GMR(123,GMRCDA,40,GMRC40,0),U,3)
  1.  S AC=$P(^GMR(123,GMRCDA,40,GMRC40,0),U,2)
  1.  S GMRCOC=$S(AC=6:"OD",AC=19:"OC",AC=10:"RE",AC=9:"RE",AC=8:"ZC",1:"SC")
  1.  D EN^GMRCHL7(GMRCDFN,GMRCDA,"","",GMRCOC,"","",.GMRCMT,,GMRCAD)
  1.  Q
  1. FILEACT(GMRCO,GMRCLAST,GMRCFR,GMRCAR) ;file REQUEST PROCESSING ACTIVITY 
  1.  ; Input:
  1.  ;  GMRCO     = ien from file 123
  1.  ;  GMRCLAST  = last action taken on request
  1.  ;  GMRCFR    = service that consult was forwarded from
  1.  ;  GMRCAR    = name of the array containing the message
  1.  ;
  1.  N GMRCORC,GMRCFDA,GMRCRP,GMRCEP,GMRCACT,GMRCERR,FDA
  1.  M ^TMP("GMRCFIL",$J)=@GMRCAR
  1.  S GMRCORC=^TMP("GMRCFIL",$J,"ORC")
  1.  S GMRCFDA(.01)=$$NOW^XLFDT
  1.  S GMRCFDA(.25)=$$HL7TFM^XLFDT($P(GMRCORC,"|",9))
  1.  S GMRCFDA(1)=GMRCLAST
  1.  S GMRCFDA(2)=$$HL7TFM^XLFDT($P(GMRCORC,"|",15))
  1.  D  ;get entering and responsible persons
  1.  . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",10),.GMRCEP,0,U)
  1.  . D UNHLNAME^GMRCIUTL($P(GMRCORC,"|",12),.GMRCRP,0,U)
  1.  S GMRCFDA(.21)=GMRCEP
  1.  S GMRCFDA(.22)=GMRCRP
  1.  S GMRCFDA(.23)=$P($G(^TMP("GMRCFIL",$J,"OBX",5,1)),"|",5)
  1.  I $D(GMRCFR) S GMRCFDA(.31)=GMRCFR
  1.  I $D(^TMP("GMRCFIL",$J,"OBX",4)) D
  1.  . N RFIL,RSLT,DESC,GMRCOBX,ROOT,RSITE
  1.  . S GMRCOBX=^TMP("GMRCFIL",$J,"OBX",4,1)
  1.  . S RFIL=$P($P(GMRCOBX,"|",3),U,3),RFIL=$P(RFIL,"VA",2)
  1.  . S RSLT=+$P(GMRCOBX,"|",5)
  1.  . S RSITE=$$IEN^XUAF4($P($P(GMRCOBX,"|",5),U,3))
  1.  . S ROOT=$S($P($P(GMRCOBX,"|",3),U,2)["TIU":"TIU(",1:"MCAR(")
  1.  . S DESC=$P($P(GMRCOBX,"|",5),U,2)
  1.  . S GMRCFDA(.24)=RSLT_";"_ROOT_RFIL_";"_DESC_";"_RSITE
  1.  I GMRCLAST=10 D  ; overwite inc. report in last action?
  1.  . N GMRCLACT
  1.  . S GMRCLACT=$O(^GMR(123,GMRCO,40," "),-1)
  1.  . I '$G(GMRCLACT) Q
  1.  . I $P($G(^GMR(123,GMRCO,40,GMRCLACT,0)),U,2)'=9 Q
  1.  . I $$FMDIFF^XLFDT($$NOW^XLFDT,+^GMR(123,GMRCO,40,GMRCLACT,0),2)>900 Q
  1.  . I $P($G(^GMR(123,GMRCO,40,GMRCLACT,2)),U,4)=GMRCFDA(.24) D
  1.  .. S GMRCACT(1)=GMRCLACT
  1.  .. M FDA(1,123.02,GMRCACT(1)_","_GMRCO_",")=GMRCFDA
  1.  .. D UPDATE^DIE("","FDA(1)",,"GMRCERR")
  1.  . Q
  1.  I '$D(GMRCACT(1)) D  ; need to create new activity
  1.  . M FDA(1,123.02,"+1,"_GMRCO_",")=GMRCFDA
  1.  . D UPDATE^DIE("","FDA(1)","GMRCACT","GMRCERR")
  1.  K GMRCFDA,FDA
  1.  D  ; file comments if present
  1.  . I $D(^TMP("GMRCFIL",$J,"OBX",3)) D  ; general comments
  1.  .. N TMPARR
  1.  .. S TMPARR=$NA(^TMP("GMRCFIL",$J,"OBX",3))
  1.  .. D TRIMWP^GMRCIUTL(TMPARR,5)
  1.  .. D WP^DIE(123.02,GMRCACT(1)_","_GMRCO_",",5,"K",TMPARR)
  1.  . I $D(^TMP("GMRCFIL",$J,"NTE")) D  ; DC or cancel comments
  1.  .. N TMPARR
  1.  .. S TMPARR=$NA(^TMP("GMRCFIL",$J,"NTE"))
  1.  .. D TRIMWP^GMRCIUTL(TMPARR,3)
  1.  .. D WP^DIE(123.02,GMRCACT(1)_","_GMRCO_",",5,"K",TMPARR)
  1.  .. Q
  1.  D  ; update order if necessary
  1.  . I $P($G(^GMR(123,GMRCO,12)),U,5)="F" Q  ; fillers have no order
  1.  . I GMRCLAST=11!(GMRCLAST=13)!(GMRCLAST=14) Q  ;no status chg
  1.  . I GMRCLAST=4!(GMRCLAST=20) Q  ;no status chg
  1.  . D UPDORD(GMRCO,GMRCACT(1))
  1.  K ^TMP("GMRCFIL",$J)
  1.  Q
  1.  ;
  1. TST(ARRAY) ;process test message and check item ordered
  1.  ;Input:
  1.  ; ARRAY  = name of array containing message parts
  1.  ;
  1.  N GMRCFDA,GMRCORC,GMRCDA,GMRCITM,GMRCITER
  1.  K ^TMP("GMRCIN",$J)
  1.  M ^TMP("GMRCIN",$J)=@ARRAY
  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.  . 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.  I $D(GMRCITER) D  ;error in procedure or service, reject new order
  1.  . N GMRCRSLT
  1.  . D RESP^GMRCIUTL("AR",HL("MID"),,,GMRCITER) ;build HLA(
  1.  . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
  1.  I '$D(GMRCITER) D
  1.  . N GMRCRSLT
  1.  . D RESP^GMRCIUTL("AA",HL("MID")) ;build HLA(
  1.  . D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
  1.  K ^TMP("GMRCIN",$J)
  1.  Q
  1.  ;
  1. GETDA(GMRCORC) ; determine what local Consult ien to work on
  1.  ; Input:
  1.  ;  GMRCORC = ORC seg from incoming message
  1.  ; Output:
  1.  ;  ien from file 123
  1.  ;
  1.  N GMRCORC2,GMRCORC3
  1.  S GMRCORC2=$P(GMRCORC,"|",2),GMRCORC3=$P(GMRCORC,"|",3)
  1.  I $$IEN^XUAF4($P(GMRCORC2,U,2))=$$KSP^XUPARAM("INST") Q +GMRCORC2
  1.  Q +GMRCORC3
  1.  ;
  1. DUPACT(GMRCO,ACTVT,ORC,OBX) ;check to see if activity is a dup transmission
  1.  ;Input:
  1.  ;  GMRCO = ien of consult
  1.  ;  ACTVT = ien of activity from file 123.1
  1.  ;  ORC   = ORC segment from message
  1.  ;  OBX   = OBX segment containing result
  1.  ;
  1.  ;Output:
  1.  ;  0  = activity is not a duplicate of one on file already
  1.  ;  1  = duplicate, activity already on file
  1.  ;
  1.  N GMRCIADT,GMRCIFDT,DUP
  1.  S GMRCIFDT=+$$HL7TFM^XLFDT($P(ORC,"|",9))
  1.  S GMRCIADT=+$$HL7TFM^XLFDT($P(ORC,"|",15))
  1.  S DUP=0
  1.  I $D(^GMR(123,GMRCO,40,"AC",ACTVT,GMRCIFDT,GMRCIADT)) D  Q DUP ;dupl.
  1.  . N RSLT,RFIL,RSITE,ROOT
  1.  . I $L($G(OBX)) D  Q:'$G(DUP)
  1.  .. S RFIL=$P($P(OBX,"|",3),U,3),RFIL=$P(RFIL,"VA",2)
  1.  .. S RSLT=+$P(OBX,"|",5)
  1.  .. S RSITE=$$IEN^XUAF4($P($P(OBX,"|",5),U,3))
  1.  .. S ROOT=$S($P($P(OBX,"|",3),U,2)["TIU":"TIU(",1:"MCAR(")
  1.  .. S RSLT=RSLT_";"_ROOT_RFIL
  1.  .. I ACTVT=12,$D(^GMR(123,GMRCO,51,"AR",RSLT,RSITE)) Q  ;no dup
  1.  .. I ACTVT'=12,'$D(^GMR(123,GMRCO,51,"AR",RSLT,RSITE)) Q  ;no dup
  1.  .. S DUP=1
  1.  . S DUP=1
  1.  . D APPACK(GMRCO,"AR",802) ;send app. ACK and unlock record
  1.  Q 0
  1.  ;
  1. APPACK(GMRCO,ACK,ERR) ;send application acknowledgement for all cases
  1.  ;Input:
  1.  ;  GMRCO = ien from file 123
  1.  ;  ACK   = ACK code to include  ("AA"=accept or "AR"=reject)
  1.  ;  ERR   = error code to return if there is one (optional)
  1.  ;
  1.  ; Output: none
  1.  ;
  1.  ;send appl ACK
  1.  N GMRCRSLT
  1.  I '$G(ERR) S ERR=""
  1.  D RESP^GMRCIUTL(ACK,HL("MID"),,,ERR) ;build HLA("HLA", array
  1.  D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.GMRCRSLT)
  1.  ;
  1.  D UNLKREC^GMRCUTL1(GMRCO) ;unlock record
  1.  Q