' + Text2XML(TmpSL[i]) + '
'); + Data.Add(Pad + ' '); + finally + TmpSL.Free; + end; + if assigned(Fields) then + ListTemplateFields(Txt, Fields); + end; +end; + +function GetXMLFromWord(const AFileName: string; Data: TStrings): boolean; +var + itmp, itmp2, itmp3, i, j: integer; + WDoc: TWordDocument; + WasVis: boolean; + WApp: TWordApplication; + Boiler: string; + FldCache, Fields, PendingAdd: TStringList; + OldCur: TCursor; + idx, TmpVar, RangeStart, RangeEnd: oleVariant; + ddTotal, ffTotal, ffStartCur, ffEndCur, ffEndLast : integer; + ffRange, textRange: Range; + tmp, TemplateName, fName: string; + tmpType, tfIdx: TTemplateFieldType; + tmpDate: TTmplFldDateType; + + tfCount: array[TTemplateFieldType] of integer; + + procedure AddBoiler(txt: string); + var + i: integer; + c: char; + tmp: string; + + begin + tmp := ''; + for i := 1 to length(txt) do + begin + c := txt[i]; + if (c > #31) or (c = #13) or (c = #10) then + tmp := tmp + c; + end; + Boiler := Boiler + tmp; + end; + + procedure AddField(Typ: TTemplateFieldExportField; Value: string; Pending: boolean = FALSE); + var + sl: TStringList; + + begin + if Pending then + sl := PendingAdd + else + sl := Fields; + sl.Add('<' + TemplateFieldExportTag[Typ] + '>' + Text2XML(Value) + + ''); + end; + + procedure AddFieldHeader(FldType: TTemplateFieldType; First: boolean); + var + tmp: string; + + begin + tmp := '<'; + if not First then + tmp := tmp + '/'; + tmp := tmp + XMLFieldTag; + if First then + begin + fname := 'WORDFLD_' + FldNames[FldType] + '_'; + tfIdx := FldType; + tmp := tmp + ' ' + TemplateFieldExportTag[tfName] + '="' + Text2XML(fname); + end; + if not First then + tmp := tmp + '>'; + Fields.Add(tmp); + if First then + AddField(tfType, TemplateFieldTypeCodes[FldType]); + end; + + procedure WordWrap(var Str: string); + var + TmpSL: TStringList; + i: integer; + + begin + TmpSL := TStringList.Create; + try + TmpSL.Text := Str; + Str := ''; + for i := 0 to TmpSL.Count-1 do + begin + if Str <> '' then + Str := Str + CRLF; + Str := Str + WrapText(TmpSL[i], #13#10, [' ','-'], MAX_ENTRY_WIDTH); + end; + finally + TmpSL.Free; + end; + end; + +begin + for tfIdx := low(TTemplateFieldType) to high(TTemplateFieldType) do + tfCount[tfIdx] := 1; + TemplateName := ExtractFileName(AFileName); + Result := TRUE; + try + OldCur := Screen.Cursor; + Screen.Cursor := crAppStart; + try + WApp := TWordApplication.Create(nil); + try + WasVis := WApp.Visible; + WApp.Visible := FALSE; + try + WDoc := TWordDocument.Create(nil); + try + try + WApp.Connect; + TmpVar := AFileName; + {$IFDEF VER140} + WDoc.ConnectTo(WApp.Documents.Add(TmpVar, EmptyParam)); + {$ELSE} + WDoc.ConnectTo(WApp.Documents.Add(TmpVar, EmptyParam, EmptyParam, EmptyParam)); + {$ENDIF} + ffTotal := WDoc.FormFields.Count; + + if ffTotal > 3 then + StartImportMessage(TemplateName, ffTotal+1); + + if WDoc.ProtectionType <> wdNoProtection then + WDoc.Unprotect; + + Data.Add('<'+XMLHeader+'>'); + + tmp := ExtractFileExt(TemplateName); + if tmp <> '' then + begin + i := pos(tmp,TemplateName); + if i > 0 then + delete(TemplateName, i, length(tmp)); + end; + TemplateName := copy(TemplateName, 1, 60); + + if BadTemplateName(TemplateName) then + begin + tmp := copy('WordDoc ' + TemplateName, 1, 60); + if BadTemplateName(TemplateName) then + tmp := 'Imported Word Document' + else + tmp := TemplateName; + end + else + tmp := TemplateName; + Data.Add('<' + XMLTemplateTag + ' ' + TemplateExportTag[efName] + '="' + Text2XML(tmp) + '">'); + AddXMLData(Data, '', efType, TemplateTypeCodes[ttDoc], ''); + AddXMLData(Data, '', efStatus, TemplateActiveCode[TRUE], ''); + + Boiler := ''; + Fields := TStringList.Create; + try + FldCache := TStringList.Create; + try + PendingAdd := TStringList.Create; + try + ffEndCur := 0; + + for i := 1 to ffTotal do + begin + if UpdateImportMessage(i) then + begin + Result := FALSE; + Data.Clear; + break; + end; + idx := i; + ffEndLast := ffEndCur; + ffRange := WDoc.FormFields.Item(idx).Range; + ffStartCur := ffRange.Start; + ffEndCur := ffRange.End_; + + // Assign working start range for text collection: + if i = 1 then + rangeStart := 0 // Before first FormField, use start of document. + else + rangeStart := ffEndLast; // Start of new range is end of the last FormField range. + + // Assign working end range for text collection: + rangeEnd := ffStartCur; // End of new range is start of current FormField range. + + // Collect text in the range: + textRange := WDoc.Range(rangeStart, rangeEnd); + textRange.Select; + + AddBoiler(TextRange.text); + tfIdx := dftUnknown; + fname := ''; + case WDoc.FormFields.Item(idx).type_ of + wdFieldFormTextInput: + begin + itmp3 := WDoc.FormFields.Item(idx).TextInput.Type_; + case itmp3 of + wdNumberText: tmpType := dftNumber; + wdDateText, wdCurrentDateText, wdCurrentTimeText: tmpType := dftDate; + else tmpType := dftEditBox; + end; + AddFieldHeader(tmpType, TRUE); + tmpDate := dtUnknown; + tmp := WDoc.FormFields.Item(idx).TextInput.Default; + case itmp3 of + wdNumberText: + begin + AddField(tfMinVal, IntToStr(-9999), TRUE); + AddField(tfMaxVal, IntToStr(9999), TRUE); + end; + + wdDateText: tmpDate := dtDate; + wdCurrentDateText: + begin + tmpDate := dtDate; + if tmp = '' then + tmp := 'T'; + end; + wdCurrentTimeText: + begin + tmpDate := dtDateTime; + if tmp = '' then + tmp := 'NOW'; + end; + else + begin + itmp2 := WDoc.FormFields.Item(idx).TextInput.Width; + itmp := itmp2; + if (itmp < 1) then + begin + itmp := length(tmp); + if itmp < 10 then + itmp := 10 + else + if itmp > 70 then + itmp := 70; + itmp2 := 240; + end + else + begin + if (itmp > 70) then + itmp := 70; + if (itmp2 > 240) then + itmp2 := 240; + end; + AddField(tfLength, IntToStr(itmp)); + AddField(tfTextLen, IntToStr(itmp2), TRUE); + end; + end; + if tmpDate <> dtUnknown then + AddField(tfDateType, TemplateFieldDateCodes[tmpDate], TRUE); + if tmp <> '' then + AddField(tfDefault, tmp); + FastAddStrings(PendingAdd, Fields); + PendingAdd.Clear; + AddFieldHeader(tmpType, FALSE); + end; + + wdFieldFormCheckBox: + begin + AddFieldHeader(dftButton, TRUE); + itmp := ord(boolean(WDoc.FormFields.Item(idx).CheckBox.Default))+1; + AddField(tfDefIdx, IntToStr(itmp)); + Fields.Add('<' + TemplateFieldExportTag[tfItems] + '>'); + Fields.Add('' + Text2XML('[ ]') + '
'); + Fields.Add('' + Text2XML('[X]') + '
'); + Fields.Add(''); + AddFieldHeader(dftButton, FALSE); + end; + + wdFieldFormDropDown: + begin + ddTotal := WDoc.FormFields.Item(Idx).DropDown.ListEntries.Count; + if(ddTotal > 0)then + begin + AddFieldHeader(dftComboBox, TRUE); + itmp := WDoc.FormFields.Item(idx).DropDown.Default; + if itmp > 0 then + AddField(tfDefIdx, IntToStr(itmp)); + + Fields.Add('<' + TemplateFieldExportTag[tfItems] + '>'); + for j := 1 to ddTotal do + begin + TmpVar := j; + tmp := WDoc.FormFields.Item(Idx).DropDown.ListEntries.Item(TmpVar).Name; + Fields.Add('' + Text2XML(tmp) + '
'); + end; + Fields.Add(''); + AddFieldHeader(dftComboBox, FALSE); + end; + end; + end; + if (Fields.Count > 0) then + begin + if tfIdx <> dftUnknown then + begin + tmp := Fields.CommaText; + j := FldCache.IndexOf(tmp); + if j < 0 then + begin + FldCache.AddObject(tmp, TObject(tfCount[tfIdx])); + j := tfCount[tfIdx]; + inc(tfCount[tfIdx]); + end + else + j := Integer(FldCache.Objects[j]); + Boiler := Boiler + TemplateFieldBeginSignature + fname + IntToStr(j) + TemplateFieldEndSignature; + end; + Fields.Clear; + end; + end; + if Result then + begin + rangeStart := ffEndCur; // Start of new range is end of last FormField range. + rangeEnd := WDoc.Range.End_; // After last FormField, use end of document. + + // Collect text in trailing range: + textRange := WDoc.Range(rangeStart, rangeEnd); + textRange.Select; + + AddBoiler(TextRange.text); + + WordWrap(Boiler); + + AddXMLList(Data, nil, '', efBoilerplate, Boiler); + + tmp := WrapText('Imported on ' + FormatFMDateTime('mmm dd yyyy hh:nn', FMNow) + + ' from Word Document: ' + AFileName, #13#10, [' '], MAX_ENTRY_WIDTH); + + AddXMLList(Data, nil, '', efDescription, tmp); + + Data.Add(''); + if FldCache.Count > 0 then + begin + Data.Add('<' + XMLTemplateFieldsTag + '>'); + for i := 0 to FldCache.Count-1 do + begin + Fields.Clear; + Fields.CommaText := FldCache[i]; + if Fields.Count > 0 then + begin + Fields[0] := Fields[0] + IntToStr(Integer(FldCache.Objects[i])) + '">'; + FastAddStrings(Fields, Data); + end; + end; + Data.Add(''); + end; + + Data.Add(''); + UpdateImportMessage(ffTotal+1); + end; + finally + PendingAdd.Free; + end; + finally + FldCache.Free; + end; + finally + Fields.Free; + end; + + except + on E:Exception do + WordImportError(E.Message); + end; + finally + TmpVar := wdDoNotSaveChanges; + WDoc.Close(TmpVar); + WDoc.Free; + end; + finally + WApp.Visible := WasVis; + end; + finally + WApp.Disconnect; + WApp.Free; + end; + finally + Screen.Cursor := OldCur; + end; + finally + StopImportMessage; + end; + if not Result then + InfoBox('Importing Word Document Canceled.','Import Canceled', MB_OK); +end; + +function WordImportActive: boolean; +begin + Result := True; + //Result := SpellCheckAvailable; spell check disabled in v19.16 +end; + +procedure UnlockAllTemplates; +var + i: integer; + +begin + if(assigned(Templates)) then + begin + for i := 0 to Templates.Count-1 do + TTemplate(Templates.Objects[i]).Unlock; + end; +end; + +function DisplayGroupToLinkType(DGroup: integer): TTemplateLinkType; +begin + Result := ltNone; + if DGroup <> 0 then + begin + if uDGroupConsults = 0 then + uDGroupConsults := DisplayGroupByName('CONSULTS'); + if uDGroupProcedures = 0 then + uDGroupProcedures := DisplayGroupByName('PROCEDURES'); + if DGroup = uDGroupConsults then + Result := ltConsult + else + if DGroup = uDGroupProcedures then + Result := ltProcedure; + end; +end; + +(*procedure ExecuteTemplateOrBoilerPlate(SL: TStrings; IEN: Integer; LType: TTemplateLinkType; + OwningForm: TForm; const CaptionText: string = ''; DocInfo: string = '');*) +procedure ExecuteTemplateOrBoilerPlate(SL: TStrings; IEN: Integer; LType: TTemplateLinkType; + OwningForm: TForm; CaptionText: string; var DocInfo: string); + +var + Template: TTemplate; + txt: string; + +begin + SetTemplateDialogCanceled(FALSE); + SetTemplateBPHasObjects(FALSE); + Template := GetLinkedTemplate(IntToStr(IEN), LType); + if assigned(Template) then + begin + if Template.IsReminderDialog then + begin + Template.ExecuteReminderDialog(OwningForm); + DocInfo := ''; + end + else + begin + if Template.IsCOMObject then + txt := Template.COMObjectText(SL.Text, DocInfo) + else + begin + txt := Template.Text; + DocInfo := ''; + end; + if(txt <> '') then + begin + CheckBoilerplate4Fields(txt, CaptionText); + SL.Text := txt; + end; + end; + end + else + begin + txt := SL.Text; + CheckBoilerplate4Fields(txt, CaptionText); + DocInfo := ''; + SL.Text := txt; + end; +end; + +(*procedure ExecuteTemplateOrBoilerPlate(var AText: string; IEN: Integer; LType: TTemplateLinkType; + OwningForm: TForm; const CaptionText: string = ''; DocInfo: string = '');*) +procedure ExecuteTemplateOrBoilerPlate(var AText: string; IEN: Integer; LType: TTemplateLinkType; + OwningForm: TForm; CaptionText: string; var DocInfo: string); + +var + tmp: TStringList; + +begin + tmp := TStringList.Create; + try + tmp.text := AText; + ExecuteTemplateOrBoilerPlate(tmp, IEN, LType, OwningForm, CaptionText, DocInfo); + AText := tmp.text; + finally + tmp.free; + end; +end; + +{ TTemplate } + +constructor TTemplate.Create(DataString: string); +var + i: TTemplateType; + Code: string[2]; + +begin + FCloning := TRUE; + try + FNodes := TStringList.Create; + FID := Piece(DataString, U, 1); + Code := Piece(DataString, U, 2); + FRealType := ttNone; + for i := FirstRealTemplateType to LastRealTemplateType do + begin + if(TemplateTypeCodes[i] = Code) then + begin + FRealType := i; + break; + end; + end; + if FRealType = ttNone then + raise ETemplateError.Create('Template has invalid Type Code of "' + Code + '"'); + FActive := (Piece(DataString, U, 3) = TemplateActiveCode[TRUE]); + FPrintName := Piece(DataString, U, 4); + FExclude := (Piece(DataString, U, 5) = '1'); + FDialog := (Piece(DataString, U, 9) = '1'); + FDisplayOnly := (Piece(DataString, U, 10) = '1'); + FFirstLine := (Piece(DataString, U, 11) = '1'); + FOneItemOnly := (Piece(DataString, U, 12) = '1'); + FHideDlgItems := (Piece(DataString, U, 13) = '1'); + FHideItems := (Piece(DataString, U, 14) = '1'); + FIndentItems := (Piece(DataString, U, 15) = '1'); + FLock := (Piece(DataString, U, 18) = '1'); + FReminderDialog := Pieces(DataString, U, 16, 17); + FReminderDialog := FReminderDialog + U + Piece(DataString, U, 25); //AGP CHANGE 24.8 + FIsReminderDialog := (ReminderDialogIEN <> ''); + FCOMObject := StrToIntDef(Piece(DataString, U, 19), 0); + FCOMParam := Piece(DataString, U, 20); + FFileLink := Piece(DataString, U, 21); + FIsCOMObject := (FCOMObject > 0); + FGap := StrToIntDef(Piece(DataString, U, 6),0); + FPersonalOwner := StrToInt64Def(Piece(DataString, U, 7),0); + case StrToIntDef(Piece(DataString, U, 8),0) of + 1: FChildren := tcActive; + 2: FChildren := tcInactive; + 3: FChildren := tcBoth; + else FChildren := tcNone; + end; + FLocked := FALSE; + finally + FCloning := FALSE; + end; +end; + +class function TTemplate.CreateFromXML(Element: IXMLDOMNode; Owner: string): TTemplate; +var + DataStr: string; + Children, Items: IXMLDOMNodeList; + Child, Item: IXMLDOMNode; + i, j, count, ItemCount: integer; + fld: TTemplateExportField; + ETag: string; + +begin + DataStr := '0'; + SetPiece(DataStr, U, 4, FindXMLAttributeValue(Element, TemplateExportTag[efName])); + SetPiece(DataStr, U, 7, Owner); + Children := Element.Get_childNodes; + try + if assigned(Children) then + begin + count := Children.Length; + for i := 0 to Count - 1 do + begin + Child := Children.Item[i]; + ETag := Child.NodeName; + for fld := low(TTemplateExportField) to high(TTemplateExportField) do + begin + if(ExportPieces[fld] > 0) and (CompareText(ETag, TemplateExportTag[fld]) = 0) then + SetPiece(DataStr, U, ExportPieces[fld], Child.Get_Text); + end; + end; + end + else + Count := 0; + Result := Create(DataStr); + Result.FCloning := TRUE; + try + if assigned(Children) then + begin + for i := 0 to Count - 1 do + begin + Child := Children.Item[i]; + ETag := Child.NodeName; + for fld := low(TTemplateExportField) to high(TTemplateExportField) do + begin + if(ExportPieces[fld] = 0) and (CompareText(ETag, TemplateExportTag[fld]) = 0) then + begin + case fld of + efBoilerplate: Result.SetBoilerplate(GetXMLWPText(Child)); + efDescription: Result.SetDescription(GetXMLWPText(Child)); + efItems: + begin + Result.GetItems; + Items := Child.Get_childNodes; + if assigned(Items) then + begin + ItemCount := Items.Length; + for j := 0 to ItemCount - 1 do + begin + Item := Items.Item[j]; + if(CompareText(Item.NodeName, XMLTemplateTag) = 0) then + Result.FItems.Add(CreateFromXML(Item, Owner)); + end; + end; + end; + end; + end; + end; + end; + end; + finally + Result.FCloning := FALSE; + end; + finally + Children := nil; + end; + Result.BackupItems; + Templates.AddObject(Result.ID, Result); +end; + +destructor TTemplate.Destroy; +begin + Unlock; + FNodes.Free; + if(assigned(FItems)) then FItems.Free; + inherited; +end; + +procedure TTemplate.AddChild(Child: TTemplate); +begin + GetItems; + if(FItems.IndexOf(Child) < 0) then + FItems.Add(Child); +end; + +procedure TTemplate.RemoveChild(Child: TTemplate); +var + idx: integer; + +begin + GetItems; + idx := FItems.IndexOf(Child); + if(idx >= 0) and CanModify then + FItems.delete(idx); +end; + +function TTemplate.GetItems: TList; +begin + if(not assigned(FItems)) then + begin + FItems := TList.Create; + FCreatingChildren := TRUE; + try + ExpandTemplate(Self); + finally + FCreatingChildren := FALSE; + end; + end; + Result := FItems; +end; + +function TTemplate.GetTemplateType: TTemplateType; +begin + Result := FRealType; + if(Result in [ttDoc, ttGroup]) and (FExclude) then + begin + case (Result) of + ttDoc: Result := ttDocEx; + ttGroup: Result := ttGroupEx; + end; + end; +end; + +function TTemplate.GetChildren: TTemplateChildren; +var + i: integer; + +begin + if((assigned(FItems)) and (not FCreatingChildren)) then + begin + Result := tcNone; + for i := 0 to FItems.Count-1 do + begin + if(TTemplate(FItems[i]).Active) then + Result := TTemplateChildren(ord(Result) or ord(tcActive)) + else + Result := TTemplateChildren(ord(Result) or ord(tcInactive)); + if(Result = tcBoth) then break; + end; + end + else + Result := FChildren; +end; + +procedure TTemplate.SetTemplateType(const Value: TTemplateType); +begin + if(GetTemplateType <> Value) and CanModify then + begin + if(Value in AllTemplateTrueTypes) then + SetRealType(Value) + else + begin + case Value of + ttDoc: begin SetExclude(FALSE); SetRealType(ttDoc); end; + ttGroup: begin SetExclude(FALSE); SetRealType(ttGroup); end; + ttDocEx: begin SetExclude(TRUE); SetRealType(ttDoc); end; + ttGroupEx: begin SetExclude(TRUE); SetRealType(ttGroup); end; + end; + end; + end; +end; + +function TTemplate.GetBoilerplate: string; +begin + Result := ''; + if FIsReminderDialog or FIsCOMObject then exit; + if(RealType in [ttDoc, ttGroup]) then + begin + if(not FBoilerPlateLoaded) then + begin + StatusText('Loading Template Boilerplate...'); + try + GetTemplateBoilerplate(FID); + FBoilerplate := RPCBrokerV.Results.Text; + FBoilerPlateLoaded := TRUE; + finally + StatusText(''); + end; + end; + Result := FBoilerplate; + end; +end; + +{ Returns the cumulative boilerplate of a groups items } +function TTemplate.ItemBoilerplate: string; +var + i, j: integer; + Template: TTemplate; + GapStr: string; + +begin + Result := ''; + if FIsReminderDialog or FIsCOMObject then exit; + if(RealType = ttGroup) then + begin + GetItems; + GapStr := ''; + if(FGap > 0) then + begin + for j := 1 to FGap do + GapStr := GapStr + CRLF; + end; + if(IndentItems) then + inc(uIndentLevel); + try + for i := 0 to FItems.Count-1 do + begin + Template := TTemplate(FItems[i]); + if(Template.Active and (Template.TemplateType in [ttDoc, ttGroup])) then + begin + if i > 0 then + Result := Result + GapStr; + Result := Result + DlgText(TTemplate(FItems[i]).FullBoilerplate, + TTemplate(FItems[i]).DialogProperties(Self)); + end; + end; + finally + if(IndentItems) then + dec(uIndentLevel); + end; + end; +end; + +{returns the complete boilerplate, including a group's items } +function TTemplate.FullBoilerplate: string; +var + Itm: string; +begin + Result := GetBoilerplate; + if FIsReminderDialog or FIsCOMObject then exit; + Itm := ItemBoilerplate; + if(Result <> '') and (Itm <> '') and (copy(Result,length(Result)-1,2) <> CRLF) then + Result := Result + CRLF; + Result := DlgText(Result, DialogProperties) + Itm; +end; + +{Sets the items boilerplate - does not affect children boilerplates of a group } +procedure TTemplate.SetBoilerplate(Value: string); +begin + if(FBoilerplate <> Value) and CanModify then + begin + with FBkup do + begin + if(FBoilerPlateLoaded and (not SavedBoilerplate) and ValidID) then + begin + BBoilerplate := FBoilerplate; + SavedBoilerplate := TRUE; + end; + end; + FBoilerplate := Value; + end; + FBoilerPlateLoaded := TRUE; +end; + +{Gets the object-expanded boilerplated text} +function TTemplate.GetText: string; +var + OldGettingDialogText: boolean; + TmpSL: TStringList; + +begin + Result := ''; + if FIsReminderDialog or FIsCOMObject then exit; + TmpSL := TStringList.Create; + try + StatusText('Expanding Boilerplate Text...'); + try + OldGettingDialogText := GettingDialogText; + if(IsDialog) then + begin + GettingDialogText := TRUE; + inc(uDlgCount); + if not OldGettingDialogText then + uIndentLevel := 0; + end; + try + TmpSL.Text := FullBoilerPlate; + if Pos('|', TmpSL.Text) > 0 then SetTemplateBPHasObjects(TRUE); + finally + if(IsDialog) then + GettingDialogText := OldGettingDialogText; + end; + GetTemplateText(TmpSL); + if(IsDialog) then + FDialogAborted := DoTemplateDialog(TmpSL, 'Template: ' + FPrintName, TemplatePreviewMode); + Result := TmpSL.Text; + finally + StatusText(''); + end; + finally + TmpSL.Free; + end; +end; + +procedure TTemplate.SetPersonalOwner(Value: Int64); +var + i: integer; + ok: boolean; + +begin + if(FPersonalOwner <> Value) then + begin + ok := CanModify; + if ok then + begin + with FBkup do + begin + if(not SavedPersonalOwner) and ValidID then + begin + BPersonalOwner := FPersonalOwner; + SavedPersonalOwner := TRUE; + end; + end; + FPersonalOwner := Value; + end; + end + else + ok := TRUE; + if ok and (Value = 0) then // No Shared Template can have personal items within it. + begin + GetItems; + for i := 0 to FItems.Count-1 do + TTemplate(FItems[i]).SetPersonalOwner(0); + end; +end; + +procedure TTemplate.AddNode(Node: Pointer); +begin + if(dmodShared.InEditor) and (FNodes.IndexOfObject(Node) < 0) then + begin + inc(NodeCount); + FNodes.AddObject(IntToStr(NodeCount),Node); + end; +end; + +procedure TTemplate.RemoveNode(Node: Pointer); +var + idx: integer; + +begin + if(dmodShared.InEditor) then + begin + idx := FNodes.IndexOfObject(Node); + if(idx >= 0) then FNodes.Delete(idx); + end; +end; + +{ Creates a new Template that looks like the old one, but with a new Owner } +{ - an example of where this is needed: when a shared template in a user's } +{ personal folder is modified, we need to create a copy of the shared } +{ template, make it a personal template, and make the changes to the copy } +function TTemplate.Clone(Owner: Int64): TTemplate; +var + i: integer; + +begin + Result := Self; + if(FPersonalOwner <> Owner) and (RealType in [ttDoc, ttGroup, ttClass]) then + begin + Result := TrueClone; + Result.FCloning := TRUE; + try + Result.FID := '0'; + GetItems; + Result.FPersonalOwner := Owner; + Result.Expanded := TRUE; + Result.GetItems; + for i := 0 to Items.Count-1 do + Result.Items.Add(Items[i]); + Result.BackupItems; + Templates.AddObject(Result.ID, Result); + finally + Result.FCloning := FALSE; + end; + end; +end; + +{ Creates a duplicate Template - used for backups and comparrisons } +function TTemplate.TrueClone: TTemplate; +var + Code, DataStr: string; + +begin + DataStr := ID+U+TemplateTypeCodes[RealType]+U+TemplateActiveCode[Active]+U+PrintName+U; + if(Exclude) then + DataStr := DataStr + '1' + else + DataStr := DataStr + '0'; + case GetChildren of + tcActive: Code := '1'; + tcInactive: Code := '2'; + tcBoth: Code := '3'; + else Code := '0'; + end; + DataStr := DataStr + U + IntToStr(Gap) + U + IntToStr(PersonalOwner) + U + Code + U + + BOOLCHAR[Dialog] + U + + BOOLCHAR[DisplayOnly] + U + + BOOLCHAR[FirstLine] + U + + BOOLCHAR[OneItemOnly] + U + + BOOLCHAR[HideDlgItems] + U + + BOOLCHAR[HideItems] + U + + BOOLCHAR[IndentItems] + U + + FReminderDialog; + SetPiece(DataStr,U,18,BOOLCHAR[Lock]); + SetPiece(DataStr,U,19,IntToStr(COMObject)); + SetPiece(DataStr,U,20,COMParam); + SetPiece(DataStr,U,21,FileLink); + Result := TTemplate.Create(DataStr); + Result.FCloning := TRUE; + try + Result.SetBoilerplate(GetBoilerplate); + Result.SetDescription(GetDescription); + finally + Result.FCloning := FALSE; + end; +end; + +function TTemplate.ItemIENs: string; +var + i: integer; + +begin + GetItems; + Result := ''; + for i := 0 to FItems.Count-1 do + Result := Result + TTemplate(FItems[i]).FID+','; +end; + +function TemplateChildrenCompare(Item1, Item2: Pointer): Integer; +begin + Result := CompareText(TTemplate(Item1).PrintName,TTemplate(Item2).PrintName); +end; + +procedure TTemplate.SortChildren; +begin + GetItems; + if (FItems.Count > 1) and CanModify then + FItems.Sort(TemplateChildrenCompare); +end; + +procedure TTemplate.BackupItems; +begin + with FBkup do + begin + if((not SavedItemIENs) and assigned(FItems)) then + begin + BItemIENs := ItemIENs; + SavedItemIENs := TRUE; + end; + end; +end; + +procedure TTemplate.SetActive(const Value: boolean); +begin + if(FActive <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedActive) and ValidID then + begin + BActive := FActive; + SavedActive := TRUE; + end; + end; + FActive := Value; + end; +end; + +procedure TTemplate.SetExclude(const Value: boolean); +begin + if(FExclude <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedExclude) and ValidID then + begin + BExclude := FExclude; + SavedExclude := TRUE; + end; + end; + FExclude := Value; + end; +end; + +procedure TTemplate.SetDialog(const Value: boolean); +begin + if(FDialog <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedDialog) and ValidID then + begin + BDialog := FDialog; + SavedDialog := TRUE; + end; + end; + FDialog := Value; + end; +end; + +procedure TTemplate.SetGap(const Value: integer); +begin + if(FGap <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedGap) and ValidID then + begin + BGap := FGap; + SavedGap := TRUE; + end; + end; + FGap := Value; + end; +end; + +procedure TTemplate.SetPrintName(const Value: string); +begin + if(FPrintName <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedPrintName) and ValidID then + begin + BPrintName := FPrintName; + SavedPrintName := TRUE; + end; + end; + FPrintName := Value; + end; +end; + +procedure TTemplate.SetRealType(const Value: TTemplateType); +begin + if(FRealType <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedRealType) and ValidID then + begin + BRealType := FRealType; + SavedRealType := TRUE; + end; + end; + FRealType := Value; + if(FFileLink <> '') and (not (FRealType in [ttDoc, ttGroup])) then + SetFileLink(''); + end; +end; + +procedure TTemplate.ClearBackup(ClearItemIENs: boolean = TRUE); +begin + with FBkup do + begin + SavedPrintName := FALSE; + SavedGap := FALSE; + SavedRealType := FALSE; + SavedActive := FALSE; + SavedDisplayOnly := FALSE; + SavedFirstLine := FALSE; + SavedOneItemOnly := FALSE; + SavedHideDlgItems := FALSE; + SavedHideItems := FALSE; + SavedIndentItems := FALSE; + SavedLock := FALSE; + SavedExclude := FALSE; + SavedDialog := FALSE; + SavedPersonalOwner := FALSE; + SavedBoilerPlate := FALSE; + SavedDescription := FALSE; + SavedReminderDialog := FALSE; + SavedCOMObject := FALSE; + SavedCOMParam := FALSE; + SavedFileLink := FALSE; + if(ClearItemIENs) then + begin + if(FExpanded) then + begin + BItemIENs := ItemIENs; + SavedItemIENs := TRUE; + end + else + SavedItemIENs := FALSE; + end; + end; +end; + +function TTemplate.Changed: boolean; +begin + Result := not ValidID; + with FBkup do + begin + if(not Result) and (SavedPrintName) then Result := (BPrintName <> FPrintName); + if(not Result) and (SavedGap) then Result := (BGap <> FGap); + if(not Result) and (SavedRealType) then Result := (BRealType <> FRealType); + if(not Result) and (SavedActive) then Result := (BActive <> FActive); + if(not Result) and (SavedDisplayOnly) then Result := (BDisplayOnly <> FDisplayOnly); + if(not Result) and (SavedFirstLine) then Result := (BFirstLine <> FFirstLine); + if(not Result) and (SavedOneItemOnly) then Result := (BOneItemOnly <> FOneItemOnly); + if(not Result) and (SavedHideDlgItems) then Result := (BHideDlgItems <> FHideDlgItems); + if(not Result) and (SavedHideItems) then Result := (BHideItems <> FHideItems); + if(not Result) and (SavedIndentItems) then Result := (BIndentItems <> FIndentItems); + if(not Result) and (SavedLock) then Result := (BLock <> FLock); + if(not Result) and (SavedExclude) then Result := (BExclude <> FExclude); + if(not Result) and (SavedDialog) then Result := (BDialog <> FDialog); + if(not Result) and (SavedPersonalOwner) then Result := (BPersonalOwner <> FPersonalOwner); + if(not Result) and (SavedReminderDialog) then Result := (BReminderDialog <> FReminderDialog); + if(not Result) and (SavedCOMObject) then Result := (BCOMObject <> FCOMObject); + if(not Result) and (SavedCOMParam) then Result := (BCOMParam <> FCOMParam); + if(not Result) and (SavedFileLink) then Result := (BFileLink <> FFileLink); + if(not Result) and (SavedBoilerplate) then Result := (BBoilerplate <> FBoilerplate); + if(not Result) and (SavedDescription) then Result := (BDescription <> FDescription); + if(not Result) and (SavedItemIENs) then Result := (BItemIENs <> ItemIENs); // Keep last + end; +end; + +procedure TTemplate.SetDescription(const Value: string); +begin + if(FDescription <> Value) and CanModify then + begin + with FBkup do + begin + if(FDescriptionLoaded and (not SavedDescription) and ValidID) then + begin + BDescription := FDescription; + SavedDescription := TRUE; + end; + end; + FDescription := Value; + end; + FDescriptionLoaded := TRUE; +end; + +function TTemplate.GetDescription: string; +begin + if(not FDescriptionLoaded) then + begin + StatusText('Loading Template Boilerplate...'); + try + LoadTemplateDescription(FID); + FDescription := RPCBrokerV.Results.Text; + finally + StatusText(''); + end; + FDescriptionLoaded := TRUE; + end; + Result := FDescription; +end; + +procedure TTemplate.SetDisplayOnly(const Value: boolean); +begin + if(FDisplayOnly <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedDisplayOnly) and ValidID then + begin + BDisplayOnly := FDisplayOnly; + SavedDisplayOnly := TRUE; + end; + end; + FDisplayOnly := Value; + end; +end; + +procedure TTemplate.SetFirstLine(const Value: boolean); +begin + if(FFirstLine <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedFirstLine) and ValidID then + begin + BFirstLine := FFirstLine; + SavedFirstLine := TRUE; + end; + end; + FFirstLine := Value; + end; +end; + +procedure TTemplate.SetHideItems(const Value: boolean); +begin + if(FHideItems <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedHideItems) and ValidID then + begin + BHideItems := FHideItems; + SavedHideItems := TRUE; + end; + end; + FHideItems := Value; + end; +end; + +procedure TTemplate.SetIndentItems(const Value: boolean); +begin + if(FIndentItems <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedIndentItems) and ValidID then + begin + BIndentItems := FIndentItems; + SavedIndentItems := TRUE; + end; + end; + FIndentItems := Value; + end; +end; + +procedure TTemplate.SetOneItemOnly(const Value: boolean); +begin + if(FOneItemOnly <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedOneItemOnly) and ValidID then + begin + BOneItemOnly := FOneItemOnly; + SavedOneItemOnly := TRUE; + end; + end; + FOneItemOnly := Value; + end; +end; + +procedure TTemplate.SetHideDlgItems(const Value: boolean); +begin + if(FHideDlgItems <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedHideDlgItems) and ValidID then + begin + BHideDlgItems := FHideDlgItems; + SavedHideDlgItems := TRUE; + end; + end; + FHideDlgItems := Value; + end; +end; + +function TTemplate.DlgID: string; +begin + Result := IntToStr(StrToIntDef(FID, 0)); + if(Result = '0') then + begin + if(FLastDlgCnt <> uDlgCount) then + begin + FLastDlgCnt := uDlgCount; + inc(uUniqueIDNum); + FLastUniqueID := uUniqueIDNum; + end; + Result := '-' + inttostr(FLastUniqueID); + end; +end; + +function TTemplate.DialogProperties(Parent: TTemplate = nil): string; +var + Show, ToggleItems: boolean; + bGap: integer; + GroupIdx: string; + +begin + GroupIdx := '0'; + bGap := 0; + if(assigned(parent)) then + begin + Show := ((not Parent.HideDlgItems) or (Parent.Boilerplate = '')); +// if(Parent.Boilerplate <> '') and (Parent.OneItemOnly) then + if(Parent.OneItemOnly) then + GroupIdx := Parent.DlgID; + if(Parent.RealType = ttGroup) then + bGap := Parent.Gap; + end + else + Show := TRUE; + + ToggleItems := ((HideDlgItems) and (Boilerplate <> '')); + + Result := BOOLCHAR[DisplayOnly] + + BOOLCHAR[FirstLine] + + BOOLCHAR[Show] + + BOOLCHAR[ToggleItems] + + IntToStr(bGap) + // Depends on Gap being 1 character in length + ';' + GroupIdx + ';' + DlgID; + if(assigned(Parent)) then + SetPiece(Result, ';', 4, Parent.DlgID); + SetPiece(Result,';',5, inttostr(uIndentLevel)); +end; + +function TTemplate.GetDialogAborted: boolean; +begin + Result := FDialogAborted; + FDialogAborted := FALSE; +end; + +function TTemplate.IsDialog: boolean; +begin + Result := (FDialog and (FRealType = ttGroup)); +end; + +function TTemplate.CanExportXML(Data, Fields: TStringList; IndentLevel: integer = 0): boolean; +var + Pad, Tmp: string; + i: integer; + +begin + if BadTemplateName(PrintName) then + begin + InfoBox('Can not export template.' + CRLF + 'Template has an invalid name: ' + + PrintName + '.' + BadNameText, 'Error', MB_OK or MB_ICONERROR); + Result := FALSE; + exit; + end; + Result := TRUE; + Pad := StringOfChar(' ',IndentLevel); + Data.Add(Pad + '<' + XMLTemplateTag + ' ' + TemplateExportTag[efName] + '="' + Text2XML(PrintName) + '">'); + AddXMLData(Data, Pad, efBlankLines, IntToStr(Gap), '0'); + if(RealType in AllTemplateRootTypes) then + Tmp := TemplateTypeCodes[ttClass] + else + Tmp := TemplateTypeCodes[RealType]; + AddXMLData(Data, Pad, efType, Tmp, ''); + AddXMLData(Data, Pad, efStatus, TemplateActiveCode[Active], ''); + AddXMLBool(Data, Pad, efExclude, Exclude); + AddXMLBool(Data, Pad, efDialog, Dialog); + AddXMLBool(Data, Pad, efDisplayOnly, DisplayOnly); + AddXMLBool(Data, Pad, efFirstLine, FirstLine); + AddXMLBool(Data, Pad, efOneItemOnly, OneItemOnly); + AddXMLBool(Data, Pad, efHideDialogItems, HideDlgItems); + AddXMLBool(Data, Pad, efHideTreeItems, HideItems); + AddXMLBool(Data, Pad, efIndentItems, IndentItems); + AddXMLBool(Data, Pad, efLock, Lock); + AddXMLList(Data, Fields, Pad, efBoilerplate, GetBoilerplate); + AddXMLList(Data, Fields, Pad, efDescription, GetDescription); + GetItems; + if(FItems.Count > 0) then + begin + Data.Add(Pad + ' <' + TemplateExportTag[efItems] + '>'); + for i := 0 to FItems.Count-1 do + begin + Result := TTemplate(FItems[i]).CanExportXML(Data, Fields, IndentLevel + 4); + if(not Result) then exit; + end; + Data.Add(Pad + ' '); + end; + Data.Add(Pad + ''); +end; + +procedure TTemplate.UpdateImportedFieldNames(List: TStrings); +const + SafeCode = #1 + '^@^' + #2; + SafeCodeLen = length(SafeCode); + +var + i, p, l1: integer; + Tag1, Tag2, tmp: string; + First, ok: boolean; + +begin + GetBoilerplate; + ok := TRUE; + First := TRUE; + for i := 0 to List.Count-1 do + begin + if(Piece(List[i],U,2) = '0') then + begin + Tag1 := TemplateFieldBeginSignature + Piece(List[i],U,1) + TemplateFieldEndSignature; + Tag2 := TemplateFieldBeginSignature + SafeCode + Piece(List[i],U,3) + TemplateFieldEndSignature; + l1 := length(Tag1); + repeat + p := pos(Tag1, FBoilerplate); + if(p > 0) then + begin + if First then + begin + ok := CanModify; + First := FALSE; + end; + if ok then + begin + tmp := copy(FBoilerplate,1,p-1) + Tag2 + copy(FBoilerplate,p+l1, MaxInt); + FBoilerplate := tmp; + end + else + p := 0; + end; + until (p = 0); + end; + if not ok then break; + end; + if ok then + begin + repeat + p := pos(SafeCode, FBoilerplate); + if(p > 0) then + delete(FBoilerplate, p, SafeCodeLen); + until (p = 0); + GetItems; + for i := 0 to FItems.Count-1 do + TTemplate(FItems[i]).UpdateImportedFieldNames(List); + end; +end; + +procedure TTemplate.SetReminderDialog(const Value: string); +begin + if(FReminderDialog <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedReminderDialog) and ValidID then + begin + BReminderDialog := FReminderDialog; + SavedReminderDialog := TRUE; + end; + end; + FReminderDialog := Value; + FIsReminderDialog := (ReminderDialogIEN <> ''); + if FIsReminderDialog and (not (LinkType in [ltNone, ltTitle])) then + SetFileLink(''); + end; +end; + +function TTemplate.ReminderDialogIEN: string; +begin + Result := Piece(FReminderDialog,U,1); + if Result = '0' then + Result := ''; +end; + +function TTemplate.ReminderDialogName: string; +begin + Result := Piece(FReminderDialog,U,2); +end; + +function TTemplate.CanModify: boolean; +begin + if(not FLocked) and ValidID and (not FCloning) then + begin + FLocked := LockTemplate(FID); + Result := FLocked; + if(not FLocked) then + begin + if(assigned(dmodShared.OnTemplateLock)) then + dmodShared.OnTemplateLock(Self) + else + ShowMsg(Format(TemplateLockedText, [FPrintName])); + end; + end + else + Result := TRUE; +end; + +function TTemplate.ValidID: boolean; +begin + Result := ((FID <> '0') and (FID <> '')); +end; + +procedure TTemplate.Unlock; +begin + if FLocked and ValidID then + begin + UnlockTemplate(FID); + FLocked := FALSE; + end; +end; + +procedure TTemplate.SetLock(const Value: boolean); +begin + if(FLock <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedLock) and ValidID then + begin + BLock := FLock; + SavedLock := TRUE; + end; + end; + FLock := Value; + end; +end; + +function TTemplate.IsLocked: boolean; +begin + Result := (FLock and (FPersonalOwner = 0)) or AutoLock; +end; + +procedure TTemplate.SetCOMObject(const Value: integer); +begin + if(FCOMObject <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedCOMObject) and ValidID then + begin + BCOMObject := FCOMObject; + SavedCOMObject := TRUE; + end; + end; + FCOMObject := Value; + FIsCOMObject := (FCOMObject > 0); + end; +end; + +procedure TTemplate.SetCOMParam(const Value: string); +begin + if(FCOMParam <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedCOMParam) and ValidID then + begin + BCOMParam := FCOMParam; + SavedCOMParam := TRUE; + end; + end; + FCOMParam := Value; + end; +end; + +procedure TTemplate.AssignFileLink(const Value: string; Force: boolean); +var + i: integer; + DoItems: boolean; + +begin + DoItems := Force; + if(FFileLink <> Value) and CanModify then + begin + with FBkup do + begin + if(not SavedFileLink) and ValidID then + begin + BFileLink := FFileLink; + SavedFileLink := TRUE; + end; + end; + FFileLink := Value; + FLinkName := ''; + if (not (LinkType in [ltNone, ltTitle])) then + SetReminderDialog(''); + if not DoItems then + DoItems := (FFileLink <> ''); + end; + if DoItems then + begin + GetItems; + for i := 0 to FItems.Count-1 do + TTemplate(FItems[i]).AssignFileLink('', TRUE); + end; +end; + +procedure TTemplate.SetFileLink(const Value: string); +begin + AssignFileLink(Value, FALSE); +end; + +//function TTemplate.COMObjectText(const DefText: string = ''; DocInfo: string = ''): string; +function TTemplate.COMObjectText(DefText: string; var DocInfo: string): string; +var + p2: string; + +begin + Result := ''; + if (FCOMObject > 0) then + begin + p2 := ''; + if (LinkType <> ltNone) and (LinkIEN <> '') then + p2 := LinkPassCode[LinkType] + '=' + LinkIEN; + Result := DefText; + GetCOMObjectText(FCOMObject, p2, FCOMParam, Result, DocInfo); + end; +end; + +function TTemplate.AutoLock: boolean; +begin + Result := FIsCOMObject; + if (not Result) and (not (RealType in AllTemplateLinkTypes)) and (LinkType <> ltNone) then + Result := TRUE; +end; + +function TTemplate.LinkType: TTemplateLinkType; +var + idx: TTemplateLinkType; + +begin + Result := ltNone; + case FRealType of + ttTitles: Result := ltTitle; + ttConsults: Result := ltConsult; + ttProcedures: Result := ltProcedure; + else + begin + for idx := succ(low(TTemplateLinkType)) to high(TTemplateLinkType) do + begin + if pos(LinkGlobal[idx], FFileLink) > 0 then + begin + Result := idx; + break; + end; + end; + end; + end; +end; + +function TTemplate.LinkIEN: string; +begin + Result := piece(FFileLink,';',1); +end; + +function TTemplate.LinkName: string; +begin + if FLinkName = '' then + FLinkName := GetLinkName(LinkIEN, LinkType); + Result := FLinkName; +end; + +procedure TTemplate.ExecuteReminderDialog(OwningForm: TForm); +var + sts: integer; + txt: string; + +begin + sts := IsRemDlgAllowed(ReminderDialogIEN); + txt := ''; + if sts < 0 then + txt := 'Reminder Dialog has been Deleted or Deactivated.' + else + if sts = 0 then + txt := 'You are not Authorized to use this Reminder Dialog in a Template' + else + ViewRemDlgTemplateFromForm(OwningForm, Self, TRUE, TRUE); + if txt <> '' then + InfoBox(txt,'Can not use Reminder Dialog', MB_OK or MB_ICONERROR); +end; + +procedure ExpandEmbeddedFields(flds: TStringList); +{07/26/01 S Monson Procedure to take a list of fields and expand it with any + embedded fields. Handles embedded field loops + (self referencing loops.)} +var + i,pos1,pos2: integer; + ifield: TTemplateField; + estring,next: string; +begin + if flds.count < 1 then + Exit; + i := 0; + repeat + ifield := GetTemplateField(flds[i],False); + if ifield <> nil then + begin + estring := ''; + case ifield.FldType of + dftText,dftComboBox,dftButton, + dftCheckBoxes,dftRadioButtons: estring := ifield.items; + dftHyperlink: estring := ifield.EditDefault; + end; + while (estring <> '') do + begin + pos1 := pos(TemplateFieldBeginSignature,estring); + if pos1 > 0 then + begin + estring := copy(estring,(pos1 + length(TemplateFieldBeginSignature)),maxint); + pos2 := pos(TemplateFieldEndSignature,estring); + if pos2 > 0 then + begin + next := copy(estring,1,pos2-1); + delete(estring,1,pos2-1+length(TemplateFieldEndSignature)); + if flds.IndexOf(next) < 0 then + flds.add(next); + end + else + estring := ''; + end + else + estring := ''; + end; + inc(i); + end + else + flds.Delete(i); + until (i > flds.count-1); +end; + +function MakeXMLParamTIU(ANoteID: string; ANoteRec: TEditNoteRec): string; +var + tmpList: TStringList; +begin + tmpList := TStringList.Create; + try + tmpList.Add(''; + HTML_POST = CRLF + ''; + +{$R *.DFM} + +var + uFrozen: Boolean; + uGraphingActivated: Boolean; + uRemoteCount: Integer; + uHTMLDoc: string; + uReportRPC: string; + uHTMLPatient: ANSIstring; + uEmptyImageList: TImageList; + uRptID: String; + uDirect: String; + ColumnToSort: Integer; + ColumnSortForward: Boolean; + +procedure TfrmLabs.RequestPrint; +var + aID : integer; +begin + aID := 0; + if CharAt(uRPTID,2) =':' then + aID := strToInt(piece(uRPTID,':',1)); + if (aID = 0) and (CharAt(uRPTID,3) =':') then + aID := StrToInt(piece(uRptID,':',1)); + if uReportType = 'M' then + begin + InfoBox(TX_NOREPORT, TX_NOREPORT_CAP, MB_OK); + Exit; + end; + if (uReportType = 'V') and (length(piece(uHState,';',2)) > 0) then + begin + if lvReports.Items.Count < 1 then + begin + InfoBox('There are no items to be printed.', 'No Items to Print', MB_OK); + Exit; + end; + if lvReports.SelCount < 1 then + begin + InfoBox('Please select one or more items from the list to be printed.', 'No Items Selected', MB_OK); + Exit; + end; + end; + {if (uReportType = 'G') and GraphFormActive then + with GraphForm do + begin + if (lvwItemsTop.SelCount < 1) and (lvwItemsBottom.SelCount < 1) then + begin + InfoBox('There are no items graphed.', 'No Items to Print', MB_OK); + Exit; + end + else + begin + mnuPopGraphPrintClick(mnuPopGraphPrint); + Exit; + end; + end; } + if uQualifierType = QT_DATERANGE then + begin // = 2 + if lstQualifier.ItemIndex < 0 then + begin + InfoBox('Please select from one of the Date Range items before printing', 'Incomplete Information', MB_OK); + end + else + PrintReports(uRptID, piece(uRemoteType,'^',4)); + end + else + if uQualifierType = 0 then + begin + if aID = 0 then InfoBox(TX_NOREPORT, TX_NOREPORT_CAP, MB_OK); + case aID of + 1: begin + InfoBox('Unable to print ''Most Recent'' report.', 'No Print Available', MB_OK); + end; + 2: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 3: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 4: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 5: begin + InfoBox('Unable to print ''Worksheet'' report.', 'No Print Available', MB_OK); + end; + 6: begin + if chtChart.Visible then PrintLabGraph; + end; + 8: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 9: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 10: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 20: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + 21: begin + PrintLabs(IntToStr(aID), piece(uRemoteType,'^',4), lstDates.ItemIEN); + end; + end; + end + else + PrintLabs(uRptID, piece(uRemoteType,'^',4), lstDates.ItemIEN); +end; + + +procedure TfrmLabs.FormCreate(Sender: TObject); +var + aList: TStrings; +begin + inherited; + PageID := CT_LABS; + uFrozen := False; + uScreenSplitMoved := False; + aList := TStringList.Create; + FastAssign(rpcGetGraphSettings, aList); + uGraphingActivated := aList.Count > 0; + aList.Free; + uRemoteCount := 0; + tmpGrid := TStringList.Create; + uLabLocalReportData := TStringList.Create; + uLabRemoteReportData := TStringList.Create; + uColumns := TStringList.Create; + uTreeStrings := TStringList.Create; + uEmptyImageList := TImageList.Create(Self); + uEmptyImageList.Width := 0; + uLocalReportData := TStringList.Create; + uRemoteReportData := TStringList.Create; + uPrevReportNode := tvReports.Items.GetFirstNode; + tvReports.Selected := uPrevReportNode; + if Patient.Inpatient then lstDates.ItemIndex := 2 else lstDates.ItemIndex := 5; + lblSingleTest.Caption := ''; + lblSpecimen.Caption := ''; + SerTest.GetHorizAxis.ExactDateTime := true; + SerTest.GetHorizAxis.Increment := DateTimeStep[dtOneMinute]; + grdLab508Manager := TGrdLab508Manager.Create; + amgrMain.ComponentManager[grdLab] := grdLab508Manager; + memo1.Visible := false; +end; + +procedure TfrmLabs.UpdateRemoteStatus(aSiteID, aStatus: string); +var + j: integer; + s: string; + c: boolean; +begin + if uUpdateStat = true then exit; //uUpdateStat also looked at in fFrame + uUpdateStat := true; + for j := 0 to frmFrame.lstCIRNLocations.Items.Count - 1 do + begin + s := frmFrame.lstCIRNLocations.Items[j]; + c := frmFrame.lstCIRNLocations.checked[j]; + if piece(s, '^', 1) = aSiteID then + begin + frmFrame.lstCIRNLocations.Items[j] := pieces(s, '^', 1, 3) + '^' + aStatus; + frmFrame.lstCIRNLocations.checked[j] := c; + end; + end; + uUpdateStat := false; +end; + +function TfrmLabs.AllowContextChange(var WhyNot: string): Boolean; +var + i: integer; +begin + Result := inherited AllowContextChange(WhyNot); // sets result = true + if Timer1.Enabled = true then + case BOOLCHAR[frmFrame.CCOWContextChanging] of + '1': begin + WhyNot := 'A remote data query in progress will be aborted.'; + Result := False; + end; + '0': if WhyNot = 'COMMIT' then + begin + with RemoteSites.SiteList do for i := 0 to Count - 1 do + if TRemoteSite(Items[i]).Selected then + if Length(TRemoteSite(Items[i]).LabRemoteHandle) > 0 then + begin + TRemoteSite(Items[i]).ReportClear; + TRemoteSite(Items[i]).LabQueryStatus := '-1^Aborted'; + TabControl1.OnChange(nil); + end; + Timer1.Enabled := false; + Result := True; + end; + end; +end; + +procedure TfrmLabs.ClearPtData; +begin + inherited ClearPtData; + Timer1.Enabled := False; + memLab.Lines.Clear; + uLabLocalReportData.Clear; + uLabRemoteReportData.Clear; + TabControl1.Tabs.Clear; + TabControl1.Visible := false; + tmpGrid.Clear; + lvReports.SmallImages := uEmptyImageList; + uLocalReportData.Clear; + uRemoteReportData.Clear; + with grdLab do + begin + RowCount := 1; + ColCount := 1; + Cells[0, 0] := ''; + end; +end; + +procedure TfrmLabs.DisplayPage; +var + i: integer; +begin + inherited DisplayPage; + frmFrame.mnuFilePrint.Tag := CT_LABS; + frmFrame.mnuFilePrint.Enabled := True; + frmFrame.mnuFilePrintSetup.Enabled := True; + memLab.SelStart := 0; + uHTMLPatient := '
| Patient: ' + Patient.Name + ' | ' + + '' + Patient.SSN + ' | ' +{ TODO -oRV -cWVEHR Long Age : Changed to use long age } + //+ 'Age: ' + IntToStr(Patient.Age) + ' | ' + + 'Age: ' + GetPatientBriefAge(Patient.DFN) + ' | ' +{} + + '
'; + HTML_POST = CRLF + ''; + +var + uRemoteCount: Integer; + uFrozen: Boolean; + uHTMLDoc: string; + uReportRPC: string; + uHTMLPatient: ANSIstring; + uRptID: String; + uDirect: String; + uEmptyImageList: TImageList; + ColumnToSort: Integer; + ColumnSortForward: Boolean; + GraphForm: TfrmGraphs; + GraphFormActive: boolean; + +procedure TfrmReports.ClearPtData; +begin + inherited ClearPtData; + Timer1.Enabled := False; + memText.Clear; + tvProcedures.Items.Clear; + lblProcTypeMsg.Visible := FALSE; + lvReports.SmallImages := uEmptyImageList; + imgLblImages.ComponentImageListChanged; + lvReports.Items.Clear; + uLocalReportData.Clear; + uRemoteReportData.Clear; + TabControl1.Tabs.Clear; + TabControl1.Visible := false; + TabControl1.TabStop := false; + lstDateRange.Tag := 0; // used to reset date default on graph + if (GraphForm <> nil) and GraphFormActive then + with GraphForm do + begin + GraphForm.SendToBack; + Initialize; + DisplayData('top'); + DisplayData('bottom'); + GtslCheck.Clear; + GraphFormActive := false; + end; + begin + end; +end; + +procedure TfrmReports.Graph(reportien: integer); +begin + if GraphForm = nil then + begin + GraphForm := TfrmGraphs.Create(self); + try + with GraphForm do + begin + if btnClose.Tag = 1 then + Exit; + Parent := pnlRight; + Align := alClient; + pnlFooter.Tag := 1; //suppresses bottom of graph form + pnlBottom.Height := 1; + pnlMain.BevelInner := bvLowered; + pnlMain.BevelOuter := bvRaised; + pnlMain.Tag := reportien; + Initialize; + ResizeAnchoredFormToFont(GraphForm); + Show; + DisplayData('top'); + DisplayData('bottom'); + GtslCheck.Clear; + GraphPanel(true); + frmGraphData.pnlData.Hint := Patient.DFN; + BringToFront; + end; + finally + if GraphForm.btnClose.Tag = 1 then + begin + GraphFormActive := false; + GraphForm.Free; + GraphForm := nil; + end + else + GraphFormActive := true; + end; + end + else if GraphForm.btnClose.Tag = 1 then + Exit + else + begin + with GraphForm do + if pnlMain.Tag <> reportien then + begin // different report + pnlMain.Tag := reportien; + Initialize; + GtslCheck.Clear; + GraphPanel(true); + BringToFront; + end; + end; +end; + +procedure TfrmReports.GraphPanel(active: boolean); +var + adddaterange: boolean; + i: integer; + aQualifier, aStartTime, aStopTime, aNewLine: string; +begin + if active then + begin + pnlLeftBottom.Height := pnlLeft.Height div 2; + pnlViews.Height := pnlLeftBottom.Height; + if pnlLeft.Height < 200 then + pnlTopViews.Height := 3 + else + pnlTopViews.Height := 80; + lblQualifier.Visible := false; + lstQualifier.Visible := false; + pnlViews.Visible := true; + if lstDateRange.Tag = 0 then + begin + lstDateRange.Tag := 1; + aQualifier := PReportTreeObject(tvReports.Selected.Data)^.Qualifier; + aStartTime := Piece(aQualifier,';',1); + aStopTime := Piece(aQualifier,';',2); + adddaterange := true; + aNewLine := '^' + aStartTime + ' to ' + aStopTime +'^^^' + aStartTime + ';' + aStopTime + + '^' + floattostr(strtofmdatetime(aStartTime)) + '^' + floattostr(strtofmdatetime(aStopTime)); + for i := 0 to GraphForm.cboDateRange.Items.Count - 1 do + if GraphForm.cboDateRange.Items[i] = aNewLine then + begin + adddaterange := false; + break; + end; + if adddaterange then GraphForm.cboDateRange.Items.Add(aNewLine); + lstDateRange.Items := GraphForm.cboDateRange.Items; + GraphForm.DateDefaults; + lstDateRange.ItemIndex := GraphForm.cboDateRange.ItemIndex; + //lstDateRange.ItemIndex := lstDateRange.Items.Count - 1; + //lstDateRange.ItemIndex := lstDateRange.Items.Count - 2; //set to all results till fixed + lstDateRangeClick(self); + end; + pnlLeftBottom.Visible := true; + splitter1.Visible := true; + end + else + begin + lblQualifier.Visible := true; + lstQualifier.Visible := true; + pnlViews.Visible := false; + pnlLeftBottom.Height := lblHeaders.Height + lblQualifier.Height + 90; + end; +end; + +function TfrmReports.AllowContextChange(var WhyNot: string): Boolean; +var + i: integer; +begin + Result := inherited AllowContextChange(WhyNot); // sets result = true + if Timer1.Enabled = true then + case BOOLCHAR[frmFrame.CCOWContextChanging] of + '1': begin + WhyNot := 'A remote data query in progress will be aborted.'; + Result := False; + end; + '0': if WhyNot = 'COMMIT' then + begin + with RemoteSites.SiteList do for i := 0 to Count - 1 do + if TRemoteSite(Items[i]).Selected then + if Length(TRemoteSite(Items[i]).RemoteHandle) > 0 then + begin + TRemoteSite(Items[i]).ReportClear; + TRemoteSite(Items[i]).QueryStatus := '-1^Aborted'; + UpdateRemoteStatus(TRemoteSite(Items[i]).SiteID, 'Query Aborted'); + end; + Timer1.Enabled := false; + Result := True; + end; + end; +end; + +procedure TfrmReports.RequestPrint; +begin + if uReportType = 'M' then + begin + InfoBox(TX_NOREPORT, TX_NOREPORT_CAP, MB_OK); + Exit; + end; + if (uReportType = 'V') and (length(piece(uHState,';',2)) > 0) then + begin + if lvReports.Items.Count < 1 then + begin + InfoBox('There are no items to be printed.', 'No Items to Print', MB_OK); + Exit; + end; + if lvReports.SelCount < 1 then + begin + InfoBox('Please select one or more items from the list to be printed.', 'No Items Selected', MB_OK); + Exit; + end; + end; + if (uReportType = 'G') and GraphFormActive then + with GraphForm do + begin + if (lvwItemsTop.SelCount < 1) and (lvwItemsBottom.SelCount < 1) then + begin + InfoBox('There are no items graphed.', 'No Items to Print', MB_OK); + Exit; + end + else + begin + mnuPopGraphPrintClick(mnuPopGraphPrint); + Exit; + end; + end; + if uQualifierType = QT_DATERANGE then + begin // = 2 + if lstQualifier.ItemIndex < 0 then + begin + InfoBox('Please select from one of the Date Range items before printing', 'Incomplete Information', MB_OK); + end + else + PrintReports(uRptID, piece(uRemoteType,'^',4)); + end + else + PrintReports(uRptID, piece(uRemoteType,'^',4)); +end; + +procedure TfrmReports.DisplayPage; +var + i: integer; +begin + inherited DisplayPage; + frmFrame.mnuFilePrint.Tag := CT_REPORTS; + frmFrame.mnuFilePrint.Enabled := True; + frmFrame.mnuFilePrintSetup.Enabled := True; + uUpdateStat := false; + ulvSelectOn := false; + uListState := GetAdhocLookup(); + memText.SelStart := 0; + FormShow(self); + uHTMLPatient := '
| Patient: ' + Patient.Name + ' | ' + + '' + Patient.SSN + ' | ' +{ TODO -oRV -cWVEHR Long Age : Changed to use long age } + //+ 'Age: ' + IntToStr(Patient.Age) + ' | ' + + 'Age: ' + GetPatientBriefAge(Patient.DFN) + ' | ' +{} + + '