XUMF0 ;ISS/RAM - XUMF API's;04/15/02
;;8.0;KERNEL;**407,474**;Jul 10, 1995;Build 12
;Per VHA Directive 10-92-142, this routine should not be modified
;
Q
;
;
MFE(IFN,VUID,IEN,ERROR) ; -- update
;
I 'IFN S ERROR="1^Error - IFN required HLNODE: "_HLNODE Q
I IFN=4.009 S IEN=$$FIND1^DIC(IFN,,"B","GLOBAL VERSION") Q
I 'VUID S ERROR="1^Error - VUID required HLNODE: "_HLNODE Q
;
S ROOT=$$ROOT^DILFD(IFN,,1)
S IEN=$O(@ROOT@("AMASTERVUID",VUID,1,0))
;
;reactivate an existing inactive VUID
I 'IEN D
.S IEN=$O(@ROOT@("AMASTERVUID",VUID,0,0)) Q:'IEN
.K FDA,ERR
.S IENS=IEN_","
.S FDA(IFN,IENS,99.98)=1
.D FILE^DIE("E","FDA","ERR")
.I $D(ERR) D
..S ERROR="1^flag update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
..D EM^XUMF1H(ERROR,.ERR) K ERR
;
Q
;
STUB ; -- create record and update VUID with master flag
;
S XREF="B"
S NAME=$$UNESC($P(HLNODE,HLFS,3),.HL)
S ROOT=$$ROOT^DILFD(IFN,,1)
S IEN=$O(@ROOT@(XREF,NAME,0))
;
I IEN D
.N ROOT
.S ROOT=$$ROOT^DILFD(IFN,,1)
.M RECORD("BEFORE")=@ROOT@(IEN)
.S RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")
;
I 'IEN D Q:ERROR
.D CHK^DIE(IFN,.01,,NAME,.X)
.I X="^" S ERROR="1^Error - .01 is invalid"_" File #: "_IFN_" HLNODE="_HLNODE Q
.K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
.I Y="-1" S ERROR="1^Error - stub entry IFN: "_IFN_" failed HLNODE: "_HLNODE Q
.S IEN=+Y,RECORD("NEW")=1
;
S:'$G(RECORD("NEW")) ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"REPLACED BY")=""
S:'$G(RECORD("NEW")) ^TMP("XUMF EVENT",$J,IFN,"BEFORE",IEN,"INHERITS FROM")=""
;
S IENS=IEN_","
;
;I $L($P(MFE,U)),$P(MFE,U)'=99.99 Q
S FDA(IFN,IENS,99.99)=VUID
S FDA(IFN,IENS,99.98)=1
;
K ERR
;
D FILE^DIE("E","FDA","ERR")
I $D(ERR) D
.S ERROR="1^VUID update error IFN: "_IFN_" IEN: "_IEN_" VUID: "_VUID_" HLNODE: "_HLNODE
.D EM^XUMF1H(ERROR,.ERR) K ERR
;
D ADD^XUMF1H
;
; clean multiple flag
K:'$D(XIEN(IEN)) XIEN
S XIEN(IEN)=$G(XIEN(IEN))+1
;
Q
;
VUID(FILE,FIELD,VUID1,X) ; -- If value type pointer and VUID may be used,
; get IEN and set it as internal value
N X1
Q:'$L(FILE)!'FIELD!'$L(VUID1) 0
D FIELD^DID(FILE,FIELD,,"POINTER","X1")
S X1=$G(X1("POINTER"))
Q:'$L(X1) 0
S X1=U_X1_"""AMASTERVUID"",X,1,0)"
S X1=$O(@X1)
Q +X1
;
VAL(FILE,FIELD,VUID1,VALUE,IENS) ; convert to internal
;
N RESULT,ERR
;
I $G(VALUE)="" Q "^"
I $G(VALUE)="""""" Q ""
;
I $L(VUID1) D Q RESULT
.S RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
.I 'RESULT S RESULT="^",ERROR="1^VUID lookup failed on "_VALUE
;
D VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
I $D(ERR)!(RESULT="^") D
.S ERROR="1^data validation error"
.D EM^XUMF1H(ERROR,.ERR)
;
Q RESULT
;
UNESC(VALUE,HL) ;Unescape value
N RESULT,ESC,ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC,ESCSEQ,CVRT
S ESC=$E(HL("ECH"),3)
S ESCFS=ESC_"F"_ESC S CVRT(ESCFS)=HL("FS")
S ESCCMP=ESC_"S"_ESC S CVRT(ESCCMP)=$E(HL("ECH"),1)
S ESCREP=ESC_"R"_ESC S CVRT(ESCREP)=$E(HL("ECH"),2)
S ESCESC=ESC_"E"_ESC S CVRT(ESCESC)=ESC
S ESCSUB=ESC_"T"_ESC S CVRT(ESCSUB)=$E(HL("ECH"),4)
F ESCSEQ=ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC D
.F Q:VALUE'[ESCSEQ D
..S VALUE=$P(VALUE,ESCSEQ,1)_CVRT(ESCSEQ)_$P(VALUE,ESCSEQ,2,9999)
Q VALUE
;
UNESCWP(TEXT,HL) ;Unescape word processing field
N ESC,NODE,NXTNODE,BNDBEG,BNDEND,CHECK,SPOT
S ESC=$E(HL("ECH"),3)
S NODE=0
F S NODE=+$O(TEXT(NODE)) Q:'NODE D
.S TEXT(NODE)=$$UNESC(TEXT(NODE),.HL)
.S BNDBEG=$E(TEXT(NODE),$L(TEXT(NODE))-1,$L(TEXT(NODE)))
.I BNDBEG[ESC D
..S NXTNODE=$O(TEXT(NODE)) Q:'NXTNODE
..S BNDEND=$E(TEXT(NXTNODE),1,2)
..Q:(BNDEND'[ESC)
..S CHECK=$$UNESC(BNDBEG_BNDEND,.HL)
..Q:($L(CHECK)=4)
..I $E(BNDBEG,1)=ESC D Q
...S TEXT(NODE)=$E(TEXT(NODE),1,$L(TEXT(NODE))-2)_$E(CHECK,1)
...S TEXT(NXTNODE)=$E(CHECK,2)_$E(TEXT(NXTNODE),3,$L(TEXT(NXTNODE)))
..S TEXT(NODE)=$E(TEXT(NODE),1,$L(TEXT(NODE))-2)_CHECK
..S TEXT(NXTNODE)=$E(TEXT(NXTNODE),3,$L(TEXT(NXTNODE)))
Q
;
EM ; -- error message
;
N X,XMTEXT,XMDUZ,GROUP,XMSUB,XMY
;
D MSG^DIALOG("AM",.X,80,,"ERR")
;
S X(.1)="HL7 message ID: "_$G(HL("MID"))
S X(.11)="",X(.12)="This message was generated by the NTRT process and MFS. No action is required on your part."
S X(.13)="This message is informational and may be used in some instances as a troubleshooting tool."
S X(.2)="",X(.3)=$G(ERROR)
S X(.4)="",X(.5)="VUID: "_$G(VUID),X(.6)=""
S:$G(XMSUB)="" XMSUB="MFS ERROR/WARNING/INFO"
S XMY("G.XUMF ERROR")="",XMDUZ=.5
S GROUP=$P($G(^DIC(4.001,+IFN,0)),U,6)
I GROUP'="" S GROUP="G."_GROUP,XMY(GROUP)=""
S XMTEXT="X("
;
M X=^TMP("XUMF ERROR",$J)
;
D ^XMD
;
Q
;
;
EVT ; -- calls the MFS event protocol
;
N OROLD,X
K DTOUT,DIROUT
;
I '$D(^TMP("XUMF EVENT")) Q
;
S X=+$O(^ORD(101,"B","XUMF MFS EVENTS",0))_";ORD(101,"
D EN^XQOR
;
K XQORPOP,X,^TMP("XUMF EVENT",$J) Q
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF0 4895 printed Apr 09, 2024@21:10:30 Page 2
XUMF0 ;ISS/RAM - XUMF API's;04/15/02
+1 ;;8.0;KERNEL;**407,474**;Jul 10, 1995;Build 12
+2 ;Per VHA Directive 10-92-142, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ;
MFE(IFN,VUID,IEN,ERROR) ; -- update
+1 ;
+2 IF 'IFN
SET ERROR="1^Error - IFN required HLNODE: "_HLNODE
QUIT
+3 IF IFN=4.009
SET IEN=$$FIND1^DIC(IFN,,"B","GLOBAL VERSION")
QUIT
+4 IF 'VUID
SET ERROR="1^Error - VUID required HLNODE: "_HLNODE
QUIT
+5 ;
+6 SET ROOT=$$ROOT^DILFD(IFN,,1)
+7 SET IEN=$ORDER(@ROOT@("AMASTERVUID",VUID,1,0))
+8 ;
+9 ;reactivate an existing inactive VUID
+10 IF 'IEN
Begin DoDot:1
+11 SET IEN=$ORDER(@ROOT@("AMASTERVUID",VUID,0,0))
if 'IEN
QUIT
+12 KILL FDA,ERR
+13 SET IENS=IEN_","
+14 SET FDA(IFN,IENS,99.98)=1
+15 DO FILE^DIE("E","FDA","ERR")
+16 IF $DATA(ERR)
Begin DoDot:2
+17 SET ERROR="1^flag update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
+18 DO EM^XUMF1H(ERROR,.ERR)
KILL ERR
End DoDot:2
End DoDot:1
+19 ;
+20 QUIT
+21 ;
STUB ; -- create record and update VUID with master flag
+1 ;
+2 SET XREF="B"
+3 SET NAME=$$UNESC($PIECE(HLNODE,HLFS,3),.HL)
+4 SET ROOT=$$ROOT^DILFD(IFN,,1)
+5 SET IEN=$ORDER(@ROOT@(XREF,NAME,0))
+6 ;
+7 IF IEN
Begin DoDot:1
+8 NEW ROOT
+9 SET ROOT=$$ROOT^DILFD(IFN,,1)
+10 MERGE RECORD("BEFORE")=@ROOT@(IEN)
+11 SET RECORD("STATUS")=$$GETSTAT^XTID(IFN,,IEN_",")
End DoDot:1
+12 ;
+13 IF 'IEN
Begin DoDot:1
+14 DO CHK^DIE(IFN,.01,,NAME,.X)
+15 IF X="^"
SET ERROR="1^Error - .01 is invalid"_" File #: "_IFN_" HLNODE="_HLNODE
QUIT
+16 KILL DIC
SET DIC=IFN
SET DIC(0)="F"
DO FILE^DICN
KILL DIC
+17 IF Y="-1"
SET ERROR="1^Error - stub entry IFN: "_IFN_" failed HLNODE: "_HLNODE
QUIT
+18 SET IEN=+Y
SET RECORD("NEW")=1
End DoDot:1
if ERROR
QUIT
+19 ;
+20 if '$GET(RECORD("NEW"))
SET ^TMP("XUMF EVENT",$JOB,IFN,"BEFORE",IEN,"REPLACED BY")=""
+21 if '$GET(RECORD("NEW"))
SET ^TMP("XUMF EVENT",$JOB,IFN,"BEFORE",IEN,"INHERITS FROM")=""
+22 ;
+23 SET IENS=IEN_","
+24 ;
+25 ;I $L($P(MFE,U)),$P(MFE,U)'=99.99 Q
+26 SET FDA(IFN,IENS,99.99)=VUID
+27 SET FDA(IFN,IENS,99.98)=1
+28 ;
+29 KILL ERR
+30 ;
+31 DO FILE^DIE("E","FDA","ERR")
+32 IF $DATA(ERR)
Begin DoDot:1
+33 SET ERROR="1^VUID update error IFN: "_IFN_" IEN: "_IEN_" VUID: "_VUID_" HLNODE: "_HLNODE
+34 DO EM^XUMF1H(ERROR,.ERR)
KILL ERR
End DoDot:1
+35 ;
+36 DO ADD^XUMF1H
+37 ;
+38 ; clean multiple flag
+39 if '$DATA(XIEN(IEN))
KILL XIEN
+40 SET XIEN(IEN)=$GET(XIEN(IEN))+1
+41 ;
+42 QUIT
+43 ;
VUID(FILE,FIELD,VUID1,X) ; -- If value type pointer and VUID may be used,
+1 ; get IEN and set it as internal value
+2 NEW X1
+3 if '$LENGTH(FILE)!'FIELD!'$LENGTH(VUID1)
QUIT 0
+4 DO FIELD^DID(FILE,FIELD,,"POINTER","X1")
+5 SET X1=$GET(X1("POINTER"))
+6 if '$LENGTH(X1)
QUIT 0
+7 SET X1=U_X1_"""AMASTERVUID"",X,1,0)"
+8 SET X1=$ORDER(@X1)
+9 QUIT +X1
+10 ;
VAL(FILE,FIELD,VUID1,VALUE,IENS) ; convert to internal
+1 ;
+2 NEW RESULT,ERR
+3 ;
+4 IF $GET(VALUE)=""
QUIT "^"
+5 IF $GET(VALUE)=""""""
QUIT ""
+6 ;
+7 IF $LENGTH(VUID1)
Begin DoDot:1
+8 SET RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
+9 IF 'RESULT
SET RESULT="^"
SET ERROR="1^VUID lookup failed on "_VALUE
End DoDot:1
QUIT RESULT
+10 ;
+11 DO VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
+12 IF $DATA(ERR)!(RESULT="^")
Begin DoDot:1
+13 SET ERROR="1^data validation error"
+14 DO EM^XUMF1H(ERROR,.ERR)
End DoDot:1
+15 ;
+16 QUIT RESULT
+17 ;
UNESC(VALUE,HL) ;Unescape value
+1 NEW RESULT,ESC,ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC,ESCSEQ,CVRT
+2 SET ESC=$EXTRACT(HL("ECH"),3)
+3 SET ESCFS=ESC_"F"_ESC
SET CVRT(ESCFS)=HL("FS")
+4 SET ESCCMP=ESC_"S"_ESC
SET CVRT(ESCCMP)=$EXTRACT(HL("ECH"),1)
+5 SET ESCREP=ESC_"R"_ESC
SET CVRT(ESCREP)=$EXTRACT(HL("ECH"),2)
+6 SET ESCESC=ESC_"E"_ESC
SET CVRT(ESCESC)=ESC
+7 SET ESCSUB=ESC_"T"_ESC
SET CVRT(ESCSUB)=$EXTRACT(HL("ECH"),4)
+8 FOR ESCSEQ=ESCFS,ESCCMP,ESCSUB,ESCREP,ESCESC
Begin DoDot:1
+9 FOR
if VALUE'[ESCSEQ
QUIT
Begin DoDot:2
+10 SET VALUE=$PIECE(VALUE,ESCSEQ,1)_CVRT(ESCSEQ)_$PIECE(VALUE,ESCSEQ,2,9999)
End DoDot:2
End DoDot:1
+11 QUIT VALUE
+12 ;
UNESCWP(TEXT,HL) ;Unescape word processing field
+1 NEW ESC,NODE,NXTNODE,BNDBEG,BNDEND,CHECK,SPOT
+2 SET ESC=$EXTRACT(HL("ECH"),3)
+3 SET NODE=0
+4 FOR
SET NODE=+$ORDER(TEXT(NODE))
if 'NODE
QUIT
Begin DoDot:1
+5 SET TEXT(NODE)=$$UNESC(TEXT(NODE),.HL)
+6 SET BNDBEG=$EXTRACT(TEXT(NODE),$LENGTH(TEXT(NODE))-1,$LENGTH(TEXT(NODE)))
+7 IF BNDBEG[ESC
Begin DoDot:2
+8 SET NXTNODE=$ORDER(TEXT(NODE))
if 'NXTNODE
QUIT
+9 SET BNDEND=$EXTRACT(TEXT(NXTNODE),1,2)
+10 if (BNDEND'[ESC)
QUIT
+11 SET CHECK=$$UNESC(BNDBEG_BNDEND,.HL)
+12 if ($LENGTH(CHECK)=4)
QUIT
+13 IF $EXTRACT(BNDBEG,1)=ESC
Begin DoDot:3
+14 SET TEXT(NODE)=$EXTRACT(TEXT(NODE),1,$LENGTH(TEXT(NODE))-2)_$EXTRACT(CHECK,1)
+15 SET TEXT(NXTNODE)=$EXTRACT(CHECK,2)_$EXTRACT(TEXT(NXTNODE),3,$LENGTH(TEXT(NXTNODE)))
End DoDot:3
QUIT
+16 SET TEXT(NODE)=$EXTRACT(TEXT(NODE),1,$LENGTH(TEXT(NODE))-2)_CHECK
+17 SET TEXT(NXTNODE)=$EXTRACT(TEXT(NXTNODE),3,$LENGTH(TEXT(NXTNODE)))
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
EM ; -- error message
+1 ;
+2 NEW X,XMTEXT,XMDUZ,GROUP,XMSUB,XMY
+3 ;
+4 DO MSG^DIALOG("AM",.X,80,,"ERR")
+5 ;
+6 SET X(.1)="HL7 message ID: "_$GET(HL("MID"))
+7 SET X(.11)=""
SET X(.12)="This message was generated by the NTRT process and MFS. No action is required on your part."
+8 SET X(.13)="This message is informational and may be used in some instances as a troubleshooting tool."
+9 SET X(.2)=""
SET X(.3)=$GET(ERROR)
+10 SET X(.4)=""
SET X(.5)="VUID: "_$GET(VUID)
SET X(.6)=""
+11 if $GET(XMSUB)=""
SET XMSUB="MFS ERROR/WARNING/INFO"
+12 SET XMY("G.XUMF ERROR")=""
SET XMDUZ=.5
+13 SET GROUP=$PIECE($GET(^DIC(4.001,+IFN,0)),U,6)
+14 IF GROUP'=""
SET GROUP="G."_GROUP
SET XMY(GROUP)=""
+15 SET XMTEXT="X("
+16 ;
+17 MERGE X=^TMP("XUMF ERROR",$JOB)
+18 ;
+19 DO ^XMD
+20 ;
+21 QUIT
+22 ;
+23 ;
EVT ; -- calls the MFS event protocol
+1 ;
+2 NEW OROLD,X
+3 KILL DTOUT,DIROUT
+4 ;
+5 IF '$DATA(^TMP("XUMF EVENT"))
QUIT
+6 ;
+7 SET X=+$ORDER(^ORD(101,"B","XUMF MFS EVENTS",0))_";ORD(101,"
+8 DO EN^XQOR
+9 ;
+10 KILL XQORPOP,X,^TMP("XUMF EVENT",$JOB)
QUIT
+11 ;
+12 QUIT
+13 ;
