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

XUMF0.m

Go to the documentation of this file. 
  1. XUMF0 ;ISS/RAM - XUMF API's;04/15/02
  1.  ;;8.0;KERNEL;**407,474**;Jul 10, 1995;Build 18
  1.  ;Per VHA Directive 10-92-142, this routine should not be modified
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. MFE(IFN,VUID,IEN,ERROR) ; -- update
  1.  ;
  1.  I 'IFN S ERROR="1^Error - IFN required HLNODE: "_HLNODE Q
  1.  I IFN=4.009 S IEN=$$FIND1^DIC(IFN,,"B","GLOBAL VERSION") Q
  1.  I 'VUID S ERROR="1^Error - VUID required HLNODE: "_HLNODE Q
  1.  ;
  1.  S ROOT=$$ROOT^DILFD(IFN,,1)
  1.  S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0))
  1.  ;
  1.  ;reactivate an existing inactive VUID
  1.  I 'IEN D
  1.  .S IEN=$O(@ROOT@("AMASTERVUID",VUID,0,0)) Q:'IEN
  1.  .K FDA,ERR
  1.  .S IENS=IEN_","
  1.  .S FDA(IFN,IENS,99.98)=1
  1.  .D FILE^DIE("E","FDA","ERR")
  1.  .I $D(ERR) D
  1.  ..S ERROR="1^flag update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
  1.  ..D EM^XUMF1H(ERROR,.ERR) K ERR
  1.  ;
  1.  Q
  1.  ;
  1. STUB ; -- create record and update VUID with master flag
  1.  ;
  1.  S XREF="B"
  1.  S NAME=$$UNESC($P(HLNODE,HLFS,3),.HL)
  1.  S ROOT=$$ROOT^DILFD(IFN,,1)
  1.  S IEN=$O(@ROOT@(XREF,NAME,0))
  1.  ;
  1.  I IEN D
  1.  .N ROOT
  1.  .S ROOT=$$ROOT^DILFD(IFN,,1)
  1.  .M RECORD("BEFORE")=@ROOT@(IEN)
  1.  .S RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")
  1.  ;
  1.  I 'IEN D  Q:ERROR
  1.  .D CHK^DIE(IFN,.01,,NAME,.X)
  1.  .I X="^" S ERROR="1^Error - .01 is invalid"_" File #: "_IFN_" HLNODE="_HLNODE Q
  1.  .K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
  1.  .I Y="-1" S ERROR="1^Error - stub entry IFN: "_IFN_" failed HLNODE: "_HLNODE Q
  1.  .S IEN=+Y,RECORD("NEW")=1
  1.  ;
  1.  S:'$G(RECORD("NEW")) ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"REPLACED BY")=""
  1.  S:'$G(RECORD("NEW")) ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"INHERITS FROM")=""
  1.  ;
  1.  S IENS=IEN_","
  1.  ;
  1.  ;I $L($P(MFE,U)),$P(MFE,U)'=99.99 Q
  1.  S FDA(IFN,IENS,99.99)=VUID
  1.  S FDA(IFN,IENS,99.98)=1
  1.  ;
  1.  K ERR
  1.  ;
  1.  D FILE^DIE("E","FDA","ERR")
  1.  I $D(ERR) D
  1.  .S ERROR="1^VUID update error IFN: "_IFN_" IEN: "_IEN_" VUID: "_VUID_" HLNODE: "_HLNODE
  1.  .D EM^XUMF1H(ERROR,.ERR) K ERR
  1.  ;
  1.  D ADD^XUMF1H
  1.  ;
  1.  ; clean multiple flag
  1.  K:'$D(XIEN(IEN)) XIEN
  1.  S XIEN(IEN)=$G(XIEN(IEN))+1
  1.  ;
  1.  Q
  1.  ;
  1. VUID(FILE,FIELD,VUID1,X) ; -- If value type pointer and VUID may be used,
  1.  ; get IEN and set it as internal value
  1.  N X1
  1.  Q:'$L(FILE)!'FIELD!'$L(VUID1) 0
  1.  D FIELD^DID(FILE,FIELD,,"POINTER","X1")
  1.  S X1=$G(X1("POINTER"))
  1.  Q:'$L(X1) 0
  1.  S X1=U_X1_"""AMASTERVUID"",X,1,0)"
  1.  S X1=$O(@X1)
  1.  Q +X1
  1.  ;
  1. VAL(FILE,FIELD,VUID1,VALUE,IENS) ; convert to internal
  1.  ;
  1.  N RESULT,ERR
  1.  ;
  1.  I $G(VALUE)="" Q "^"
  1.  I $G(VALUE)="""""" Q ""
  1.  ;
  1.  I $L(VUID1) D  Q RESULT
  1.  .S RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
  1.  .I 'RESULT S RESULT="^",ERROR="1^VUID lookup failed on "_VALUE
  1.  ;
  1.  D VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
  1.  I $D(ERR)!(RESULT="^") D
  1.  .S ERROR="1^data validation error"
  1.  .D EM^XUMF1H(ERROR,.ERR)
  1.  ;
  1.  Q RESULT
  1.  ;
  1. UNESC(VALUE,HL) ;Unescape value
  1.  N RESULT,ESC,ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC,ESCSEQ,CVRT
  1.  S ESC=$E(HL("ECH"),3)
  1.  S ESCFS=ESC_"F"_ESC S CVRT(ESCFS)=HL("FS")
  1.  S ESCCMP=ESC_"S"_ESC S CVRT(ESCCMP)=$E(HL("ECH"),1)
  1.  S ESCREP=ESC_"R"_ESC S CVRT(ESCREP)=$E(HL("ECH"),2)
  1.  S ESCESC=ESC_"E"_ESC S CVRT(ESCESC)=ESC
  1.  S ESCSUB=ESC_"T"_ESC S CVRT(ESCSUB)=$E(HL("ECH"),4)
  1.  F ESCSEQ=ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC D
  1.  .F  Q:VALUE'[ESCSEQ  D
  1.  ..S VALUE=$P(VALUE,ESCSEQ,1)_CVRT(ESCSEQ)_$P(VALUE,ESCSEQ,2,9999)
  1.  Q VALUE
  1.  ;
  1. UNESCWP(TEXT,HL) ;Unescape word processing field
  1.  N ESC,NODE,NXTNODE,BNDBEG,BNDEND,CHECK,SPOT
  1.  S ESC=$E(HL("ECH"),3)
  1.  S NODE=0
  1.  F  S NODE=+$O(TEXT(NODE)) Q:'NODE  D
  1.  .S TEXT(NODE)=$$UNESC(TEXT(NODE),.HL)
  1.  .S BNDBEG=$E(TEXT(NODE),$L(TEXT(NODE))-1,$L(TEXT(NODE)))
  1.  .I BNDBEG[ESC D
  1.  ..S NXTNODE=$O(TEXT(NODE)) Q:'NXTNODE
  1.  ..S BNDEND=$E(TEXT(NXTNODE),1,2)
  1.  ..Q:(BNDEND'[ESC)
  1.  ..S CHECK=$$UNESC(BNDBEG_BNDEND,.HL)
  1.  ..Q:($L(CHECK)=4)
  1.  ..I $E(BNDBEG,1)=ESC D  Q
  1.  ...S TEXT(NODE)=$E(TEXT(NODE),1,$L(TEXT(NODE))-2)_$E(CHECK,1)
  1.  ...S TEXT(NXTNODE)=$E(CHECK,2)_$E(TEXT(NXTNODE),3,$L(TEXT(NXTNODE)))
  1.  ..S TEXT(NODE)=$E(TEXT(NODE),1,$L(TEXT(NODE))-2)_CHECK
  1.  ..S TEXT(NXTNODE)=$E(TEXT(NXTNODE),3,$L(TEXT(NXTNODE)))
  1.  Q
  1.  ;
  1. EM ; -- error message
  1.  ;
  1.  N X,XMTEXT,XMDUZ,GROUP,XMSUB,XMY
  1.  ;
  1.  D MSG^DIALOG("AM",.X,80,,"ERR")
  1.  ;
  1.  S X(.1)="HL7 message ID: "_$G(HL("MID"))
  1.  S X(.11)="",X(.12)="This message was generated by the NTRT process and MFS.  No action is required on your part."
  1.  S X(.13)="This message is informational and may be used in some instances as a troubleshooting tool."
  1.  S X(.2)="",X(.3)=$G(ERROR)
  1.  S X(.4)="",X(.5)="VUID: "_$G(VUID),X(.6)=""
  1.  S:$G(XMSUB)="" XMSUB="MFS ERROR/WARNING/INFO"
  1.  S XMY("G.XUMF ERROR")="",XMDUZ=.5
  1.  S GROUP=$P($G(^DIC(4.001,+IFN,0)),U,6)
  1.  I GROUP'="" S GROUP="G."_GROUP,XMY(GROUP)=""
  1.  S XMTEXT="X("
  1.  ;
  1.  M X=^TMP("XUMF ERROR",$J)
  1.  ;
  1.  D ^XMD
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. EVT ; -- calls the MFS event protocol
  1.  ;
  1.  N OROLD,X
  1.  K DTOUT,DIROUT
  1.  ;
  1.  I '$D(^TMP("XUMF EVENT")) Q
  1.  ;
  1.  S X=+$O(^ORD(101,"B","XUMF MFS EVENTS",0))_";ORD(101,"
  1.  D EN^XQOR
  1.  ;
  1.  K XQORPOP,X,^TMP("XUMF EVENT",$J) Q
  1.  ;
  1.  Q
  1.  ;