TMGDBAP2 ;TMG/kst/Database API library 2 ;03/25/06; 5/2/10 ;;1.0;TMG-LIB;**1**;07/12/05 ;"This module holds moved functions from TMGDBAPI (moved due to size constraints) ConvertFDA(FDA,MarkerArray) ;"Purpose: To convert all the IENS's in a FDA via ConvertIENS ;"Input: FDA -- An FDA that need conversion. MUST PASS BY REFERENCE ;" Expected FDA is as follows. I.e., expecting that ;" there will only be ONE filenumber (the 19.01) part: ;" FDA(*) ;" }~19.01 ;" }~?+4,?+2, ;" | }~.01 = DIUSER ;" | }~2 = FM2 ;" | }~3 = 1 ;" | ;" }~?+5,?+2, ;" | }~.01 = XMMGR ;" | }~2 = X2 ;" | }~3 = 1 ;" | ;" }~?+6,?+2, ;" }~.01 = DIEDIT ;" }~2 = Edit ;" }~3 = 2 ;" MarkerArray -- see documentation in ConvertIENS ;"Output: FDA is changed ;"Result: 1=OKToContinue, 0=Abort if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cParentIENS set cParentIENS="ParentIENS" new cRef set cRef="Ref" ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI") new result set result=1 if $data(FDA)=0 set result=0 goto CvFDAQ new FileNum new Index new IENS,OldIENS ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the FDA to convert") ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the MarkerArray") ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MarkerArray") set FileNum=$order(FDA("")) if +FileNum=0 set result=0 goto CvFDAQ ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Looking at filenumber ",FileNum) set IENS=$order(FDA(FileNum,"")) for do quit:(IENS="") . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS) . if IENS="" do quit . . set result=0 . set OldIENS=IENS . if $$ConvertIENS(.IENS,.MarkerArray)=0 do quit . . set IENS="" . . set result=0 . if IENS'=OldIENS do . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Converted to IENS=",IENS) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Convert FDA(FileNumber,"""_OldIENS_""") to FDA(Filenumber,"""_IENS_""")") . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(FDA(FileNum,OLDIENS))=",$data(FDA(FileNum,OldIENS))) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is FDA so far") . . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") . . merge FDA(FileNum,IENS)=FDA(FileNum,OldIENS) . . set IENS=$order(FDA(FileNum,OldIENS)) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"killing FDA(FileNumber,"_OldIENS_")") . . kill FDA(FileNum,OldIENS) . else do . . set IENS=$order(FDA(FileNum,OldIENS)) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Resulting FDA so far") . ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------") . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of cycle. IENS=",IENS) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"-----------------------") ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"After conversion, here is the FDA.") ;"if TMGDEBUG do ArrayDump^TMGDEBUG("FDA") CvFDAQ ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertFDA^TMGDBAPI") quit result ConvertIENS(IENS,MarkerArray) ;"Purpose: to convert an IENS such as "?+4,?+2," into "?+4,12345,", given ;" the MarkerArray that corelates "2" to #"12345" ;"Input: IENS -- the IENS string to convert. MUST PASS BY REFERENCE ;" MarkerArray -- a composite array composed of results returned ;" by database server, like below. SHOULD PASS BY REFERENCE ;" MarkerArray(*) ;" }~2 = 10033 ;" }~0 = + ;" }~4 = 12345 ;" }~0 = + ;"Output: IENS will be changed ;"Result: 1=OkToContinue, 0=Abort if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cParentIENS set cParentIENS="ParentIENS" ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI") new result set result=1 new S set S="" if $data(IENS)#10=0 set result=0 goto CvIENSQ if $data(MarkerArray)=0 set result=0 goto CvIENSQ ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Initial IENS=",IENS) new I set I=1 for do quit:(I=-1) . new Part,RecMarker . set Part=$piece(IENS,",",I) . ;";"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"Part="_Part_" --> ",0) . if Part="" set I=-1 quit . set RecMarker=+$translate(Part,"?+","") . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"RecMarker="_RecMarker_" --> ",0) . new tS set tS=$get(MarkerArray(RecMarker),Part) . ;"if $get(TMGDEBUG)>0 do DebugWrite^TMGDEBUG(.DBIndent,"tS="_tS,1) . set S=S_tS_"," . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"S so far=",S) . set I=I+1 set IENS=S CvIENSQ ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ConvertIENS^TMGDBAPI") quit result SetupFDA(Data,FDA,parentIENS,SrchType,MarkNum,MsgArray,Minimal,RecNum) ;"Purpose: to transfer from Data format to FDA format ;"Input: Data - Data array should be in format output from GetRInfo ;" FDA -- SHOULD BE PASSED BY REFERENCE (to receive results) ;" parentIENS -- initial IENS.. the IENS of any PARENT record, or "" if no parent record ;" SrchType -- should be "?", "+", or "?+" ;" MarkNum -- -- SHOULD BE PASSED BY REFERENCE. A variable to ensure ;" "?X" search term always has unique number. On first call, should=0 ;" MsgArray -- SHOULD BE PASSED BY REFERENCE. An array that can accept ;" messages back from function. ;" -- One such type of message is a list of needed hackwrites. ;" Format as follows: ;" MsgArray(cHack,0,Entries)=2 ;" MsgArray(cHack,1)="^VA(;200;?+1;.01;SomeData" ;" MsgArray(cHack,1,cFlags)="H" ;" MsgArray(cHack,2)="^VA(;200;?+1;.02;SomeMoreData" ;" MsgArray(cHack,2,cFlags)="H" ;" i.e. MsgArray(cHack,0,Entries)=Number of Entries ;" MsgArray(cHack,n) = Global;FileNumber;IENS;FieldNum;Data ;" MsgArray(n,cFlags)=User specified Flags for field. ;" -- MsgArray(cRef,SubFileNumber)=Reference to Part of Data that created this. ;" MsgArray(*) ;" }~cRef ;" }~1234.21 = "Data(6,".07") ;" }~1234.2101 = "Data(6,".07",2,".04") ;" Minimal -- OPTIONAL. 1=fill only .01 fields and subfile .01 fields ;" RecNum -- OPTIONAL. If FDA is to be setup such that data is put into ;" a specified record number, put that number here. ;" !!! Note: I believe this is used erroneously here. A record number ;" is not specified in the FDA. For calls to UPDATE^DIE to a specific ;" record number, the FDA should have an IENS that is like "+1,", and then ;" put the desired record number into the IEN_ROOT, like TMGIEN(1)=1234 ;" with the "1" matching the "1" in TMGIEN(1) ;"Output: FDA is changed if passed by reference. ;"Returns: If should continue execution: 1=OK to continue. 0=abort. ;"Note: input Data array will be formated like this: ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," ;" Data(0,cRecNum)=2 <-- only if user-specified. ;" Data(0,cEntries)=1 ;" Data(1,".01")="MyData1" ;" Data(1,".01",cMatchValue)="MyData1" ;" Data(1,".02")="Bill" ;" Data(1,".02",cMatchValue)="John" ;" Data(1,".03")="MyData3" ;" Data(1,".04")="MyData4" ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" ;" Data(1,".07",1,".01")="SubEntry1" ;" Data(1,".07",1,".02")="SE1" ;" Data(1,".07",1,".03")="'Some Info'" ;" Data(1,".07",2,".01")="SubEntry2" ;" Data(1,".07",2,".02")="SE2" ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 ;" Data(1,".07",2,".04",1,".01")="JD" ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" ;" ADDENDUM ;" Data(1,".01",cFlags)=any flags specified for given field. ;" only present if user specified. ;"Resulting FDA will look like this. ;" i.e. FDA(1234,"?+1,10024,",.01)="MyData1" ;" i.e. FDA(1234,"?+1,10024,",.02)="Bill" ;" i.e. FDA(1234,"?+1,10024,",.03)="MyData3" ;" i.e. FDA(1234,"?+1,10024,",.04)="MyData4" ;" i.e. FDA(1234,"?+1,10024,",.06)="MyData5" ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.01)="SubEntry1" ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.02)="SE1" ;" i.e. FDA(1234.21,"?+2,?+1,10024,",.03)="'Some Info'" ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.01)="SubEntry2" ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.02)="SE2" ;" i.e. FDA(1234.21,"?+3,?+1,10024,",.03)="'Some Info'" ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.01)="JD" ;" i.e. FDA(1234.2101,"?+4,?+3,?+1,10024,",.02)="DOE,JOHN" ;"(OR... reformat of above) ;" FDA(*) ;" }~1234 ;" }~?+1,10024 ;" }~.01 = MyData1 ;" }~.02 = Bill ;" }~.03 = MyData3 ;" }~.04 = MyData4 ;" }~.06 = MyData5 ;" }~1234.21 ;" }~?+2,?+1,10024 ;" }~.01 = SubEntry1 ;" }~.02 = SE1 ;" }~.03 = 'Some Info' ;" }~?+3,?+1,10024 ;" }~.01 = SubEntry2 ;" }~.02 = SE2 ;" }~.03 = 'Some Info' ;" }~1234.2101 ;" }~?+4,?+3,?+1,10024 ;" }~.01 = JD ;" }~.02 = DOE,JOHN ;"MsgArray will hold the following ;" MsgArray(*) ;" }~"H" ;" }~"Ref" ;" }~1234.21 = "Data(6,".07") ;" }~1234.2101 = "Data(6,".07",2,".04") if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cFile set cFile="FILE" ;"File" new cHack set cHack="H" new cFlags set cFlags="FLAGS" ;"Flags" new cEntries set cEntries="Entries" new cNoOverwrite set cNoOverwrite="N" ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI") new result set result=cOKToCont new index new FieldNum new FileNumber new SubMarkNum set SubMarkNum=0 new IENS set IENS="" if $get(RecNum)="" kill RecNum set FileNumber=$get(Data(0,cFile)) if +FileNumber=0 goto SFDAQ ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"parentIENS=",parentIENS) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SrchType=",SrchType) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",$get(RecNum)) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the Data array to work with:") ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") set index=$order(Data(0)) ;"Cycle through all entries (i.e. 1, 2, 3) for do quit:(index="")!(result=cAbort) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"index=",index) . set FieldNum=$order(Data(index,"")) . ;"Cycle through all fields (i.e. .01, .02, ,1223) . for do quit:(FieldNum="")!(result=cAbort) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNum=",FieldNum) . . new NextFieldNum set NextFieldNum=$order(Data(index,FieldNum)) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NextFieldNum=",NextFieldNum) . . if ($get(Data(index,FieldNum,cFlags))[cNoOverwrite)&(SrchType["?") do quit . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m0") . . . set FieldNum=NextFieldNum . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"NoOverwrite flag found, ignoring current field.") . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m1") . . if (FieldNum=.01)!(IENS="") do . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"m2") . . . if $data(RecNum)#10=0 do . . . . set MarkNum=+$get(MarkNum)+1 . . . . set IENS=SrchType_MarkNum_","_$get(parentIENS) . . . else do . . . . set IENS=$get(RecNum)_","_$get(parentIENS) . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS=",IENS) . . if $get(Data(index,FieldNum,cFlags))[cHack do ;"HACK PROCESSING . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Hack Processing") . . . ;"Load hacks into a message array for later processing . . . new NumHacks set NumHacks=$get(MsgArray(cHack,0,cEntries))+1 . . . new Entry set Entry=Data(index,FieldNum) . . . if $get(Data(index,FieldNum,cFlags))[cEncrypt do . . . . set Entry=$$EN^XUSHSH(Entry) ;"encrypt data . . . new Global set Global=$get(Data(0,cFile,cGlobal)) . . . if Global="" do quit . . . . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to local global name for file") . . . . set result=cAbort . . . set MsgArray(cHack,NumHacks)=Global_";"_FileNumber_";"_IENS_";"_FieldNum_";"_Entry . . . set MsgArray(cHack,NumHacks,cFlags)=Data(index,FieldNum,cFlags) . . else if $data(Data(index,FieldNum,0,cEntries)) do ;"SUB-FILE PROCESSING . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub-file processing") . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Addition of subfile entries encountered.") . . . new tempData merge tempData=Data(index,FieldNum) . . . new SubFileNum set SubFileNum=$get(Data(index,FieldNum,0,cFile),0) . . . set MsgArray(cRef,SubFileNum)=$name(Data(index,FieldNum)) . . . ;"call self recursively to handle subfile. . . . new SubMarkNum set SubMarkNum=MarkNum . . . set result=$$SetupFDA(.tempData,.FDA,IENS,SrchType,.SubMarkNum,.MsgArray,.Minimal) . . . if SubMarkNum>MarkNum set MarkNum=SubMarkNum . . else do ;"THE-USUAL-CASE PROCESSING . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing usual case") . . . if (FieldNum=.01)!($get(Minimal)'=1) do . . . . new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")="_$get(Data(index,FieldNum)) . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"ts=",ts) . . . . set FDA(FileNumber,IENS,FieldNum)=$get(Data(index,FieldNum)) . . . if $data(Data(index,FieldNum,"WP")) do . . . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Detected word-processor field") . . . . merge FDA(FileNumber,IENS,FieldNum,"WP")=Data(index,FieldNum,"WP") . . . . ;"if $get(TMGDEBUG)>0 do . . . . ;". new ts set ts="Setting: FDA("_FileNumber_","""_IENS_""","_FieldNum_")=" . . . . ;". ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE . . . . ;". set ts=ts_$name(TMGFDA(FileNumber,IENS,FieldNum,"WP")) . . . . ;". do DebugMsg^TMGDEBUG(.DBIndent,ts) . . . . ;"NOTE: the "TMGFDA" MUST!! match the FDA name passed to UPDATE^DIE, FILE^DIE . . . . set FDA(FileNumber,IENS,FieldNum)=$name(TMGFDA(FileNumber,IENS,FieldNum,"WP")) . . set FieldNum=NextFieldNum . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of field loop") . set index=$order(Data(index)) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"End of index loop") SFDAQ ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is resulting FDA") ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("FDA") ;"zwr FDA(*) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFDA^TMGDBAPI") quit result OverwriteRec(RecNum,Data) ;"Purpose: To stuff data from data array into record specified by RecNum. ;" This function will not directly put any data into subfiles, but will ;" call UploadData to handle this. ;"Input: RecNum -- the record number (as returned by GetRecMatch) to put data into ;" Data - Should be in format output from GetRInfo ;"Output: database will be modified by changing record ;"Returns: If should continue execution: 1=OK to continue. 0=abort. if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 if $data(cAbort)#10=0 new cAbort set cAbort=0 new cParentIENS set cParentIENS="ParentIENS" new result set result=cOKToCont new Flags new FileNumber,FieldNum,SubFileNum new FieldFlags new tmgFDA,TMGFDA,TMGMsg new index new IENS set IENS=$get(Data(0,cParentIENS)) new FDAIndex new MarkerArray new MsgArray ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI") if $get(RecNum)=0 set result=cAbort goto OWQuit set FileNumber=Data(0,cFile) set Flags="KE" ;"E=External format values; K=Func locks file during use. set IENS=$get(Data(0,cParentIENS)) new MarkNum set MarkNum=0 ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"RecNum=",RecNum) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("Data") set result=$$SetupFDA(.Data,.tmgFDA,IENS,"?",.MarkNum,.MsgArray,0,RecNum) if result=cAbort goto OWQuit set FileNum=$get(Data(0,cFile),0) if FileNum=0 set result=cAbort goto OWQuit ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master MsgArray") ;"if TMGDEBUG do ArrayDump^TMGDEBUG("MsgArray") ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is master tmgFDA") ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("tmgFDA") ;"zwr tmgFDA(*) if $data(tmgFDA)=0 do goto OWPast ;"This can happen with single records with NoOverwrite flag . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"No data to file with fileman, so skipping.") set FDAIndex=FileNum kill TMGFDA merge TMGFDA(FDAIndex)=tmgFDA(FDAIndex) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing "_FDAIndex_" part of tmgFDA") ; set Flags="E" ;"E=External format values ; ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is the TMGFDA to pass to FILE^DIE") ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGFDA") ;"zwr TMGFDA(*) ; ;"====================================================== ;"Call FILE^DIE ;"====================================================== if $data(TMGFDA)=0 set result=cAbort quit ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE") do . new $etrap set $etrap="do ErrTrp^TMGDBAPI" . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, FILE^DIE is for working with records that already exist.") . set ^TMP("TMG",$J,"ErrorTrap")=result . set ^TMP("TMG",$J,"Caller")="FILE^DIE" . do FILE^DIE(Flags,"TMGFDA","TMGMsg") . set result=^TMP("TMG",$J,"ErrorTrap") . kill ^TMP("TMG",$J,"ErrorTrap") . kill ^TMP("TMG",$J,"Caller") ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::FILE^DIE") ;"====================================================== ;"====================================================== ;" if $data(TMGMsg("DIERR")) do goto OWQuit . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . set result=cAbort if result=cAbort goto OWQuit kill tmgFDA(FDAIndex) set FDAIndex="" ;"I don't want to loop through rest of tmgFDA, will handle below. OWPast set result=$$HandleHacksArray^TMGDBAPI(.MsgArray) if result=cAbort do ShowError^TMGDEBUG(.PriorErrorFound,"Error in writing record") goto OWQuit ;"Now we handle possible subfile entries. Info regarding these is in MsgArray if $data(MsgArray(cRef))'=0 do . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Handling subfile entries.") . set SubFileNum=$order(MsgArray(cRef,"")) . for do quit:(+SubFileNum=0)!(result=cAbort) . . if +SubFileNum=0 quit . . new SubData,DataP . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"SubFileNum="_SubFileNum) . . set DataP=MsgArray(cRef,SubFileNum) . . merge SubData=@DataP . . set SubData(0,cParentIENS)=RecNum_","_IENS . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Sub IENS="_RecNum_","_IENS) . . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"DataP="_DataP) . . set result=$$UploadData^TMGDBAPI(.SubData) . . set SubFileNum=$order(MsgArray(cRef,SubFileNum)) OWQuit ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"OverwriteRec^TMGDBAPI") quit result GetFileNum(FileName) ;"Purpose: Convert a file name into a file number ;"Input: The name of a file ;"Result: The filenumber, or 0 if not found. ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI") new result set result=0 if $get(FileName)="" goto GtFlNumDone ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'") if FileName=" " do goto GtFlNumDone . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!") . set result=0 set DIC=1 ;"File 1=Global file reference (the file listing info for all files) set DIC(0)="M" set X=FileName ;"i.e. "AGENCY" do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY" ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y) set result=$piece(Y,"^",1) if result=-1 set result=0 GtFlNumDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileNum^TMGDBAPI") quit result GetFName(FileNumber) ;"Purpose: Convert a file number into a file name ;"Input: The number of a file ;"Result: The file name, or "" if not found. ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI") new result set result="" if $get(FileNumber)=0 goto GtFlNumDone ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Number='"_FileNumber_"'") set result=$get(^DIC(FileNumber,0)) if (result="")&(FileNumber[".") do . set result=$get(^DD(FileNumber,0)) set result=$piece(result,"^",1) GtFNmDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFileName^TMGDBAPI") quit result GetFldName(File,FieldNumber) ;"Purpose: Convert a field number into a field name ;"Input: File -- name or number of file ;" FieldNumber -- the number of the field to convert ;"Result: The field name, or "" if not found. ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI") new result set result="" new array do GetFieldInfo^TMGDBAPI(.File,.FieldNumber,"array","LABEL") set result=$get(array("LABEL")) GFldNmDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"GetFldName^TMGDBAPI") quit result GetFldList(File,pArray) ;"Purpose: Get list of all fields for a file. ;"Input: File -- File name or number to look query. May be a sub file number ;" pArray -- pointer to (i.e. name of) array to put data into ;" Any preexisting data in pArray will be killed. ;"Output: Array will be fille with info like this: ;" example: Array(.01)=""<--- shows that field .01 exists ;" Array(1)="" <--- shows that field 1 exists ;" Array(2)="" <--- shows that field 2 exists ;"Results: 1=OK to continue. 0=error new result set result=1 new FileNumber,FileName if ($get(File)="")!($get(pArray)="") set result=0 goto GFdLDone kill @pArray if +File=File do . set FileNumber=File . set FileName=$$GetFName(File) else do . set FileName=File . set FileNumber=$$GetFileNum(File) if FileNumber'>0 do goto GFdLDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, "_File_", doesn't exist.") . set result=0 new index set index=$order(^DD(FileNumber,0)) if +index>0 for do quit:(+index'>0) . set @pArray@(index)="" . set index=$order(^DD(FileNumber,index)) GFdLDone quit result SetupFileNum(Data) ;"Purpose: To Ensure that Data(0,cFile) contains valid file number ;"Input: Data-- should be passed by reference, Array setup by GetRInfo ;" Specifically, Data(0,cFile) should have file name OR number ;"Output: Data is changed: ;" Data(0,cFile)=FileNumber ;" Data(0,cFile,cGlobal)=Global reference name ;i.e. "^VA(200)" ;" Data(0,cFile,cGlobal,cOpen)=Open Global reference name ;i.e. "^VA(200," ;"Returns: If should continue execution: 1=OK to continue. 0=abort. if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 new cOKToCont set cOKToCont=1 new cAbort set cAbort=0 new cFile set cFile="FILE" ;"File" new cGlobal set cGlobal="GLOBAL" new cOpen set cOpen="OPEN" new result set result=cOKToCont new FileNumber,FileName,File ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI") ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here is Data passed to SetupFileNum") ;"if TMGDEBUG do ArrayDump^TMGDEBUG("Data") ;"zwr Data(*) set File=$get(Data(0,cFile)," ") if +File'=0 do goto CKFileNum . set FileNumber=File set FileName=File ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"File Name='"_FileName_"'") if FileName=" " do goto SFNDone . do ShowError^TMGDEBUG(.PriorErrorFound,"No file specifier (either name or number) given!") . set result=cAbort ;"0=Abort ;"Note: I could replace this code with GetFileNum(FileName) ;"---------------- set DIC=1 ;"File 1=Global file reference (the file listing info for all files) set DIC(0)="M" set X=FileName ;"i.e. "AGENCY" do ^DIC ;"lookup filename Result comes back in Y ... i.e. "4.11^AGENCY" ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"lookup for filename '"_FileName_"' ==> "_Y) set FileNumber=$piece(Y,"^",1) ;"---------------- CKFileNum set Data(0,cFile)=FileNumber ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"Uploading to File number: "_FileNumber) ;"if $data(FileName) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"('",FileName,"' file)") if FileNumber=-1 do goto SFNDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Unable to locate file specified as #"_FileNumber_" or '"_FileName_"'.") . set result=cAbort ;"0=Abort if $$VFILE^DILFD(FileNumber)=0 do goto SFNDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Error: Requested file, #"_FileNumber_", doesn't exist.") . set result=cAbort ;"0=Abort set Global=$get(^DIC(FileNumber,0,"GL"),"INVALID") ;"^DIC is file 1/FILE set Data(0,cFile,cGlobal,cOpen)=Global ;"Convert global form of ^VA(200, into ^VA(200) new Len set Len=$length(Global) if $extract(Global,Len)="," do . set $extract(Global,Len)=")" if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(DBIndent,"The global file to access is: "_Global) set Data(0,cFile,cGlobal)=Global SFNDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"SetupFileNum^TMGDBAPI") quit result RecFind(Params) ;"Purpose: To look through a file and find matching record ;"Input -- Params(cFile)=File name or number ;" Params(FieldNumber)=LookupValue ;" Params(FieldNumber)=LookupValue ;" ;" e.g. Params(0,cFile)="PERSON CLASS" ;" Params(.01)="Physicians (M.D. and D.O.)" ;" Params(1)="Physician/Osteopath" ;" Params(2)="Family Practice" ;" ;"Note: Does not support searching based on subfile data. ;"Output -- (via results) ;"Result -- Returns record number file, OR 0 if not found if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI") if $data(cFile)=0 new cFile set cFile="FILE" if $data(cEntries)=0 new cEntries set cEntries="Entries" if $data(cMatchValue)=0 new cMatchValue set cMatchValue="MATCHVALUE" new result set result=0 new Data new RecNum new FieldNum set Data(0,cFile)=$get(Params(0,cFile)) if Data(0,cFile)="" goto RFDone if $$SetupFileNum(.Data)=0 goto RFDone set Data(0,cEntries)=1 set FieldNum=$order(Params(0)) for do quit:(+FieldNum=0) . if +FieldNum=0 quit . set Data(1,FieldNum,cMatchValue)=$get(Params(FieldNum)) . set FieldNum=$order(Params(FieldNum)) if $$GetRecMatch^TMGDBAPI(.Data,.RecNum)=0 goto RFDone set result=RecNum RFDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"RecFind^TMGDBAPI") quit result FieldCompare(TestField,dbField,Type) ;"PURPOSE: To compare two fields and return a comparison code ;"INPUT: TestField -- User input to be tested (in "external format"). **Don't pass by Ref** ;" dbField -- data from database to be tested. **Don't pass by Ref ;" Type -- (Optional) The type of data being compared: ;" "NORMAL" or "" -- Simple comparison carried out (i.e. 'if A=B') ;" "DATE" -- the two values are date/time values ;" "SSNUM"-- the two values are social security numbers ;" "SEX" -- the two values are Sex descriptors. ;" "NUMBER" -- the two values are numbers ;"Results: ;" return value = cConflict (0) if entries conflict ;" i.e. TestField="John" vs dbField="Bill" ;" return value = cFullMatch (1) if entries completely match ;" ie. TestField="John" vs dbField="John" ;" or TestField="" vs. dbField="" ;" return value = cExtraInfo (2) if entries have no conflict, but TestField has extra info. ;" i.e. TestField="John" vs. dbField="" ;" return value = cdbExtraInfo (3) if entries have no conflict, but dbField has extra info. ;" i.e. TestField="" vs. dbField="12345" ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI") if $data(cConflict)#10=0 new cConflict set cConflict=0 if $data(cFullMatch)#10=0 new cFullMatch set cFullMatch=1 if $data(cExtraInfo)#10=0 new cExtraInfo set cExtraInfo=2 if $data(cdbExtraInfo)#10=0 new cdbExtraInfo set cdbExtraInfo=3 set TestField=$get(TestField) set dbField=$get(dbField) set Type=$get(Type) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField=",TestField) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField=",dbField) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Type=",Type) new result set result=cConflict if Type="DATE" do . set TestField=$$IDATE^TIULC(TestField) . set dbField=$$IDATE^TIULC(dbField) else if Type="SSNUM" do . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Processing SSNUM's") . set TestField=$translate(TestField," /-","") ;"Clean delimiters . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField) . if TestField["P" set TestField="P" . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"TestField now=",TestField) . if dbField["P" set dbField="P" . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"dbField now=",dbField) else if Type="SEX" do . if (TestField="m")!(TestField="M") set TestField="MALE" . if (TestField="f")!(TestField="F") set TestField="FEMALE" if TestField'="" do . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$data(dbField)=",$data(dbField)) . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"$get(dbField)='' =",($get(dbField)="")) . if ($data(dbField)#10=0)!($get(dbField)="") set result=cExtraInfo . else do . . if Type="NUMBER" do . . . if +TestField=+dbField set result=cFullMatch . . else do . . . if TestField=dbField set result=cFullMatch else do ;"i.e. test case when TestField="" . if $get(dbfield)="" set result=cFullMatch . else set result=cdbExtraInfo ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"result=",result) ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"FieldCompare^TMGDBAPI") quit result EnsureWrite(File,Field,IENS,Value,Flags,MsgArray) ;"Purpose: To provide code to that will ensure that data is written to ;" the database, but it will not add duplicate records if the value ;" is already there. So a FIND is done first, and added if not found. ;" Note: This is primarly targeted at adding entries in a subfile. ;"Input: File -- File name or number ;" Field -- Field name or number ;" IENS -- standard IENS string describing IEN in File, or IEN path to subfile ;" Value -- The value to be filed ;" Flags -- Flags to be passed ;" MsgArray -- PASS BY REFERENCE. Messages to pass back out. ;"Results : 1=Writen OK, 0=Already present so not written, -1=error new result set result=-1 quit result dbWrite(FDA,Overwrite,TMGIEN,Flags,ErrArray) ;"Purpose: To provide a unified interface for writing a FDA to the database ;"Input: FDA -- PASS BY REFERENCE. A standard FDA structure. (won't be changed) ;" Overwrite -- specifies if records already exist in database ;" if = 1, then FILE^DIE used to write into pre-existing records ;" if = 0, then UPDATE^DIE used to write new records ;" TMGIEN (OPTIONAL)-- an array to receive back records added (only applies if ;" Overwrite=0) ;" It can also be used to pass info to UPDATE^DIE recarding requested record numbers ;" Flags (OPTIONAL) -- Flags to pass to UPDATE^DIE or FILE^DIE. ;" default is "E". If "E" is not wanted, then pass a " " ;" ErrArray (OPTIONAL) -- an OUT parameter to receive fileman "DIERR" results, if any ;"Results --1 if OK, or 0 if error merge ^TMG("TMP","EDDIE","FDA")=FDA ;"TEMP!! set Overwrite=$get(Overwrite,0) new TMGFDA merge TMGFDA=FDA new TMGMsg new TMGFlags set TMGFlags=$get(Flags,"E") ;"E=External values if TMGFlags=" " set TMGFlags="" if (Overwrite=1)&($get(Flags)'="") set TMGFlags=TMGFlags_"K" ;"K means filer does file locking. new result set result=1 ;"Default to success if $data(TMGFDA)=0 set result=-1 goto DBWDone set ^TMP("TMG",$J,"ErrorTrap")=result ;"====================================================== ;"====================================================== if Overwrite=1 do ;"i.e. FILE^DIE used to write into pre-existing records . new $etrap set $etrap="do ErrTrp^TMGDBAPI" . set ^TMP("TMG",$J,"Caller")="FILE^DIE" . do FILE^DIE(TMGFlags,"TMGFDA","TMGMsg") else if Overwrite=0 do ;"i.e. UPDATE^DIE used to write new records . new $etrap set $etrap="do ErrTrp^TMGDBAPI" . set ^TMP("TMG",$J,"Caller")="UPDATE^DIE" . do UPDATE^DIE(TMGFlags,"TMGFDA","TMGIEN","TMGMsg") ;"====================================================== ;"====================================================== set result=^TMP("TMG",$J,"ErrorTrap") kill ^TMP("TMG",$J,"ErrorTrap") kill ^TMP("TMG",$J,"Caller") if $data(TMGMsg("DIERR")) do . ;"TMGDEBUG=-1 --> extra quiet mode . if $get(TMGDEBUG)>-1 do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . set result=0 . merge ErrArray("DIERR")=TMGMsg("DIERR") DBWDone quit result DelIEN(File,RecNumIEN,ErrArray) ;"Purpose: To delete record# RecNumIEN from file FILE ;"Input: File -- File name or number to delete from ;" RecNumIEN -- the IEN to delete ;" ErrArray --OPTIONAL, PASS BY REFERENCE. ;" an OUT parameter to receive fileman "DIERR" results, if any ;"Output: will cause deletion from database ;"Results -- if error occured ;" cOKToCont (i.e. 1) if no error ;" cAbort (i.e. 0) if error new TMGFDA,result set result=0 if $get(File)="" goto DIENDone if +$get(RecNumIEN)'>0 goto DIENDone if +File'>0 set File=$$GetFileNum(File) set TMGFDA(File,+RecNumIEN_",",.01)="@" set result=$$dbWrite(.TMGFDA,1,,,.ErrArray) DIENDone quit result WriteWP(File,RecNumIEN,Field,TMGArray) ;"Purpose: To provide a shell around WP^DIE with error trap, error reporting ;"Note: This does not support subfiles or multiples. Does not support appending ;"Input: File: a number or name ;" RecNumIEN: The record number, in File, to use ;" Field: a name or number ;" TMGArray: The array that contains WP data. Must be in Fileman acceptible format. ;"Results -- if error occured ;" cOKToCont (i.e. 1) if no error ;" cAbort (i.e. 0) if error if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 if $data(cAbort)#10=0 new cAbort set cAbort=0 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI") new IENS new TMGMsg new FileNumber,FieldNumber new result set result=cAbort new TMGFlags set TMGFlags="K" set FileNumber=+$get(File) if FileNumber=0 set FileNumber=$$GetFileNum(.File) if FileNumber=0 do goto WWPDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert file '"_$get(File)_", to a number.") set FieldNumber=$get(Field) if FieldNumber=0 set FieldNumber=$$GetNumField^TMGDBAPI(.Field) if FieldNumber=0 do goto WWPDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Can't convert field '"_$get(Field)_", to a number.") if +$get(RecNumIEN)=0 do goto WWPDone . do ShowError^TMGDEBUG(.PriorErrorFound,"No numeric record number supplied.") set IENS=RecNumIEN_"," ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FileNumber=",FileNumber) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"IENS='",IENS,"'") ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"FieldNumber=",FieldNumber) ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Flags=",TMGFlags) ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGArray") do . ;"====================================================== . ;"Call WP^DIE . ;"====================================================== . ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE") . new $etrap set $etrap="do ErrTrp^TMGDBAPI" . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Remember, WP^DIE files WP data.") . set ^TMP("TMG",$J,"ErrorTrap")=result . set ^TMP("TMG",$J,"Caller")="WP^DIE" . do WP^DIE(FileNumber,IENS,FieldNumber,TMGFlags,"TMGArray","TMGMsg") . set result=^TMP("TMG",$J,"ErrorTrap") . kill ^TMP("TMG",$J,"ErrorTrap") . kill ^TMP("TMG",$J,"Caller") . ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"TMGDBAPI::WP^DIE") . ;"====================================================== . ;"====================================================== if $data(TMGMsg("DIERR"))'=0 do goto WWPDone . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . set result=cAbort set result=cOKToCont ;"zbreak WWPDone WWPDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"WriteWP^TMGDBAPI") quit result ReadWP(File,IENS,Field,Array) ;"Purpose: To provide a shell for reading a WP with error trap, error reporting ;"Input: File: a number or name ;" IENS: a standard IENS (i.e. "IEN,parent-IEN,grandparent-IEN,ggparent-IEN," etc. ;" Note: can just pass a single IEN (without a terminal ",") ;" Field: a name or number ;" Array: The array to receive WP data. PASS BY REFERENCE ;" returned In Fileman acceptible format. ;" Array will be deleted before refilling ;"Results -- if error occured ;" cOKToCont (i.e. 1) if no error ;" cAbort (i.e. 0) if error if $data(TMGDEBUG)#10=0 new TMGDEBUG set TMGDEBUG=0 if $data(cOKToCont)#10=0 new cOKToCont set cOKToCont=1 if $data(cAbort)#10=0 new cAbort set cAbort=0 ;"if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI") new FileNumber,FieldNumber new TMGWP,temp new result set result=cOKToCont if $get(IENS)="" do goto RWPDone . do ShowError^TMGDEBUG(.PriorErrorFound,"Valid IENS not supplied.") if $extract(IENS,$length(IENS))'="," set IENS=IENS_"," if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=cAbort goto RWPDone set temp=$$GET1^DIQ(FileNumber,IENS,FieldNumber,"","TMGWP","TMGMsg") if $data(TMGMsg) do . ;"if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Here are TMGMsg entries") . ;"if $get(TMGDEBUG)>0 do ArrayDump^TMGDEBUG("TMGMsg") . if $data(TMGMsg("DIERR"))'=0 do quit . . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . . set result=cAbort if result=cAbort goto RWPDone kill Array merge Array=TMGWP RWPDone ;"if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"ReadWP^TMGDBAPI") quit result ShowIfError(TMGMsg,PriorErrorFound) ;"Purpose: to show DIERR if preesnt in pTMGMsg ;"Input: pTMGMsg -- PASS BY REFERENCE, holds message route, as set up by Fileman ;" PriorErrroFound -- OPTIONAL, a variable holding if a prior error has been found ;"Output: 1 if ERROR found, 0 otherwise new result set result=0 if $data(TMGMsg("DIERR"))'=0 do . do ShowDIERR^TMGDEBUG(.TMGMsg,.PriorErrorFound) . set result=1 quit result DataImport(Info,ProgressFN) ;"Purpose: to provide a generic loading utility. ;" Note: this is more specific than code found in DDMP.m ;"Assumptions: that all data for one record is found on one line, with a given ;" number of columns for each field. ;"Input: Info, an array with relevent info. PASS BY REFERENCE ;" Format as follows: ;" Info("HFS DIR")= ;" Info("HFS FILE")= ;" Info("DEST FILE")= ;" Info(x)=field# (or "IEN" if data should be used to determine record number ;" Info(x,"START")=starting column ;" Info(x,"END")=ending column ;" ProgressFN: optional. If not "", then this will be XECUTED after each line ;"Result: 1 if OK to continue, 0 if error ;"Note: input Data array will be formated like this: ;" Data(0,cFile)="1234.1" <-- "NEW PERSON" Note conversion ;" Data(0,cFile,cGlobal)="^DIC(200)" <-- note, NOT "^DIC(200," ;" Data(0,cRecNum)=2 <-- only if user-specified. ;" Data(0,cEntries)=1 ;" Data(1,".01")="MyData1" ;" Data(1,".01",cMatchValue)="MyData1" ;" Data(1,".02")="Bill" ;" Data(1,".02",cMatchValue)="John" ;" Data(1,".03")="MyData3" ;" Data(1,".04")="MyData4" ;" Data(1,".06")="MyData5" <-- note "NAME" was converted to ".06" ;" Data(1,".07",0,cEntries)=2 <-- "ITEM" converted to ".07" ;" Data(1,".07",1,".01")="SubEntry1" ;" Data(1,".07",1,".02")="SE1" ;" Data(1,".07",1,".03")="'Some Info'" ;" Data(1,".07",2,".01")="SubEntry2" ;" Data(1,".07",2,".02")="SE2" ;" Data(1,".07",2,".04",0,cEntries)=1 ;"TEXT converted to .04 ;" Data(1,".07",2,".04",1,".01")="JD" ;" Data(1,".07",2,".04",1,".02")="DOE,JOHN" ;" ADDENDUM ;" Data(1,".01",cFlags)=any flags specified for given field. ;" only present if user specified. new cFile set cFile="FILE" new cRecNum set cRecNum="RECNUM" new result set result=1 new GRef set GRef=$name(^TMP("TMG","DATAIMPORT",$J)) new GRef1 set GRef1=$name(@GRef@(1)) ;"I have to use this to load file kill @GRef new result new dir set dir=$get(Info("HFS DIR")) new HFSfile set HFSfile=$get(Info("HFS FILE")) set result=$$FTG^%ZISH(dir,HFSfile,GRef1,4) if result=0 goto DIDone new file set file=$get(Info("DEST FILE")) if +file=0 set file=$$GetFileNum(file) new index set index=$order(@GRef@("")) for do quit:(+index=0)!(result=0) . new RecData,FDA . set RecData(0,cFile)=file . new line set line=$get(@GRef@(index)) . new fields set fields=$order(Info("")) . new IEN set IEN="" . for do quit:(+fields=0)!(result=0) . . new fieldNum set fieldNum=$get(Info(fields)) ;"could be number or 'IEN' . . new oneField . . set oneField=$extract(line,$get(Info(fields,"START")),$get(Info(fields,"END"))) . . set oneField=$$Trim^TMGSTUTL(oneField) . . if fieldNum="IEN" do . . . set RecData(0,cRecNum)=fieldNum . . . set IEN=fieldNum . . else do . . . set RecData(1,fieldNum)=oneField . . set fields=$order(Info(fields)) . new MarkNum set MarkNum=0 . new MsgArray . set result=$$SetupFDA(.RecData,.FDA,,"+",.MarkNum,.MsgArray,IEN) . if result=0 quit . set result=$$dbWrite(.FDA,0,," ") . if result=0 quit . if $get(ProgressFN)'="" do . . new $etrap set $etrap="w ""??Progress function -- error trapped??"",!" . . xecute ProgressFN . set index=$order(@GRef@(index)) DIDone kill @GRef quit result Set1(File,IEN,Field,Value,Flag) ;"Purpose: to be the reverse of GET1^DIQ (i.e. a setter instead of a getter) ;" It will set the value for 1 field in 1 record in 1 file. ;" Note: only to be used in existing files. ;"Input: File -- the Filename or number ;" IEN -- the record number to set into ;" Field -- the field name or number ;" Value -- the value to set it to (WP not currently supported) ;" Flag -- OPTIONAL. Combinations of below: ;" 'I' -- values are in internal format ;" 'E' -- values are in external format (this is the DEFAULT) ;"Results: 1 if OKtoCont, 0 if error new FileNumber,FieldNumber new result set result=0 ;"default to error ;"new tempDebug set tempDebug=$get(TMGDEBUG) ;"set TMGDEBUG=-1 ;"Extra quiet mode if $$SetFileFldNums^TMGDBAPI(.File,.Field,.FileNumber,.FieldNumber)=0 goto S1Done if (+FileNumber=0)!(+FieldNumber=0) goto S1Done if ($get(Value)="")!(+IEN=0) goto S1Done new result set result=1 ;"default to success. new TMGFDA,FMFlag,TMGMSG set FMFlag="E" if $get(Flag)["I" set FMFlag="" set FMFlag=FMFlag_"K" set TMGFDA(FileNumber,IEN_",",FieldNumber)=Value do FILE^DIE(FMFlag,"TMGFDA","TMGMSG") if $data(TMGMSG("DIERR"))'=0 do goto S1Done . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) S1Done ;"set TMGDEBUG=tempDebug quit result GetValidInput(File,Field) ;"Purpose: Gets a valid input for field in file, asking user from console ;"Input: File: File number or name of file to use ;" Field: Field number or name in file. ;"Results: returns valid input, or "" new FileNum,FldNum new DIR,X,Y set Y="" set FileNum=+$get(File) if FileNum=0 set FileNum=$$GetFileNum^TMGDBAPI(.File) if FileNum=0 goto GVIDone set FldNum=$get(Field) if FldNum=0 set FldNum=$$GetNumField^TMGDBAPI(FileNum,.Field) if FldNum=0 goto GVIDone set DIR(0)=FileNum_","_FldNum do ^DIR write ! GVIDone quit Y AskFIENS() ;"Purpose: Ask user to pick a file number, then pick a record ;" from that file. This supports selection of subfiles. ;"Input: none ;"Results: format-- File^IENS, or ^ if abort new result set result="^" new DIR,X,Y set DIR(0)="F" set DIR("A")="Select FILE (or SUBFILE)" set DIR("?")="Answer with FILE NUMBER or NAME, or SUBFILE NUMBER" set DIR("PRE")="D ASKSCRN^TMGDBAPI" do ^DIR set Y=+Y if Y>0 set result=Y_"^"_$$AskIENS(Y) quit result ASKSCRN ;"Purpose: an Input transform for AskFIENS ;"Input: (global) X -- the user's response in ^DIR ;" (global) DTOUT -- this will be defined if the read timed out. ;"Output: If X is changed, it will be as if user entered in new X ;" If X is killed, it will be as if user entered an illegal value. if $data(DTOUT) quit if +X=X do . if $data(^DD(X,0))=0 kill X quit . if $data(^DIC(X,0)) write " ",$piece(^DIC(X,0),"^",1)," " quit . ;"Here we deal with subfiles . new temp,i,filenum . set filenum=X . set X="" . for i=100:-1:0 do quit:(filenum=0) . . set temp(i)=filenum . . set X=X_filenum_"," . . set filenum=+$get(^DD(filenum,0,"UP")) . new indent set indent=5 . new indentS set $piece(indentS," ",75)=" " . write ! . set i="" . for set i=$order(temp(i)) quit:(i="") do . . set filenum=+$get(temp(i)) quit:(filenum=0) . . write $extract(indentS,1,indent) . . if $data(^DIC(filenum,0)) do . . . write $piece(^DIC(filenum,0),"^",1)," (FILE #",filenum,")",! . . else write "+--SUBFILE# ",filenum,! . . set indent=indent+3 else do ;"check validity of FILE NAME . if X="" quit . new filenum . set filenum=$order(^DIC("B",X,"")) . if +filenum>0 set X=+filenum_"," quit . set filenum=$$GetFileNum(X) . if +filenum>0 set X=+filenum_"," quit . new DIC,Y . set DIC=1 set DIC(0)="EQM" . do ^DIC w ! . if +Y>0 set X=+Y quit . set X=0 if $get(X)="" set X=0 quit AskIENS(FileNum,IENS) ;"Purpose: To ask user to select a record in File indicated by FileNum. ;" If FileNum is a subfile number, then the user will be asked ;" for records to drill down to desired record, and return values ;" as an IENS. ;"Input: FileNum: A file number or subfile number ;" IENS: OPTIONAL. Allows for supplying a partial IENS supplying a ;" partial path. E.g. if a full IENS to FileNum ;" would be '2,3,4455,' and if the IENS supplied is ;" '3,4455,' then only the missing IEN (in this case 2) ;" would be asked. ;"Results: Returns IENS. format: IEN in file,IEN in parentfile,IEN in grandparentfile, ... , ;" Note: IENS will contain '?' if there is a problem, ;" or "" if FileNum is invalid new array do GetRefArray(FileNum,.array) new resultIENS set resultIENS="" set IENS=$get(IENS) new DANum set DANum=1 new TMGDA,numIENS set numIENS=$length(IENS,",") new i,abort set i="",abort=0 for set i=$order(array(i),-1) quit:(i="")!abort do . new DIC,X,Y,DA . new tempIEN set tempIEN=+$piece(IENS,",",numIENS-DANum) . if tempIEN'>0 do . . set DIC=$get(array(i,"GL")),DIC(0)="AEQM" . . if DIC'="" write !,"Select entry in file# ",array(i,"FILE NUM") . . do ^DIC write ! . else set Y=tempIEN . if +Y'>0 set resultIENS="?,"_resultIENS,abort=1 quit . set TMGDA(DANum)=+Y,DANum=DANum+1 . set resultIENS=+Y_","_resultIENS write "#: ",resultIENS,! quit resultIENS GetRefArray(FileNum,array) ;"Purpose: To return an array containing global references that can ;" be passed to ^DIC, for given file or subfile number ;"Input: FileNum: A file number or subfile number ;" array: PASS BY REFERENCE. See format below ;"Results: none, but array is filled with result. Format (example): ;" array(1,"FILE NUM")=2.011 <--- sub sub file ;" array(1,"GL")="^DPT(TMGDA(1),""DE"",TMGDA(2),""1""," ;" array(2,"FILE NUM")=2.001 <---- sub file ;" array(2,"GL")="^DPT(TMGDA(1),""DE""," ;" array(3,"FILE NUM")=2 <---- parent file ;" array(3,"GL")="^DPT(" ;"Note: To use the references stored in "GL", then the IEN for ;" each step should be stored in TMGDA(x) new i for i=1:1 quit:(+$get(FileNum)=0) do . set array(i,"FILE NUM")=FileNum . if $data(^DD(FileNum,0,"UP")) do . . new parentFlNum,field . . set parentFlNum=+$get(^DD(FileNum,0,"UP")) . . if parentFlNum=0 quit ;"really should be an abort . . set field=$order(^DD(parentFlNum,"SB",FileNum,"")) . . if field="" quit ;"really should be an abort . . new node set node=$piece($piece($get(^DD(parentFlNum,field,0)),"^",4),";",1) . . set array(i,"NODE IN PARENT")=node . else do . . set array(i,"GL")=$get(^DIC(FileNum,0,"GL")) . set FileNum=+$get(^DD(FileNum,0,"UP")) set i="" set i=$order(array(i),-1) set array(i,"ref")=$get(array(i,"GL"))_"TMGDA(1)," new DANum set DANum=2 for set i=$order(array(i),-1) quit:(i="") do . new ref . set ref=$get(array(i+1,"ref"))_""""_$get(array(i,"NODE IN PARENT"))_"""," . kill array(i+1,"ref"),array(i,"NODE IN PARENT") . set array(i,"GL")=ref . set array(i,"ref")=ref_"TMGDA("_DANum_")," . set DANum=DANum+1 kill array(1,"ref") quit FIENS2Root(FIENS) ;"Purpose: to convert a Files^IENS string into a root reference ;"Input: FIENS: format: FileNumber^StandardIENS ;"Output: A global root in open format quit GetRef(file,IENS,field) ;"Purpose: to return the global reference for a given record ;"Input: file -- File or subfile number ;" IENS -- an IEN, or an IENS for record ;" field -- OPTIONAL. ;"Results: if field is NOT supplied, or ;" OPEN global ref ;" if field IS supplied ;" CLOSED global ref@piece ;" e.g. ^TMG(22706.9,3,2,IEN,0)@1 <-- note 'IEN' placeholder ;"Note: This function really needs to be fleshed out some more... ;"Note: this only will work for normal files, or subfiles ONE (1) level deep... new ref set ref="" new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file) if parentFile=0 goto GRF1 ;"handle non-subfiles separately. set fieldInParent=$piece(parentFile,"^",2) set ref=$get(^DIC(+parentFile,0,"GL")) new IENinParent set IENinParent=$piece(IENS,",",2) set ref=ref_IENinParent_"," new storeLoc set storeLoc=$piece($get(^DD(+parentFile,fieldInParent,0)),"^",4) ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this... set ref=ref_+storeLoc_"," new IENinSubRec set IENinSubRec=$piece(IENS,",",1) if IENinSubRec="" set IENinSubRec="IEN" set ref=ref_IENinSubRec_"," if $get(field)="" goto GRF2 ;"done set storeLoc=$piece($get(^DD(file,field,0)),"^",4) set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2) goto GRF2 GRF1 set ref=$get(^DIC(file,0,"GL")) set ref=ref_+IENS_"," if $get(field)="" goto GRF2 ;"done new storeLoc set storeLoc=$piece($get(^DD(file,field,0)),"^",4) set ref=ref_+storeLoc_")@"_$piece(storeLoc,";",2) ;"Note: works only with storeLoc in Node;Piece format... not all fields follow this... GRF2 quit ref TrimFDA(FDA,Quiet) ;"Purpose: To take an FDA, and compare it to data already present in the ;" record specified by the FDA. If any values already in the record ;" match those in the FDA, then those entries will be removed from the ;" FDA array. ;"Input: FDA -- PASS BY REFERENCE. A standard Fileman FDA. ;" Quiet -- OPTIONAL. If 1, then error messages will be supressed ;" (These would be messages generated on READING existing ;" data, not writing new data.) ;" default value=1 ;"Output: Values from FDA may be removed. ;"Results: final IENS (i.e. '+1,3,' --> '5,3,' if prev value found) ;"Note: match will be made base on INTERNAL, or EXTERNAL forms ;"Note: Fields should be specified by numbers, NOT NAMES. new tempIENS set tempIENS="" if $data(FDA)'>0 goto TFDDone new TMGDATA,TMGMSG new file,IENS set file=$order(FDA("")) set IENS=$order(FDA(file,"")) set tempIENS=IENS set Quiet=$get(Quiet,1) new fieldsS set fieldsS="" new field set field="" for set field=$order(FDA(file,IENS,field)) quit:(field="") do . set fieldsS=fieldsS_field_";" new parentFile set parentFile=$$IsSubFile^TMGDBAPI(file) if parentFile=0 goto TFD0 ;"handle non-subfiles separately. ;"e.g. FDA(22706.9001,"+1,3",.01)=1 ;" FDA(22706.9001,"+1,3",.02)=2 ;"Note: The .01 field is used to find a matching subrecord, which is then ;" check for preexisting data. If multiple matches for .01 are found, ;" then the process is aborted, and the FDA will NOT BE TRIMMED. set $piece(tempIENS,",",1)="" ;"leave first piece blank in IENS new value set value=$get(FDA(file,IENS,.01)) ;"new i for i=1:1:$length(fieldsS,",") do ;"append 'E' to each field number ;". new field set field=$piece(fieldsS,";",i) ;". set field=field_"E" ;". set $piece(fieldsS,";",i)=field ;" ;"new TMGFIND ;" ;"I can't get this part to work... so will work around ;"do FIND^DIC(file,tempIENS,fieldsS,"BMU",value,"*",,,,"TMGFIND","TMGMSG") ;"do ShowIfDIERR^TMGDEBUG(.TMGMSG) ;"if +$get(TMGFIND(0))'=1 goto TFDDone ;"abort ;"merge TMGDATA(file,IENS)=TMGDATA("ID",1) ;"goto TFD1 new ref set ref=$$GetRef(file,tempIENS,.01) ;"returns ref with 'IEN' built in... new ref2 set ref2=$$CREF^DILF($piece(ref,"IEN",1)) new ref3 set ref3=$piece(ref,"@",1) new p set p=$piece(ref,"@",2) new found set found=0 new IEN set IEN=0 for set IEN=$order(@ref2@(IEN)) quit:(+IEN'>0)!(found>0) do . new valueFound set valueFound=$piece($get(@ref3),"^",p) . if valueFound=value set found=IEN if found=0 set tempIENS=IENS goto TFDDone set tempIENS=found_tempIENS TFD0 do GETS^DIQ(file,tempIENS,fieldsS,"EI","TMGDATA","TMGMSG") if 'Quiet do ShowIfDIERR^TMGDEBUG(.TMGMSG) TFD1 for set field=$order(FDA(file,IENS,field)) quit:(field="") do . new found set found=0 . new FDAvalue set FDAvalue=$get(FDA(file,IENS,field)) . if $get(TMGDATA(file,tempIENS,field,"I"))=FDAvalue set found=1 . if $get(TMGDATA(file,tempIENS,field,"E"))=FDAvalue set found=1 . if (FDAvalue="@")&($data(TMGDATA(file,tempIENS,field))=0) set found=1 . if found=1 kill FDA(file,IENS,field) goto TFDDone TFDDone quit tempIENS GetPtrsOUT(File,Info) ;"Purpose: to get a list of pointers out from the file. ;"Input: File -- File Name or Number of file to investigate ;" Info -- PASS BY REFERENCE. An OUT PARAMETER. Format: ;" Info(Field#)=PointedToFileNum ;" Info(Field#,"GL")=an open global ref to pointed-to file ;"results: none if $get(File)="" goto GPODone if +File'=File set File=$$GetFileNum(File) new field set field=0 new done set done=0 for set field=$order(^DD(File,field)) quit:(+field'>0)!(done=1) do . new array . do FIELD^DID(File,field,"N","POINTER","array") . if $get(array("POINTER"))="" quit . if array("POINTER")[";" quit . set Info(field,"GL")=array("POINTER") . new temp set temp=$piece($get(^DD(File,field,0)),"^",2) . set temp=+$piece(temp,"P",2) . set Info(field)=temp . if $data(array) write field," " zwr array GPODone quit