XUMF ;OIFO-OAK/RAM - XUMF API's;04/15/02
;;8.0;KERNEL;**218,335,416,555**;Jul 10, 1995;Build 3
;
Q
;
IEN(IFN,CDSYS,ID) ; -- Internal Entry Number
;
I IFN=4 N X S X=$O(^DIC(4,"D",ID,0)) Q $S(X:X,1:"0^not found")
;
N IEN,ROOT
;
S IFN=$G(IFN),CDSYS=$G(CDSYS),ID=$G(ID)
;
Q:'IFN "0^IFN required"
Q:CDSYS="" "0^CDSYS required"
Q:ID="" "0^ID required"
;
S ROOT=$$ROOT^DILFD(IFN,,1) Q:ROOT="" "0^invalid IFN"
S IEN=$O(@ROOT@("XUMFIDX",CDSYS,ID,0))
;
Q $S(IEN:IEN,1:"0^not found")
;
FLD(FILE,FIELD) ; field
;
N Y,DA,X
;
S Y=$$FIELD(FILE,FIELD,"LABEL")
;
Q $S(Y'="":1,1:0)
;
LBL(FILE,FIELD) ; field label
;
Q $$FIELD(FILE,FIELD,"LABEL")
;
TYP(FILE,FIELD) ; field type
;
Q $$FIELD(FILE,FIELD,"TYPE")
;
PTR(FILE,FIELD) ; pointer field?
;
Q $S($$TYP(FILE,FIELD)="POINTER":1,1:0)
;
FIELD(FILE,FIELD,ATT) ; field attributes
;
N Y,DA,X
;
Q:'$G(FILE) ""
Q:'$G(FIELD) ""
Q:$G(ATT)="" ""
;
D FIELD^DID(FILE,FIELD,"N",ATT,"Y")
;
Q $G(Y(ATT))
;
FILE(FILE,ATT) ; file attributes
;
N Y,DA,X
;
Q:'$G(FILE) ""
Q:$G(ATT)="" ""
;
D FILE^DID(FILE,,ATT,"Y")
;
Q $G(Y(ATT))
;
ECHO(FILE,IDX,X,XUMF) ; validate field exists and echo name
;
Q:'$$F(+$G(XUMF)) 0
;
N SUBFILE,NAME
;
S SUBFILE=$P($G(^DIC(4.001,+$G(FILE),1,+$G(IDX),0)),U,4)
;
S NAME=$$LBL($S(SUBFILE:SUBFILE,1:+$G(FILE)),X)
;
Q:NAME="" 0
;
;W " "_NAME
;
Q 1
;
F(XUMF) ; constrain edits to standard values
;
Q $S($G(XUMF):1,1:0)
;
PKV(IFN,IEN,HLCS) ; Primary Key Value - MFE.4
;
S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS)
;
N MFE,NODE,ID,TEXT,CDSYS,IENS
;
S NODE=$G(^DIC(4.001,IFN,"MFE"))
Q:NODE="" "1Error - MFS parameter not defined for IFN "_IFN
;
S:HLCS="" HLCS="~"
S CDSYS=$P(NODE,U,3)
;
Q:IEN="NEW" IEN_HLCS_"NEW ENTRY"_HLCS_CDSYS
;
Q:'IFN "1Error - IFN required"
Q:'IEN "1Error - IEN required"
;
S IENS=IEN_","
;
S FIELD=$P(NODE,U,1),ID=$$GET1^DIQ(IFN,IENS,FIELD)
S FIELD=$P(NODE,U,2),TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
;
S MFE=ID_HLCS_TEXT_HLCS_CDSYS
;
Q:'$P(NODE,U,4) MFE
;
S FIELD=$P(NODE,U,4),ID=$$GET1^DIQ(IFN,IENS,FIELD)
S FIELD=$P(NODE,U,5),TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
S CDSYS=$P(NODE,U,6)
;
Q MFE_HLCS_ID_HLCS_TEXT_HLCS_CDSYS
;
MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
;
N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC
;
S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS),ERROR=$G(ERROR)
S:HLCS="" HLCS="~"
;
Q:ERROR
;
I 'IFN S ERROR="1Error - IFN required" Q
;
I IFN'=4.001 D Q:ERROR
.S MFE=$G(^DIC(4.001,IFN,"MFE")),XREF=$P(MFE,U,8)
.I '$P(MFE,U,1) D Q
..S ERROR="1MFS PARAM MFE.4.1 null"
..D EM^XUMFH(ERROR,.ERR)
.I '$P(MFE,U,2) D Q
..S ERROR="1MFS PARAM MFE.4.2 null"
..D EM^XUMFH(ERROR,.ERR)
.I XREF="" D Q
..S ERROR="1MFS PARAM MFE XREF not defined"
..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="1not a valid IEN in MFE XUMF"
..D EM^XUMFH(ERROR,.ERR)
.Q:$D(^DIC(4.001,IEN))
.X HLNEXT
.I $P(HLNODE,HLFS)'="ZZZ" D Q
..S ERROR="1MFP error in MFE XUMF"
..D EM^XUMFH(ERROR,.ERR)
.S MFE=$P(HLNODE,HLFS,7,12),MFE=$TR(MFE,HLFS,U)
.S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I
.I 'X D Q
..S ERROR="1MFS PARAM no .01 in MFE"
..D EM^XUMFH(ERROR,.ERR)
.S NAME=$P(PKV,HLCS,X) K X
.K FDA
.S FDA(IFN,"?+1,",.01)=NAME
.D UPDATE^DIE("E","FDA")
;
S ID=$P(PKV,HLCS)
I ID="" D Q
.S ERROR="1MFS PARAM MFE PKV ID null"
.D EM^XUMFH(ERROR,.ERR)
S ROOT=$$ROOT^DILFD(IFN,,1)
I $D(@ROOT@(XREF)),'$G(IEN) S IEN=$O(@ROOT@(XREF,ID,0))
S:'IEN IEN=$$FIND1^DIC(IFN,,"B",ID)
;
I 'IEN D Q:ERROR
.S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I
.I 'X D Q
..S ERROR="1MFS PARAM no .01 in MFE"
..D EM^XUMFH(ERROR,.ERR)
.S NAME=$P(PKV,HLCS,X) K X
.I NAME="" S ERROR="1MFS PARAM MFE PKV .01 is null" Q
.D CHK^DIE(IFN,.01,,NAME,.X)
.I X="^" D Q
..S ERROR="1MFS PARAM MFE PKV .01 is invalid"
..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="1MFS PARAM MFE FileDICN unsuccessful"
..D EM^XUMFH(ERROR,.ERR)
.S IEN=+Y
;
S IENS=IEN_","
;
F I=1,2,4,5 D
.S FLD=$P(MFE,U,I) Q:'FLD
.S FDA(IFN,IENS,FLD)=$P(PKV,HLCS,I)
;
D FILE^DIE("E","FDA","ERR")
I $D(ERR) D
.D EM^XUMFH("1FILE DIE error msg in MFE of XUMF",.ERR)
.K ERR
;
Q
;
MFP(IFN,ERR) ; -- validate Master File Parameters entry FALSE=valid
;
Q:'$G(IFN) "IFN null"
;
D ZERO(IFN,.ERR)
D MFE1(IFN,.ERR)
D SEQ(IFN,.ERR)
;
Q $S($D(ERR("FATAL")):1,$D(ERR("WARNING")):2,1:0)
;
ZERO(IFN,ERR) ; -- zero node
;
N X,CNT
;
S X=$G(^DIC(4.001,+IFN,0)),CNT=1
I $P(X,U,2)="" D
.S ERR("FATAL","ZERO",CNT)="Z SEGMENT is null",CNT=CNT+1
I $P(X,U,3)="" D
.S ERR("FATAL","ZERO",CNT)="MFI CODE is null",CNT=CNT+1
I $P(X,U,4)="" D
.S ERR("WARNING","ZERO",CNT)="PRE-UPDATE ROUTINE is null",CNT=CNT+1
I $P(X,U,5)="" D
.S ERR("WARNING","ZERO",CNT)="POST-UPDATE ROUTINE is null",CNT=CNT+1
I $P(X,U,6)="" D
.S ERR("WARNING","ZERO",CNT)="MAIL GROUP is null",CNT=CNT+1
;
Q
;
MFE1(IFN,ERR) ; -- MFE node
;
N X,I,CNT
;
S X=$G(^DIC(4.001,+IFN,"MFE")),CNT=1
F I=1:1:6 I $P(X,U,I)="" D
.S ERR("FATAL","MFE",CNT)="MFE ID & ALT ID field and codsys required"
.S CNT=CNT+1
I $P(X,U,8)="" D
.S ERR("FATAL","MFE",CNT)="MFE PKV X-REF required",CNT=CNT+1
F I=11,12,14,15 I $P(X,U,I)="" D
.S ERR("WARNING","MFE",CNT)="MFE PKV types are null",CNT=CNT+1
I $P(X,U,9)="" D
.S ERR("WARNING","MFE",CNT)="ASSIGNING AUTHORITY is null",CNT=CNT+1
;
Q
;
SEQ(IFN,ERR) ; -- sequence nodes
;
N SEQ,MULT,X,I,Y
;
S SEQ=0
F S SEQ=$O(^DIC(4.001,IFN,1,SEQ)) Q:'SEQ D
.S X=$G(^DIC(4.001,IFN,1,SEQ,0))
.I $$TYP($S($P(X,U,4):$P(X,U,4),1:IFN),$P(X,U,2))="POINTER" D
..Q:$P(X,U,7)'=""
..S Y=$S($P(X,U,4):$P(X,U,4),1:IFN),Y=$$LBL(Y,$P(X,U,2))
..S Y="field "_Y_" is pointer EXTENDED POINTER LKUP is NULL"
..S ERR("WARNING",SEQ)=Y
.S MULT=$S($P(X,U,4):1,1:0)
.I '$P(X,U,2) S ERR("FATAL",SEQ)=" missing FIELD NUMBER"
.I MULT,$P(X,U,8)="" D
..S ERR("FATAL",SEQ)=" MULT IEN FUNCTION is null"
.I MULT,$P(X,U,6),$P(X,U,5)'="" D
..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
.I MULT,'$P(X,U,6),$P(X,U,5)="" D
..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
.I 'MULT F I=5,6,8 D
..Q:$P(X,U,I)=""
..S ERR("FATAL",SEQ)=" SUBFILE null with subfile parameters"
;
Q
;
BG(IFN,IEN,TYP) ; -- background job
;
; type (5=file, 7=array)
;
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
;
S TYP=$G(TYP) S:'TYP TYP=5
S IEN=$G(IEN) S:IEN="" IEN="ALL"
;
S ZTDTH=$$NOW^XLFDT,ZTRTN="BG1^XUMF",ZTIO=""
S ZTSAVE("IFN")="",ZTSAVE("TYP")="",ZTSAVE("IEN")=""
S ZTDESC="XUMF get "_$$FILE^XUMF(IFN,"NAME")_" using MFS"
;
D ^%ZTLOAD
;
Q
;
BG1 ; -- get file
;
D MFS(IFN,IEN,TYP,.ERROR),EXIT
;
Q
;
LOAD(IFN) ; -- query and file
;
D MFS(IFN,"ALL",5,.ERROR)
;
Q
;
ARRAY(IFN) ; -- query and put in array
;
D MFS(IFN,"ALL",7,.ERROR)
;
Q
;
GETCE(IFN,IEN,TYP,ERROR) ; -- get master file provide coded element
;
Q
;
MFS(IFN,IEN,TYP,ERROR) ; -- get file from Master File Server
;
; TYP (5=query/file, 7=query/tmp_array)
;
N TEST
;
S (ERROR,TEST)=0
;
S IFN=$G(IFN),IEN=$G(IEN),TYP=$G(TYP)
;
I 'IFN S ERROR="1IFN not valid MFS in XUMF" Q
I IEN="" S ERROR="1IEN not valid MFS in XUMF" Q
I TYP'=5,TYP'=7 S ERROR="1type not support by MFS in XUMF" Q
;
I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
;
S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
;
D MAIN^XUMFP(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFI(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR
D MAIN^XUMFH
;
Q
;
;
EXIT ; -- cleanup and quit
;
K ^TMP("XUMF MFS",$J),^TMP("DIERR",$J)
;
S ZTREQ="@"
;
Q
;
NPI ; -- NPI
;
N COL,X,FDA,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,ERR
;
D SEGPRSE^XUMFXHL7("HLNODE","COL")
;
S NPIDT=$$FMDATE^HLFNC(COL(17))
S NPISTAT=COL(18)
S NPI=COL(19)
S TAX=COL(20)
S TAXPC=COL(21)
S TAXSTAT=COL(22)
;
S X=$$NPI^XUSNPI("Organization_ID",IEN,NPIDT)
I $S(X=0:1,$$UP^XLFSTR($P(X,U,3))'=NPISTAT:1,NPI'=+X:1,1:0) D
.S X=$$ADDNPI^XUSNPI("Organization_ID",IEN,NPI,NPIDT,$S(NPISTAT="ACTIVE":1,1:0))
;
S IENS="?+1,"_IEN_","
K FDA
S FDA(4.9999,IENS,.01)="NPI"
S FDA(4.9999,IENS,.02)=NPI
D UPDATE^DIE("E","FDA",,"ERR")
;
K FDA
S IENS="?+1,"_IEN_","
S FDA(4.043,IENS,.01)=TAX
S FDA(4.043,IENS,.02)=TAXPC
S FDA(4.043,IENS,.03)=TAXSTAT
D UPDATE^DIE("E","FDA",,"ERR")
;
S SEQ=22
;
Q
;
CDSYS(CDSYS,ID,IEN) ; udpate coding system / ID
;
N IENS,FDA
;
S IENS="?+1,"_IEN_","
K FDA
S FDA(4.9999,IENS,.01)=CDSYS
S FDA(4.9999,IENS,.02)=ID
D
.N IEN,VALUE
.D UPDATE^DIE("E","FDA")
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMF 8884 printed Apr 09, 2024@21:16:22 Page 2
XUMF ;OIFO-OAK/RAM - XUMF API's;04/15/02
+1 ;;8.0;KERNEL;**218,335,416,555**;Jul 10, 1995;Build 3
+2 ;
+3 QUIT
+4 ;
IEN(IFN,CDSYS,ID) ; -- Internal Entry Number
+1 ;
+2 IF IFN=4
NEW X
SET X=$ORDER(^DIC(4,"D",ID,0))
QUIT $SELECT(X:X,1:"0^not found")
+3 ;
+4 NEW IEN,ROOT
+5 ;
+6 SET IFN=$GET(IFN)
SET CDSYS=$GET(CDSYS)
SET ID=$GET(ID)
+7 ;
+8 if 'IFN
QUIT "0^IFN required"
+9 if CDSYS=""
QUIT "0^CDSYS required"
+10 if ID=""
QUIT "0^ID required"
+11 ;
+12 SET ROOT=$$ROOT^DILFD(IFN,,1)
if ROOT=""
QUIT "0^invalid IFN"
+13 SET IEN=$ORDER(@ROOT@("XUMFIDX",CDSYS,ID,0))
+14 ;
+15 QUIT $SELECT(IEN:IEN,1:"0^not found")
+16 ;
FLD(FILE,FIELD) ; field
+1 ;
+2 NEW Y,DA,X
+3 ;
+4 SET Y=$$FIELD(FILE,FIELD,"LABEL")
+5 ;
+6 QUIT $SELECT(Y'="":1,1:0)
+7 ;
LBL(FILE,FIELD) ; field label
+1 ;
+2 QUIT $$FIELD(FILE,FIELD,"LABEL")
+3 ;
TYP(FILE,FIELD) ; field type
+1 ;
+2 QUIT $$FIELD(FILE,FIELD,"TYPE")
+3 ;
PTR(FILE,FIELD) ; pointer field?
+1 ;
+2 QUIT $SELECT($$TYP(FILE,FIELD)="POINTER":1,1:0)
+3 ;
FIELD(FILE,FIELD,ATT) ; field attributes
+1 ;
+2 NEW Y,DA,X
+3 ;
+4 if '$GET(FILE)
QUIT ""
+5 if '$GET(FIELD)
QUIT ""
+6 if $GET(ATT)=""
QUIT ""
+7 ;
+8 DO FIELD^DID(FILE,FIELD,"N",ATT,"Y")
+9 ;
+10 QUIT $GET(Y(ATT))
+11 ;
FILE(FILE,ATT) ; file attributes
+1 ;
+2 NEW Y,DA,X
+3 ;
+4 if '$GET(FILE)
QUIT ""
+5 if $GET(ATT)=""
QUIT ""
+6 ;
+7 DO FILE^DID(FILE,,ATT,"Y")
+8 ;
+9 QUIT $GET(Y(ATT))
+10 ;
ECHO(FILE,IDX,X,XUMF) ; validate field exists and echo name
+1 ;
+2 if '$$F(+$GET(XUMF))
QUIT 0
+3 ;
+4 NEW SUBFILE,NAME
+5 ;
+6 SET SUBFILE=$PIECE($GET(^DIC(4.001,+$GET(FILE),1,+$GET(IDX),0)),U,4)
+7 ;
+8 SET NAME=$$LBL($SELECT(SUBFILE:SUBFILE,1:+$GET(FILE)),X)
+9 ;
+10 if NAME=""
QUIT 0
+11 ;
+12 ;W " "_NAME
+13 ;
+14 QUIT 1
+15 ;
F(XUMF) ; constrain edits to standard values
+1 ;
+2 QUIT $SELECT($GET(XUMF):1,1:0)
+3 ;
PKV(IFN,IEN,HLCS) ; Primary Key Value - MFE.4
+1 ;
+2 SET IFN=$GET(IFN)
SET IEN=$GET(IEN)
SET HLCS=$GET(HLCS)
+3 ;
+4 NEW MFE,NODE,ID,TEXT,CDSYS,IENS
+5 ;
+6 SET NODE=$GET(^DIC(4.001,IFN,"MFE"))
+7 if NODE=""
QUIT "1Error - MFS parameter not defined for IFN "_IFN
+8 ;
+9 if HLCS=""
SET HLCS="~"
+10 SET CDSYS=$PIECE(NODE,U,3)
+11 ;
+12 if IEN="NEW"
QUIT IEN_HLCS_"NEW ENTRY"_HLCS_CDSYS
+13 ;
+14 if 'IFN
QUIT "1Error - IFN required"
+15 if 'IEN
QUIT "1Error - IEN required"
+16 ;
+17 SET IENS=IEN_","
+18 ;
+19 SET FIELD=$PIECE(NODE,U,1)
SET ID=$$GET1^DIQ(IFN,IENS,FIELD)
+20 SET FIELD=$PIECE(NODE,U,2)
SET TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
+21 ;
+22 SET MFE=ID_HLCS_TEXT_HLCS_CDSYS
+23 ;
+24 if '$PIECE(NODE,U,4)
QUIT MFE
+25 ;
+26 SET FIELD=$PIECE(NODE,U,4)
SET ID=$$GET1^DIQ(IFN,IENS,FIELD)
+27 SET FIELD=$PIECE(NODE,U,5)
SET TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
+28 SET CDSYS=$PIECE(NODE,U,6)
+29 ;
+30 QUIT MFE_HLCS_ID_HLCS_TEXT_HLCS_CDSYS
+31 ;
MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
+1 ;
+2 NEW IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC
+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="1Error - IFN required"
QUIT
+10 ;
+11 IF IFN'=4.001
Begin DoDot:1
+12 SET MFE=$GET(^DIC(4.001,IFN,"MFE"))
SET XREF=$PIECE(MFE,U,8)
+13 IF '$PIECE(MFE,U,1)
Begin DoDot:2
+14 SET ERROR="1MFS PARAM MFE.4.1 null"
+15 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+16 IF '$PIECE(MFE,U,2)
Begin DoDot:2
+17 SET ERROR="1MFS PARAM MFE.4.2 null"
+18 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+19 IF XREF=""
Begin DoDot:2
+20 SET ERROR="1MFS PARAM MFE XREF not defined"
+21 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
End DoDot:1
if ERROR
QUIT
+22 ;
+23 IF IFN=4.001
Begin DoDot:1
+24 SET IEN=$$FIND1^DIC(1,,"BX",$PIECE(PKV,HLCS))
+25 IF 'IEN
Begin DoDot:2
+26 SET ERROR="1not a valid IEN in MFE XUMF"
+27 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+28 if $DATA(^DIC(4.001,IEN))
QUIT
+29 XECUTE HLNEXT
+30 IF $PIECE(HLNODE,HLFS)'="ZZZ"
Begin DoDot:2
+31 SET ERROR="1MFP error in MFE XUMF"
+32 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+33 SET MFE=$PIECE(HLNODE,HLFS,7,12)
SET MFE=$TRANSLATE(MFE,HLFS,U)
+34 SET X=""
FOR I=5,4,2,1
if $PIECE(MFE,U,I)=.01
SET X=I
+35 IF 'X
Begin DoDot:2
+36 SET ERROR="1MFS PARAM no .01 in MFE"
+37 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+38 SET NAME=$PIECE(PKV,HLCS,X)
KILL X
+39 KILL FDA
+40 SET FDA(IFN,"?+1,",.01)=NAME
+41 DO UPDATE^DIE("E","FDA")
End DoDot:1
QUIT
+42 ;
+43 SET ID=$PIECE(PKV,HLCS)
+44 IF ID=""
Begin DoDot:1
+45 SET ERROR="1MFS PARAM MFE PKV ID null"
+46 DO EM^XUMFH(ERROR,.ERR)
End DoDot:1
QUIT
+47 SET ROOT=$$ROOT^DILFD(IFN,,1)
+48 IF $DATA(@ROOT@(XREF))
IF '$GET(IEN)
SET IEN=$ORDER(@ROOT@(XREF,ID,0))
+49 if 'IEN
SET IEN=$$FIND1^DIC(IFN,,"B",ID)
+50 ;
+51 IF 'IEN
Begin DoDot:1
+52 SET X=""
FOR I=5,4,2,1
if $PIECE(MFE,U,I)=.01
SET X=I
+53 IF 'X
Begin DoDot:2
+54 SET ERROR="1MFS PARAM no .01 in MFE"
+55 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+56 SET NAME=$PIECE(PKV,HLCS,X)
KILL X
+57 IF NAME=""
SET ERROR="1MFS PARAM MFE PKV .01 is null"
QUIT
+58 DO CHK^DIE(IFN,.01,,NAME,.X)
+59 IF X="^"
Begin DoDot:2
+60 SET ERROR="1MFS PARAM MFE PKV .01 is invalid"
+61 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+62 KILL DIC
SET DIC=IFN
SET DIC(0)="F"
DO FILE^DICN
KILL DIC
+63 IF Y="-1"
Begin DoDot:2
+64 SET ERROR="1MFS PARAM MFE FileDICN unsuccessful"
+65 DO EM^XUMFH(ERROR,.ERR)
End DoDot:2
QUIT
+66 SET IEN=+Y
End DoDot:1
if ERROR
QUIT
+67 ;
+68 SET IENS=IEN_","
+69 ;
+70 FOR I=1,2,4,5
Begin DoDot:1
+71 SET FLD=$PIECE(MFE,U,I)
if 'FLD
QUIT
+72 SET FDA(IFN,IENS,FLD)=$PIECE(PKV,HLCS,I)
End DoDot:1
+73 ;
+74 DO FILE^DIE("E","FDA","ERR")
+75 IF $DATA(ERR)
Begin DoDot:1
+76 DO EM^XUMFH("1FILE DIE error msg in MFE of XUMF",.ERR)
+77 KILL ERR
End DoDot:1
+78 ;
+79 QUIT
+80 ;
MFP(IFN,ERR) ; -- validate Master File Parameters entry FALSE=valid
+1 ;
+2 if '$GET(IFN)
QUIT "IFN null"
+3 ;
+4 DO ZERO(IFN,.ERR)
+5 DO MFE1(IFN,.ERR)
+6 DO SEQ(IFN,.ERR)
+7 ;
+8 QUIT $SELECT($DATA(ERR("FATAL")):1,$DATA(ERR("WARNING")):2,1:0)
+9 ;
ZERO(IFN,ERR) ; -- zero node
+1 ;
+2 NEW X,CNT
+3 ;
+4 SET X=$GET(^DIC(4.001,+IFN,0))
SET CNT=1
+5 IF $PIECE(X,U,2)=""
Begin DoDot:1
+6 SET ERR("FATAL","ZERO",CNT)="Z SEGMENT is null"
SET CNT=CNT+1
End DoDot:1
+7 IF $PIECE(X,U,3)=""
Begin DoDot:1
+8 SET ERR("FATAL","ZERO",CNT)="MFI CODE is null"
SET CNT=CNT+1
End DoDot:1
+9 IF $PIECE(X,U,4)=""
Begin DoDot:1
+10 SET ERR("WARNING","ZERO",CNT)="PRE-UPDATE ROUTINE is null"
SET CNT=CNT+1
End DoDot:1
+11 IF $PIECE(X,U,5)=""
Begin DoDot:1
+12 SET ERR("WARNING","ZERO",CNT)="POST-UPDATE ROUTINE is null"
SET CNT=CNT+1
End DoDot:1
+13 IF $PIECE(X,U,6)=""
Begin DoDot:1
+14 SET ERR("WARNING","ZERO",CNT)="MAIL GROUP is null"
SET CNT=CNT+1
End DoDot:1
+15 ;
+16 QUIT
+17 ;
MFE1(IFN,ERR) ; -- MFE node
+1 ;
+2 NEW X,I,CNT
+3 ;
+4 SET X=$GET(^DIC(4.001,+IFN,"MFE"))
SET CNT=1
+5 FOR I=1:1:6
IF $PIECE(X,U,I)=""
Begin DoDot:1
+6 SET ERR("FATAL","MFE",CNT)="MFE ID & ALT ID field and codsys required"
+7 SET CNT=CNT+1
End DoDot:1
+8 IF $PIECE(X,U,8)=""
Begin DoDot:1
+9 SET ERR("FATAL","MFE",CNT)="MFE PKV X-REF required"
SET CNT=CNT+1
End DoDot:1
+10 FOR I=11,12,14,15
IF $PIECE(X,U,I)=""
Begin DoDot:1
+11 SET ERR("WARNING","MFE",CNT)="MFE PKV types are null"
SET CNT=CNT+1
End DoDot:1
+12 IF $PIECE(X,U,9)=""
Begin DoDot:1
+13 SET ERR("WARNING","MFE",CNT)="ASSIGNING AUTHORITY is null"
SET CNT=CNT+1
End DoDot:1
+14 ;
+15 QUIT
+16 ;
SEQ(IFN,ERR) ; -- sequence nodes
+1 ;
+2 NEW SEQ,MULT,X,I,Y
+3 ;
+4 SET SEQ=0
+5 FOR
SET SEQ=$ORDER(^DIC(4.001,IFN,1,SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+6 SET X=$GET(^DIC(4.001,IFN,1,SEQ,0))
+7 IF $$TYP($SELECT($PIECE(X,U,4):$PIECE(X,U,4),1:IFN),$PIECE(X,U,2))="POINTER"
Begin DoDot:2
+8 if $PIECE(X,U,7)'=""
QUIT
+9 SET Y=$SELECT($PIECE(X,U,4):$PIECE(X,U,4),1:IFN)
SET Y=$$LBL(Y,$PIECE(X,U,2))
+10 SET Y="field "_Y_" is pointer EXTENDED POINTER LKUP is NULL"
+11 SET ERR("WARNING",SEQ)=Y
End DoDot:2
+12 SET MULT=$SELECT($PIECE(X,U,4):1,1:0)
+13 IF '$PIECE(X,U,2)
SET ERR("FATAL",SEQ)=" missing FIELD NUMBER"
+14 IF MULT
IF $PIECE(X,U,8)=""
Begin DoDot:2
+15 SET ERR("FATAL",SEQ)=" MULT IEN FUNCTION is null"
End DoDot:2
+16 IF MULT
IF $PIECE(X,U,6)
IF $PIECE(X,U,5)'=""
Begin DoDot:2
+17 SET ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
End DoDot:2
+18 IF MULT
IF '$PIECE(X,U,6)
IF $PIECE(X,U,5)=""
Begin DoDot:2
+19 SET ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
End DoDot:2
+20 IF 'MULT
FOR I=5,6,8
Begin DoDot:2
+21 if $PIECE(X,U,I)=""
QUIT
+22 SET ERR("FATAL",SEQ)=" SUBFILE null with subfile parameters"
End DoDot:2
End DoDot:1
+23 ;
+24 QUIT
+25 ;
BG(IFN,IEN,TYP) ; -- background job
+1 ;
+2 ; type (5=file, 7=array)
+3 ;
+4 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
+5 ;
+6 SET TYP=$GET(TYP)
if 'TYP
SET TYP=5
+7 SET IEN=$GET(IEN)
if IEN=""
SET IEN="ALL"
+8 ;
+9 SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="BG1^XUMF"
SET ZTIO=""
+10 SET ZTSAVE("IFN")=""
SET ZTSAVE("TYP")=""
SET ZTSAVE("IEN")=""
+11 SET ZTDESC="XUMF get "_$$FILE^XUMF(IFN,"NAME")_" using MFS"
+12 ;
+13 DO ^%ZTLOAD
+14 ;
+15 QUIT
+16 ;
BG1 ; -- get file
+1 ;
+2 DO MFS(IFN,IEN,TYP,.ERROR)
DO EXIT
+3 ;
+4 QUIT
+5 ;
LOAD(IFN) ; -- query and file
+1 ;
+2 DO MFS(IFN,"ALL",5,.ERROR)
+3 ;
+4 QUIT
+5 ;
ARRAY(IFN) ; -- query and put in array
+1 ;
+2 DO MFS(IFN,"ALL",7,.ERROR)
+3 ;
+4 QUIT
+5 ;
GETCE(IFN,IEN,TYP,ERROR) ; -- get master file provide coded element
+1 ;
+2 QUIT
+3 ;
MFS(IFN,IEN,TYP,ERROR) ; -- get file from Master File Server
+1 ;
+2 ; TYP (5=query/file, 7=query/tmp_array)
+3 ;
+4 NEW TEST
+5 ;
+6 SET (ERROR,TEST)=0
+7 ;
+8 SET IFN=$GET(IFN)
SET IEN=$GET(IEN)
SET TYP=$GET(TYP)
+9 ;
+10 IF 'IFN
SET ERROR="1IFN not valid MFS in XUMF"
QUIT
+11 IF IEN=""
SET ERROR="1IEN not valid MFS in XUMF"
QUIT
+12 IF TYP'=5
IF TYP'=7
SET ERROR="1type not support by MFS in XUMF"
QUIT
+13 ;
+14 IF $PIECE($$PARAM^HLCS2,U,3)="T"
SET TEST=1
+15 ;
+16 SET PARAM("LLNK")="XUMF MFR^XUMF "_$SELECT('TEST:"FORUM",1:"TEST")
+17 SET PARAM("PROTOCOL")=$ORDER(^ORD(101,"B","XUMF MFQ",0))
+18 ;
+19 DO MAIN^XUMFP(IFN,"ALL",TYP,.PARAM,.ERROR)
if ERROR
QUIT
+20 DO MAIN^XUMFI(IFN,"ALL",TYP,.PARAM,.ERROR)
if ERROR
QUIT
+21 DO MAIN^XUMFH
+22 ;
+23 QUIT
+24 ;
+25 ;
EXIT ; -- cleanup and quit
+1 ;
+2 KILL ^TMP("XUMF MFS",$JOB),^TMP("DIERR",$JOB)
+3 ;
+4 SET ZTREQ="@"
+5 ;
+6 QUIT
+7 ;
NPI ; -- NPI
+1 ;
+2 NEW COL,X,FDA,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,ERR
+3 ;
+4 DO SEGPRSE^XUMFXHL7("HLNODE","COL")
+5 ;
+6 SET NPIDT=$$FMDATE^HLFNC(COL(17))
+7 SET NPISTAT=COL(18)
+8 SET NPI=COL(19)
+9 SET TAX=COL(20)
+10 SET TAXPC=COL(21)
+11 SET TAXSTAT=COL(22)
+12 ;
+13 SET X=$$NPI^XUSNPI("Organization_ID",IEN,NPIDT)
+14 IF $SELECT(X=0:1,$$UP^XLFSTR($PIECE(X,U,3))'=NPISTAT:1,NPI'=+X:1,1:0)
Begin DoDot:1
+15 SET X=$$ADDNPI^XUSNPI("Organization_ID",IEN,NPI,NPIDT,$SELECT(NPISTAT="ACTIVE":1,1:0))
End DoDot:1
+16 ;
+17 SET IENS="?+1,"_IEN_","
+18 KILL FDA
+19 SET FDA(4.9999,IENS,.01)="NPI"
+20 SET FDA(4.9999,IENS,.02)=NPI
+21 DO UPDATE^DIE("E","FDA",,"ERR")
+22 ;
+23 KILL FDA
+24 SET IENS="?+1,"_IEN_","
+25 SET FDA(4.043,IENS,.01)=TAX
+26 SET FDA(4.043,IENS,.02)=TAXPC
+27 SET FDA(4.043,IENS,.03)=TAXSTAT
+28 DO UPDATE^DIE("E","FDA",,"ERR")
+29 ;
+30 SET SEQ=22
+31 ;
+32 QUIT
+33 ;
CDSYS(CDSYS,ID,IEN) ; udpate coding system / ID
+1 ;
+2 NEW IENS,FDA
+3 ;
+4 SET IENS="?+1,"_IEN_","
+5 KILL FDA
+6 SET FDA(4.9999,IENS,.01)=CDSYS
+7 SET FDA(4.9999,IENS,.02)=ID
+8 Begin DoDot:1
+9 NEW IEN,VALUE
+10 DO UPDATE^DIE("E","FDA")
End DoDot:1
+11 ;
+12 QUIT
+13 ;
