XUMFX ;ISS/RAM - XUMF API's;04/15/02
;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
;
Q
;
;
MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
;
N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC,Y
;
S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS),ERROR=$G(ERROR)
S:HLCS="" HLCS="~"
;
Q:ERROR
;
I 'IFN S ERROR="1^Error - IFN required HLNODE: "_HLNODE Q
;
I $P(PKV,HLCS)=""!($P(PKV,HLCS,2)="")!($P(PKV,HLCS,4)="") D Q:ERROR
.Q:$G(XUMFSDS)="1H"
.S ERROR="1^Error - PKV not valid HLNODE: "_HLNODE
.D EM^XUMFH(ERROR,.ERR)
;
S MFE=$G(^DIC(4.001,IFN,"MFE")),XREF=$P(MFE,U,8)
I XREF="" D Q
.S ERROR="1^Error - MFE parameter XREF missing HLNODE: "_HLNODE
.D EM^XUMFH(ERROR,.ERR)
;
;I IFN=4.001 D Q
;.S IEN=$$FIND1^DIC(1,,"BX",$P(PKV,HLCS))
;.I 'IEN D Q
;..S ERROR="1^not a valid IEN in MFE - HLNODE: "_HLNODE
;..D EM^XUMFH(ERROR,.ERR)
;.Q:$D(^DIC(4.001,IEN))
;.S NAME=$P(PKV,HLCS)
;.K FDA
;.S FDA(IFN,"?+1,",.01)=NAME
;.D UPDATE^DIE("E","FDA",,"ERR")
;.I $D(ERR) D Q
;..S ERROR="1^MFE UPDATE FAILED for .01 File#: "_IFN
;..D EM^XUMFH(ERROR,.ERR)
;
;lookup an active VUID
S VUID=$P(PKV,HLCS)
I $G(XUMFSDS)="1H" S VUID=$P(PKV,HLCS,4)
S ROOT=$$ROOT^DILFD(IFN,,1)
I '$L(ROOT) D Q
.S ERROR="1^Error - MFE no root file#: "_IFN
.D EM^XUMFH(ERROR,.ERR)
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^XUMFH(ERROR,.ERR)
..K ERR
;
Q:IEN
;
I $G(XUMFSDS)="1H",'IEN D Q
.S ERROR="1^SDS history could not find owning record PKV: "_PKV
.D EM^XUMFH(ERROR,.ERR)
;
I 'IEN D
.S KEY=$P(PKV,HLCS,4)
.S IEN=$O(@ROOT@(XREF,KEY,0))
;
I 'IEN D Q:ERROR
.S NAME=$P(PKV,HLCS,2)
.D CHK^DIE(IFN,.01,,NAME,.X)
.I X="^" D Q
..S ERROR="1^Error - PKV .01 is invalid"_" File #: "_IFN_" PKV="_PKV
..D EM^XUMFH(ERROR,.ERR)
.K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
.I Y="-1" D Q
..S ERROR="1^stub entry for "_PKV_" failed PKV: "_PKV
..D EM^XUMFH(ERROR,.ERR)
.S IEN=+Y
;
S IENS=IEN_","
;
I $L($P(MFE,U)),$P(MFE,U)'=99.99 Q
S FDA(IFN,IENS,99.99)=$P(PKV,HLCS,1)
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 for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
.D EM^XUMFH(ERROR,.ERR)
.K ERR
;
Q
;
VUID(FILE,FIELD,VUID,X) ; -- If value type pointer and VUID may be used,
; get IEN and set it as internal value
N XVUID,X1
Q:'$L(FILE)!'FIELD!'$L(VUID) 0
Q:$E(X,1,$L(VUID))'=VUID 0
S XVUID=$E(X,$L(VUID)+1,$L(X))
D FIELD^DID(FILE,FIELD,,"POINTER","X1")
S X1=$G(X1("POINTER"))
Q:'$L(X1) 0
S X1=U_X1_"""AMASTERVUID"",XVUID,1,0)"
S X1=$O(@X1)
Q +X1
;
VAL(FILE,FIELD,VUID,VALUE,IENS) ; convert to internal
;
N RESULT,ERR
;
I $L(VUID) D Q RESULT
.I VUID="SDS" S VALUE=VUID_+VALUE
.S RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
.I 'RESULT D
..S RESULT="^",ERROR="1^VUID lookup failed on "_VALUE
..D EM("VUID lookup failed on "_VALUE)
;
I VALUE["\F\" F Q:VALUE'["\F\" D
.S VALUE=$P(VALUE,"\F\")_"^"_$P(VALUE,"\F\",2,9999)
I VALUE["\T\" F Q:VALUE'["\T\" D
.S VALUE=$P(VALUE,"\T\")_"&"_$P(VALUE,"\T\",2,9999)
;
D VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
I $D(ERR) D EM("validation error",.ERR)
I RESULT="^" S ERROR="1^data validation error"
;
Q RESULT
;
EM(ERROR,ERR,XMSUB,XMY) ; -- error message
;
N X,XMTEXT,XMDUZ,GROUP
;
D MSG^DIALOG("AM",.X,80,,"ERR")
;
S X(.1)="HL7 message ID: "_$G(HL("MID"))
S X(.2)="",X(.3)=$G(ERROR)
S X(.4)="",X(.5)="Key: "_$G(KEY),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 ^TMP("XUMF ERROR",$J,$O(^TMP("XUMF ERROR",$J,9999999999999),-1)+1)=X
;
D ^XMD
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMFX 4074 printed Apr 09, 2024@21:07:28 Page 2
XUMFX ;ISS/RAM - XUMF API's;04/15/02
+1 ;;8.0;KERNEL;**299,382,383**;Jul 10, 1995
+2 ;
+3 QUIT
+4 ;
+5 ;
MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
+1 ;
+2 NEW IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC,Y
+3 ;
+4 SET IFN=$GET(IFN)
SET IEN=$GET(IEN)
SET HLCS=$GET(HLCS)
SET ERROR=$GET(ERROR)
+5 if HLCS=""
SET HLCS="~"
+6 ;
+7 if ERROR
QUIT
+8 ;
+9 IF 'IFN
SET ERROR="1^Error - IFN required HLNODE: "_HLNODE
QUIT
+10 ;
+11 IF $PIECE(PKV,HLCS)=""!($PIECE(PKV,HLCS,2)="")!($PIECE(PKV,HLCS,4)="")
Begin DoDot:1
+12 if $GET(XUMFSDS)="1H"
QUIT
+13 SET ERROR="1^Error - PKV not valid HLNODE: "_HLNODE
+14 DO EM^XUMFH(ERROR,.ERR)
End DoDot:1
if ERROR
QUIT
+15 ;
+16 SET MFE=$GET(^DIC(4.001,IFN,"MFE"))
SET XREF=$PIECE(MFE,U,8)
+17 IF XREF=""
Begin DoDot:1
+18 SET ERROR="1^Error - MFE parameter XREF missing HLNODE: "_HLNODE
+19 DO EM^XUMFH(ERROR,.ERR)
End DoDot:1
QUIT
+20 ;
+21 ;I IFN=4.001 D Q
+22 ;.S IEN=$$FIND1^DIC(1,,"BX",$P(PKV,HLCS))
+23 ;.I 'IEN D Q
+24 ;..S ERROR="1^not a valid IEN in MFE - HLNODE: "_HLNODE
+25 ;..D EM^XUMFH(ERROR,.ERR)
+26 ;.Q:$D(^DIC(4.001,IEN))
+27 ;.S NAME=$P(PKV,HLCS)
+28 ;.K FDA
+29 ;.S FDA(IFN,"?+1,",.01)=NAME
+30 ;.D UPDATE^DIE("E","FDA",,"ERR")
+31 ;.I $D(ERR) D Q
+32 ;..S ERROR="1^MFE UPDATE FAILED for .01 File#: "_IFN
+33 ;..D EM^XUMFH(ERROR,.ERR)
+34 ;
+35 ;lookup an active VUID
+36 SET VUID=$PIECE(PKV,HLCS)
+37 IF $GET(XUMFSDS)="1H"
SET VUID=$PIECE(PKV,HLCS,4)
+38 SET ROOT=$$ROOT^DILFD(IFN,,1)
+39 IF '$LENGTH(ROOT)
Begin DoDot:1
+40 SET ERROR="1^Error - MFE no root file#: "_IFN
+41 DO EM^XUMFH(ERROR,.ERR)
End DoDot:1
QUIT
+42 SET IEN=$ORDER(@ROOT@("AMASTERVUID",VUID,1,0))
+43 ;
+44 ;reactivate an existing inactive VUID
+45 IF 'IEN
Begin DoDot:1
+46 SET IEN=$ORDER(@ROOT@("AMASTERVUID",VUID,0,0))
if 'IEN
QUIT
+47 KILL FDA,ERR
+48 SET IENS=IEN_","
+49 SET FDA(IFN,IENS,99.98)=1
+50 DO FILE^DIE("E","FDA","ERR")
+51 IF $DATA(ERR)
Begin DoDot:2
+52 SET ERROR="1^flag update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
+53 DO EM^XUMFH(ERROR,.ERR)
+54 KILL ERR
End DoDot:2
End DoDot:1
+55 ;
+56 if IEN
QUIT
+57 ;
+58 IF $GET(XUMFSDS)="1H"
IF 'IEN
Begin DoDot:1
+59 SET ERROR="1^SDS history could not find owning record PKV: "_PKV
+60 DO EM^XUMFH(ERROR,.ERR)
End DoDot:1
QUIT
+61 ;
+62 IF 'IEN
Begin DoDot:1
+63 SET KEY=$PIECE(PKV,HLCS,4)
+64 SET IEN=$ORDER(@ROOT@(XREF,KEY,0))
End DoDot:1
+65 ;
+66 IF 'IEN
Begin DoDot:1
+67 SET NAME=$PIECE(PKV,HLCS,2)
+68 DO CHK^DIE(IFN,.01,,NAME,.X)
+69 IF X="^"
Begin DoDot:2
+70 SET ERROR="1^Error - PKV .01 is invalid"_" File #: "_IFN_" PKV="_PKV
+71 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+72 KILL DIC
SET DIC=IFN
SET DIC(0)="F"
DO FILE^DICN
KILL DIC
+73 IF Y="-1"
Begin DoDot:2
+74 SET ERROR="1^stub entry for "_PKV_" failed PKV: "_PKV
+75 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+76 SET IEN=+Y
End DoDot:1
if ERROR
QUIT
+77 ;
+78 SET IENS=IEN_","
+79 ;
+80 IF $LENGTH($PIECE(MFE,U))
IF $PIECE(MFE,U)'=99.99
QUIT
+81 SET FDA(IFN,IENS,99.99)=$PIECE(PKV,HLCS,1)
+82 SET FDA(IFN,IENS,99.98)=1
+83 ;
+84 KILL ERR
+85 ;
+86 DO FILE^DIE("E","FDA","ERR")
+87 IF $DATA(ERR)
Begin DoDot:1
+88 SET ERROR="1^VUID update error for IFN: "_IFN_" IEN: "_IEN_" PKV: "_PKV
+89 DO EM^XUMFH(ERROR,.ERR)
+90 KILL ERR
End DoDot:1
+91 ;
+92 QUIT
+93 ;
VUID(FILE,FIELD,VUID,X) ; -- If value type pointer and VUID may be used,
+1 ; get IEN and set it as internal value
+2 NEW XVUID,X1
+3 if '$LENGTH(FILE)!'FIELD!'$LENGTH(VUID)
QUIT 0
+4 if $EXTRACT(X,1,$LENGTH(VUID))'=VUID
QUIT 0
+5 SET XVUID=$EXTRACT(X,$LENGTH(VUID)+1,$LENGTH(X))
+6 DO FIELD^DID(FILE,FIELD,,"POINTER","X1")
+7 SET X1=$GET(X1("POINTER"))
+8 if '$LENGTH(X1)
QUIT 0
+9 SET X1=U_X1_"""AMASTERVUID"",XVUID,1,0)"
+10 SET X1=$ORDER(@X1)
+11 QUIT +X1
+12 ;
VAL(FILE,FIELD,VUID,VALUE,IENS) ; convert to internal
+1 ;
+2 NEW RESULT,ERR
+3 ;
+4 IF $LENGTH(VUID)
Begin DoDot:1
+5 IF VUID="SDS"
SET VALUE=VUID_+VALUE
+6 SET RESULT=$$VUID(FILE,FIELD,VUID,VALUE)
+7 IF 'RESULT
Begin DoDot:2
+8 SET RESULT="^"
SET ERROR="1^VUID lookup failed on "_VALUE
+9 DO EM("VUID lookup failed on "_VALUE)
End DoDot:2
End DoDot:1
QUIT RESULT
+10 ;
+11 IF VALUE["\F\"
FOR
if VALUE'["\F\"
QUIT
Begin DoDot:1
+12 SET VALUE=$PIECE(VALUE,"\F\")_"^"_$PIECE(VALUE,"\F\",2,9999)
End DoDot:1
+13 IF VALUE["\T\"
FOR
if VALUE'["\T\"
QUIT
Begin DoDot:1
+14 SET VALUE=$PIECE(VALUE,"\T\")_"&"_$PIECE(VALUE,"\T\",2,9999)
End DoDot:1
+15 ;
+16 DO VAL^DIE(FILE,IENS,FIELD,,VALUE,.RESULT,,"ERR")
+17 IF $DATA(ERR)
DO EM("validation error",.ERR)
+18 IF RESULT="^"
SET ERROR="1^data validation error"
+19 ;
+20 QUIT RESULT
+21 ;
EM(ERROR,ERR,XMSUB,XMY) ; -- error message
+1 ;
+2 NEW X,XMTEXT,XMDUZ,GROUP
+3 ;
+4 DO MSG^DIALOG("AM",.X,80,,"ERR")
+5 ;
+6 SET X(.1)="HL7 message ID: "_$GET(HL("MID"))
+7 SET X(.2)=""
SET X(.3)=$GET(ERROR)
+8 SET X(.4)=""
SET X(.5)="Key: "_$GET(KEY)
SET X(.6)=""
+9 if $GET(XMSUB)=""
SET XMSUB="MFS ERROR/WARNING/INFO"
+10 SET XMY("G.XUMF ERROR")=""
SET XMDUZ=.5
+11 SET GROUP=$PIECE($GET(^DIC(4.001,+IFN,0)),U,6)
+12 IF GROUP'=""
SET GROUP="G."_GROUP
SET XMY(GROUP)=""
+13 SET XMTEXT="X("
+14 ;
+15 MERGE ^TMP("XUMF ERROR",$JOB,$ORDER(^TMP("XUMF ERROR",$JOB,9999999999999),-1)+1)=X
+16 ;
+17 DO ^XMD
+18 ;
+19 QUIT
+20 ;
