- 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 Jan 18, 2025@03:11:15 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 ;