- 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 Feb 18, 2025@23:37:33 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 ;