Released XU*8*555 SEQ #465 Extracted from mail message **KIDS**:XU*8.0*555^ **INSTALL NAME** XU*8.0*555 "BLD",6433,0) XU*8.0*555^KERNEL^0^3110727^y "BLD",6433,4,0) ^9.64PA^^ "BLD",6433,6.3) 3 "BLD",6433,"ABNS",0) ^9.66A^^ "BLD",6433,"ABPKG") y^n "BLD",6433,"INID") ^y "BLD",6433,"INIT") MAIN^XUMF555P "BLD",6433,"KRN",0) ^9.67PA^8989.52^19 "BLD",6433,"KRN",.4,0) .4 "BLD",6433,"KRN",.401,0) .401 "BLD",6433,"KRN",.402,0) .402 "BLD",6433,"KRN",.403,0) .403 "BLD",6433,"KRN",.5,0) .5 "BLD",6433,"KRN",.84,0) .84 "BLD",6433,"KRN",3.6,0) 3.6 "BLD",6433,"KRN",3.8,0) 3.8 "BLD",6433,"KRN",9.2,0) 9.2 "BLD",6433,"KRN",9.8,0) 9.8 "BLD",6433,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",6433,"KRN",9.8,"NM",1,0) XUAF4^^0^B47165433 "BLD",6433,"KRN",9.8,"NM",2,0) XUMF^^0^B100459281 "BLD",6433,"KRN",9.8,"NM","B","XUAF4",1) "BLD",6433,"KRN",9.8,"NM","B","XUMF",2) "BLD",6433,"KRN",19,0) 19 "BLD",6433,"KRN",19,"NM",0) ^9.68A^^ "BLD",6433,"KRN",19.1,0) 19.1 "BLD",6433,"KRN",19.1,"NM",0) ^9.68A^^ "BLD",6433,"KRN",101,0) 101 "BLD",6433,"KRN",409.61,0) 409.61 "BLD",6433,"KRN",771,0) 771 "BLD",6433,"KRN",870,0) 870 "BLD",6433,"KRN",8989.51,0) 8989.51 "BLD",6433,"KRN",8989.52,0) 8989.52 "BLD",6433,"KRN",8994,0) 8994 "BLD",6433,"KRN","B",.4,.4) "BLD",6433,"KRN","B",.401,.401) "BLD",6433,"KRN","B",.402,.402) "BLD",6433,"KRN","B",.403,.403) "BLD",6433,"KRN","B",.5,.5) "BLD",6433,"KRN","B",.84,.84) "BLD",6433,"KRN","B",3.6,3.6) "BLD",6433,"KRN","B",3.8,3.8) "BLD",6433,"KRN","B",9.2,9.2) "BLD",6433,"KRN","B",9.8,9.8) "BLD",6433,"KRN","B",19,19) "BLD",6433,"KRN","B",19.1,19.1) "BLD",6433,"KRN","B",101,101) "BLD",6433,"KRN","B",409.61,409.61) "BLD",6433,"KRN","B",771,771) "BLD",6433,"KRN","B",870,870) "BLD",6433,"KRN","B",8989.51,8989.51) "BLD",6433,"KRN","B",8989.52,8989.52) "BLD",6433,"KRN","B",8994,8994) "BLD",6433,"QUES",0) ^9.62^^ "BLD",6433,"REQB",0) ^9.611^^ "INIT") MAIN^XUMF555P "MBREQ") 0 "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,20,0) ^9.402P^^ "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3040115^2960606^1 "PKG",3,22,1,"PAH",1,0) 555^3110727 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","XUAF4") 0^1^B47165433^B47018536 "RTN","XUAF4",1,0) XUAF4 ;ISC-SF/RWF/RAM - Institution file access. ;04/01/99 08:07 "RTN","XUAF4",2,0) ;;8.0;KERNEL;**43,112,206,209,232,217,261,394,549,555**;Jul 10, 1995;Build 3 "RTN","XUAF4",3,0) Q ;No access from the top. "RTN","XUAF4",4,0) ; "RTN","XUAF4",5,0) PARENT(ROOT,CHILD,ASSO) ;sr. Return array of IEN's of parents "RTN","XUAF4",6,0) N %,%0 "RTN","XUAF4",7,0) S CHILD=$$LKUP(CHILD),ASSO=$$ASSO($G(ASSO)),%=0 "RTN","XUAF4",8,0) F S %=$O(^DIC(4,CHILD,7,%)) Q:%'>0 S %0=+$P(^(%,0),U,2) D "RTN","XUAF4",9,0) . Q:+%'=ASSO "RTN","XUAF4",10,0) . S @ROOT@("P",+%0)=$$NS(+%0) "RTN","XUAF4",11,0) Q "RTN","XUAF4",12,0) CHILDREN(ROOT,PAR,ASSO,XUAC) ;sr. Return the children "RTN","XUAF4",13,0) N %,%1 S %=0,PAR=$$LKUP(PAR),ASSO=$$ASSO($G(ASSO)),XUAC=$G(XUAC) "RTN","XUAF4",14,0) Q:ASSO'>0 "RTN","XUAF4",15,0) F S %=$O(^DIC(4,"AC",ASSO,PAR,%)) Q:%'>0 D "RTN","XUAF4",16,0) . I XUAC,$$STATUS(%)="I" Q "RTN","XUAF4",17,0) . S @ROOT@("C",%)=$$NS(%) "RTN","XUAF4",18,0) Q "RTN","XUAF4",19,0) SIBLING(ROOT,CHILD,ASSO) ;sr. Return the siblings "RTN","XUAF4",20,0) N % S %=0,ASSO=$$ASSO($G(ASSO)) "RTN","XUAF4",21,0) D PARENT(ROOT,CHILD,ASSO) "RTN","XUAF4",22,0) F S %=$O(@ROOT@("P",%)) Q:%'>0 D CHILDREN($NA(@ROOT@("P",%)),"`"_%,ASSO) "RTN","XUAF4",23,0) Q "RTN","XUAF4",24,0) NNT(%) ;ef.sr. Return Name, Station Number, ASSO "RTN","XUAF4",25,0) I %'>0 Q "" "RTN","XUAF4",26,0) Q $$NS(%)_"^"_$$WHAT(%,13) "RTN","XUAF4",27,0) ; "RTN","XUAF4",28,0) LKUP(%) ;ef.sr. Resolve a value into IEN "RTN","XUAF4",29,0) I $E(%)="`" S %=+$E(%,2,99) Q:$D(^DIC(4,%,0))#2 % Q 0 "RTN","XUAF4",30,0) ;Q $$FIND1^DIC(4,,"MX",%) "RTN","XUAF4",31,0) Q $$FIND1^DIC(4,,"MX",%,,"I $P(^(0),U,11)'=""I""") ;To screen Inactive "RTN","XUAF4",32,0) ; "RTN","XUAF4",33,0) STATUS(%) ;Get the status of a IEN "RTN","XUAF4",34,0) Q $P($G(^DIC(4,%,0)),U,11) "RTN","XUAF4",35,0) ; "RTN","XUAF4",36,0) TYPE(%) ;Lookup a Faclity TYPE in file 4.1 "RTN","XUAF4",37,0) I %="" Q % "RTN","XUAF4",38,0) I $D(^DIC(4.1,"B",%))>9 Q % "RTN","XUAF4",39,0) S %=$$FIND1^DIC(4.1,,"MX",%) "RTN","XUAF4",40,0) Q $P($G(^DIC(4.1,+%,0)),U) "RTN","XUAF4",41,0) ; "RTN","XUAF4",42,0) ASSO(%) ;Lookup an Asso "RTN","XUAF4",43,0) Q:+%=% % S:%="" %="VISN" "RTN","XUAF4",44,0) S %=$$FIND1^DIC(4.05,,"MX",%) "RTN","XUAF4",45,0) Q +% "RTN","XUAF4",46,0) ; "RTN","XUAF4",47,0) NS(IEN) ;ef.sr. Return name and station # "RTN","XUAF4",48,0) Q $P($G(^DIC(4,IEN,0)),U,1)_U_$P($G(^DIC(4,+IEN,99)),U,1) "RTN","XUAF4",49,0) ; "RTN","XUAF4",50,0) WHAT(IEN,FLD) ;ef.sr. Field to return "RTN","XUAF4",51,0) Q $$GET1^DIQ(4,IEN_",",FLD,"") "RTN","XUAF4",52,0) ; "RTN","XUAF4",53,0) CIRN(%1,%2) ;ef.sr. Is this a CIRN Enables inst. "RTN","XUAF4",54,0) N % S %1=+$G(%1) "RTN","XUAF4",55,0) Q:'$D(^DIC(4,%1,0)) -1 "RTN","XUAF4",56,0) I $G(%2)]"" N DIE,DR,DA S DA=%1,DR="990.1///"_%2,DIE="^DIC(4," D ^DIE "RTN","XUAF4",57,0) Q $$WHAT(%1,990.1) "RTN","XUAF4",58,0) ; "RTN","XUAF4",59,0) IEN(STA) ;return IEN for a station number "RTN","XUAF4",60,0) S STA=$G(STA) Q:STA="" STA "RTN","XUAF4",61,0) Q $O(^DIC(4,"D",STA,0)) "RTN","XUAF4",62,0) ; "RTN","XUAF4",63,0) STA(IEN) ;return station number for an IEN "RTN","XUAF4",64,0) Q $P($G(^DIC(4,+IEN,99)),U) "RTN","XUAF4",65,0) ; "RTN","XUAF4",66,0) TF(IEN) ;active treating facility? (1=YES,0=NO) "RTN","XUAF4",67,0) N ARRAY Q:'$G(IEN) 0 "RTN","XUAF4",68,0) D F4($$STA(IEN),.ARRAY,"AM") "RTN","XUAF4",69,0) Q $S(ARRAY:1,1:0) "RTN","XUAF4",70,0) ; "RTN","XUAF4",71,0) RT(IEN) ;realigned to "RTN","XUAF4",72,0) N ARRAY Q:'$G(IEN) 0 "RTN","XUAF4",73,0) D F4($$STA(IEN),.ARRAY) "RTN","XUAF4",74,0) Q $G(ARRAY("REALIGNED TO")) "RTN","XUAF4",75,0) ; "RTN","XUAF4",76,0) RF(IEN) ;realigned from "RTN","XUAF4",77,0) N ARRAY Q:'$G(IEN) 0 "RTN","XUAF4",78,0) D F4($$STA(IEN),.ARRAY) "RTN","XUAF4",79,0) Q $G(ARRAY("REALIGNED FROM")) "RTN","XUAF4",80,0) ; "RTN","XUAF4",81,0) O99(IEN) ;returns pointer to new station number IEN "RTN","XUAF4",82,0) Q:$O(^DIC(4,"AOLD99",+$G(IEN),""))="" "" "RTN","XUAF4",83,0) Q $O(^DIC(4,"D",$O(^DIC(4,"AOLD99",+$G(IEN),"")),0)) "RTN","XUAF4",84,0) ; "RTN","XUAF4",85,0) LEGACY(STA) ; -- legacy station number (1=yes; 0=no) "RTN","XUAF4",86,0) Q $S($$RT^XUAF4(+$$IEN^XUAF4(STA)):1,1:0) "RTN","XUAF4",87,0) ; "RTN","XUAF4",88,0) PRNT(STA) ; -- parent facility "RTN","XUAF4",89,0) N X S STA=$G(STA) Q:STA="" "0^no station number passed" "RTN","XUAF4",90,0) D PARENT("X",STA,"PARENT FACILITY") S X=$O(X("P",0)) "RTN","XUAF4",91,0) Q:'X "0^no parent associated with input station number" "RTN","XUAF4",92,0) Q X_U_$P($G(X("P",+X)),U,2)_U_$P($G(X("P",+X)),U) "RTN","XUAF4",93,0) ; "RTN","XUAF4",94,0) NAME(IEN) ; -- Official Name "RTN","XUAF4",95,0) Q:$P($G(^DIC(4,+IEN,99)),U,3)'="" $P($G(^DIC(4,+IEN,99)),U,3) "RTN","XUAF4",96,0) Q $P($G(^DIC(4,+IEN,0)),U) "RTN","XUAF4",97,0) ; "RTN","XUAF4",98,0) ACTIVE(IEN) ; -- active facility (1=active, 0=inactive) "RTN","XUAF4",99,0) ; "RTN","XUAF4",100,0) Q '$P($G(^DIC(4,+IEN,99)),U,4) "RTN","XUAF4",101,0) ; "RTN","XUAF4",102,0) PADD(IEN) ; -- physical address (street addr^city^state^zip) "RTN","XUAF4",103,0) ; "RTN","XUAF4",104,0) N X,STATE "RTN","XUAF4",105,0) ; "RTN","XUAF4",106,0) S X=$P($G(^DIC(4,+IEN,0)),U,2) "RTN","XUAF4",107,0) S STATE=$P($G(^DIC(5,+X,0)),U,2) "RTN","XUAF4",108,0) S X=$G(^DIC(4,+IEN,1)) Q:X="" X "RTN","XUAF4",109,0) ; "RTN","XUAF4",110,0) Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,4) "RTN","XUAF4",111,0) ; "RTN","XUAF4",112,0) MADD(IEN) ; -- mailing address (street addr^city^state^zip) "RTN","XUAF4",113,0) ; "RTN","XUAF4",114,0) N X,STATE "RTN","XUAF4",115,0) ; "RTN","XUAF4",116,0) S X=$G(^DIC(4,+IEN,4)) Q:X="" X "RTN","XUAF4",117,0) S STATE=$P($G(^DIC(5,+$P(X,U,4),0)),U,2) "RTN","XUAF4",118,0) ; "RTN","XUAF4",119,0) Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,5) "RTN","XUAF4",120,0) ; "RTN","XUAF4",121,0) F4(STA,ARRAY,FLAG,ONDT) ;File #4 multipurpose API "RTN","XUAF4",122,0) ; "RTN","XUAF4",123,0) ;INPUT "RTN","XUAF4",124,0) ; STA Station number (required) "RTN","XUAF4",125,0) ; "RTN","XUAF4",126,0) ; [.]ARRAY $NAME reference for return values. (required) "RTN","XUAF4",127,0) ; "RTN","XUAF4",128,0) ; FLAG A = Active entries only. (optional) "RTN","XUAF4",129,0) ; M = Medical treating facilities only. "RTN","XUAF4",130,0) ; "RTN","XUAF4",131,0) ; ONDT Return name on this FM internal date. (optional); "RTN","XUAF4",132,0) ; "RTN","XUAF4",133,0) ;OUTPUT "RTN","XUAF4",134,0) ; ARRAY IEN or '0^error message' "RTN","XUAF4",135,0) ; ARRAY("NAME") name "RTN","XUAF4",136,0) ; ARRAY("VA NAME") offical va name "RTN","XUAF4",137,0) ; ARRAY("STATION NUMBER") station number "RTN","XUAF4",138,0) ; ARRAY("TYPE") facilty type name "RTN","XUAF4",139,0) ; ARRAY("INACTIVE") inactive date (0=not inactive) "RTN","XUAF4",140,0) ; note: if inactive date not available but entry inactive then 1 "RTN","XUAF4",141,0) ; "RTN","XUAF4",142,0) ; ARRAY("REALIGNED TO") IEN^station number^date "RTN","XUAF4",143,0) ; ARRAY("REALIGNED FROM") IEN^station number^date "RTN","XUAF4",144,0) ; "RTN","XUAF4",145,0) K ARRAY "RTN","XUAF4",146,0) S STA=$G(STA),FLAG=$G(FLAG),ONDT=$G(ONDT) "RTN","XUAF4",147,0) I STA="" S ARRAY="0^invalid input STA - required" Q "RTN","XUAF4",148,0) ; "RTN","XUAF4",149,0) N IEN,N99,TO,FM,I,RDT,NAME,VANAME,HDT "RTN","XUAF4",150,0) ; "RTN","XUAF4",151,0) S IEN=$$IEN(STA) "RTN","XUAF4",152,0) I 'IEN S ARRAY="0^station number does not exist" Q "RTN","XUAF4",153,0) S N99=$G(^DIC(4,+IEN,99)) "RTN","XUAF4",154,0) S ARRAY=$$SCRN() Q:'ARRAY "RTN","XUAF4",155,0) ; "RTN","XUAF4",156,0) S ARRAY("NAME")=$P(^DIC(4,IEN,0),U) "RTN","XUAF4",157,0) S ARRAY("VA NAME")=$P(N99,U,3) "RTN","XUAF4",158,0) S ARRAY("STATION NUMBER")=STA "RTN","XUAF4",159,0) S ARRAY("TYPE")=$P($G(^DIC(4.1,+$G(^DIC(4,IEN,3)),0)),U) "RTN","XUAF4",160,0) ; "RTN","XUAF4",161,0) ;realignments "RTN","XUAF4",162,0) S TO=$O(^DIC(4,"ARTO",IEN,0)) D:TO "RTN","XUAF4",163,0) .S RDT=$O(^DIC(4,"ART",TO,IEN,0)) "RTN","XUAF4",164,0) .S ARRAY("REALIGNED TO")=TO_U_$$STA(TO)_U_RDT "RTN","XUAF4",165,0) S FM=$O(^DIC(4,"ARFM",IEN,0)) D:FM "RTN","XUAF4",166,0) .S ARRAY("REALIGNED FROM")=FM_U_$$STA(FM)_U_$O(^DIC(4,"ARF",FM,IEN,0)) "RTN","XUAF4",167,0) ; "RTN","XUAF4",168,0) S I=$O(^DIC(4,"AI",IEN,0)),I=$S(I:I,$G(RDT):RDT,1:+$P(N99,U,4)) "RTN","XUAF4",169,0) S ARRAY("INACTIVE")=I "RTN","XUAF4",170,0) ; "RTN","XUAF4",171,0) Q:'ONDT "RTN","XUAF4",172,0) ; "RTN","XUAF4",173,0) ;get name for date "RTN","XUAF4",174,0) S NAME=ARRAY("NAME") "RTN","XUAF4",175,0) S VANAME=ARRAY("VA NAME") "RTN","XUAF4",176,0) S HDT=DT "RTN","XUAF4",177,0) F S HDT=$O(^DIC(4,IEN,999,HDT),-1) Q:('HDT!(HDT759:1,X<700:0,X<750:1,1:0),$G(DUZ("AG"))="V" Q "0^not a treating facility" "RTN","XUAF4",199,0) Q IEN "RTN","XUAF4",200,0) ; "RTN","XUAF4",201,0) LOOKUP ; -- lookup an enty by coding system / ID pair "RTN","XUAF4",202,0) ; "RTN","XUAF4",203,0) N DIC,D "RTN","XUAF4",204,0) ; "RTN","XUAF4",205,0) S DIC="^DIC(4,",DIC(0)="QEA",D="XUMFIDX" D IX^DIC "RTN","XUAF4",206,0) ; "RTN","XUAF4",207,0) Q "RTN","XUAF4",208,0) ; "RTN","XUAF4",209,0) IDX(CDSYS,ID) ; -- return IEN for a given coding system / ID pair "RTN","XUAF4",210,0) ; "RTN","XUAF4",211,0) ;INPUT "RTN","XUAF4",212,0) ; CDSYS coding system (required) "RTN","XUAF4",213,0) ; ID identifier (required) "RTN","XUAF4",214,0) ;OUTPUT "RTN","XUAF4",215,0) ; $$ Internal Entry Number "RTN","XUAF4",216,0) ; "RTN","XUAF4",217,0) N IEN "RTN","XUAF4",218,0) ; "RTN","XUAF4",219,0) S CDSYS=$G(CDSYS),ID=$G(ID) "RTN","XUAF4",220,0) ; "RTN","XUAF4",221,0) Q:CDSYS="" "0^CDSYS required" "RTN","XUAF4",222,0) Q:ID="" "0^ID required" "RTN","XUAF4",223,0) ; "RTN","XUAF4",224,0) I CDSYS="VASTANUM" Q $O(^DIC(4,"D",ID,0)) "RTN","XUAF4",225,0) I CDSYS="NPI" Q $O(^DIC(4,"ANPI",ID,0)) "RTN","XUAF4",226,0) ; "RTN","XUAF4",227,0) S IEN=$O(^DIC(4,"XUMFIDX",CDSYS,ID,0)) "RTN","XUAF4",228,0) ; "RTN","XUAF4",229,0) Q $S(IEN:IEN,1:"0^not found") "RTN","XUAF4",230,0) ; "RTN","XUAF4",231,0) ID(CDSYS,IEN) ; returns the ID for a given coding system / IEN "RTN","XUAF4",232,0) ; "RTN","XUAF4",233,0) ;INPUT "RTN","XUAF4",234,0) ; CDSYS coding system (required) "RTN","XUAF4",235,0) ; IEN Internal Entry Number (required) "RTN","XUAF4",236,0) ;OUTPUT "RTN","XUAF4",237,0) ; $$ Identifier "RTN","XUAF4",238,0) ; "RTN","XUAF4",239,0) N ID,IDX "RTN","XUAF4",240,0) ; "RTN","XUAF4",241,0) S CDSYS=$G(CDSYS),IEN=$G(IEN) "RTN","XUAF4",242,0) Q:CDSYS="" "" Q:'IEN "" Q:'$D(^DIC(4,IEN)) "" "RTN","XUAF4",243,0) ; "RTN","XUAF4",244,0) I CDSYS="VASTANUM" Q $P($G(^DIC(4,+IEN,99)),U) "RTN","XUAF4",245,0) I CDSYS="NPI" Q $P($G(^DIC(4,+IEN,"NPI")),U) "RTN","XUAF4",246,0) ; "RTN","XUAF4",247,0) S IDX=$O(^DIC(4,IEN,9999,"B",CDSYS,0)) Q:'IDX "" "RTN","XUAF4",248,0) ; "RTN","XUAF4",249,0) Q $P($G(^DIC(4,IEN,9999,IDX,0)),U,2) "RTN","XUAF4",250,0) ; "RTN","XUAF4",251,0) CDSYS(Y) ; coding systems "RTN","XUAF4",252,0) ; "RTN","XUAF4",253,0) ;INPUT/OUTPUT "RTN","XUAF4",254,0) ; .Y Y(CDSYS) = $D local system ^ coding system name "RTN","XUAF4",255,0) ; "RTN","XUAF4",256,0) S Y("DMIS")=$D(^DIC(4,"XUMFIDX","DMIS"))_U_"DoD DMIS ID" "RTN","XUAF4",257,0) S Y("VASTANUM")=$D(^DIC(4,"D"))_U_"VA Station Number" "RTN","XUAF4",258,0) S Y("NPI")=$D(^DIC(4,"ANPI"))_U_"NPI" "RTN","XUAF4",259,0) S Y("CLIA")=$D(^DIC(4,"XUMFIDX","CLIA"))_U_"CLIA number" "RTN","XUAF4",260,0) S Y("MAMMO-ACR")=$D(^DIC(4,"XUMFIDX","MAMMO-ACR"))_U_"MAMMO-ACR number" "RTN","XUAF4",261,0) ; "RTN","XUAF4",262,0) Q "RTN","XUAF4",263,0) ; "RTN","XUAF4",264,0) LCDSYS(Y) ; list coding systems "RTN","XUAF4",265,0) ; "RTN","XUAF4",266,0) N CDSYS "RTN","XUAF4",267,0) S CDSYS="" "RTN","XUAF4",268,0) S CDSYS("NPI")="",CDSYS("VASTANUM")="" "RTN","XUAF4",269,0) F S CDSYS=$O(^DIC(4,"XUMFIDX",CDSYS)) Q:CDSYS="" D "RTN","XUAF4",270,0) .S Y(CDSYS)="" "RTN","XUAF4",271,0) ; "RTN","XUAF4",272,0) Q "RTN","XUAF4",273,0) ; "RTN","XUAF4",274,0) BNIEN(IEN) ; -- Billing Facility Name - Internal Entry Number "RTN","XUAF4",275,0) ; "RTN","XUAF4",276,0) Q $P($G(^DIC(4,+IEN,99)),U,2) "RTN","XUAF4",277,0) ; "RTN","XUAF4",278,0) BNSTA(STA) ; -- Billing Facility Name - Station Number "RTN","XUAF4",279,0) ; "RTN","XUAF4",280,0) Q $P($G(^DIC(4,+$$IEN^XUAF4(STA),99)),U,2) "RTN","XUAF4",281,0) ; "RTN","XUMF") 0^2^B100459281^B99395645 "RTN","XUMF",1,0) XUMF ;OIFO-OAK/RAM - XUMF API's;04/15/02 "RTN","XUMF",2,0) ;;8.0;KERNEL;**218,335,416,555**;Jul 10, 1995;Build 3 "RTN","XUMF",3,0) ; "RTN","XUMF",4,0) Q "RTN","XUMF",5,0) ; "RTN","XUMF",6,0) IEN(IFN,CDSYS,ID) ; -- Internal Entry Number "RTN","XUMF",7,0) ; "RTN","XUMF",8,0) I IFN=4 N X S X=$O(^DIC(4,"D",ID,0)) Q $S(X:X,1:"0^not found") "RTN","XUMF",9,0) ; "RTN","XUMF",10,0) N IEN,ROOT "RTN","XUMF",11,0) ; "RTN","XUMF",12,0) S IFN=$G(IFN),CDSYS=$G(CDSYS),ID=$G(ID) "RTN","XUMF",13,0) ; "RTN","XUMF",14,0) Q:'IFN "0^IFN required" "RTN","XUMF",15,0) Q:CDSYS="" "0^CDSYS required" "RTN","XUMF",16,0) Q:ID="" "0^ID required" "RTN","XUMF",17,0) ; "RTN","XUMF",18,0) S ROOT=$$ROOT^DILFD(IFN,,1) Q:ROOT="" "0^invalid IFN" "RTN","XUMF",19,0) S IEN=$O(@ROOT@("XUMFIDX",CDSYS,ID,0)) "RTN","XUMF",20,0) ; "RTN","XUMF",21,0) Q $S(IEN:IEN,1:"0^not found") "RTN","XUMF",22,0) ; "RTN","XUMF",23,0) FLD(FILE,FIELD) ; field "RTN","XUMF",24,0) ; "RTN","XUMF",25,0) N Y,DA,X "RTN","XUMF",26,0) ; "RTN","XUMF",27,0) S Y=$$FIELD(FILE,FIELD,"LABEL") "RTN","XUMF",28,0) ; "RTN","XUMF",29,0) Q $S(Y'="":1,1:0) "RTN","XUMF",30,0) ; "RTN","XUMF",31,0) LBL(FILE,FIELD) ; field label "RTN","XUMF",32,0) ; "RTN","XUMF",33,0) Q $$FIELD(FILE,FIELD,"LABEL") "RTN","XUMF",34,0) ; "RTN","XUMF",35,0) TYP(FILE,FIELD) ; field type "RTN","XUMF",36,0) ; "RTN","XUMF",37,0) Q $$FIELD(FILE,FIELD,"TYPE") "RTN","XUMF",38,0) ; "RTN","XUMF",39,0) PTR(FILE,FIELD) ; pointer field? "RTN","XUMF",40,0) ; "RTN","XUMF",41,0) Q $S($$TYP(FILE,FIELD)="POINTER":1,1:0) "RTN","XUMF",42,0) ; "RTN","XUMF",43,0) FIELD(FILE,FIELD,ATT) ; field attributes "RTN","XUMF",44,0) ; "RTN","XUMF",45,0) N Y,DA,X "RTN","XUMF",46,0) ; "RTN","XUMF",47,0) Q:'$G(FILE) "" "RTN","XUMF",48,0) Q:'$G(FIELD) "" "RTN","XUMF",49,0) Q:$G(ATT)="" "" "RTN","XUMF",50,0) ; "RTN","XUMF",51,0) D FIELD^DID(FILE,FIELD,"N",ATT,"Y") "RTN","XUMF",52,0) ; "RTN","XUMF",53,0) Q $G(Y(ATT)) "RTN","XUMF",54,0) ; "RTN","XUMF",55,0) FILE(FILE,ATT) ; file attributes "RTN","XUMF",56,0) ; "RTN","XUMF",57,0) N Y,DA,X "RTN","XUMF",58,0) ; "RTN","XUMF",59,0) Q:'$G(FILE) "" "RTN","XUMF",60,0) Q:$G(ATT)="" "" "RTN","XUMF",61,0) ; "RTN","XUMF",62,0) D FILE^DID(FILE,,ATT,"Y") "RTN","XUMF",63,0) ; "RTN","XUMF",64,0) Q $G(Y(ATT)) "RTN","XUMF",65,0) ; "RTN","XUMF",66,0) ECHO(FILE,IDX,X,XUMF) ; validate field exists and echo name "RTN","XUMF",67,0) ; "RTN","XUMF",68,0) Q:'$$F(+$G(XUMF)) 0 "RTN","XUMF",69,0) ; "RTN","XUMF",70,0) N SUBFILE,NAME "RTN","XUMF",71,0) ; "RTN","XUMF",72,0) S SUBFILE=$P($G(^DIC(4.001,+$G(FILE),1,+$G(IDX),0)),U,4) "RTN","XUMF",73,0) ; "RTN","XUMF",74,0) S NAME=$$LBL($S(SUBFILE:SUBFILE,1:+$G(FILE)),X) "RTN","XUMF",75,0) ; "RTN","XUMF",76,0) Q:NAME="" 0 "RTN","XUMF",77,0) ; "RTN","XUMF",78,0) ;W " "_NAME "RTN","XUMF",79,0) ; "RTN","XUMF",80,0) Q 1 "RTN","XUMF",81,0) ; "RTN","XUMF",82,0) F(XUMF) ; constrain edits to standard values "RTN","XUMF",83,0) ; "RTN","XUMF",84,0) Q $S($G(XUMF):1,1:0) "RTN","XUMF",85,0) ; "RTN","XUMF",86,0) PKV(IFN,IEN,HLCS) ; Primary Key Value - MFE.4 "RTN","XUMF",87,0) ; "RTN","XUMF",88,0) S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS) "RTN","XUMF",89,0) ; "RTN","XUMF",90,0) N MFE,NODE,ID,TEXT,CDSYS,IENS "RTN","XUMF",91,0) ; "RTN","XUMF",92,0) S NODE=$G(^DIC(4.001,IFN,"MFE")) "RTN","XUMF",93,0) Q:NODE="" "1Error - MFS parameter not defined for IFN "_IFN "RTN","XUMF",94,0) ; "RTN","XUMF",95,0) S:HLCS="" HLCS="~" "RTN","XUMF",96,0) S CDSYS=$P(NODE,U,3) "RTN","XUMF",97,0) ; "RTN","XUMF",98,0) Q:IEN="NEW" IEN_HLCS_"NEW ENTRY"_HLCS_CDSYS "RTN","XUMF",99,0) ; "RTN","XUMF",100,0) Q:'IFN "1Error - IFN required" "RTN","XUMF",101,0) Q:'IEN "1Error - IEN required" "RTN","XUMF",102,0) ; "RTN","XUMF",103,0) S IENS=IEN_"," "RTN","XUMF",104,0) ; "RTN","XUMF",105,0) S FIELD=$P(NODE,U,1),ID=$$GET1^DIQ(IFN,IENS,FIELD) "RTN","XUMF",106,0) S FIELD=$P(NODE,U,2),TEXT=$$GET1^DIQ(IFN,IENS,FIELD) "RTN","XUMF",107,0) ; "RTN","XUMF",108,0) S MFE=ID_HLCS_TEXT_HLCS_CDSYS "RTN","XUMF",109,0) ; "RTN","XUMF",110,0) Q:'$P(NODE,U,4) MFE "RTN","XUMF",111,0) ; "RTN","XUMF",112,0) S FIELD=$P(NODE,U,4),ID=$$GET1^DIQ(IFN,IENS,FIELD) "RTN","XUMF",113,0) S FIELD=$P(NODE,U,5),TEXT=$$GET1^DIQ(IFN,IENS,FIELD) "RTN","XUMF",114,0) S CDSYS=$P(NODE,U,6) "RTN","XUMF",115,0) ; "RTN","XUMF",116,0) Q MFE_HLCS_ID_HLCS_TEXT_HLCS_CDSYS "RTN","XUMF",117,0) ; "RTN","XUMF",118,0) MFE(IFN,PKV,HLCS,IEN,ERROR) ; -- update "RTN","XUMF",119,0) ; "RTN","XUMF",120,0) N IENS,MFE,I,X,ID,XREF,NAME,FLD,FDA,DIC "RTN","XUMF",121,0) ; "RTN","XUMF",122,0) S IFN=$G(IFN),IEN=$G(IEN),HLCS=$G(HLCS),ERROR=$G(ERROR) "RTN","XUMF",123,0) S:HLCS="" HLCS="~" "RTN","XUMF",124,0) ; "RTN","XUMF",125,0) Q:ERROR "RTN","XUMF",126,0) ; "RTN","XUMF",127,0) I 'IFN S ERROR="1Error - IFN required" Q "RTN","XUMF",128,0) ; "RTN","XUMF",129,0) I IFN'=4.001 D Q:ERROR "RTN","XUMF",130,0) .S MFE=$G(^DIC(4.001,IFN,"MFE")),XREF=$P(MFE,U,8) "RTN","XUMF",131,0) .I '$P(MFE,U,1) D Q "RTN","XUMF",132,0) ..S ERROR="1MFS PARAM MFE.4.1 null" "RTN","XUMF",133,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",134,0) .I '$P(MFE,U,2) D Q "RTN","XUMF",135,0) ..S ERROR="1MFS PARAM MFE.4.2 null" "RTN","XUMF",136,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",137,0) .I XREF="" D Q "RTN","XUMF",138,0) ..S ERROR="1MFS PARAM MFE XREF not defined" "RTN","XUMF",139,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",140,0) ; "RTN","XUMF",141,0) I IFN=4.001 D Q "RTN","XUMF",142,0) .S IEN=$$FIND1^DIC(1,,"BX",$P(PKV,HLCS)) "RTN","XUMF",143,0) .I 'IEN D Q "RTN","XUMF",144,0) ..S ERROR="1not a valid IEN in MFE XUMF" "RTN","XUMF",145,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",146,0) .Q:$D(^DIC(4.001,IEN)) "RTN","XUMF",147,0) .X HLNEXT "RTN","XUMF",148,0) .I $P(HLNODE,HLFS)'="ZZZ" D Q "RTN","XUMF",149,0) ..S ERROR="1MFP error in MFE XUMF" "RTN","XUMF",150,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",151,0) .S MFE=$P(HLNODE,HLFS,7,12),MFE=$TR(MFE,HLFS,U) "RTN","XUMF",152,0) .S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I "RTN","XUMF",153,0) .I 'X D Q "RTN","XUMF",154,0) ..S ERROR="1MFS PARAM no .01 in MFE" "RTN","XUMF",155,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",156,0) .S NAME=$P(PKV,HLCS,X) K X "RTN","XUMF",157,0) .K FDA "RTN","XUMF",158,0) .S FDA(IFN,"?+1,",.01)=NAME "RTN","XUMF",159,0) .D UPDATE^DIE("E","FDA") "RTN","XUMF",160,0) ; "RTN","XUMF",161,0) S ID=$P(PKV,HLCS) "RTN","XUMF",162,0) I ID="" D Q "RTN","XUMF",163,0) .S ERROR="1MFS PARAM MFE PKV ID null" "RTN","XUMF",164,0) .D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",165,0) S ROOT=$$ROOT^DILFD(IFN,,1) "RTN","XUMF",166,0) I $D(@ROOT@(XREF)),'$G(IEN) S IEN=$O(@ROOT@(XREF,ID,0)) "RTN","XUMF",167,0) S:'IEN IEN=$$FIND1^DIC(IFN,,"B",ID) "RTN","XUMF",168,0) ; "RTN","XUMF",169,0) I 'IEN D Q:ERROR "RTN","XUMF",170,0) .S X="" F I=5,4,2,1 S:$P(MFE,U,I)=.01 X=I "RTN","XUMF",171,0) .I 'X D Q "RTN","XUMF",172,0) ..S ERROR="1MFS PARAM no .01 in MFE" "RTN","XUMF",173,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",174,0) .S NAME=$P(PKV,HLCS,X) K X "RTN","XUMF",175,0) .I NAME="" S ERROR="1MFS PARAM MFE PKV .01 is null" Q "RTN","XUMF",176,0) .D CHK^DIE(IFN,.01,,NAME,.X) "RTN","XUMF",177,0) .I X="^" D Q "RTN","XUMF",178,0) ..S ERROR="1MFS PARAM MFE PKV .01 is invalid" "RTN","XUMF",179,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",180,0) .K DIC S DIC=IFN,DIC(0)="F" D FILE^DICN K DIC "RTN","XUMF",181,0) .I Y="-1" D Q "RTN","XUMF",182,0) ..S ERROR="1MFS PARAM MFE FileDICN unsuccessful" "RTN","XUMF",183,0) ..D EM^XUMFH(ERROR,.ERR) "RTN","XUMF",184,0) .S IEN=+Y "RTN","XUMF",185,0) ; "RTN","XUMF",186,0) S IENS=IEN_"," "RTN","XUMF",187,0) ; "RTN","XUMF",188,0) F I=1,2,4,5 D "RTN","XUMF",189,0) .S FLD=$P(MFE,U,I) Q:'FLD "RTN","XUMF",190,0) .S FDA(IFN,IENS,FLD)=$P(PKV,HLCS,I) "RTN","XUMF",191,0) ; "RTN","XUMF",192,0) D FILE^DIE("E","FDA","ERR") "RTN","XUMF",193,0) I $D(ERR) D "RTN","XUMF",194,0) .D EM^XUMFH("1FILE DIE error msg in MFE of XUMF",.ERR) "RTN","XUMF",195,0) .K ERR "RTN","XUMF",196,0) ; "RTN","XUMF",197,0) Q "RTN","XUMF",198,0) ; "RTN","XUMF",199,0) MFP(IFN,ERR) ; -- validate Master File Parameters entry FALSE=valid "RTN","XUMF",200,0) ; "RTN","XUMF",201,0) Q:'$G(IFN) "IFN null" "RTN","XUMF",202,0) ; "RTN","XUMF",203,0) D ZERO(IFN,.ERR) "RTN","XUMF",204,0) D MFE1(IFN,.ERR) "RTN","XUMF",205,0) D SEQ(IFN,.ERR) "RTN","XUMF",206,0) ; "RTN","XUMF",207,0) Q $S($D(ERR("FATAL")):1,$D(ERR("WARNING")):2,1:0) "RTN","XUMF",208,0) ; "RTN","XUMF",209,0) ZERO(IFN,ERR) ; -- zero node "RTN","XUMF",210,0) ; "RTN","XUMF",211,0) N X,CNT "RTN","XUMF",212,0) ; "RTN","XUMF",213,0) S X=$G(^DIC(4.001,+IFN,0)),CNT=1 "RTN","XUMF",214,0) I $P(X,U,2)="" D "RTN","XUMF",215,0) .S ERR("FATAL","ZERO",CNT)="Z SEGMENT is null",CNT=CNT+1 "RTN","XUMF",216,0) I $P(X,U,3)="" D "RTN","XUMF",217,0) .S ERR("FATAL","ZERO",CNT)="MFI CODE is null",CNT=CNT+1 "RTN","XUMF",218,0) I $P(X,U,4)="" D "RTN","XUMF",219,0) .S ERR("WARNING","ZERO",CNT)="PRE-UPDATE ROUTINE is null",CNT=CNT+1 "RTN","XUMF",220,0) I $P(X,U,5)="" D "RTN","XUMF",221,0) .S ERR("WARNING","ZERO",CNT)="POST-UPDATE ROUTINE is null",CNT=CNT+1 "RTN","XUMF",222,0) I $P(X,U,6)="" D "RTN","XUMF",223,0) .S ERR("WARNING","ZERO",CNT)="MAIL GROUP is null",CNT=CNT+1 "RTN","XUMF",224,0) ; "RTN","XUMF",225,0) Q "RTN","XUMF",226,0) ; "RTN","XUMF",227,0) MFE1(IFN,ERR) ; -- MFE node "RTN","XUMF",228,0) ; "RTN","XUMF",229,0) N X,I,CNT "RTN","XUMF",230,0) ; "RTN","XUMF",231,0) S X=$G(^DIC(4.001,+IFN,"MFE")),CNT=1 "RTN","XUMF",232,0) F I=1:1:6 I $P(X,U,I)="" D "RTN","XUMF",233,0) .S ERR("FATAL","MFE",CNT)="MFE ID & ALT ID field and codsys required" "RTN","XUMF",234,0) .S CNT=CNT+1 "RTN","XUMF",235,0) I $P(X,U,8)="" D "RTN","XUMF",236,0) .S ERR("FATAL","MFE",CNT)="MFE PKV X-REF required",CNT=CNT+1 "RTN","XUMF",237,0) F I=11,12,14,15 I $P(X,U,I)="" D "RTN","XUMF",238,0) .S ERR("WARNING","MFE",CNT)="MFE PKV types are null",CNT=CNT+1 "RTN","XUMF",239,0) I $P(X,U,9)="" D "RTN","XUMF",240,0) .S ERR("WARNING","MFE",CNT)="ASSIGNING AUTHORITY is null",CNT=CNT+1 "RTN","XUMF",241,0) ; "RTN","XUMF",242,0) Q "RTN","XUMF",243,0) ; "RTN","XUMF",244,0) SEQ(IFN,ERR) ; -- sequence nodes "RTN","XUMF",245,0) ; "RTN","XUMF",246,0) N SEQ,MULT,X,I,Y "RTN","XUMF",247,0) ; "RTN","XUMF",248,0) S SEQ=0 "RTN","XUMF",249,0) F S SEQ=$O(^DIC(4.001,IFN,1,SEQ)) Q:'SEQ D "RTN","XUMF",250,0) .S X=$G(^DIC(4.001,IFN,1,SEQ,0)) "RTN","XUMF",251,0) .I $$TYP($S($P(X,U,4):$P(X,U,4),1:IFN),$P(X,U,2))="POINTER" D "RTN","XUMF",252,0) ..Q:$P(X,U,7)'="" "RTN","XUMF",253,0) ..S Y=$S($P(X,U,4):$P(X,U,4),1:IFN),Y=$$LBL(Y,$P(X,U,2)) "RTN","XUMF",254,0) ..S Y="field "_Y_" is pointer EXTENDED POINTER LKUP is NULL" "RTN","XUMF",255,0) ..S ERR("WARNING",SEQ)=Y "RTN","XUMF",256,0) .S MULT=$S($P(X,U,4):1,1:0) "RTN","XUMF",257,0) .I '$P(X,U,2) S ERR("FATAL",SEQ)=" missing FIELD NUMBER" "RTN","XUMF",258,0) .I MULT,$P(X,U,8)="" D "RTN","XUMF",259,0) ..S ERR("FATAL",SEQ)=" MULT IEN FUNCTION is null" "RTN","XUMF",260,0) .I MULT,$P(X,U,6),$P(X,U,5)'="" D "RTN","XUMF",261,0) ..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch" "RTN","XUMF",262,0) .I MULT,'$P(X,U,6),$P(X,U,5)="" D "RTN","XUMF",263,0) ..S ERR("FATAL",SEQ)=" SUBFILE KEY LKUP/KEY SEQ mismatch" "RTN","XUMF",264,0) .I 'MULT F I=5,6,8 D "RTN","XUMF",265,0) ..Q:$P(X,U,I)="" "RTN","XUMF",266,0) ..S ERR("FATAL",SEQ)=" SUBFILE null with subfile parameters" "RTN","XUMF",267,0) ; "RTN","XUMF",268,0) Q "RTN","XUMF",269,0) ; "RTN","XUMF",270,0) BG(IFN,IEN,TYP) ; -- background job "RTN","XUMF",271,0) ; "RTN","XUMF",272,0) ; type (5=file, 7=array) "RTN","XUMF",273,0) ; "RTN","XUMF",274,0) N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE "RTN","XUMF",275,0) ; "RTN","XUMF",276,0) S TYP=$G(TYP) S:'TYP TYP=5 "RTN","XUMF",277,0) S IEN=$G(IEN) S:IEN="" IEN="ALL" "RTN","XUMF",278,0) ; "RTN","XUMF",279,0) S ZTDTH=$$NOW^XLFDT,ZTRTN="BG1^XUMF",ZTIO="" "RTN","XUMF",280,0) S ZTSAVE("IFN")="",ZTSAVE("TYP")="",ZTSAVE("IEN")="" "RTN","XUMF",281,0) S ZTDESC="XUMF get "_$$FILE^XUMF(IFN,"NAME")_" using MFS" "RTN","XUMF",282,0) ; "RTN","XUMF",283,0) D ^%ZTLOAD "RTN","XUMF",284,0) ; "RTN","XUMF",285,0) Q "RTN","XUMF",286,0) ; "RTN","XUMF",287,0) BG1 ; -- get file "RTN","XUMF",288,0) ; "RTN","XUMF",289,0) D MFS(IFN,IEN,TYP,.ERROR),EXIT "RTN","XUMF",290,0) ; "RTN","XUMF",291,0) Q "RTN","XUMF",292,0) ; "RTN","XUMF",293,0) LOAD(IFN) ; -- query and file "RTN","XUMF",294,0) ; "RTN","XUMF",295,0) D MFS(IFN,"ALL",5,.ERROR) "RTN","XUMF",296,0) ; "RTN","XUMF",297,0) Q "RTN","XUMF",298,0) ; "RTN","XUMF",299,0) ARRAY(IFN) ; -- query and put in array "RTN","XUMF",300,0) ; "RTN","XUMF",301,0) D MFS(IFN,"ALL",7,.ERROR) "RTN","XUMF",302,0) ; "RTN","XUMF",303,0) Q "RTN","XUMF",304,0) ; "RTN","XUMF",305,0) GETCE(IFN,IEN,TYP,ERROR) ; -- get master file provide coded element "RTN","XUMF",306,0) ; "RTN","XUMF",307,0) Q "RTN","XUMF",308,0) ; "RTN","XUMF",309,0) MFS(IFN,IEN,TYP,ERROR) ; -- get file from Master File Server "RTN","XUMF",310,0) ; "RTN","XUMF",311,0) ; TYP (5=query/file, 7=query/tmp_array) "RTN","XUMF",312,0) ; "RTN","XUMF",313,0) N TEST "RTN","XUMF",314,0) ; "RTN","XUMF",315,0) S (ERROR,TEST)=0 "RTN","XUMF",316,0) ; "RTN","XUMF",317,0) S IFN=$G(IFN),IEN=$G(IEN),TYP=$G(TYP) "RTN","XUMF",318,0) ; "RTN","XUMF",319,0) I 'IFN S ERROR="1IFN not valid MFS in XUMF" Q "RTN","XUMF",320,0) I IEN="" S ERROR="1IEN not valid MFS in XUMF" Q "RTN","XUMF",321,0) I TYP'=5,TYP'=7 S ERROR="1type not support by MFS in XUMF" Q "RTN","XUMF",322,0) ; "RTN","XUMF",323,0) I $P($$PARAM^HLCS2,U,3)="T" S TEST=1 "RTN","XUMF",324,0) ; "RTN","XUMF",325,0) S PARAM("LLNK")="XUMF MFR^XUMF "_$S('TEST:"FORUM",1:"TEST") "RTN","XUMF",326,0) S PARAM("PROTOCOL")=$O(^ORD(101,"B","XUMF MFQ",0)) "RTN","XUMF",327,0) ; "RTN","XUMF",328,0) D MAIN^XUMFP(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR "RTN","XUMF",329,0) D MAIN^XUMFI(IFN,"ALL",TYP,.PARAM,.ERROR) Q:ERROR "RTN","XUMF",330,0) D MAIN^XUMFH "RTN","XUMF",331,0) ; "RTN","XUMF",332,0) Q "RTN","XUMF",333,0) ; "RTN","XUMF",334,0) ; "RTN","XUMF",335,0) EXIT ; -- cleanup and quit "RTN","XUMF",336,0) ; "RTN","XUMF",337,0) K ^TMP("XUMF MFS",$J),^TMP("DIERR",$J) "RTN","XUMF",338,0) ; "RTN","XUMF",339,0) S ZTREQ="@" "RTN","XUMF",340,0) ; "RTN","XUMF",341,0) Q "RTN","XUMF",342,0) ; "RTN","XUMF",343,0) NPI ; -- NPI "RTN","XUMF",344,0) ; "RTN","XUMF",345,0) N COL,X,FDA,NPIDT,NPISTAT,NPI,TAX,TAXPC,TAXSTAT,ERR "RTN","XUMF",346,0) ; "RTN","XUMF",347,0) D SEGPRSE^XUMFXHL7("HLNODE","COL") "RTN","XUMF",348,0) ; "RTN","XUMF",349,0) S NPIDT=$$FMDATE^HLFNC(COL(17)) "RTN","XUMF",350,0) S NPISTAT=COL(18) "RTN","XUMF",351,0) S NPI=COL(19) "RTN","XUMF",352,0) S TAX=COL(20) "RTN","XUMF",353,0) S TAXPC=COL(21) "RTN","XUMF",354,0) S TAXSTAT=COL(22) "RTN","XUMF",355,0) ; "RTN","XUMF",356,0) S X=$$NPI^XUSNPI("Organization_ID",IEN,NPIDT) "RTN","XUMF",357,0) I $S(X=0:1,$$UP^XLFSTR($P(X,U,3))'=NPISTAT:1,NPI'=+X:1,1:0) D "RTN","XUMF",358,0) .S X=$$ADDNPI^XUSNPI("Organization_ID",IEN,NPI,NPIDT,$S(NPISTAT="ACTIVE":1,1:0)) "RTN","XUMF",359,0) ; "RTN","XUMF",360,0) S IENS="?+1,"_IEN_"," "RTN","XUMF",361,0) K FDA "RTN","XUMF",362,0) S FDA(4.9999,IENS,.01)="NPI" "RTN","XUMF",363,0) S FDA(4.9999,IENS,.02)=NPI "RTN","XUMF",364,0) D UPDATE^DIE("E","FDA",,"ERR") "RTN","XUMF",365,0) ; "RTN","XUMF",366,0) K FDA "RTN","XUMF",367,0) S IENS="?+1,"_IEN_"," "RTN","XUMF",368,0) S FDA(4.043,IENS,.01)=TAX "RTN","XUMF",369,0) S FDA(4.043,IENS,.02)=TAXPC "RTN","XUMF",370,0) S FDA(4.043,IENS,.03)=TAXSTAT "RTN","XUMF",371,0) D UPDATE^DIE("E","FDA",,"ERR") "RTN","XUMF",372,0) ; "RTN","XUMF",373,0) S SEQ=22 "RTN","XUMF",374,0) ; "RTN","XUMF",375,0) Q "RTN","XUMF",376,0) ; "RTN","XUMF",377,0) CDSYS(CDSYS,ID,IEN) ; udpate coding system / ID "RTN","XUMF",378,0) ; "RTN","XUMF",379,0) N IENS,FDA "RTN","XUMF",380,0) ; "RTN","XUMF",381,0) S IENS="?+1,"_IEN_"," "RTN","XUMF",382,0) K FDA "RTN","XUMF",383,0) S FDA(4.9999,IENS,.01)=CDSYS "RTN","XUMF",384,0) S FDA(4.9999,IENS,.02)=ID "RTN","XUMF",385,0) D "RTN","XUMF",386,0) .N IEN,VALUE "RTN","XUMF",387,0) .D UPDATE^DIE("E","FDA") "RTN","XUMF",388,0) ; "RTN","XUMF",389,0) Q "RTN","XUMF",390,0) ; "RTN","XUMF555P") 0^^B326953^n/a "RTN","XUMF555P",1,0) XUMF555P ;BP/RAM - VISN 99 ;05/25/11 "RTN","XUMF555P",2,0) ;;8.0;KERNEL;**555**;Jul 10, 1995;Build 3 "RTN","XUMF555P",3,0) ; "RTN","XUMF555P",4,0) Q "RTN","XUMF555P",5,0) ; "RTN","XUMF555P",6,0) MAIN ; -- stuff VISN 99 "RTN","XUMF555P",7,0) ; "RTN","XUMF555P",8,0) N XUMF,IENS,IEN "RTN","XUMF555P",9,0) ; "RTN","XUMF555P",10,0) S XUMF=1 "RTN","XUMF555P",11,0) ; "RTN","XUMF555P",12,0) S IEN=$O(^DIC(4,"B","VISN 99",0)) "RTN","XUMF555P",13,0) S IENS=$S(IEN:IEN_",",1:"+1,") "RTN","XUMF555P",14,0) ; "RTN","XUMF555P",15,0) K FDA "RTN","XUMF555P",16,0) S FDA(4,IENS,.01)="VISN 99" "RTN","XUMF555P",17,0) S FDA(4,IENS,11)="LOCAL" "RTN","XUMF555P",18,0) S FDA(4,IENS,13)="VISN" "RTN","XUMF555P",19,0) D UPDATE^DIE("E","FDA") "RTN","XUMF555P",20,0) ; "RTN","XUMF555P",21,0) Q "RTN","XUMF555P",22,0) ; "VER") 8.0^22.0 "BLD",6433,6) ^465 **END** **END**