Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUMF

XUMF.m

Go to the documentation of this file.
  1. XUMF ;OIFO-OAK/RAM - XUMF API's;04/15/02
  1. ;;8.0;KERNEL;**218,335,416,555**;Jul 10, 1995;Build 3
  1. ;
  1. Q
  1. ;
  1. IEN(IFN,CDSYS,ID) ; -- Internal Entry Number
  1. ;
  1. I IFN=4 N X S X=$O(^DIC(4,"D",ID,0)) Q $S(X:X,1:"0^not found")
  1. ;
  1. N IEN,ROOT
  1. ;
  1. S IFN=$G(IFN),CDSYS=$G(CDSYS),ID=$G(ID)
  1. ;
  1. Q:'IFN "0^IFN required"
  1. Q:CDSYS="" "0^CDSYS required"
  1. Q:ID="" "0^ID required"
  1. ;
  1. S ROOT=$$ROOT^DILFD(IFN,,1) Q:ROOT="" "0^invalid IFN"
  1. S IEN=$O(@ROOT@("XUMFIDX",CDSYS,ID,0))
  1. ;
  1. Q $S(IEN:IEN,1:"0^not found")
  1. ;
  1. FLD(FILE,FIELD) ; field
  1. ;
  1. N Y,DA,X
  1. ;
  1. S Y=$$FIELD(FILE,FIELD,"LABEL")
  1. ;
  1. Q $S(Y'="":1,1:0)
  1. ;
  1. LBL(FILE,FIELD) ; field label
  1. ;
  1. Q $$FIELD(FILE,FIELD,"LABEL")
  1. ;
  1. TYP(FILE,FIELD) ; field type
  1. ;
  1. Q $$FIELD(FILE,FIELD,"TYPE")
  1. ;
  1. PTR(FILE,FIELD) ; pointer field?
  1. ;
  1. Q $S($$TYP(FILE,FIELD)="POINTER":1,1:0)
  1. ;
  1. FIELD(FILE,FIELD,ATT) ; field attributes
  1. ;
  1. N Y,DA,X
  1. ;
  1. Q:'$G(FILE) ""
  1. Q:'$G(FIELD) ""
  1. Q:$G(ATT)="" ""
  1. ;
  1. D FIELD^DID(FILE,FIELD,"N",ATT,"Y")
  1. ;
  1. Q $G(Y(ATT))
  1. ;
  1. FILE(FILE,ATT) ; file attributes
  1. ;
  1. N Y,DA,X
  1. ;
  1. Q:'$G(FILE) ""
  1. Q:$G(ATT)="" ""
  1. ;
  1. D FILE^DID(FILE,,ATT,"Y")
  1. ;
  1. Q $G(Y(ATT))
  1. ;
  1. ECHO(FILE,IDX,X,XUMF) ; validate field exists and echo name
  1. ;
  1. Q:'$$F(+$G(XUMF)) 0
  1. ;
  1. N SUBFILE,NAME
  1. ;
  1. S SUBFILE=$P($G(^DIC(4.001,+$G(FILE),1,+$G(IDX),0)),U,4)
  1. ;
  1. S NAME=$$LBL($S(SUBFILE:SUBFILE,1:+$G(FILE)),X)
  1. ;
  1. Q:NAME="" 0
  1. ;
  1. ;W " "_NAME
  1. ;
  1. Q 1
  1. ;
  1. F(XUMF) ; constrain edits to standard values
  1. ;
  1. Q $S($G(XUMF):1,1:0)
  1. ;
  1. PKV(IFN,IEN,HLCS) ; Primary Key Value - MFE.4
  1. ;
  1. S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS)
  1. ;
  1. N MFE,NODE,ID,TEXT,CDSYS,IENS
  1. ;
  1. S NODE=$G(^DIC(4.001,IFN,"MFE"))
  1. Q:NODE="" "1Error - MFS parameter not defined for IFN "_IFN
  1. ;
  1. S:HLCS="" HLCS="~"
  1. S CDSYS=$P(NODE,U,3)
  1. ;
  1. Q:IEN="NEW" IEN_HLCS_"NEW ENTRY"_HLCS_CDSYS
  1. ;
  1. Q:'IFN "1Error - IFN required"
  1. Q:'IEN "1Error - IEN required"
  1. ;
  1. S IENS=IEN_","
  1. ;
  1. S FIELD=$P(NODE,U,1),ID=$$GET1^DIQ(IFN,IENS,FIELD)
  1. S FIELD=$P(NODE,U,2),TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
  1. ;
  1. S MFE=ID_HLCS_TEXT_HLCS_CDSYS
  1. ;
  1. Q:'$P(NODE,U,4) MFE
  1. ;
  1. S FIELD=$P(NODE,U,4),ID=$$GET1^DIQ(IFN,IENS,FIELD)
  1. S FIELD=$P(NODE,U,5),TEXT=$$GET1^DIQ(IFN,IENS,FIELD)
  1. S CDSYS=$P(NODE,U,6)
  1. ;
  1. Q MFE_HLCS_ID_HLCS_TEXT_HLCS_CDSYS
  1. ;
  1. MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update
  1. ;
  1. N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC
  1. ;
  1. S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS),ERROR=$G(ERROR)
  1. S:HLCS="" HLCS="~"
  1. ;
  1. Q:ERROR
  1. ;
  1. I 'IFN S ERROR="1Error - IFN required" Q
  1. ;
  1. I IFN'=4.001 D Q:ERROR
  1. .S MFE=$G(^DIC(4.001,IFN,"MFE")),XREF=$P(MFE,U,8)
  1. .I '$P(MFE,U,1) D Q
  1. ..S ERROR="1MFS PARAM MFE.4.1 null"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .I '$P(MFE,U,2) D Q
  1. ..S ERROR="1MFS PARAM MFE.4.2 null"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .I XREF="" D Q
  1. ..S ERROR="1MFS PARAM MFE XREF not defined"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. ;
  1. I IFN=4.001 D Q
  1. .S IEN=$$FIND1^DIC(1,,"BX",$P(PKV,HLCS))
  1. .I 'IEN D Q
  1. ..S ERROR="1not a valid IEN in MFE XUMF"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .Q:$D(^DIC(4.001,IEN))
  1. .X HLNEXT
  1. .I $P(HLNODE,HLFS)'="ZZZ" D Q
  1. ..S ERROR="1MFP error in MFE XUMF"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .S MFE=$P(HLNODE,HLFS,7,12),MFE=$TR(MFE,HLFS,U)
  1. .S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I
  1. .I 'X D Q
  1. ..S ERROR="1MFS PARAM no .01 in MFE"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .S NAME=$P(PKV,HLCS,X) K X
  1. .K FDA
  1. .S FDA(IFN,"?+1,",.01)=NAME
  1. .D UPDATE^DIE("E","FDA")
  1. ;
  1. S ID=$P(PKV,HLCS)
  1. I ID="" D Q
  1. .S ERROR="1MFS PARAM MFE PKV ID null"
  1. .D EM^XUMFH(ERROR,.ERR)
  1. S ROOT=$$ROOT^DILFD(IFN,,1)
  1. I $D(@ROOT@(XREF)),'$G(IEN) S IEN=$O(@ROOT@(XREF,ID,0))
  1. S:'IEN IEN=$$FIND1^DIC(IFN,,"B",ID)
  1. ;
  1. I 'IEN D Q:ERROR
  1. .S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I
  1. .I 'X D Q
  1. ..S ERROR="1MFS PARAM no .01 in MFE"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .S NAME=$P(PKV,HLCS,X) K X
  1. .I NAME="" S ERROR="1MFS PARAM MFE PKV .01 is null" Q
  1. .D CHK^DIE(IFN,.01,,NAME,.X)
  1. .I X="^" D Q
  1. ..S ERROR="1MFS PARAM MFE PKV .01 is invalid"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC
  1. .I Y="-1" D Q
  1. ..S ERROR="1MFS PARAM MFE FileDICN unsuccessful"
  1. ..D EM^XUMFH(ERROR,.ERR)
  1. .S IEN=+Y
  1. ;
  1. S IENS=IEN_","
  1. ;
  1. F I=1,2,4,5 D
  1. .S FLD=$P(MFE,U,I) Q:'FLD
  1. .S FDA(IFN,IENS,FLD)=$P(PKV,HLCS,I)
  1. ;
  1. D FILE^DIE("E","FDA","ERR")
  1. I $D(ERR) D
  1. .D EM^XUMFH("1FILE DIE error msg in MFE of XUMF",.ERR)
  1. .K ERR
  1. ;
  1. Q
  1. ;
  1. MFP(IFN,ERR) ; -- validate Master File Parameters entry FALSE=valid
  1. ;
  1. Q:'$G(IFN) "IFN null"
  1. ;
  1. D ZERO(IFN,.ERR)
  1. D MFE1(IFN,.ERR)
  1. D SEQ(IFN,.ERR)
  1. ;
  1. Q $S($D(ERR("FATAL")):1,$D(ERR("WARNING")):2,1:0)
  1. ;
  1. ZERO(IFN,ERR) ; -- zero node
  1. ;
  1. N X,CNT
  1. ;
  1. S X=$G(^DIC(4.001,+IFN,0)),CNT=1
  1. I $P(X,U,2)="" D
  1. .S ERR("FATAL","ZERO",CNT)="Z SEGMENT is null",CNT=CNT+1
  1. I $P(X,U,3)="" D
  1. .S ERR("FATAL","ZERO",CNT)="MFI CODE is null",CNT=CNT+1
  1. I $P(X,U,4)="" D
  1. .S ERR("WARNING","ZERO",CNT)="PRE-UPDATE ROUTINE is null",CNT=CNT+1
  1. I $P(X,U,5)="" D
  1. .S ERR("WARNING","ZERO",CNT)="POST-UPDATE ROUTINE is null",CNT=CNT+1
  1. I $P(X,U,6)="" D
  1. .S ERR("WARNING","ZERO",CNT)="MAIL GROUP is null",CNT=CNT+1
  1. ;
  1. Q
  1. ;
  1. MFE1(IFN,ERR) ; -- MFE node
  1. ;
  1. N X,I,CNT
  1. ;
  1. S X=$G(^DIC(4.001,+IFN,"MFE")),CNT=1
  1. F I=1:1:6 I $P(X,U,I)="" D
  1. .S ERR("FATAL","MFE",CNT)="MFE ID & ALT ID field and codsys required"
  1. .S CNT=CNT+1
  1. I $P(X,U,8)="" D
  1. .S ERR("FATAL","MFE",CNT)="MFE PKV X-REF required",CNT=CNT+1
  1. F I=11,12,14,15 I $P(X,U,I)="" D
  1. .S ERR("WARNING","MFE",CNT)="MFE PKV types are null",CNT=CNT+1
  1. I $P(X,U,9)="" D
  1. .S ERR("WARNING","MFE",CNT)="ASSIGNING AUTHORITY is null",CNT=CNT+1
  1. ;
  1. Q
  1. ;
  1. SEQ(IFN,ERR) ; -- sequence nodes
  1. ;
  1. N SEQ,MULT,X,I,Y
  1. ;
  1. S SEQ=0
  1. F S SEQ=$O(^DIC(4.001,IFN,1,SEQ)) Q:'SEQ D
  1. .S X=$G(^DIC(4.001,IFN,1,SEQ,0))
  1. .I $$TYP($S($P(X,U,4):$P(X,U,4),1:IFN),$P(X,U,2))="POINTER" D
  1. ..Q:$P(X,U,7)'=""
  1. ..S Y=$S($P(X,U,4):$P(X,U,4),1:IFN),Y=$$LBL(Y,$P(X,U,2))
  1. ..S Y="field "_Y_" is pointer EXTENDED POINTER LKUP is NULL"
  1. ..S ERR("WARNING",SEQ)=Y
  1. .S MULT=$S($P(X,U,4):1,1:0)
  1. .I '$P(X,U,2) S ERR("FATAL",SEQ)=" missing FIELD NUMBER"
  1. .I MULT,$P(X,U,8)="" D
  1. ..S ERR("FATAL",SEQ)=" MULT IEN FUNCTION is null"
  1. .I MULT,$P(X,U,6),$P(X,U,5)'="" D
  1. ..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
  1. .I MULT,'$P(X,U,6),$P(X,U,5)="" D
  1. ..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch"
  1. .I 'MULT F I=5,6,8 D
  1. ..Q:$P(X,U,I)=""
  1. ..S ERR("FATAL",SEQ)=" SUBFILE null with subfile parameters"
  1. ;
  1. Q
  1. ;
  1. BG(IFN,IEN,TYP) ; -- background job
  1. ;
  1. ; type (5=file, 7=array)
  1. ;
  1. N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
  1. ;
  1. S TYP=$G(TYP) S:'TYP TYP=5
  1. S IEN=$G(IEN) S:IEN="" IEN="ALL"
  1. ;
  1. S ZTDTH=$$NOW^XLFDT,ZTRTN="BG1^XUMF",ZTIO=""
  1. S ZTSAVE("IFN")="",ZTSAVE("TYP")="",ZTSAVE("IEN")=""
  1. S ZTDESC="XUMF get "_$$FILE^XUMF(IFN,"NAME")_" using MFS"
  1. ;
  1. D ^%ZTLOAD
  1. ;
  1. Q
  1. ;
  1. BG1 ; -- get file
  1. ;
  1. D MFS(IFN,IEN,TYP,.ERROR),EXIT
  1. ;
  1. Q
  1. ;
  1. LOAD(IFN) ; -- query and file
  1. ;
  1. D MFS(IFN,"ALL",5,.ERROR)
  1. ;
  1. Q
  1. ;
  1. ARRAY(IFN) ; -- query and put in array
  1. ;
  1. D MFS(IFN,"ALL",7,.ERROR)
  1. ;
  1. Q
  1. ;
  1. GETCE(IFN,IEN,TYP,ERROR) ; -- get master file provide coded element
  1. ;
  1. Q
  1. ;
  1. MFS(IFN,IEN,TYP,ERROR) ; -- get file from Master File Server
  1. ;
  1. ; TYP (5=query/file, 7=query/tmp_array)
  1. ;
  1. N TEST
  1. ;
  1. S (ERROR,TEST)=0
  1. ;
  1. S IFN=$G(IFN),IEN=$G(IEN),TYP=$G(TYP)
  1. ;
  1. I 'IFN S ERROR="1IFN not valid MFS in XUMF" Q
  1. I IEN="" S ERROR="1IEN not valid MFS in XUMF" Q
  1. I TYP'=5,TYP'=7 S ERROR="1type not support by MFS in XUMF" Q
  1. ;
  1. I $P($$PARAM^HLCS2,U,3)="T" S TEST=1
  1. ;
  1. S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST")
  1. S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0))
  1. ;
  1. D MAIN^XUMFP(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR
  1. D MAIN^XUMFI(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR
  1. D MAIN^XUMFH
  1. ;
  1. Q
  1. ;
  1. ;
  1. EXIT ; -- cleanup and quit
  1. ;
  1. K ^TMP("XUMF MFS",$J),^TMP("DIERR",$J)
  1. ;
  1. S ZTREQ="@"
  1. ;
  1. Q
  1. ;
  1. NPI ; -- NPI
  1. ;
  1. N COL,X,FDA,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,ERR
  1. ;
  1. D SEGPRSE^XUMFXHL7("HLNODE","COL")
  1. ;
  1. S NPIDT=$$FMDATE^HLFNC(COL(17))
  1. S NPISTAT=COL(18)
  1. S NPI=COL(19)
  1. S TAX=COL(20)
  1. S TAXPC=COL(21)
  1. S TAXSTAT=COL(22)
  1. ;
  1. S X=$$NPI^XUSNPI("Organization_ID",IEN,NPIDT)
  1. I $S(X=0:1,$$UP^XLFSTR($P(X,U,3))'=NPISTAT:1,NPI'=+X:1,1:0) D
  1. .S X=$$ADDNPI^XUSNPI("Organization_ID",IEN,NPI,NPIDT,$S(NPISTAT="ACTIVE":1,1:0))
  1. ;
  1. S IENS="?+1,"_IEN_","
  1. K FDA
  1. S FDA(4.9999,IENS,.01)="NPI"
  1. S FDA(4.9999,IENS,.02)=NPI
  1. D UPDATE^DIE("E","FDA",,"ERR")
  1. ;
  1. K FDA
  1. S IENS="?+1,"_IEN_","
  1. S FDA(4.043,IENS,.01)=TAX
  1. S FDA(4.043,IENS,.02)=TAXPC
  1. S FDA(4.043,IENS,.03)=TAXSTAT
  1. D UPDATE^DIE("E","FDA",,"ERR")
  1. ;
  1. S SEQ=22
  1. ;
  1. Q
  1. ;
  1. CDSYS(CDSYS,ID,IEN) ; udpate coding system / ID
  1. ;
  1. N IENS,FDA
  1. ;
  1. S IENS="?+1,"_IEN_","
  1. K FDA
  1. S FDA(4.9999,IENS,.01)=CDSYS
  1. S FDA(4.9999,IENS,.02)=ID
  1. D
  1. .N IEN,VALUE
  1. .D UPDATE^DIE("E","FDA")
  1. ;
  1. Q
  1. ;